From ddb8a8cd06883444652d256605cccad23acab8c7 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Tue, 2 Jun 2026 03:13:53 +0000 Subject: [PATCH 01/14] feat(lang): add Yield cooperative scheduler Introduce Yield syntax, denotation, finite-pool scheduling, erased/visible interpretation APIs, and initial proof-surface scheduler regressions. AI-Assisted-By: GPT-5.5 --- theories/.gitignore | 1 + theories/Lang/Yield.v | 8 + theories/Lang/Yield/Denote.v | 78 +++++++ theories/Lang/Yield/Events.v | 40 ++++ theories/Lang/Yield/Interp.v | 91 ++++++++ theories/Lang/Yield/Scheduler.v | 48 +++++ theories/Lang/Yield/Syntax.v | 28 +++ theories/Lang/Yield/Ticl.v | 366 ++++++++++++++++++++++++++++++++ theories/Lang/Yield/Vec.v | 55 +++++ 9 files changed, 715 insertions(+) create mode 100644 theories/Lang/Yield.v create mode 100644 theories/Lang/Yield/Denote.v create mode 100644 theories/Lang/Yield/Events.v create mode 100644 theories/Lang/Yield/Interp.v create mode 100644 theories/Lang/Yield/Scheduler.v create mode 100644 theories/Lang/Yield/Syntax.v create mode 100644 theories/Lang/Yield/Ticl.v create mode 100644 theories/Lang/Yield/Vec.v diff --git a/theories/.gitignore b/theories/.gitignore index 059a8ee..4adf2fb 100644 --- a/theories/.gitignore +++ b/theories/.gitignore @@ -21,6 +21,7 @@ *.vo *.vok *.vos +.coq-native .rocq-native .csdp.cache .lia.cache diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v new file mode 100644 index 0000000..c6f7de0 --- /dev/null +++ b/theories/Lang/Yield.v @@ -0,0 +1,8 @@ +From TICL Require Export + Lang.Yield.Events + Lang.Yield.Syntax + Lang.Yield.Vec + Lang.Yield.Denote + Lang.Yield.Scheduler + Lang.Yield.Interp + Lang.Yield.Ticl. diff --git a/theories/Lang/Yield/Denote.v b/theories/Lang/Yield/Denote.v new file mode 100644 index 0000000..300112a --- /dev/null +++ b/theories/Lang/Yield/Denote.v @@ -0,0 +1,78 @@ +From Stdlib Require Import Nat Strings.String. +From ExtLib Require Import Data.Map.FMapAList Data.String Structures.Maps. +From TICL Require Import ICTree.Core Events.StateE Lang.Maps Lang.Yield.Events Lang.Yield.Syntax. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +Definition Ctx := alist string nat. +Definition Mem := stateE Ctx. + +(** Raw Yield denotations can yield, fork, and access memory. *) +Definition YEff := yieldE + (forkE + Mem). + +Definition ytrigger (e : YEff) : ictree YEff (encode e) := + @ICtree.trigger YEff YEff _ _ ReSum_refl ReSumRet_refl e. +Definition yget : ictree YEff Ctx := ytrigger (inr (inr Get)). +Definition yput (m : Ctx) : ictree YEff unit := ytrigger (inr (inr (Put m))). +Definition yyield : ictree YEff unit := ytrigger (inl Yield). +Definition yfork : ictree YEff bool := ytrigger (inr (inl Fork)). + +(** Denotation of expressions. Successful variable reads yield once before + returning the value; missing variables remain stuck. *) +Fixpoint denote_exp (e : YExp) : ictree YEff nat := + match e with + | YVar name => + ctx <- yget;; + match lookup name ctx with + | Some value => yyield;; Ret value + | None => stuck + end + | YLit n => Ret n + | YPlus a b => + x <- denote_exp a;; + y <- denote_exp b;; + Ret (x + y)%nat + | YMinus a b => + x <- denote_exp a;; + y <- denote_exp b;; + Ret (x - y)%nat + | YMult a b => + x <- denote_exp a;; + y <- denote_exp b;; + Ret (x * y)%nat + end. + +(** Denotation of statements to unscheduled Yield threads. *) +Fixpoint denote_stmt (s : YStmt) : ictree YEff unit := + match s with + | YAssign name expr => + value <- denote_exp expr;; + ctx <- yget;; + yput (add name value ctx) + | YSeq a b => + denote_stmt a;; + denote_stmt b + | YIf test then_branch else_branch => + condition_value <- denote_exp test;; + if is_true condition_value then + denote_stmt then_branch + else + denote_stmt else_branch + | YWhile test body => + ICtree.iter + (fun _ => + condition_value <- denote_exp test;; + if is_true condition_value then + denote_stmt body;; Ret (inl tt) + else + Ret (inr tt)) tt + | YFork inactive active => + in_child <- yfork;; + if in_child then + denote_stmt inactive + else + denote_stmt active + | YSkip => Ret tt + | YYield => yyield + end. diff --git a/theories/Lang/Yield/Events.v b/theories/Lang/Yield/Events.v new file mode 100644 index 0000000..2b6ddb1 --- /dev/null +++ b/theories/Lang/Yield/Events.v @@ -0,0 +1,40 @@ +From Stdlib Require Import Fin. +From TICL Require Import ICTree.Core Events.Core. + +Generalizable All Variables. + +(** Cooperative scheduling point emitted by source-level [yield]. *) +Variant yieldE : Type := Yield. + +(** Thread-local fork choice. The scheduler interprets the resulting [bool] + to run both continuations. *) +Variant forkE : Type := Fork. + +(** Scheduler-level observation that a fork spawned another runnable thread. *) +Variant spawnE : Type := Spawn. + +#[global] Instance Encode_yieldE : Encode yieldE := + fun e => match e with Yield => unit end. +#[global] Instance Encode_forkE : Encode forkE := + fun e => match e with Fork => bool end. +#[global] Instance Encode_spawnE : Encode spawnE := + fun e => match e with Spawn => unit end. + +Definition yield {E} `{HE : Encode E} `{RS : ReSum yieldE E} + `{RR : @ReSumRet yieldE E Encode_yieldE HE RS} : ictree E unit := + @ICtree.trigger yieldE E Encode_yieldE HE RS RR Yield. +Definition fork {E} `{HE : Encode E} `{RS : ReSum forkE E} + `{RR : @ReSumRet forkE E Encode_forkE HE RS} : ictree E bool := + @ICtree.trigger forkE E Encode_forkE HE RS RR Fork. +Definition spawn {E} `{HE : Encode E} `{RS : ReSum spawnE E} + `{RR : @ReSumRet spawnE E Encode_spawnE HE RS} : ictree E unit := + @ICtree.trigger spawnE E Encode_spawnE HE RS RR Spawn. + +(** A runnable source thread may yield, fork, or perform user effects. *) +Definition thread (E : Type) `{Encode E} := ictree (yieldE + (forkE + E)) unit. + +(** A scheduled computation exposes yields and spawns, but no raw forks. *) +Definition completed (E : Type) `{Encode E} := ictree (yieldE + (spawnE + E)) unit. + +(** Finite thread pools are represented as functions from finite indices. *) +Definition pool (E : Type) `{Encode E} (n : nat) := Fin.t n -> thread E. diff --git a/theories/Lang/Yield/Interp.v b/theories/Lang/Yield/Interp.v new file mode 100644 index 0000000..dc1487b --- /dev/null +++ b/theories/Lang/Yield/Interp.v @@ -0,0 +1,91 @@ +From Stdlib Require Import Fin. +From ExtLib Require Import + Structures.Monad + Data.Monads.StateMonad + Structures.MonadState + Data.Map.FMapAList + Data.String. +From TICL Require Import + ICTree.Core + ICTree.Interp.Core + ICTree.Interp.State + ICTree.Events.State + ICTree.Events.Writer + Events.Core + Events.StateE + Lang.Maps + Lang.Yield.Events + Lang.Yield.Syntax + Lang.Yield.Denote + Lang.Yield.Scheduler. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +(** Start a source statement as a singleton pool focused on its only thread. + This is the scheduler-visible view: source [Fork] events have been + scheduled into scheduler [Spawn] observations, and cooperative [Yield] + observations remain visible alongside memory effects. *) +Definition scheduled_visible (s : YStmt) : completed Mem := + schedule 1 (fun _ => denote_stmt s) (Some Fin.F1). + +(** Backward-compatible name for the scheduler-visible scheduled computation. *) +Definition scheduled : YStmt -> completed Mem := scheduled_visible. + +(** Erase scheduler spawn observations while preserving yield and memory events. *) +Definition handle_spawn : (yieldE + (spawnE + Mem)) ~> ictree (yieldE + Mem) := + fun event => + match event with + | inl y => ICtree.trigger y + | inr (inl Spawn) => Ret tt + | inr (inr m) => ICtree.trigger m + end. +Definition interp_spawn {X} (t : ictree (yieldE + (spawnE + Mem)) X) : ictree (yieldE + Mem) X := + interp handle_spawn t. + +(** Erase cooperative yield observations, leaving only memory effects. *) +Definition handle_yield : (yieldE + Mem) ~> ictree Mem := + fun event => + match event with + | inl Yield => Ret tt + | inr m => ICtree.trigger m + end. +Definition interp_yield {X} (t : ictree (yieldE + Mem) X) : ictree Mem X := + interp handle_yield t. + +(** Erased scheduled interpretation: both scheduler [Spawn] and cooperative + [Yield] observations are intentionally erased, leaving only memory effects. *) +Definition interp_scheduled_erased (s : YStmt) : ictree Mem unit := + interp_yield (interp_spawn (scheduled_visible s)). + +(** Backward-compatible erased scheduled interpretation. New concurrency-facing + code should choose explicitly between [scheduled_visible] and + [interp_scheduled_erased]. *) +Definition interp_scheduled : YStmt -> ictree Mem unit := interp_scheduled_erased. + +(** Interpret a raw thread without scheduling by resolving [Fork] to [false], + i.e. taking the active branch. *) +Definition handle_thread : YEff ~> ictree (yieldE + Mem) := + fun event => + match event with + | inl y => ICtree.trigger y + | inr (inl Fork) => Ret false + | inr (inr m) => ICtree.trigger m + end. +Definition interp_thread {X} (t : ictree YEff X) : ictree Mem X := + interp_yield (interp handle_thread t). + +(** Erased expression instrumentation: raw thread-level [Yield] observations + are erased before state instrumentation. *) +Definition instr_exp_erased (e : YExp) (ctx : Ctx) : ictreeW Ctx (nat * Ctx) := + instr_stateE (interp_thread (denote_exp e)) ctx. + +(** Erased statement instrumentation: scheduler [Spawn] and cooperative [Yield] + observations are erased before state instrumentation. *) +Definition instr_stmt_erased (s : YStmt) (ctx : Ctx) : ictreeW Ctx (unit * Ctx) := + instr_stateE (interp_scheduled_erased s) ctx. + +(** Backward-compatible erased instrumentation aliases. These names preserve the + iteration-1 API, where instrumentation observed only memory/state effects. *) +Definition instr_exp : YExp -> Ctx -> ictreeW Ctx (nat * Ctx) := instr_exp_erased. +Definition instr_stmt : YStmt -> Ctx -> ictreeW Ctx (unit * Ctx) := instr_stmt_erased. diff --git a/theories/Lang/Yield/Scheduler.v b/theories/Lang/Yield/Scheduler.v new file mode 100644 index 0000000..e9e1782 --- /dev/null +++ b/theories/Lang/Yield/Scheduler.v @@ -0,0 +1,48 @@ +From Stdlib Require Import Fin. +From TICL Require Import ICTree.Core Events.Core Lang.Yield.Events Lang.Yield.Vec. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +Section Scheduler. + Context {E : Type} `{Encode E}. + + (** Cooperative scheduler for a finite pool. + + [None] focus means the scheduler chooses a runnable thread after emitting + a scheduling [Yield]. [Some i] observes one step of thread [i], removing + finished threads, clearing focus on source yields, and turning source forks + into scheduler-visible [Spawn] events. *) + CoFixpoint schedule (n : nat) (v : pool E n) (focus : option (Fin.t n)) : completed E := + match focus with + | None => + match n return pool E n -> completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => Vis (inl Yield) (fun _ => Br n' (fun i => schedule (S n') v (Some i))) + end v + | Some i => + match n return pool E n -> Fin.t n -> completed E with + | 0 => fun _ i => match i with end + | S n' => fun v i => + match observe (v i) with + | RetF _ => Guard (schedule n' (remove_pool v i) None) + | BrF b k => Br b (fun j => schedule (S n') (replace_pool v i (k j)) (Some i)) + | GuardF t => Guard (schedule (S n') (replace_pool v i t) (Some i)) + | VisF e k => + match e as e0 return (encode e0 -> thread E) -> completed E with + | inl Yield => fun k => Guard (schedule (S n') (replace_pool v i (k tt)) None) + | inr (inl Fork) => fun k => + @go (yieldE + (spawnE + E)) _ unit + (VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n')) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (FS i)))) + | inr (inr e') => fun k => + @go (yieldE + (spawnE + E)) _ unit + (VisF ((inr (inr e')) : yieldE + (spawnE + E)) + (fun x => schedule (S n') (replace_pool v i (k x)) (Some i))) + end k + end + end v i + end. +End Scheduler. diff --git a/theories/Lang/Yield/Syntax.v b/theories/Lang/Yield/Syntax.v new file mode 100644 index 0000000..48d734a --- /dev/null +++ b/theories/Lang/Yield/Syntax.v @@ -0,0 +1,28 @@ +From Stdlib Require Import Nat Strings.String. + +Module YieldSyntax. + Definition var := string. + Definition value := nat. + + Inductive YExp : Type := + | YVar (_ : var) + | YLit (_ : value) + | YPlus (_ _ : YExp) + | YMinus (_ _ : YExp) + | YMult (_ _ : YExp). + + Inductive YStmt : Type := + | YAssign (x : var) (e : YExp) + | YSeq (a b : YStmt) + | YIf (i : YExp) (t e : YStmt) + | YWhile (t : YExp) (b : YStmt) + (** [YFork inactive active] keeps the prior branch polarity: + the fork result [true] selects [inactive], and [false] selects [active]. *) + | YFork (inactive active : YStmt) + | YSkip + | YYield. + + (** Yield treats any non-zero natural as true. *) + Definition is_true (v : value) : bool := negb (v =? 0). +End YieldSyntax. +Export YieldSyntax. diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v new file mode 100644 index 0000000..0f462e1 --- /dev/null +++ b/theories/Lang/Yield/Ticl.v @@ -0,0 +1,366 @@ +(** TICL-facing Yield surface. + + Public tiers exported by this façade: + + - [Lang.Yield.Events], [Lang.Yield.Syntax], and [Lang.Yield.Denote] expose + raw source-level threads with [Yield], [Fork], and memory effects. + - [Lang.Yield.Scheduler] exposes the scheduler, and [scheduled_visible] + exposes scheduled programs with scheduler [Spawn], cooperative [Yield], + and memory effects visible. + - [interp_scheduled_erased], [instr_exp_erased], and [instr_stmt_erased] + expose the state-only TICL view where scheduler/yield observations are + intentionally erased. + - [interp_scheduled], [instr_exp], and [instr_stmt] are compatibility + aliases for the erased tier. + + This file also carries a small regression surface: constructor unfold facts, + one-step scheduler facts, finite-pool slot regressions, concrete visible + YYield/YFork examples, and alias facts documenting that the compatibility + APIs are erased. *) +From Stdlib Require Import + Fin + Nat + Strings.String. + +From ExtLib Require Import + Data.Map.FMapAList + Data.String + Structures.Maps. + +From TICL Require Export + Lang.Yield.Events + Lang.Yield.Syntax + Lang.Yield.Denote + Lang.Yield.Vec + Lang.Yield.Scheduler + Lang.Yield.Interp. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.Interp.Core. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +(** Expression denotation constructor unfold facts. *) +Lemma denote_exp_yvar name : + denote_exp (YVar name) = + (ctx <- yget;; + match lookup name ctx with + | Some value => yyield;; Ret value + | None => stuck + end). +Proof. reflexivity. Qed. + +Lemma denote_exp_ylit n : denote_exp (YLit n) = Ret n. +Proof. reflexivity. Qed. + +Lemma denote_exp_yplus a b : + denote_exp (YPlus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_yminus a b : + denote_exp (YMinus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_ymult a b : + denote_exp (YMult a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). +Proof. reflexivity. Qed. + +(** Statement denotation constructor unfold facts. *) +Lemma denote_stmt_yassign name expr : + denote_stmt (YAssign name expr) = + (value <- denote_exp expr;; ctx <- yget;; yput (add name value ctx)). +Proof. reflexivity. Qed. + +Lemma denote_stmt_yseq a b : + denote_stmt (YSeq a b) = (denote_stmt a;; denote_stmt b). +Proof. reflexivity. Qed. + +Lemma denote_stmt_yif test then_branch else_branch : + denote_stmt (YIf test then_branch else_branch) = + (condition_value <- denote_exp test;; + if YieldSyntax.is_true condition_value then + denote_stmt then_branch + else + denote_stmt else_branch). +Proof. reflexivity. Qed. + +Lemma denote_stmt_ywhile test body : + denote_stmt (YWhile test body) = + ICtree.iter + (fun _ => + condition_value <- denote_exp test;; + if YieldSyntax.is_true condition_value then + denote_stmt body;; Ret (inl tt) + else + Ret (inr tt)) tt. +Proof. reflexivity. Qed. + +Lemma denote_stmt_yfork inactive active : + denote_stmt (YFork inactive active) = + (in_child <- yfork;; + if in_child then + denote_stmt inactive + else + denote_stmt active). +Proof. reflexivity. Qed. + +Lemma denote_stmt_yskip : denote_stmt YSkip = Ret tt. +Proof. reflexivity. Qed. + +Lemma denote_stmt_yyield : denote_stmt YYield = yyield. +Proof. reflexivity. Qed. + +(** Scheduler one-step/case regression facts. *) +Section SchedulerFacts. + Context {E : Type} `{Encode E}. + + Local Ltac solve_focused_schedule H := + lazy [schedule observe _observe]; + match type of H with + | observe (?v ?i) = _ => + change (@_observe _ _ unit (v i)) with (observe (v i)); + rewrite H; + reflexivity + end. + + Lemma schedule_empty_none (v : pool E 0) : + observe (schedule 0 v None) = RetF tt. + Proof. reflexivity. Qed. + + Lemma schedule_no_focus_nonempty n (v : pool E (S n)) : + observe (schedule (S n) v None) = + VisF (inl Yield) (fun _ => Br n (fun i => schedule (S n) v (Some i))). + Proof. reflexivity. Qed. + + Lemma schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule n (remove_pool v i) None). + Proof. + intro Hret. + solve_focused_schedule Hret. + Qed. + + Lemma schedule_focused_br n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + observe (schedule (S n) v (Some i)) = + BrF b (fun j => schedule (S n) (replace_pool v i (k j)) (Some i)). + Proof. + intro Hbr. + solve_focused_schedule Hbr. + Qed. + + Lemma schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v i) = GuardF t -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule (S n) (replace_pool v i t) (Some i)). + Proof. + intro Hg. + solve_focused_schedule Hg. + Qed. + + Lemma schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule (S n) (replace_pool v i (k tt)) None). + Proof. + intro Hy. + solve_focused_schedule Hy. + Qed. + + Lemma schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + observe (schedule (S n) v (Some i)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + Proof. + intro Hf. + solve_focused_schedule Hf. + Qed. + + Lemma schedule_focused_user_event n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + observe (schedule (S n) v (Some i)) = + VisF ((inr (inr e)) : yieldE + (spawnE + E)) + (fun x => schedule (S n) (replace_pool v i (k x)) (Some i)). + Proof. + intro Hu. + solve_focused_schedule Hu. + Qed. +End SchedulerFacts. + +(** Non-degenerate finite-pool scheduler regressions. *) +Section SchedulerPoolRegressions. + Context {E : Type} `{Encode E}. + + Lemma schedule_yield_two_threads_one_step (next other : thread E) : + observe + (schedule 2 + (cons_pool + (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) + (fun _ : Fin.t 1 => other)) + (Some Fin.F1)) = + GuardF + (schedule 2 + (replace_pool + (cons_pool + (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) + (fun _ : Fin.t 1 => other)) + Fin.F1 next) + None). + Proof. reflexivity. Qed. + + Lemma schedule_yield_two_threads_focused_slot (next other : thread E) : + replace_pool + (cons_pool + (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) + (fun _ : Fin.t 1 => other)) + Fin.F1 next Fin.F1 = next. + Proof. apply replace_pool_hit. Qed. + + Lemma schedule_yield_two_threads_other_slot (next other : thread E) : + replace_pool + (cons_pool + (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) + (fun _ : Fin.t 1 => other)) + Fin.F1 next (Fin.FS Fin.F1) = other. + Proof. + rewrite replace_pool_miss by discriminate. + apply cons_pool_tail. + Qed. + + Lemma schedule_fork_two_threads_one_step + (child parent other : thread E) : + observe + (schedule 2 + (cons_pool + (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent)) + (fun _ : Fin.t 1 => other)) + (Some Fin.F1)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => + schedule 3 + (cons_pool child + (replace_pool + (cons_pool + (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent)) + (fun _ : Fin.t 1 => other)) + Fin.F1 parent)) + (Some (Fin.FS Fin.F1))). + Proof. reflexivity. Qed. + + Lemma schedule_fork_two_threads_child_slot + (child parent other : thread E) : + cons_pool child + (replace_pool + (cons_pool + (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent)) + (fun _ : Fin.t 1 => other)) + Fin.F1 parent) + Fin.F1 = child. + Proof. apply cons_pool_head. Qed. + + Lemma schedule_fork_two_threads_parent_slot + (child parent other : thread E) : + cons_pool child + (replace_pool + (cons_pool + (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent)) + (fun _ : Fin.t 1 => other)) + Fin.F1 parent) + (Fin.FS Fin.F1) = parent. + Proof. + rewrite cons_pool_tail. + apply replace_pool_hit. + Qed. + + Lemma schedule_fork_two_threads_other_slot + (child parent other : thread E) : + cons_pool child + (replace_pool + (cons_pool + (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent)) + (fun _ : Fin.t 1 => other)) + Fin.F1 parent) + (Fin.FS (Fin.FS Fin.F1)) = other. + Proof. + rewrite cons_pool_tail. + rewrite replace_pool_miss by discriminate. + apply cons_pool_tail. + Qed. +End SchedulerPoolRegressions. + +(** Concrete scheduler-visible examples. *) +Lemma scheduled_visible_yyield_one_step : + observe (scheduled_visible YYield) = + GuardF + (schedule 1 + (replace_pool (fun _ : Fin.t 1 => denote_stmt YYield) Fin.F1 (Ret tt)) + None). +Proof. reflexivity. Qed. + +Lemma scheduled_visible_yfork_skip_skip_one_step : + observe (scheduled_visible (YFork YSkip YSkip)) = + let fork_continuation := + fun in_child : bool => + ICtree.subst' + (fun in_child : bool => if in_child then Ret tt else Ret tt) + (RetF in_child) in + VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) + (fun _ => + schedule 2 + (cons_pool (fork_continuation true) + (replace_pool + (fun _ : Fin.t 1 => denote_stmt (YFork YSkip YSkip)) + Fin.F1 (fork_continuation false))) + (Some (Fin.FS Fin.F1))). +Proof. + unfold scheduled_visible. + apply (@schedule_focused_fork Mem _ 0 + (fun _ : Fin.t 1 => denote_stmt (YFork YSkip YSkip)) + Fin.F1 + (fun in_child : bool => + ICtree.subst' + (fun in_child : bool => if in_child then Ret tt else Ret tt) + (RetF in_child))). + cbn. + unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. + reflexivity. +Qed. + +(** Erasure handlers intentionally hide scheduler/thread observations. *) +Lemma handle_spawn_spawn_erased : handle_spawn (inr (inl Spawn)) = Ret tt. +Proof. reflexivity. Qed. + +Lemma handle_yield_yield_erased : handle_yield (inl Yield) = Ret tt. +Proof. reflexivity. Qed. + +Lemma interp_scheduled_erased_unfold s : + interp_scheduled_erased s = interp_yield (interp_spawn (scheduled_visible s)). +Proof. reflexivity. Qed. + +(** Compatibility aliases are erased APIs. *) +Lemma scheduled_alias s : scheduled s = scheduled_visible s. +Proof. reflexivity. Qed. + +Lemma interp_scheduled_alias_erased s : interp_scheduled s = interp_scheduled_erased s. +Proof. reflexivity. Qed. + +Lemma instr_exp_alias_erased e ctx : instr_exp e ctx = instr_exp_erased e ctx. +Proof. reflexivity. Qed. + +Lemma instr_stmt_alias_erased s ctx : instr_stmt s ctx = instr_stmt_erased s ctx. +Proof. reflexivity. Qed. diff --git a/theories/Lang/Yield/Vec.v b/theories/Lang/Yield/Vec.v new file mode 100644 index 0000000..5797dad --- /dev/null +++ b/theories/Lang/Yield/Vec.v @@ -0,0 +1,55 @@ +From Stdlib Require Import Fin. + +(** Replace the value stored at one finite index. *) +Definition replace_pool {A n} (v : Fin.t n -> A) (i : Fin.t n) (a : A) : Fin.t n -> A := + fun j => + match Fin.eq_dec i j with + | left _ => a + | right _ => v j + end. + +Lemma replace_pool_hit {A n} (v : Fin.t n -> A) (i : Fin.t n) (a : A) : + replace_pool v i a i = a. +Proof. + unfold replace_pool. + destruct (Fin.eq_dec i i) as [_ | Hneq]. + - reflexivity. + - contradiction Hneq; reflexivity. +Qed. + +Lemma replace_pool_miss {A n} (v : Fin.t n -> A) (i j : Fin.t n) (a : A) : + i <> j -> replace_pool v i a j = v j. +Proof. + intro Hneq. + unfold replace_pool. + destruct (Fin.eq_dec i j) as [Heq | _]. + - contradiction Hneq; exact Heq. + - reflexivity. +Qed. + +(** Remove one index from a non-empty finite vector/function. *) +Fixpoint remove_pool {A} {n : nat} : (Fin.t (S n) -> A) -> Fin.t (S n) -> Fin.t n -> A := + match n return (Fin.t (S n) -> A) -> Fin.t (S n) -> Fin.t n -> A with + | 0 => fun _ _ j => match j with end + | S n' => fun v i j => + match i in Fin.t (S n0) return n0 = S n' -> Fin.t (S n') -> A with + | F1 => fun _ j => v (FS j) + | FS i' => fun e j => + match j in Fin.t (S n1) return n1 = n' -> A with + | F1 => fun _ => v F1 + | FS j' => fun e' => remove_pool (fun k => v (FS k)) (Fin.cast i' e) (Fin.cast j' e') + end eq_refl + end eq_refl j + end. + +(** Prepend a value at [F1] and shift the existing pool right. *) +Definition cons_pool {A n} (x : A) (v : Fin.t n -> A) : Fin.t (S n) -> A := + fun i => Fin.caseS' i (fun _ => A) x (fun j => v j). + +Lemma cons_pool_head {A n} (x : A) (v : Fin.t n -> A) : + cons_pool x v Fin.F1 = x. +Proof. reflexivity. Qed. + +Lemma cons_pool_tail {A n} (x : A) (v : Fin.t n -> A) (i : Fin.t n) : + cons_pool x v (Fin.FS i) = v i. +Proof. reflexivity. Qed. From afce958d01a8f15bfbed5cdfea70661025519cc4 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Thu, 4 Jun 2026 08:21:52 +0000 Subject: [PATCH 02/14] feat(lang): complete sbisim_schedule proof for Yield scheduler Land Phases 4-6 of the Yield cooperative scheduler bisimulation: focused-thread matching, the coinductive sbisim_schedule congruence theorem, and the sbisim_scheduled_visible corollary. SBisim.v grows to 954 lines with 0 Admitted and only standard axioms. Wire SBisim into the Lang.Yield facade export. Co-authored-by: Claude Opus 4.8 --- theories/Lang/Yield.v | 3 +- theories/Lang/Yield/SBisim.v | 954 +++++++++++++++++++++++++++++++++++ 2 files changed, 956 insertions(+), 1 deletion(-) create mode 100644 theories/Lang/Yield/SBisim.v diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v index c6f7de0..db76d7b 100644 --- a/theories/Lang/Yield.v +++ b/theories/Lang/Yield.v @@ -5,4 +5,5 @@ From TICL Require Export Lang.Yield.Denote Lang.Yield.Scheduler Lang.Yield.Interp - Lang.Yield.Ticl. + Lang.Yield.Ticl + Lang.Yield.SBisim. diff --git a/theories/Lang/Yield/SBisim.v b/theories/Lang/Yield/SBisim.v new file mode 100644 index 0000000..ee3f059 --- /dev/null +++ b/theories/Lang/Yield/SBisim.v @@ -0,0 +1,954 @@ +From Stdlib Require Import Fin Program.Equality. +From TICL Require Import + ICTree.Core + ICTree.Trans + ICTree.Equ + ICTree.Eq.Core + ICTree.Eq.Bind + ICTree.SBisim + Lang.Yield.Events + Lang.Yield.Vec + Lang.Yield.Scheduler + Lang.Yield.Denote + Lang.Yield.Interp + Lang.Yield.Ticl. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +Section PoolSBisim. + Context {E : Type} `{Encode E}. + + Definition pool_sbisim {n : nat} (v1 v2 : pool E n) : Prop := + forall i, v1 i ~ v2 i. + + Lemma pool_sbisim_refl {n} (v : pool E n) : pool_sbisim v v. + Proof. intro i; reflexivity. Qed. + + Lemma pool_sbisim_sym {n} (v1 v2 : pool E n) : + pool_sbisim v1 v2 -> pool_sbisim v2 v1. + Proof. intros Hpool i; symmetry; apply Hpool. Qed. + + Lemma replace_pool_sbisim {n} (v1 v2 : pool E n) (i : Fin.t n) + (t1 t2 : thread E) : + pool_sbisim v1 v2 -> + t1 ~ t2 -> + pool_sbisim (replace_pool v1 i t1) (replace_pool v2 i t2). + Proof. + intros Hv Ht j. + unfold replace_pool. + destruct (Fin.eq_dec i j); auto. + Qed. + + Lemma remove_pool_sbisim {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : + pool_sbisim v1 v2 -> + pool_sbisim (remove_pool v1 i) (remove_pool v2 i). + Proof. + intros Hv j. + revert v1 v2 i j Hv. + induction n as [| n IH]; intros v1 v2 i j Hv. + - dependent destruction j. + - cbn. + dependent destruction i. + + apply Hv. + + dependent destruction j. + * apply Hv. + * apply IH. intro k. apply Hv. + Qed. + + Lemma cons_pool_sbisim {n} (t1 t2 : thread E) (v1 v2 : pool E n) : + t1 ~ t2 -> + pool_sbisim v1 v2 -> + pool_sbisim (cons_pool t1 v1) (cons_pool t2 v2). + Proof. + intros Ht Hv i. + refine (Fin.caseS' i (fun i => cons_pool t1 v1 i ~ cons_pool t2 v2 i) _ _). + - exact Ht. + - intro j. apply Hv. + Qed. + + (** ** [equ]-level pool congruences, used by [schedule_pool_proper]. *) + Definition pool_equ {n : nat} (v1 v2 : pool E n) : Prop := + forall i, v1 i ≅ v2 i. + + Lemma replace_pool_equ {n} (v1 v2 : pool E n) (i : Fin.t n) + (t1 t2 : thread E) : + pool_equ v1 v2 -> + t1 ≅ t2 -> + pool_equ (replace_pool v1 i t1) (replace_pool v2 i t2). + Proof. + intros Hv Ht j. + unfold replace_pool. + destruct (Fin.eq_dec i j); auto. + Qed. + + Lemma remove_pool_equ {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : + pool_equ v1 v2 -> + pool_equ (remove_pool v1 i) (remove_pool v2 i). + Proof. + intros Hv j. + revert v1 v2 i j Hv. + induction n as [| n IH]; intros v1 v2 i j Hv. + - dependent destruction j. + - cbn. + dependent destruction i. + + apply Hv. + + dependent destruction j. + * apply Hv. + * apply IH. intro k. apply Hv. + Qed. + + Lemma cons_pool_equ {n} (t1 t2 : thread E) (v1 v2 : pool E n) : + t1 ≅ t2 -> + pool_equ v1 v2 -> + pool_equ (cons_pool t1 v1) (cons_pool t2 v2). + Proof. + intros Ht Hv i. + refine (Fin.caseS' i (fun i => cons_pool t1 v1 i ≅ cons_pool t2 v2 i) _ _). + - exact Ht. + - intro j. apply Hv. + Qed. +End PoolSBisim. + +Section SchedulerTransitions. + Context {E : Type} `{Encode E}. + + Lemma trans_schedule_no_focus_nonempty n (v : pool E (S n)) : + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v None) + (Br n (fun i => schedule (S n) v (Some i))). + Proof. + unfold trans; cbn. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inl Yield) _ tt + (Br n (fun i => schedule (S n) v (Some i)))). + reflexivity. + Qed. + + Lemma trans_schedule_no_focus_choose n (v : pool E (S n)) (i : Fin.t (S n)) : + trans tau + (Br n (fun i => schedule (S n) v (Some i))) + (schedule (S n) v (Some i)). + Proof. + apply trans_br with (x := i). reflexivity. + Qed. + + Lemma trans_schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (Br n (fun j => schedule (S n) (replace_pool v i (k tt)) (Some j))). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v i)) with (observe (v i)). + rewrite Hobs. + eapply Stepguard. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inl Yield) _ tt + (Br n (fun j => schedule (S n) (replace_pool v i (k tt)) (Some j)))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v i)) with (observe (v i)). + rewrite Hobs. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inr (inl Spawn)) _ tt + (schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i)))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_user_event + n (v : pool E (S n)) (i : Fin.t (S n)) e k x : + observe (v i) = VisF (inr (inr e)) k -> + trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (schedule (S n) v (Some i)) + (schedule (S n) (replace_pool v i (k x)) (Some i)). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v i)) with (observe (v i)). + rewrite Hobs. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inr (inr e)) _ x + (schedule (S n) (replace_pool v i (k x)) (Some i))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_br + n (v : pool E (S n)) (i : Fin.t (S n)) b k (j : Fin.t (S b)) : + observe (v i) = BrF b k -> + trans tau (schedule (S n) v (Some i)) + (schedule (S n) (replace_pool v i (k j)) (Some i)). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v i)) with (observe (v i)). + rewrite Hobs. + eapply (@Steptau + (yieldE + (spawnE + E)) _ unit b j _ + (schedule (S n) (replace_pool v i (k j)) (Some i))). + reflexivity. + Qed. + + (** ** Phase 2: remaining transition / unfold constructors. *) + + Lemma trans_schedule_empty_ret (v : pool E 0) : + schedule 0 v None ≅ Ret tt. + Proof. + rewrite (ictree_eta (schedule 0 v None)). + rewrite schedule_empty_none. + reflexivity. + Qed. + + Lemma trans_schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + schedule (S n) v (Some i) ≅ Guard (schedule n (remove_pool v i) None). + Proof. + intro Hobs. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_ret _ v i Hobs). + reflexivity. + Qed. + + Lemma trans_schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v i) = GuardF t -> + schedule (S n) v (Some i) + ≅ Guard (schedule (S n) (replace_pool v i t) (Some i)). + Proof. + intro Hobs. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_guard _ v i t Hobs). + reflexivity. + Qed. + + (** ** Phase 3: scheduler transition inversions. *) + + Lemma schedule_no_focus_equ n (v : pool E (S n)) : + schedule (S n) v None + ≅ Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ => Br n (fun i => schedule (S n) v (Some i))). + Proof. + rewrite (ictree_eta (schedule (S n) v None)). + rewrite schedule_no_focus_nonempty. + reflexivity. + Qed. + + Lemma trans_schedule_no_focus_inv n (v : pool E (S n)) l t' : + trans l (schedule (S n) v None) t' -> + l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ + t' ≅ Br n (fun i => schedule (S n) v (Some i)). + Proof. + intro TR. + rewrite schedule_no_focus_equ in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + Qed. + + Lemma trans_schedule_focused_inv n (v : pool E (S n)) (i : Fin.t (S n)) l t' : + trans l (schedule (S n) v (Some i)) t' -> + (** focused [Ret]: collapse the [Guard], step the residual pool *) + (observe (v i) = RetF tt /\ + trans l (schedule n (remove_pool v i) None) t') + \/ + (** focused [Guard]: collapse, step the [replace_pool] residual *) + (exists g, observe (v i) = GuardF g /\ + trans l (schedule (S n) (replace_pool v i g) (Some i)) t') + \/ + (** focused [Br b k]: [tau] to one of the branches *) + (exists b k (j : Fin.t (S b)), observe (v i) = BrF b k /\ + l = tau /\ + t' ≅ schedule (S n) (replace_pool v i (k j)) (Some i)) + \/ + (** focused [Yield]: visible [Yield], [Br] back over the residual pool *) + (exists k, observe (v i) = VisF (inl Yield) k /\ + l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ + t' ≅ Br n (fun j => + schedule (S n) (replace_pool v i (k tt)) (Some j))) + \/ + (** focused [Fork]: visible [Spawn], cons the child, focus it *) + (exists k, observe (v i) = VisF (inr (inl Fork)) k /\ + l = obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt /\ + t' ≅ schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))) + \/ + (** focused user event [e]: visible [e], step the focused thread *) + (exists e k x, observe (v i) = VisF (inr (inr e)) k /\ + l = obs (inr (inr e) : yieldE + (spawnE + E)) x /\ + t' ≅ schedule (S n) (replace_pool v i (k x)) (Some i)). + Proof. + intro TR. + destruct (observe (v i)) as [r | b k | g | e k] eqn:Hobs. + - (* RetF *) + destruct r. + left. + split; auto. + rewrite (trans_schedule_focused_ret _ v i Hobs) in TR. + now apply trans_guard_inv in TR. + - (* BrF b k *) + do 2 right; left. + assert (Hsch := schedule_focused_br _ v i b k Hobs). + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite Hsch in TR. + apply trans_br_inv in TR as (j & Heq & Hl). + exists b, k, j; auto. + - (* GuardF g *) + right; left. + exists g. + split; auto. + rewrite (trans_schedule_focused_guard _ v i g Hobs) in TR. + now apply trans_guard_inv in TR. + - (* VisF e k *) + destruct e as [yld | [frk | usr]]. + + (* Yield *) + destruct yld. + do 3 right; left. + exists k. + split; auto. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_yield _ v i k Hobs) in TR. + apply trans_guard_inv in TR. + rewrite schedule_no_focus_equ in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + + (* Fork *) + destruct frk. + do 4 right; left. + exists k. + split; auto. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_fork _ v i k Hobs) in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + + (* user event *) + do 5 right. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_user_event _ v i usr k Hobs) in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + exists usr, k, x; auto. + Qed. + + (** ** [schedule] respects [equ]-equality of pools, in every focus. *) + Lemma schedule_pool_proper n (v w : pool E n) focus : + pool_equ v w -> + schedule n v focus ≅ schedule n w focus. + Proof. + revert n v w focus. + coinduction R CH. + intros n v w focus Hvw. + destruct focus as [i |]. + - destruct n as [| n']; [ inversion i |]. + pose proof (Hvw i) as Hi. + assert (Hgo : go (observe (v i)) ≅ go (observe (w i))). + { rewrite <- !ictree_eta. exact Hi. } + rewrite (ictree_eta (schedule (S n') v (Some i))). + rewrite (ictree_eta (schedule (S n') w (Some i))). + destruct (observe (v i)) as [r | b k | g | e k] eqn:Hv; + destruct (observe (w i)) as [r2 | b2 k2 | g2 | e2 k2] eqn:Hw; + try (step in Hgo; inversion Hgo; fail). + + destruct r, r2. + rewrite (@schedule_focused_ret E _ n' v i Hv). + rewrite (@schedule_focused_ret E _ n' w i Hw). + cbn. constructor. apply CH. apply remove_pool_equ. exact Hvw. + + pose proof (equ_br_invT Hgo) as Hbeq; subst b2. + pose proof (equ_br_invE Hgo) as Hke. + rewrite (@schedule_focused_br E _ n' v i b k Hv). + rewrite (@schedule_focused_br E _ n' w i b k2 Hw). + cbn. constructor. intro j. apply CH. + apply replace_pool_equ. exact Hvw. apply Hke. + + pose proof (equ_guard_invE Hgo) as Hge. + rewrite (@schedule_focused_guard E _ n' v i g Hv). + rewrite (@schedule_focused_guard E _ n' w i g2 Hw). + cbn. constructor. apply CH. + apply replace_pool_equ. exact Hvw. exact Hge. + + pose proof (equ_vis_invT Hgo) as [_ Heeq]; subst e2. + pose proof (equ_vis_invE Hgo) as Hke. + destruct e as [yld | [frk | usr]]. + * destruct yld. + rewrite (@schedule_focused_yield E _ n' v i k Hv). + rewrite (@schedule_focused_yield E _ n' w i k2 Hw). + cbn. constructor. apply CH. + apply replace_pool_equ. exact Hvw. apply (Hke tt). + * destruct frk. + rewrite (@schedule_focused_fork E _ n' v i k Hv). + rewrite (@schedule_focused_fork E _ n' w i k2 Hw). + cbn. constructor. intros _. apply CH. + apply cons_pool_equ. + -- apply (Hke true). + -- apply replace_pool_equ. exact Hvw. apply (Hke false). + * rewrite (@schedule_focused_user_event E _ n' v i usr k Hv). + rewrite (@schedule_focused_user_event E _ n' w i usr k2 Hw). + cbn. constructor. intro x. apply CH. + apply replace_pool_equ. exact Hvw. apply (Hke x). + - destruct n as [| n']. + + rewrite (ictree_eta (schedule 0 v None)). + rewrite (ictree_eta (schedule 0 w None)). + rewrite schedule_empty_none, schedule_empty_none. + cbn. reflexivity. + + rewrite (ictree_eta (schedule (S n') v None)). + rewrite (ictree_eta (schedule (S n') w None)). + rewrite schedule_no_focus_nonempty, schedule_no_focus_nonempty. + cbn. constructor. intros _. cbn. step. + constructor. intro i. apply CH. exact Hvw. + Qed. + (** ** Phase 4: thread-step to scheduler-step lifts. *) + + Lemma pool_equ_refl {n} (v : pool E n) : pool_equ v v. + Proof. intro j; reflexivity. Qed. + + Lemma replace_pool_idem_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) + (a b : thread E) : + pool_equ (replace_pool v i b) (replace_pool (replace_pool v i a) i b). + Proof. intro j. unfold replace_pool. destruct (Fin.eq_dec i j); reflexivity. Qed. + + Lemma br_schedule_pool_equ {n} (v w : pool E (S n)) : + pool_equ v w -> + Br n (fun j => schedule (S n) v (Some j)) + ≅ Br n (fun j => schedule (S n) w (Some j)). + Proof. + intro Hvw. step. constructor. intro j. + apply schedule_pool_proper. exact Hvw. + Qed. + + Lemma schedule_lift_yield n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans (obs (inl Yield : yieldE + (forkE + E)) tt) (v i) u -> + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (Br n (fun j => schedule (S n) (replace_pool v i u) (Some j))). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inl Yield : yieldE + (forkE + E)) tt) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard: observe (v i) = GuardF t *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (br_schedule_pool_equ (replace_pool v i u0) + (replace_pool (replace_pool v i t) i u0) + (replace_pool_idem_equ v i t u0)). + apply (IHTR (replace_pool v i t) i u0). + + now rewrite replace_pool_hit. + + exact Hou. + + exact Hlbl. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + assert (Hu0 : u ≅ k tt). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (br_schedule_pool_equ (replace_pool v i u) + (replace_pool v i (k tt)) + (replace_pool_equ v v i u (k tt) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_yield n v i k (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma schedule_some_pool_equ {m} (v w : pool E (S m)) (i : Fin.t (S m)) : + pool_equ v w -> + schedule (S m) v (Some i) ≅ schedule (S m) w (Some i). + Proof. intro Hvw. apply schedule_pool_proper. exact Hvw. Qed. + + Lemma schedule_lift_user n (v : pool E (S n)) (i : Fin.t (S n)) + (e : E) (x : encode e) (u : thread E) : + trans (obs (inr (inr e) : yieldE + (forkE + E)) x) (v i) u -> + trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (schedule (S n) v (Some i)) + (schedule (S n) (replace_pool v i u) (Some i)). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inr (inr e) : yieldE + (forkE + E)) x) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_some_pool_equ (replace_pool v i u0) + (replace_pool (replace_pool v i t) i u0) i + (replace_pool_idem_equ v i t u0)). + apply (IHTR (replace_pool v i t) i u0). + + now rewrite replace_pool_hit. + + exact Hou. + + exact Hlbl. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + assert (Hu0 : u ≅ k x). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (schedule_some_pool_equ (replace_pool v i u) + (replace_pool v i (k x)) i + (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_user_event n v i e k x (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma schedule_lift_tau n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans tau (v i) u -> + trans tau + (schedule (S n) v (Some i)) + (schedule (S n) (replace_pool v i u) (Some i)). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (tau : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_some_pool_equ (replace_pool v i u0) + (replace_pool (replace_pool v i t) i u0) i + (replace_pool_idem_equ v i t u0)). + apply (IHTR (replace_pool v i t) i u0). + + now rewrite replace_pool_hit. + + exact Hou. + + exact Hlbl. + - (* Steptau *) + assert (Hu0 : u ≅ k x). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (schedule_some_pool_equ (replace_pool v i u) + (replace_pool v i (k x)) i + (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_br n v i n0 k x (eq_sym Hot)). + - discriminate Hlbl. + - discriminate Hlbl. + Qed. + + Lemma schedule_lift_fork n (v : pool E (S n)) (i : Fin.t (S n)) + (b : bool) (u : thread E) : + trans (obs (inr (inl Fork) : yieldE + (forkE + E)) b) (v i) u -> + exists k2, + (forall c : bool, + trans (obs (inr (inl Fork) : yieldE + (forkE + E)) c) (v i) (k2 c)) /\ + trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (schedule (S (S n)) + (cons_pool (k2 true) (replace_pool v i (k2 false))) + (Some (Fin.FS i))). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inr (inl Fork) : yieldE + (forkE + E)) b) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + destruct (IHTR (replace_pool v i t) i u0 + ltac:(now rewrite replace_pool_hit) Hou Hlbl) + as (k2 & Hcont & Hstep). + exists k2. split. + + intro c. specialize (Hcont c). + rewrite replace_pool_hit in Hcont. + rewrite (ictree_eta (v i)), <- Hot. + now apply trans_guard. + + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_pool_proper (S (S n)) + (cons_pool (k2 true) (replace_pool v i (k2 false))) + (cons_pool (k2 true) + (replace_pool (replace_pool v i t) i (k2 false))) + (Some (Fin.FS i))). + * exact Hstep. + * apply cons_pool_equ; [reflexivity |]. + apply replace_pool_idem_equ. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + exists k. split. + + intro c. + rewrite (ictree_eta (v i)), <- Hot. + apply trans_vis. + + apply (trans_schedule_focused_fork n v i k (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma cast_refl m (i : Fin.t m) : Fin.cast i eq_refl = i. + Proof. induction i; cbn; [reflexivity | now rewrite IHi]. Qed. + + Lemma remove_pool_agree {n} : + forall (v w : pool E (S n)) (i : Fin.t (S n)), + (forall j, i <> j -> v j ≅ w j) -> + pool_equ (remove_pool v i) (remove_pool w i). + Proof. + induction n as [| n IH]; intros v w i Hag j. + - dependent destruction j. + - cbn. dependent destruction i. + + apply Hag. intro Hc; discriminate. + + dependent destruction j. + * apply Hag. intro Hc; discriminate. + * apply IH. intros k Hik. + rewrite (cast_refl _ i) in Hik. + apply Hag. intro Heq. apply Hik. + apply Fin.FS_inj. exact Heq. + Qed. + + Lemma remove_replace_pool_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) + (a : thread E) : + pool_equ (remove_pool (replace_pool v i a) i) (remove_pool v i). + Proof. + apply remove_pool_agree. intros j Hij. + rewrite replace_pool_miss; [reflexivity | exact Hij]. + Qed. + + Lemma schedule_lift_ret n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans (val tt : label (yieldE + (forkE + E))) (v i) u -> + schedule (S n) v (Some i) ~ schedule n (remove_pool v i) None. + Proof. + intro TR. + unfold trans in TR. + remember (observe (v i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (val tt : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + rewrite sb_guard. + rewrite (IHTR (replace_pool v i t) i u0 + ltac:(now rewrite replace_pool_hit) Hou Hlbl). + now rewrite (schedule_pool_proper n (remove_pool (replace_pool v i t) i) + (remove_pool v i) None (remove_replace_pool_equ v i t)). + - discriminate Hlbl. + - discriminate Hlbl. + - (* Stepval *) + dependent destruction Hlbl. + rewrite (trans_schedule_focused_ret n v i (eq_sym Hot)). + apply sb_guard. + Qed. + + (** ** Phase 5: [schedule] preserves pool strong bisimilarity. *) + + Notation completed' := (completed E). + Notation stR R := (lattice.body (coinduction.t (sb eq)) R). + + Lemma schedule_match (R : rel completed' completed') + (Hch : forall m (w1 w2 : pool E m) f, + pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)) : + forall l os ot', trans_ l os ot' -> + forall n (v1 v2 : pool E n) focus (t' : completed'), + os = observe (schedule n v1 focus) -> + ot' = observe t' -> + pool_sbisim v1 v2 -> + exists u', trans l (schedule n v2 focus) u' /\ stR R t' u'. + Proof. + intros l os ot' TR. + induction TR; intros nn v1 v2 focus t' Hos Hot' Hpool. + - (* Stepguard *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. + * (* Ret: recurse on the smaller pool *) + destruct r0. + rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + dependent destruction Hos. + destruct (IHTR n' (remove_pool v1 i) (remove_pool v2 i) None t' + eq_refl Hot' (remove_pool_sbisim v1 v2 i Hpool)) + as (u' & Htru & Hresu). + assert (Hvr : v1 i ≅ Ret tt). + { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } + assert (Htrv : trans (val tt : label (yieldE + (forkE + E))) + (v1 i) stuck). + { rewrite Hvr. apply trans_ret. } + destruct (sbisim_trans (v1 i) (v2 i) stuck (val tt) eq + (Hpool i) Htrv) as (lv & uv & Htr2v & Hlv & Hsbv). + subst lv. + assert (Hlift : schedule (S n') v2 (Some i) + ~ schedule n' (remove_pool v2 i) None). + { apply (schedule_lift_ret n' v2 i uv Htr2v). } + destruct (sbisim_trans (schedule n' (remove_pool v2 i) None) + (schedule (S n') v2 (Some i)) u' l eq + ltac:(symmetry; exact Hlift) Htru) + as (lq & uq & Htrq & Hlq & Hsbq). + subst lq. + exists uq. split. + -- exact Htrq. + -- rewrite <- Hsbq. exact Hresu. + * (* Br: schedule head is a Br, not a Guard *) + rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + discriminate Hos. + * (* Guard: recurse on the same pool, focus unchanged *) + rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + dependent destruction Hos. + apply (IHTR (S n') (replace_pool v1 i g) v2 (Some i) t' + eq_refl Hot'). + intro j. unfold replace_pool. destruct (Fin.eq_dec i j) as [Hij | Hij]. + -- subst j. + assert (Hvg : v1 i ≅ Guard g). + { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } + transitivity (v1 i); [| apply Hpool]. + rewrite Hvg. symmetry. apply sb_guard. + -- apply Hpool. + * (* Vis: Yield (Guard head), or Fork / user (Vis head) *) + destruct e0 as [yld | [frk | usr]]. + -- (* Yield: invert the focused-yield residual directly *) + destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + dependent destruction Hos. + assert (TR0 : trans l + (schedule (S n') (replace_pool v1 i (k0 tt)) None) t'). + { unfold trans. rewrite <- Hot'. exact TR. } + apply trans_schedule_no_focus_inv in TR0 as (Hl & Hbr). + subst l. + assert (Hvis : v1 i ≅ Vis (inl Yield) k0). + { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } + assert (Htry : trans + (obs (inl Yield : yieldE + (forkE + E)) tt) (v1 i) (k0 tt)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 i) (v2 i) (k0 tt) + (obs (inl Yield : yieldE + (forkE + E)) tt) eq + (Hpool i) Htry) as (ly & uy & Htr2y & Hly & Hsby). + subst ly. + exists (Br n' (fun j => + schedule (S n') (replace_pool v2 i uy) (Some j))). split. + ++ apply (schedule_lift_yield n' v2 i uy Htr2y). + ++ rewrite Hbr. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + apply replace_pool_sbisim; assumption. + -- (* Fork: Vis head, not a Guard *) + destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- (* user: Vis head, not a Guard *) + rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. + - (* Steptau *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + dependent destruction Hos. + assert (Htr1 : trans tau (v1 i) (k0 x)). + { rewrite (ictree_eta (v1 i)), Hvi. + apply trans_br with (x := x). reflexivity. } + destruct (sbisim_trans (v1 i) (v2 i) (k0 x) tau eq (Hpool i) Htr1) + as (l' & u' & Htr2 & Hl' & Hsb). + subst l'. + exists (schedule (S n') (replace_pool v2 i u') (Some i)). split. + -- apply schedule_lift_tau. exact Htr2. + -- assert (Ht' : t' ≅ schedule (S n') (replace_pool v1 i (k0 x)) (Some i)). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. apply Hch. + apply replace_pool_sbisim; assumption. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. + - (* Stepobs *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 i)) as [r0 | b0 k0 | g | e1 k0] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e1 as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- (* Fork *) + destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + dependent destruction Hos. + destruct x. + assert (Hvis : v1 i ≅ Vis (inr (inl Fork)) k0). + { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } + assert (Htrf : trans + (obs (inr (inl Fork) : yieldE + (forkE + E)) false) (v1 i) + (k0 false)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 i) (v2 i) (k0 false) + (obs (inr (inl Fork)) false) eq (Hpool i) Htrf) + as (lf & uf & Htr2 & Hlf & Hsbf). + subst lf. + destruct (schedule_lift_fork n' v2 i false uf Htr2) + as (kf & Hforall & Hstep). + exists (schedule (S (S n')) + (cons_pool (kf true) (replace_pool v2 i (kf false))) + (Some (Fin.FS i))). + split. + ++ exact Hstep. + ++ assert (Ht' : t' ≅ schedule (S (S n')) + (cons_pool (k0 true) (replace_pool v1 i (k0 false))) + (Some (Fin.FS i))). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. + assert (Hii : v2 i ~ v1 i) by (symmetry; apply Hpool). + assert (Hkf : forall c, k0 c ~ kf c). + { intro c. + destruct (sbisim_trans (v2 i) (v1 i) (kf c) + (obs (inr (inl Fork)) c) eq Hii (Hforall c)) + as (lc & wc & Htrc & Hlc & Hsbc). + subst lc. + rewrite Hvis in Htrc. + apply trans_vis_inv in Htrc as (y & Hwy & Hly). + dependent destruction Hly. + rewrite Hwy in Hsbc. symmetry; exact Hsbc. } + apply Hch. + apply cons_pool_sbisim. + ** apply Hkf. + ** apply replace_pool_sbisim; [exact Hpool | apply Hkf]. + -- (* user event *) + rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + dependent destruction Hos. + assert (Hvis : v1 i ≅ Vis (inr (inr usr)) k0). + { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } + assert (Htru : trans + (obs (inr (inr usr) : yieldE + (forkE + E)) x) (v1 i) (k0 x)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 i) (v2 i) (k0 x) + (obs (inr (inr usr) : yieldE + (forkE + E)) x) eq + (Hpool i) Htru) + as (lu & u' & Htr2 & Hlu & Hsbu). + subst lu. + exists (schedule (S n') (replace_pool v2 i u') (Some i)). split. + ++ apply (schedule_lift_user n' v2 i usr x u' Htr2). + ++ assert (Ht' : t' ≅ + schedule (S n') (replace_pool v1 i (k0 x)) (Some i)). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. apply Hch. + apply replace_pool_sbisim; assumption. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * (* None nonempty Yield *) + rewrite (schedule_no_focus_nonempty n' v1) in Hos. + dependent destruction Hos. + destruct x. + exists (Br n' (fun j => schedule (S n') v2 (Some j))). split. + -- apply (trans_schedule_no_focus_nonempty n' v2). + -- assert (Ht' : t' ≅ Br n' (fun j => schedule (S n') v1 (Some j))). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. exact Hpool. + - (* Stepval *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 i)) as [r0 | b k | g | e k] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b k Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k Hvi) in Hos. + discriminate Hos. + -- destruct frk. + rewrite (schedule_focused_fork n' v1 i k Hvi) in Hos. + discriminate Hos. + -- rewrite (schedule_focused_user_event n' v1 i usr k Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. + inversion Hos; subst. + exists stuck. split. + -- rewrite (trans_schedule_empty_ret v2). apply trans_ret. + -- assert (Ht' : t' ≅ stuck). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. reflexivity. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. + discriminate Hos. + Qed. + + Theorem sbisim_schedule n (v1 v2 : pool E n) focus : + pool_sbisim v1 v2 -> schedule n v1 focus ~ schedule n v2 focus. + Proof. + revert n v1 v2 focus. + coinduction R CH. + intros n v1 v2 focus Hpool. + assert (Hch : forall m (w1 w2 : pool E m) f, + pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)). + { intros m w1 w2 f Hw. apply CH. exact Hw. } + split. + - intros l t' TR. + destruct (schedule_match R Hch _ _ _ TR n v1 v2 focus t' + eq_refl eq_refl Hpool) as (u' & Htru & Hres). + exists l, u'. split; [exact Htru | split; [exact Hres | reflexivity]]. + - intros l t' TR. + destruct (schedule_match R Hch _ _ _ TR n v2 v1 focus t' + eq_refl eq_refl (pool_sbisim_sym v1 v2 Hpool)) + as (u' & Htru & Hres). + exists l, u'. split; [exact Htru | split]. + + unfold Basics.flip. symmetry. exact Hres. + + reflexivity. + Qed. + + +End SchedulerTransitions. + +(** ** Phase 6: scheduler-visible denotation respects thread bisimilarity. *) + +(** Two source statements with strongly-bisimilar thread denotations yield + strongly-bisimilar scheduler-visible computations. This is the singleton + instance of [sbisim_schedule] for the start-up pool of [scheduled_visible]. *) +Corollary sbisim_scheduled_visible (s1 s2 : YStmt) : + denote_stmt s1 ~ denote_stmt s2 -> + scheduled_visible s1 ~ scheduled_visible s2. +Proof. + intro Hs. + unfold scheduled_visible. + apply sbisim_schedule. + intro i. exact Hs. +Qed. From a05210e63eb549544d967ce3c664be927d3a97ad Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Thu, 4 Jun 2026 11:44:51 +0000 Subject: [PATCH 03/14] feat(lang): make YFork single-body spawn MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Update Yield source syntax so YFork accepts a single child body and use flow-sensitive statement denotation to keep spawned children from inheriting surrounding continuations. Restore fork-facing façade/regression lemmas for the public Yield surface while preserving the raw scheduler boundary. Assistant-model: GPT-5.5 --- theories/Lang/Yield/Denote.v | 64 +++++++++---- theories/Lang/Yield/Interp.v | 3 +- theories/Lang/Yield/Syntax.v | 7 +- theories/Lang/Yield/Ticl.v | 174 +++++++++++++++++++++++++++-------- 4 files changed, 188 insertions(+), 60 deletions(-) diff --git a/theories/Lang/Yield/Denote.v b/theories/Lang/Yield/Denote.v index 300112a..08a4108 100644 --- a/theories/Lang/Yield/Denote.v +++ b/theories/Lang/Yield/Denote.v @@ -1,6 +1,11 @@ From Stdlib Require Import Nat Strings.String. From ExtLib Require Import Data.Map.FMapAList Data.String Structures.Maps. -From TICL Require Import ICTree.Core Events.StateE Lang.Maps Lang.Yield.Events Lang.Yield.Syntax. +From TICL Require Import + ICTree.Core + Events.StateE + Lang.Maps + Lang.Yield.Events + Lang.Yield.Syntax. Import ICtree ICTreeNotations. Local Open Scope ictree_scope. @@ -14,7 +19,8 @@ Definition YEff := yieldE + (forkE + Mem). Definition ytrigger (e : YEff) : ictree YEff (encode e) := @ICtree.trigger YEff YEff _ _ ReSum_refl ReSumRet_refl e. Definition yget : ictree YEff Ctx := ytrigger (inr (inr Get)). -Definition yput (m : Ctx) : ictree YEff unit := ytrigger (inr (inr (Put m))). +Definition yput (m : Ctx) : ictree YEff unit := + ytrigger (inr (inr (Put m))). Definition yyield : ictree YEff unit := ytrigger (inl Yield). Definition yfork : ictree YEff bool := ytrigger (inr (inl Fork)). @@ -43,36 +49,62 @@ Fixpoint denote_exp (e : YExp) : ictree YEff nat := Ret (x * y)%nat end. -(** Denotation of statements to unscheduled Yield threads. *) -Fixpoint denote_stmt (s : YStmt) : ictree YEff unit := +(** Internal result used to prevent child threads from inheriting source + continuations outside their fork body. + + [Fallthrough] means the current thread should continue with the enclosing + source continuation. [HaltThread] means a spawned child has finished its + declared body and must not inherit enclosing continuations. *) +Inductive YStmtFlow : Type := +| Fallthrough +| HaltThread. + +(** Flow-sensitive denotation of statements. *) +Fixpoint denote_stmt_flow (s : YStmt) : ictree YEff YStmtFlow := match s with | YAssign name expr => value <- denote_exp expr;; ctx <- yget;; - yput (add name value ctx) + yput (add name value ctx);; + Ret Fallthrough | YSeq a b => - denote_stmt a;; - denote_stmt b + flow <- denote_stmt_flow a;; + match flow with + | Fallthrough => denote_stmt_flow b + | HaltThread => Ret HaltThread + end | YIf test then_branch else_branch => condition_value <- denote_exp test;; if is_true condition_value then - denote_stmt then_branch + denote_stmt_flow then_branch else - denote_stmt else_branch + denote_stmt_flow else_branch | YWhile test body => ICtree.iter (fun _ => condition_value <- denote_exp test;; if is_true condition_value then - denote_stmt body;; Ret (inl tt) + flow <- denote_stmt_flow body;; + match flow with + | Fallthrough => Ret (inl tt) + | HaltThread => Ret (inr HaltThread) + end else - Ret (inr tt)) tt - | YFork inactive active => + Ret (inr Fallthrough)) tt + | YFork body => in_child <- yfork;; if in_child then - denote_stmt inactive + _ <- denote_stmt_flow body;; + Ret HaltThread else - denote_stmt active - | YSkip => Ret tt - | YYield => yyield + Ret Fallthrough + | YSkip => Ret Fallthrough + | YYield => + yyield;; + Ret Fallthrough end. + +(** Public denotation of statements to unscheduled Yield threads. *) +Definition denote_stmt (s : YStmt) : ictree YEff unit := + _ <- denote_stmt_flow s;; + Ret tt. diff --git a/theories/Lang/Yield/Interp.v b/theories/Lang/Yield/Interp.v index dc1487b..14c4e9e 100644 --- a/theories/Lang/Yield/Interp.v +++ b/theories/Lang/Yield/Interp.v @@ -64,7 +64,8 @@ Definition interp_scheduled_erased (s : YStmt) : ictree Mem unit := Definition interp_scheduled : YStmt -> ictree Mem unit := interp_scheduled_erased. (** Interpret a raw thread without scheduling by resolving [Fork] to [false], - i.e. taking the active branch. *) + so a standalone thread behaves as the parent path and never starts the + fork body. *) Definition handle_thread : YEff ~> ictree (yieldE + Mem) := fun event => match event with diff --git a/theories/Lang/Yield/Syntax.v b/theories/Lang/Yield/Syntax.v index 48d734a..5c6a554 100644 --- a/theories/Lang/Yield/Syntax.v +++ b/theories/Lang/Yield/Syntax.v @@ -16,9 +16,10 @@ Module YieldSyntax. | YSeq (a b : YStmt) | YIf (i : YExp) (t e : YStmt) | YWhile (t : YExp) (b : YStmt) - (** [YFork inactive active] keeps the prior branch polarity: - the fork result [true] selects [inactive], and [false] selects [active]. *) - | YFork (inactive active : YStmt) + (** [YFork body] spawns [body] as the child-side statement. + The parent path performs no source statement at the fork node; it + continues through the surrounding sequence. *) + | YFork (body : YStmt) | YSkip | YYield. diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v index 0f462e1..bb63837 100644 --- a/theories/Lang/Yield/Ticl.v +++ b/theories/Lang/Yield/Ticl.v @@ -71,49 +71,78 @@ Lemma denote_exp_ymult a b : (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). Proof. reflexivity. Qed. -(** Statement denotation constructor unfold facts. *) -Lemma denote_stmt_yassign name expr : - denote_stmt (YAssign name expr) = - (value <- denote_exp expr;; ctx <- yget;; yput (add name value ctx)). +(** Flow-sensitive statement denotation constructor unfold facts. *) +Lemma denote_stmt_unfold s : + denote_stmt s = (_ <- denote_stmt_flow s;; Ret tt). Proof. reflexivity. Qed. -Lemma denote_stmt_yseq a b : - denote_stmt (YSeq a b) = (denote_stmt a;; denote_stmt b). +Lemma denote_stmt_flow_yassign name expr : + denote_stmt_flow (YAssign name expr) = + (value <- denote_exp expr;; + ctx <- yget;; + yput (add name value ctx);; + Ret Fallthrough). Proof. reflexivity. Qed. -Lemma denote_stmt_yif test then_branch else_branch : - denote_stmt (YIf test then_branch else_branch) = +Lemma denote_stmt_flow_yseq a b : + denote_stmt_flow (YSeq a b) = + (flow <- denote_stmt_flow a;; + match flow with + | Fallthrough => denote_stmt_flow b + | HaltThread => Ret HaltThread + end). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yif test then_branch else_branch : + denote_stmt_flow (YIf test then_branch else_branch) = (condition_value <- denote_exp test;; if YieldSyntax.is_true condition_value then - denote_stmt then_branch + denote_stmt_flow then_branch else - denote_stmt else_branch). + denote_stmt_flow else_branch). Proof. reflexivity. Qed. -Lemma denote_stmt_ywhile test body : - denote_stmt (YWhile test body) = +Lemma denote_stmt_flow_ywhile test body : + denote_stmt_flow (YWhile test body) = ICtree.iter (fun _ => condition_value <- denote_exp test;; if YieldSyntax.is_true condition_value then - denote_stmt body;; Ret (inl tt) + flow <- denote_stmt_flow body;; + match flow with + | Fallthrough => Ret (inl tt) + | HaltThread => Ret (inr HaltThread) + end else - Ret (inr tt)) tt. + Ret (inr Fallthrough)) tt. Proof. reflexivity. Qed. -Lemma denote_stmt_yfork inactive active : - denote_stmt (YFork inactive active) = +Lemma denote_stmt_flow_yfork body : + denote_stmt_flow (YFork body) = (in_child <- yfork;; if in_child then - denote_stmt inactive + _ <- denote_stmt_flow body;; + Ret HaltThread else - denote_stmt active). + Ret Fallthrough). Proof. reflexivity. Qed. -Lemma denote_stmt_yskip : denote_stmt YSkip = Ret tt. +Lemma denote_stmt_yfork body : + denote_stmt (YFork body) = + (_ <- (in_child <- yfork;; + if in_child then + _ <- denote_stmt_flow body;; + Ret HaltThread + else + Ret Fallthrough);; + Ret tt). Proof. reflexivity. Qed. -Lemma denote_stmt_yyield : denote_stmt YYield = yyield. +Lemma denote_stmt_flow_yskip : denote_stmt_flow YSkip = Ret Fallthrough. +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yyield : + denote_stmt_flow YYield = (yyield;; Ret Fallthrough). Proof. reflexivity. Qed. (** Scheduler one-step/case regression facts. *) @@ -304,41 +333,106 @@ Section SchedulerPoolRegressions. End SchedulerPoolRegressions. (** Concrete scheduler-visible examples. *) +Local Ltac solve_visible_regression := + cbn; + unfold resum, ReSum_refl, resum_ret, ReSumRet_refl; + reflexivity. + Lemma scheduled_visible_yyield_one_step : observe (scheduled_visible YYield) = GuardF (schedule 1 - (replace_pool (fun _ : Fin.t 1 => denote_stmt YYield) Fin.F1 (Ret tt)) + (replace_pool + (fun _ : Fin.t 1 => denote_stmt YYield) + Fin.F1 (denote_stmt YSkip)) None). -Proof. reflexivity. Qed. +Proof. + unfold scheduled_visible. + apply (@schedule_focused_yield Mem _ 0 + (fun _ : Fin.t 1 => denote_stmt YYield) + Fin.F1 + (fun _ : unit => denote_stmt YSkip)). + solve_visible_regression. +Qed. -Lemma scheduled_visible_yfork_skip_skip_one_step : - observe (scheduled_visible (YFork YSkip YSkip)) = - let fork_continuation := - fun in_child : bool => - ICtree.subst' - (fun in_child : bool => if in_child then Ret tt else Ret tt) - (RetF in_child) in +Definition yfork_yield_fork_continuation (in_child : bool) : thread Mem := + ICtree.subst' + (fun _ : YStmtFlow => Ret tt) + (observe + (ICtree.subst' + (fun branch : bool => + if branch then + denote_stmt_flow YYield;; Ret HaltThread + else + Ret Fallthrough) + (RetF in_child))). + +Lemma scheduled_visible_yfork_yield_one_step : + observe (scheduled_visible (YFork YYield)) = VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) (fun _ => schedule 2 - (cons_pool (fork_continuation true) + (cons_pool (yfork_yield_fork_continuation true) (replace_pool - (fun _ : Fin.t 1 => denote_stmt (YFork YSkip YSkip)) - Fin.F1 (fork_continuation false))) + (fun _ : Fin.t 1 => denote_stmt (YFork YYield)) + Fin.F1 (yfork_yield_fork_continuation false))) (Some (Fin.FS Fin.F1))). Proof. unfold scheduled_visible. apply (@schedule_focused_fork Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt (YFork YSkip YSkip)) + (fun _ : Fin.t 1 => denote_stmt (YFork YYield)) Fin.F1 - (fun in_child : bool => - ICtree.subst' - (fun in_child : bool => if in_child then Ret tt else Ret tt) - (RetF in_child))). - cbn. - unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. - reflexivity. + yfork_yield_fork_continuation). + solve_visible_regression. +Qed. + +Definition yseq_yfork_skip_yield_fork_continuation + (in_child : bool) : thread Mem := + ICtree.subst' + (fun _ : YStmtFlow => Ret tt) + (observe + (ICtree.subst' + (fun flow : YStmtFlow => + match flow with + | Fallthrough => denote_stmt_flow YYield + | HaltThread => Ret HaltThread + end) + (observe + (ICtree.subst' + (fun branch : bool => + if branch then + denote_stmt_flow YSkip;; Ret HaltThread + else + Ret Fallthrough) + (RetF in_child))))). + +Lemma yseq_yfork_skip_yield_child_done : + observe (yseq_yfork_skip_yield_fork_continuation true) = RetF tt. +Proof. solve_visible_regression. Qed. + +Lemma yseq_yfork_skip_yield_parent_yields : + observe (yseq_yfork_skip_yield_fork_continuation false) = + VisF ((inl Yield) : YEff) (fun _ : unit => denote_stmt YSkip). +Proof. solve_visible_regression. Qed. + +Lemma scheduled_visible_yseq_yfork_skip_yield_one_step : + observe (scheduled_visible (YSeq (YFork YSkip) YYield)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) + (fun _ => + schedule 2 + (cons_pool (yseq_yfork_skip_yield_fork_continuation true) + (replace_pool + (fun _ : Fin.t 1 => + denote_stmt (YSeq (YFork YSkip) YYield)) + Fin.F1 (yseq_yfork_skip_yield_fork_continuation false))) + (Some (Fin.FS Fin.F1))). +Proof. + unfold scheduled_visible. + apply (@schedule_focused_fork Mem _ 0 + (fun _ : Fin.t 1 => denote_stmt (YSeq (YFork YSkip) YYield)) + Fin.F1 + yseq_yfork_skip_yield_fork_continuation). + solve_visible_regression. Qed. (** Erasure handlers intentionally hide scheduler/thread observations. *) From 167312595fe0f8d6e26fb172e8e406c10820094d Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 5 Jun 2026 03:53:31 +0000 Subject: [PATCH 04/14] feat(lang): add Yield structural lemmas Add generic expression, assignment, sequence, branch, while, and fork structural proof doors for the Yield language, including the public while invariant lemma. AI-Assisted-By: GPT-5.5 --- theories/Lang/Yield/Ticl.v | 891 ++++++++++++++++++++++++++++++++++++- 1 file changed, 889 insertions(+), 2 deletions(-) diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v index bb63837..477e819 100644 --- a/theories/Lang/Yield/Ticl.v +++ b/theories/Lang/Yield/Ticl.v @@ -19,7 +19,9 @@ APIs are erased. *) From Stdlib Require Import Fin + Morphisms Nat + Program.Equality Strings.String. From ExtLib Require Import @@ -38,11 +40,96 @@ From TICL Require Export From TICL Require Import ICTree.Core ICTree.Equ - ICTree.Interp.Core. + ICTree.Eq.Bind + ICTree.Events.Writer + ICTree.Interp.Core + ICTree.Interp.State + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.Bind + ICTree.Logic.CanStep + ICTree.Logic.Iter + ICTree.Logic.State + ICTree.SBisim + Logic.Core. -Import ICtree ICTreeNotations. +Import ICtree ICTreeNotations TiclNotations. +Local Open Scope ticl_scope. Local Open Scope ictree_scope. +Local Typeclasses Transparent equ. +Lemma interp_equ_hetero + {E F : Type} `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) : + forall (x y : ictree E X), + x ≅ y -> @equ F _ X X eq (interp h x) (interp h y). +Proof. + change (forall x y : ictree E X, + @equ E _ X X eq x y -> + @equ F _ X X eq (interp h x) (interp h y)). + __coinduction_equ RR IH; intros * EQ1. + setoid_rewrite unfold_iter. + step in EQ1; inv EQ1. + - setoid_rewrite bind_ret_l; reflexivity. + - setoid_rewrite bind_bind; setoid_rewrite bind_ret_l. + upto_bind_equ. + constructor. intros. + apply IH. apply H3. + - setoid_rewrite bind_ret_l. + constructor. + apply IH. apply H3. + - setoid_rewrite bind_bind. + upto_bind_equ. + setoid_rewrite bind_ret_l. + constructor. + apply IH. apply H3. +Qed. + +#[local] Instance interp_equ_hetero_proper + {E F : Type} `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) : + Proper (equ eq ==> equ eq) (@interp E _ _ _ _ _ h X). +Proof. + intros x y Hxy. + now apply interp_equ_hetero. +Qed. + +Lemma interp_bind_hetero + {E F : Type} `{Encode E} `{Encode F} {A B} + (h : E ~> ictree F) (t : ictree E A) (k : A -> ictree E B) : + interp h (x <- t;; k x) ≅ (x <- interp h t;; interp h (k x)). +Proof. + revert t. + __coinduction_equ RR IH; intros. + rewrite (ictree_eta t). + rewrite unfold_bind, unfold_interp. + destruct (observe t) eqn:Hobs; cbn. + - rewrite unfold_interp. + cbn. + rewrite bind_ret_l. + rewrite unfold_interp. + reflexivity. + - rewrite unfold_interp. + cbn. + rewrite bind_br. + setoid_rewrite bind_guard. + constructor; intro i. + step; econstructor; intros. + apply IH. + - rewrite (@unfold_interp _ _ _ _ _ h (Guard t0)). + cbn. + rewrite bind_guard. + constructor. + apply IH. + - rewrite unfold_interp. + cbn. + rewrite bind_bind. + upto_bind_equ. + rewrite bind_guard. + constructor. + apply IH. +Qed. + (** Expression denotation constructor unfold facts. *) Lemma denote_exp_yvar name : denote_exp (YVar name) = @@ -145,6 +232,715 @@ Lemma denote_stmt_flow_yyield : denote_stmt_flow YYield = (yyield;; Ret Fallthrough). Proof. reflexivity. Qed. +(** Erased source-structural facts for the state-only TICL tier. *) +Local Ltac unfold_erased_expression := + unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE; + cbn; + setoid_rewrite unfold_interp; + cbn. + +Local Ltac unfold_erased_statement := + unfold instr_stmt_erased, interp_scheduled_erased, interp_yield, + interp_spawn, scheduled_visible, instr_stateE; + cbn; + setoid_rewrite unfold_interp; + cbn. + +Local Ltac step_erased_state := + rewrite interp_state_tau, sb_guard; + setoid_rewrite unfold_interp; + cbn. + +Local Ltac expose_erased_get_result ctx := + rewrite interp_state_tau, sb_guard; + change (resum_ret (inr (inr StateE.Get)) (resum_ret StateE.Get ctx)) + with ctx; + setoid_rewrite unfold_interp; + cbn; + rewrite interp_state_tau, sb_guard; + setoid_rewrite unfold_interp; + cbn. + +Local Ltac step_erased_state3 := + step_erased_state; step_erased_state; step_erased_state. + +(** Flow-preserving erased statement instrumentation for structural facts whose + contracts must expose [Fallthrough] versus [HaltThread]. The public + [instr_stmt_erased] remains the scheduled unit-returning view. *) +Definition instr_stmt_flow_erased + (s : YStmt) (ctx : Ctx) : ictreeW Ctx (YStmtFlow * Ctx) := + instr_stateE (interp_thread (denote_stmt_flow s)) ctx. + +Lemma axr_yexp_ylit : forall n n' ctx ctx' w w', + n = n' -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YLit n) ctx}, + w |= AX done= {(n', ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_expression. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axr_yexp_yvar_some : forall name value ctx ctx' w w', + lookup name ctx = Some value -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YVar name) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_expression. + eapply anr_state_bind_r_eq. + - rewrite interp_state_get. + now apply axr_ret. + - cbn. + rewrite interp_state_tau, sb_guard. + change (resum_ret (inr (inr StateE.Get)) (resum_ret StateE.Get ctx')) + with ctx'. + setoid_rewrite subst_ret_l. + cbn. + setoid_rewrite unfold_interp. + cbn. + rewrite interp_state_tau, sb_guard. + setoid_rewrite subst_ret_l. + cbn. + setoid_rewrite unfold_interp. + cbn. + change (alist_find RelDec_string name ctx') with (lookup name ctx'). + destruct (lookup name ctx') eqn:Hlookup; try congruence. + inv H. + cbn. + rewrite bind_ret_l. + repeat (rewrite interp_state_tau, sb_guard). + change (resum_ret (inl Yield) (resum_ret Yield tt)) with tt. + rewrite subst_ret_l. + cbn. + setoid_rewrite unfold_interp. + cbn. + rewrite interp_state_tau, sb_guard. + rewrite subst_ret_l. + cbn. + setoid_rewrite unfold_interp. + cbn. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axr_yexp_yplus : forall a b x y value ctx ctx' w w', + <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> + <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> + value = (x + y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YPlus a b) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. + subst. + unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + - exact Ha. + - cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + + exact Hb. + + cbn. + rewrite !unfold_interp. + cbn. + rewrite interp_state_ret. + apply axr_ret; auto. +Qed. + +Lemma axr_yexp_yminus : forall a b x y value ctx ctx' w w', + <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> + <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> + value = (x - y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YMinus a b) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. + subst. + unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + - exact Ha. + - cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + + exact Hb. + + cbn. + rewrite !unfold_interp. + cbn. + rewrite interp_state_ret. + apply axr_ret; auto. +Qed. + +Lemma axr_yexp_ymult : forall a b x y value ctx ctx' w w', + <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> + <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> + value = (x * y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YMult a b) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. + subst. + unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + - exact Ha. + - cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq. + + exact Hb. + + cbn. + rewrite !unfold_interp. + cbn. + rewrite interp_state_ret. + apply axr_ret; auto. +Qed. + +Lemma axr_yexp_yplus_ylit_ylit : forall x y value ctx ctx' w w', + value = (x + y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YPlus (YLit x) (YLit y)) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_expression. + repeat rewrite subst_ret_l. + cbn. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axr_yexp_yminus_ylit_ylit : forall x y value ctx ctx' w w', + value = (x - y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YMinus (YLit x) (YLit y)) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_expression. + repeat rewrite subst_ret_l. + cbn. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axr_yexp_ymult_ylit_ylit : forall x y value ctx ctx' w w', + value = (x * y)%nat -> + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (YMult (YLit x) (YLit y)) ctx}, + w |= AX done= {(value, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_expression. + repeat rewrite subst_ret_l. + cbn. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axr_ystmt_yskip_erased : forall ctx ctx' w w', + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_stmt_erased YSkip ctx}, + w |= AX done= {(tt, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_statement. + step_erased_state. + rewrite interp_state_ret. + now apply axr_ret. +Qed. + +Lemma axax_ystmt_yyield_erased : forall ctx ctx' w w', + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_stmt_erased YYield ctx}, + w |= AX AX done= {(tt, ctx')} w' ]>. +Proof. + intros; subst. + unfold_erased_statement. + step_erased_state. + rewrite bind_ret_l. + cbn. + step_erased_state. + step_erased_state. + apply anr_state_br; split. + - csplit; auto. + - intro i; dependent destruction i. + + step_erased_state3. + rewrite interp_state_ret. + apply axr_ret; auto. + + inversion i. +Qed. + +Lemma aur_ystmt_yyield_erased : forall ctx ctx' w w' ψ, + ctx = ctx' -> + w = w' -> + not_done w -> + <[ {instr_stmt_erased YYield ctx}, + w |= ψ AU AX AX done= {(tt, ctx')} w' ]>. +Proof. + intros; subst. + cleft. + now apply axax_ystmt_yyield_erased. +Qed. + +Local Definition yassign_after_value + (name : var) (value : nat) : ictree YEff YStmtFlow := + ctx <- yget;; yput (add name value ctx);; Ret Fallthrough. + +Local Lemma aur_yassign_after_value : forall name value ctx w ψ R, + <( {log (add name value ctx)}, w |= ψ )> -> + R (Fallthrough, add name value ctx) + (Obs (Log (add name value ctx)) tt) -> + <[ {instr_stateE (interp_thread (yassign_after_value name value)) ctx}, + w |= ψ AU AX done R ]>. +Proof. + intros name value ctx w ψ R Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + unfold yassign_after_value, interp_thread, interp_yield, instr_stateE. + cbn. + setoid_rewrite unfold_interp. + cbn. + eapply aur_state_bind_r_eq. + - apply aur_get; auto; split; reflexivity. + - cbn. + expose_erased_get_result ctx. + eapply aur_state_bind_r_eq. + + apply aur_put; auto; split; reflexivity. + + cbn. + step_erased_state. + step_erased_state. + rewrite interp_state_ret. + cleft. + apply axr_ret; auto. + constructor. +Qed. + +Local Lemma aul_yassign_after_value : forall name value ctx w ψ φ, + <( {log (add name value ctx)}, w |= ψ )> -> + <( {Ret (Fallthrough, add name value ctx)}, + {Obs (Log (add name value ctx)) tt} |= φ )> -> + <( {instr_stateE (interp_thread (yassign_after_value name value)) ctx}, + w |= ψ AU φ )>. +Proof. + intros name value ctx w ψ φ Hlog Hret. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + unfold yassign_after_value, interp_thread, interp_yield, instr_stateE. + cbn. + setoid_rewrite unfold_interp. + cbn. + eapply aul_state_bind_r_eq. + - apply aur_get; auto; split; reflexivity. + - cbn. + expose_erased_get_result ctx. + eapply aul_state_bind_r_eq. + + apply aur_put; auto; split; reflexivity. + + cbn. + step_erased_state. + step_erased_state. + rewrite interp_state_ret. + cleft. + exact Hret. +Qed. + +Lemma aur_ystmt_yassign : forall name expr value ctx w ψ R, + <[ {instr_exp_erased expr ctx}, w |= AX done= {(value, ctx)} w ]> -> + <( {log (add name value ctx)}, w |= ψ )> -> + R (Fallthrough, add name value ctx) + (Obs (Log (add name value ctx)) tt) -> + <[ {instr_stmt_flow_erased (YAssign name expr) ctx}, + w |= ψ AU AX done R ]>. +Proof. + intros name expr value ctx w ψ R Hexp Hlog HR. + unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, + interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aur_bind_r_eq. + - cleft. + exact Hexp. + - cbn. + change (interp_state h_stateW + (interp handle_yield + (interp handle_thread + (ctx <- yget;; yput (add name value ctx);; + Ret Fallthrough))) ctx) + with (instr_stateE (interp_thread (yassign_after_value name value)) ctx). + now apply aur_yassign_after_value. +Qed. + +Lemma aul_ystmt_yassign : forall name expr value ctx w ψ φ, + <[ {instr_exp_erased expr ctx}, w |= AX done= {(value, ctx)} w ]> -> + <( {log (add name value ctx)}, w |= ψ )> -> + <( {Ret (Fallthrough, add name value ctx)}, + {Obs (Log (add name value ctx)) tt} |= φ )> -> + <( {instr_stmt_flow_erased (YAssign name expr) ctx}, w |= ψ AU φ )>. +Proof. + intros name expr value ctx w ψ φ Hexp Hlog Hret. + unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, + interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aul_bind_r_eq. + - cleft. + exact Hexp. + - cbn. + change (interp_state h_stateW + (interp handle_yield + (interp handle_thread + (ctx <- yget;; yput (add name value ctx);; + Ret Fallthrough))) ctx) + with (instr_stateE (interp_thread (yassign_after_value name value)) ctx). + now apply aul_yassign_after_value. +Qed. + +Lemma anr_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, + <[ {instr_stmt_flow_erased a ctx}, + w |= φ AN done= {(Fallthrough, ctx')} w' ]> -> + <[ {instr_stmt_flow_erased b ctx'}, w' |= φ AN ψ ]> -> + <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AN ψ ]>. +Proof. + intros a b ctx ctx' w w' φ ψ Ha Hb. + unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply anr_bind_r_eq; eauto. +Qed. + +Lemma aur_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, + <[ {instr_stmt_flow_erased a ctx}, + w |= φ AU AX done= {(Fallthrough, ctx')} w' ]> -> + <[ {instr_stmt_flow_erased b ctx'}, w' |= φ AU ψ ]> -> + <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ ]>. +Proof. + intros a b ctx ctx' w w' φ ψ Ha Hb. + unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aur_bind_r_eq; eauto. +Qed. + +Lemma aul_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, + <[ {instr_stmt_flow_erased a ctx}, + w |= φ AU AX done= {(Fallthrough, ctx')} w' ]> -> + <( {instr_stmt_flow_erased b ctx'}, w' |= φ AU ψ )> -> + <( {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ )>. +Proof. + intros a b ctx ctx' w w' φ ψ Ha Hb. + unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aul_bind_r_eq; eauto. +Qed. + +Lemma yseq_halt_propagates : forall a b ctx ctx' w w' φ, + <[ {instr_stmt_flow_erased a ctx}, + w |= φ AU AX done= {(HaltThread, ctx')} w' ]> -> + not_done w' -> + <[ {instr_stmt_flow_erased (YSeq a b) ctx}, + w |= φ AU AX done= {(HaltThread, ctx')} w' ]>. +Proof. + intros a b ctx ctx' w w' φ Ha Hnd. + unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aur_bind_r_eq. + - exact Ha. + - cbn. + rewrite !unfold_interp. + cbn. + apply aur_state_ret; auto; split; reflexivity. +Qed. + +Lemma aul_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, + <[ {instr_exp_erased test ctx}, w |= AX done= {(condition, ctx)} w ]> -> + (if YieldSyntax.is_true condition then + <( {instr_stmt_flow_erased then_branch ctx}, w |= φ AU ψ )> + else + <( {instr_stmt_flow_erased else_branch ctx}, w |= φ AU ψ )>) -> + <( {instr_stmt_flow_erased (YIf test then_branch else_branch) ctx}, + w |= φ AU ψ )>. +Proof. + intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. + unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, + interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aul_bind_r_eq. + - cleft; exact Htest. + - cbn. + destruct (YieldSyntax.is_true condition); exact Hbranch. +Qed. + +Lemma aur_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, + <[ {instr_exp_erased test ctx}, w |= AX done= {(condition, ctx)} w ]> -> + (if YieldSyntax.is_true condition then + <[ {instr_stmt_flow_erased then_branch ctx}, w |= φ AU ψ ]> + else + <[ {instr_stmt_flow_erased else_branch ctx}, w |= φ AU ψ ]>) -> + <[ {instr_stmt_flow_erased (YIf test then_branch else_branch) ctx}, + w |= φ AU ψ ]>. +Proof. + intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. + unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, + interp_yield, instr_stateE in *. + cbn. + rewrite !interp_bind_hetero. + rewrite !interp_state_bind. + eapply aur_bind_r_eq. + - cleft; exact Htest. + - cbn. + destruct (YieldSyntax.is_true condition); exact Hbranch. +Qed. + +(** Raw source-flow while unrolling facts. These expose [YStmtFlow] + directly, avoiding any claim that the scheduled erased unit layer can + distinguish loop fallthrough from child-thread halt. *) +Definition ywhile_iteration (test : YExp) (body : YStmt) : + ictree YEff (unit + YStmtFlow) := + condition_value <- denote_exp test;; + if YieldSyntax.is_true condition_value then + flow <- denote_stmt_flow body;; + match flow with + | Fallthrough => Ret (inl tt) + | HaltThread => Ret (inr HaltThread) + end + else + Ret (inr Fallthrough). + +Lemma aul_ystmt_ywhile_true : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + YieldSyntax.is_true condition = true -> + <[ {denote_stmt_flow body}, + w |= φ AU AX done= Fallthrough w' ]> -> + not_done w' -> + <( {denote_stmt_flow (YWhile test body)}, w' |= φ AU ψ )> -> + <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. + cbn. + eapply aul_iter_next with (R := fun (_ : unit) w0 => w0 = w'). + - eapply aur_bind_r_eq. + + exact Htest. + + rewrite Htrue. + eapply aur_bind_r_eq. + * exact Hbody. + * cbn. + cleft. + apply axr_ret; auto. + exists tt; split; auto. + - intros [] w0 ->. + exact Hloop. +Qed. + +Lemma aul_ystmt_ywhile_false : forall test body condition w φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + YieldSyntax.is_true condition = false -> + <( {Ret Fallthrough}, w |= ψ )> -> + <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w φ ψ Htest Hfalse Hret. + pose proof Htest as Htest_not_done. + apply aur_not_done in Htest_not_done. + cbn. + rewrite unfold_iter. + eapply aul_bind_r_eq. + - eapply aur_bind_r_eq. + + exact Htest. + + rewrite Hfalse. + cbn. + cleft. + apply axr_ret. + * exact Htest_not_done. + * split; reflexivity. + - cbn. + cleft. + exact Hret. +Qed. + +Lemma aul_ystmt_ywhile_halt : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + YieldSyntax.is_true condition = true -> + <[ {denote_stmt_flow body}, + w |= φ AU AX done= HaltThread w' ]> -> + not_done w' -> + <( {Ret HaltThread}, w' |= ψ )> -> + <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hret. + cbn. + rewrite unfold_iter. + eapply aul_bind_r_eq. + - eapply aur_bind_r_eq. + + exact Htest. + + rewrite Htrue. + eapply aur_bind_r_eq. + * exact Hbody. + * cbn. + cleft. + apply axr_ret; auto. + - cbn. + cleft. + exact Hret. +Qed. + +Lemma aur_ystmt_ywhile_true : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + YieldSyntax.is_true condition = true -> + <[ {denote_stmt_flow body}, + w |= φ AU AX done= Fallthrough w' ]> -> + not_done w' -> + <[ {denote_stmt_flow (YWhile test body)}, w' |= φ AU AX ψ ]> -> + <[ {denote_stmt_flow (YWhile test body)}, w |= φ AU AX ψ ]>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. + cbn. + eapply aur_iter_next with (R := fun (_ : unit) w0 => w0 = w'). + - eapply aur_bind_r_eq. + + exact Htest. + + rewrite Htrue. + eapply aur_bind_r_eq. + * exact Hbody. + * cbn. + cleft. + apply axr_ret; auto. + exists tt; split; auto. + - intros [] w0 ->. + exact Hloop. +Qed. + +Lemma aur_ystmt_ywhile_false : forall test body condition w φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + YieldSyntax.is_true condition = false -> + <[ {Ret Fallthrough}, w |= AX ψ ]> -> + <[ {denote_stmt_flow (YWhile test body)}, w |= φ AU AX ψ ]>. +Proof. + intros test body condition w φ ψ Htest Hfalse Hret. + pose proof Htest as Htest_not_done. + apply aur_not_done in Htest_not_done. + cbn. + rewrite unfold_iter. + eapply aur_bind_r_eq. + - eapply aur_bind_r_eq. + + exact Htest. + + rewrite Hfalse. + cbn. + cleft. + apply axr_ret. + * exact Htest_not_done. + * split; reflexivity. + - cbn. + cleft. + exact Hret. +Qed. + +Lemma ag_ystmt_ywhile : forall test body (R : World YEff -> Prop) w φ, + R w -> + (forall w, + R w -> + <( {denote_stmt_flow (YWhile test body)}, w |= φ )> /\ + <[ {ywhile_iteration test body}, w |= AX (φ AU AX done + {fun lr w' => exists i' : unit, lr = inl i' /\ R w'}) ]>) -> + <( {denote_stmt_flow (YWhile test body)}, w |= AG φ )>. +Proof. + intros test body R w φ HR Hstep. + cbn. + change (ICtree.iter (fun _ : unit => ywhile_iteration test body) tt) + with (denote_stmt_flow (YWhile test body)). + eapply ag_iter with (R := fun (_ : unit) w => R w); eauto. + intros [] w0 HR0. + specialize (Hstep w0 HR0) as [Hφ Hnext]. + split. + - exact Hφ. + - cbn. + exact Hnext. +Qed. + +Lemma aur_ystmt_yassign_ylit_erased : forall name n ctx w ψ R, + <( {log (add name n ctx)}, w |= ψ )> -> + R (tt, add name n ctx) (Obs (Log (add name n ctx)) tt) -> + <[ {instr_stmt_erased (YAssign name (YLit n)) ctx}, + w |= ψ AU AX done R ]>. +Proof. + intros name n ctx w ψ R Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + unfold_erased_statement. + eapply aur_state_bind_r_eq. + - apply aur_get; auto; split; reflexivity. + - cbn. + expose_erased_get_result ctx. + eapply aur_state_bind_r_eq. + + apply aur_put. + * exact Hlog. + * split; reflexivity. + + cbn. + step_erased_state3. + apply aur_state_ret; auto with ticl. +Qed. + +Lemma aul_ystmt_yassign_ylit_erased : forall name n ctx w ψ φ, + <( {log (add name n ctx)}, w |= ψ )> -> + <( {Ret (tt, add name n ctx)}, + {Obs (Log (add name n ctx)) tt} |= φ )> -> + <( {instr_stmt_erased (YAssign name (YLit n)) ctx}, w |= ψ AU φ )>. +Proof. + intros name n ctx w ψ φ Hlog Hret. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + unfold_erased_statement. + eapply aul_state_bind_r_eq. + - apply aur_get; auto; split; reflexivity. + - cbn. + expose_erased_get_result ctx. + eapply aul_state_bind_r_eq. + + apply aur_put. + * exact Hlog. + * split; reflexivity. + + cbn. + step_erased_state3. + apply aul_state_ret; auto with ticl. +Qed. + (** Scheduler one-step/case regression facts. *) Section SchedulerFacts. Context {E : Type} `{Encode E}. @@ -355,6 +1151,97 @@ Proof. solve_visible_regression. Qed. +Definition yfork_body_fork_continuation + (body : YStmt) (in_child : bool) : thread Mem := + ICtree.subst' + (fun _ : YStmtFlow => Ret tt) + (observe + (ICtree.subst' + (fun branch : bool => + if branch then + denote_stmt_flow body;; Ret HaltThread + else + Ret Fallthrough) + (RetF in_child))). + +Lemma scheduled_visible_yfork_body_one_step : forall body, + observe (scheduled_visible (YFork body)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) + (fun _ => + schedule 2 + (cons_pool (yfork_body_fork_continuation body true) + (replace_pool + (fun _ : Fin.t 1 => denote_stmt (YFork body)) + Fin.F1 (yfork_body_fork_continuation body false))) + (Some (Fin.FS Fin.F1))). +Proof. + intro body. + unfold scheduled_visible. + apply (@schedule_focused_fork Mem _ 0 + (fun _ : Fin.t 1 => denote_stmt (YFork body)) + Fin.F1 + (yfork_body_fork_continuation body)). + solve_visible_regression. +Qed. + +Lemma yfork_child_halts_after_body body : + yfork_body_fork_continuation body true = + ICtree.subst' (fun _ : YStmtFlow => Ret tt) + (observe (denote_stmt_flow body;; Ret HaltThread)). +Proof. reflexivity. Qed. + +Lemma yfork_parent_falls_through body : + observe (yfork_body_fork_continuation body false) = RetF tt. +Proof. solve_visible_regression. Qed. + +Definition yseq_yfork_body_rest_fork_continuation + (body rest : YStmt) (in_child : bool) : thread Mem := + ICtree.subst' + (fun _ : YStmtFlow => Ret tt) + (observe + (ICtree.subst' + (fun flow : YStmtFlow => + match flow with + | Fallthrough => denote_stmt_flow rest + | HaltThread => Ret HaltThread + end) + (observe + (ICtree.subst' + (fun branch : bool => + if branch then + denote_stmt_flow body;; Ret HaltThread + else + Ret Fallthrough) + (RetF in_child))))). + +Lemma scheduled_visible_yseq_yfork_body_rest_one_step : forall body rest, + observe (scheduled_visible (YSeq (YFork body) rest)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) + (fun _ => + schedule 2 + (cons_pool + (yseq_yfork_body_rest_fork_continuation body rest true) + (replace_pool + (fun _ : Fin.t 1 => + denote_stmt (YSeq (YFork body) rest)) + Fin.F1 + (yseq_yfork_body_rest_fork_continuation body rest false))) + (Some (Fin.FS Fin.F1))). +Proof. + intros body rest. + unfold scheduled_visible. + apply (@schedule_focused_fork Mem _ 0 + (fun _ : Fin.t 1 => denote_stmt (YSeq (YFork body) rest)) + Fin.F1 + (yseq_yfork_body_rest_fork_continuation body rest)). + solve_visible_regression. +Qed. + +Lemma yseq_yfork_body_rest_parent_runs_rest body rest : + observe (yseq_yfork_body_rest_fork_continuation body rest false) = + observe (denote_stmt rest). +Proof. solve_visible_regression. Qed. + Definition yfork_yield_fork_continuation (in_child : bool) : thread Mem := ICtree.subst' (fun _ : YStmtFlow => Ret tt) From 8f8f47b4b243cfc5c44e29b71fc404ec7d47a6ff Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Mon, 8 Jun 2026 15:38:39 +0000 Subject: [PATCH 05/14] feat(yield): add scheduler fairness proof surface Introduce an additive scheduler-offer proof facade for Yield, including live-slot offer observations, return/spawn transport lemmas, non-circular scheduling-point fairness, and a stuttering erasure theorem tying the observed scheduler back to schedule. Validation: dune build theories/Lang/Yield/SchedulerFairness.vo theories/Lang/Yield.vo Assistant-model: GPT-5.5 --- theories/Lang/Yield.v | 3 +- theories/Lang/Yield/SchedulerFairness.v | 2519 +++++++++++++++++++++++ 2 files changed, 2521 insertions(+), 1 deletion(-) create mode 100644 theories/Lang/Yield/SchedulerFairness.v diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v index db76d7b..adc1084 100644 --- a/theories/Lang/Yield.v +++ b/theories/Lang/Yield.v @@ -6,4 +6,5 @@ From TICL Require Export Lang.Yield.Scheduler Lang.Yield.Interp Lang.Yield.Ticl - Lang.Yield.SBisim. + Lang.Yield.SBisim + Lang.Yield.SchedulerFairness. diff --git a/theories/Lang/Yield/SchedulerFairness.v b/theories/Lang/Yield/SchedulerFairness.v new file mode 100644 index 0000000..e7bd815 --- /dev/null +++ b/theories/Lang/Yield/SchedulerFairness.v @@ -0,0 +1,2519 @@ +From Stdlib Require Import + Fin + Program.Equality. +From Coinduction Require Import lattice. +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.Interp.Core + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.CanStep + ICTree.Logic.Trans + ICTree.Trans + Events.Core + Logic.Core + Logic.Kripke + Lang.Yield.Events + Lang.Yield.Scheduler + Lang.Yield.SBisim + Lang.Yield.Ticl + Lang.Yield.Vec + ICTree.SBisim. + +Import ICtree ICTreeNotations TiclNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. + +(** Proof-facing scheduler observations for local fairness reasoning. + + The core scheduler is left unchanged. This module mirrors [schedule] with + an additive observation tier that records no-focus scheduling points and + the finite set of slots offered at each such point. *) + +Definition LiveSlot (n : nat) : Type := Fin.t n. + +Record SlotRef : Type := { + slot_pool_size : nat; + slot_live_slot : LiveSlot slot_pool_size; +}. + +Definition live_slot_ref {n : nat} (i : LiveSlot n) : SlotRef := + {| slot_pool_size := n; slot_live_slot := i |}. + +Variant SchedulerObs : Type := +| ObsSchedulingPoint : nat -> SchedulerObs +| ObsOffered : SlotRef -> SchedulerObs. + +Definition schedulerObsE : Type := SchedulerObs. + +#[global] Instance Encode_schedulerObsE : Encode SchedulerObs := + fun _ => unit. + +Definition scheduler_observedE (E : Type) : Type := + schedulerObsE + (yieldE + (spawnE + E)). + +Definition observed_completed (E : Type) `{Encode E} : Type := + ictree (scheduler_observedE E) unit. + +Definition observed_scheduling_point (n : nat) (obs : schedulerObsE) : Prop := + obs = ObsSchedulingPoint n. + +Definition offer_live_slot_obs (n : nat) (i : LiveSlot n) + (obs : schedulerObsE) : Prop := + obs = ObsOffered (live_slot_ref i). + +Definition offer_live_slot {E : Type} `{Encode E} + (n : nat) (i : LiveSlot n) : ticll (scheduler_observedE E) := + CNow (fun w => w = Obs (inl (ObsOffered (live_slot_ref i))) tt). + +Definition recognize_live_slot {E : Type} `{Encode E} + (n : nat) (_ : pool E n) (_ : LiveSlot n) : Prop := + True. + +Lemma fin_cast_refl {n : nat} (i : Fin.t n) : + Fin.cast i eq_refl = i. +Proof. induction i; cbn; congruence. Qed. + +Lemma live_slot_one_eq (i j : LiveSlot 1) : i = j. +Proof. + refine (Fin.caseS' i (fun i => forall j, i = j) _ _ j). + - intro j'. + refine (Fin.caseS' j' (fun j => Fin.F1 = j) eq_refl _). + intro j0. + exact (Fin.case0 (fun j0 => Fin.F1 = Fin.FS j0) j0). + - intro i0. + exact (Fin.case0 (fun i0 => forall j, Fin.FS i0 = j) i0). +Qed. + +Section ObservedScheduler. + Context {E : Type} `{Encode E}. + + Definition emit_scheduler_obs (obs : schedulerObsE) : observed_completed E := + Vis (inl obs) (fun _ : unit => Ret tt). + + Fixpoint emit_live_slot_offers_into_then + (m n : nat) (embed : LiveSlot n -> LiveSlot m) + (k : observed_completed E) {struct n} : observed_completed E := + match n return (LiveSlot n -> LiveSlot m) -> observed_completed E with + | 0 => fun _ => k + | S n' => fun embed => + Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun i => embed (Fin.FS i)) k) + end embed. + + Definition emit_live_slot_offers_then + (n : nat) (k : observed_completed E) : observed_completed E := + emit_live_slot_offers_into_then n n (fun i => i) k. + + Definition emit_live_slot_offers (n : nat) : observed_completed E := + emit_live_slot_offers_then n (Ret tt). + + (** Observed scheduler. The only extra visible events are proof-facing + [schedulerObsE] events at nonempty no-focus scheduling points. *) + CoFixpoint schedule_with_offers + (n : nat) (v : pool E n) (focus : option (Fin.t n)) + : observed_completed E := + match focus with + | None => + match n return pool E n -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inl (ObsSchedulingPoint (S n'))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n') (S n') + (fun i => i) v) + end v + | Some i => + match n return pool E n -> Fin.t n -> observed_completed E with + | 0 => fun _ i => match i with end + | S n' => fun v i => + match observe (v i) with + | RetF _ => + Guard (schedule_with_offers n' (remove_pool v i) None) + | BrF b k => + Br b (fun j => + schedule_with_offers (S n') + (replace_pool v i (k j)) (Some i)) + | GuardF t => + Guard (schedule_with_offers (S n') + (replace_pool v i t) (Some i)) + | VisF e k => + match e as e0 return + (encode e0 -> thread E) -> observed_completed E with + | inl Yield => fun k => + Guard (schedule_with_offers (S n') + (replace_pool v i (k tt)) None) + | inr (inl Fork) => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inl Spawn)) + : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n')) + (cons_pool (k true) + (replace_pool v i (k false))) + (Some (Fin.FS i)))) + | inr (inr e') => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inr e')) + : scheduler_observedE E) + (fun x => schedule_with_offers (S n') + (replace_pool v i (k x)) (Some i))) + end k + end + end v i + end + with schedule_with_offers_offer_prefix + (pool_size remaining : nat) + (embed : LiveSlot remaining -> LiveSlot pool_size) + (v : pool E pool_size) : observed_completed E := + match remaining return + (LiveSlot remaining -> LiveSlot pool_size) -> + pool E pool_size -> observed_completed E with + | 0 => fun _ v => + match pool_size return pool E pool_size -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inr (inl Yield) : scheduler_observedE E) + (fun _ : unit => + Br n' (fun i => + schedule_with_offers (S n') v (Some i))) + end v + | S n' => fun embed v => + Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix pool_size n' + (fun i => embed (Fin.FS i)) v) + end embed v. + + Definition observe_scheduler_offers + (n : nat) (v : pool E n) (focus : option (Fin.t n)) + : observed_completed E := + schedule_with_offers n v focus. + + Definition handle_scheduler_offers + : scheduler_observedE E ~> ictree (yieldE + (spawnE + E)) := + fun event => + match event with + | inl _ => Ret tt + | inr event' => ICtree.trigger event' + end. + + Definition forget_scheduler_offers {X} + (t : ictree (scheduler_observedE E) X) + : ictree (yieldE + (spawnE + E)) X := + interp handle_scheduler_offers t. + + Lemma handle_scheduler_offers_obs obs : + handle_scheduler_offers (inl obs) = Ret tt. + Proof. reflexivity. Qed. + + Lemma handle_scheduler_offers_visible event : + handle_scheduler_offers (inr event) = ICtree.trigger event. + Proof. reflexivity. Qed. + + Lemma forget_scheduler_offers_no_focus_nonempty_unfold n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ + Guard (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. reflexivity. + Qed. + + Theorem forget_scheduler_offers_preserves_schedule_exact_no_focus_impossible n + (v : pool E (S n)) : + ~ forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ + schedule (S n) v None. + Proof. + intro Heq. + step in Heq. + cbn in Heq. + inversion Heq. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_succ_stutter m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m (S n) embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_stutter m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m r embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m 0 + (fun i : LiveSlot 0 => match i with end) v). + Proof. + revert m embed v. + induction r as [| r IHr]; intros m embed v. + - destruct m as [| m']. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + apply sb_ret. reflexivity. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + reflexivity. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix m r + (fun i => embed (Fin.FS i)) v)). + + apply forget_scheduler_offers_offer_prefix_succ_stutter. + + apply IHr. + Qed. + + Lemma forget_scheduler_offers_no_focus_stutters_to_offer_prefix n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v). + Proof. + rewrite forget_scheduler_offers_no_focus_nonempty_unfold. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_zero_nonempty_unfold n + (embed : LiveSlot 0 -> LiveSlot (S n)) (v : pool E (S n)) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 embed v) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard_l. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_br_id. intro i. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_no_focus_projection_to_focused n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + - apply forget_scheduler_offers_no_focus_stutters_to_offer_prefix. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 + (fun i : LiveSlot 0 => match i with end) v)). + + apply forget_scheduler_offers_offer_prefix_stutter. + + apply forget_scheduler_offers_offer_prefix_zero_nonempty_unfold. + Qed. + + Lemma emit_live_slot_offers_into_then_zero m + (embed : LiveSlot 0 -> LiveSlot m) k : + emit_live_slot_offers_into_then m 0 embed k = k. + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_into_then_succ m n + (embed : LiveSlot (S n) -> LiveSlot m) k : + observe (emit_live_slot_offers_into_then m (S n) embed k) = + VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + emit_live_slot_offers_into_then m n + (fun i => embed (Fin.FS i)) k). + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_zero : + observe (emit_live_slot_offers 0) = RetF tt. + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_succ n : + observe (emit_live_slot_offers (S n)) = + VisF (inl (ObsOffered (live_slot_ref (Fin.F1 : LiveSlot (S n))))) + (fun _ : unit => + emit_live_slot_offers_into_then (S n) n + (fun i => Fin.FS i) (Ret tt)). + Proof. reflexivity. Qed. + + Local Ltac solve_focused_schedule_with_offers H := + lazy [schedule_with_offers observe _observe]; + match type of H with + | observe (?v ?i) = _ => + change (@_observe _ _ unit (v i)) with (observe (v i)); + rewrite H; + reflexivity + end. + + Lemma schedule_with_offers_empty_none (v : pool E 0) : + observe (schedule_with_offers 0 v None) = RetF tt. + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_no_focus_nonempty n + (v : pool E (S n)) : + observe (schedule_with_offers (S n) v None) = + VisF (inl (ObsSchedulingPoint (S n))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n) (S n) + (fun i => i) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_offer_prefix_zero m + (embed : LiveSlot 0 -> LiveSlot m) (v : pool E m) : + observe (schedule_with_offers_offer_prefix m 0 embed v) = + match m return pool E m -> ictree' (scheduler_observedE E) unit with + | 0 => fun _ => RetF tt + | S n => fun v => + VisF (inr (inl Yield) : scheduler_observedE E) + (fun _ : unit => + Br n (fun i => schedule_with_offers (S n) v (Some i))) + end v. + Proof. destruct m; reflexivity. Qed. + + Lemma schedule_with_offers_offer_prefix_succ m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + observe (schedule_with_offers_offer_prefix m (S n) embed v) = + VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_focused_ret n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers n (remove_pool v i) None). + Proof. + intro Hret. + solve_focused_schedule_with_offers Hret. + Qed. + + Lemma schedule_with_offers_focused_br n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + observe (schedule_with_offers (S n) v (Some i)) = + BrF b (fun j => + schedule_with_offers (S n) (replace_pool v i (k j)) (Some i)). + Proof. + intro Hbr. + solve_focused_schedule_with_offers Hbr. + Qed. + + Lemma schedule_with_offers_focused_guard n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v i) = GuardF t -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) (replace_pool v i t) (Some i)). + Proof. + intro Hg. + solve_focused_schedule_with_offers Hg. + Qed. + + Lemma schedule_with_offers_focused_yield n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) + (replace_pool v i (k tt)) None). + Proof. + intro Hy. + solve_focused_schedule_with_offers Hy. + Qed. + + Lemma schedule_with_offers_focused_fork n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inl Spawn)) : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + Proof. + intro Hf. + solve_focused_schedule_with_offers Hf. + Qed. + + Lemma schedule_with_offers_focused_user_event n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inr e)) : scheduler_observedE E) + (fun x => schedule_with_offers (S n) + (replace_pool v i (k x)) (Some i)). + Proof. + intro Hu. + solve_focused_schedule_with_offers Hu. + Qed. + + Lemma focused_yield_returns_to_scheduling_point n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) + (replace_pool v i (k tt)) None). + Proof. apply schedule_with_offers_focused_yield. Qed. + + Lemma forget_scheduler_offers_empty_no_focus_projection + (v : pool E 0) : + forget_scheduler_offers (schedule_with_offers 0 v None) ~ Ret tt. + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_ret. reflexivity. + Qed. + + Lemma forget_scheduler_offers_focused_ret_projection n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers (schedule_with_offers n (remove_pool v i) None). + Proof. + intro Hret. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_ret n v i Hret). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_br_projection n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Br b (fun j => + forget_scheduler_offers + (schedule_with_offers (S n) (replace_pool v i (k j)) (Some i))). + Proof. + intro Hbr. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + cbn. + apply sb_br_id. intro j. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_guard_projection n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v i) = GuardF t -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers + (schedule_with_offers (S n) (replace_pool v i t) (Some i)). + Proof. + intro Hguard. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_guard n v i t Hguard). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_yield_projection n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers + (schedule_with_offers (S n) (replace_pool v i (k tt)) None). + Proof. + intro Hyield. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_yield n v i k Hyield). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_fork_projection n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => + forget_scheduler_offers (schedule_with_offers (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_user_event_projection n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => + forget_scheduler_offers + (schedule_with_offers (S n) (replace_pool v i (k x)) (Some i))). + Proof. + intro Huser. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intro x. + apply sb_guard. + Qed. + + Local Notation completed' := (completed E). + Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). + + Local Definition erased_schedule (n : nat) (v : pool E n) + (focus : option (Fin.t n)) : completed E := + forget_scheduler_offers (schedule_with_offers n v focus). + + Local Lemma erased_focused_ret_equ n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule n (remove_pool v i) None). + Proof. + intro Hret. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_ret n v i Hret). + reflexivity. + Qed. + + Local Lemma erased_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + erased_schedule (S n) v (Some i) ≅ + Br b (fun j => Guard (erased_schedule (S n) + (replace_pool v i (k j)) (Some i))). + Proof. + intro Hbr. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma erased_focused_guard_equ n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v i) = GuardF t -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) (replace_pool v i t) (Some i)). + Proof. + intro Hguard. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_guard n v i t Hguard). + reflexivity. + Qed. + + Local Lemma erased_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) (replace_pool v i (k tt)) None). + Proof. + intro Hyield. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma erased_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma erased_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n) + (replace_pool v i (k x)) (Some i))). + Proof. + intro Huser. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma schedule_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inl Yield) k -> + schedule (S n) v (Some i) ≅ + Guard (schedule (S n) (replace_pool v i (k tt)) None). + Proof. + intro Hyield. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma guard_residual_from_equ (actual target residual : completed') : + observe actual = GuardF residual -> + actual ≅ Guard target -> + residual ≅ target. + Proof. + intros Hobs Heq. + apply equ_guard_invE. + transitivity actual. + - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. + - exact Heq. + Qed. + + Local Ltac contradiction_from_shape_equ actual Hobs Heq := + exfalso; + rewrite (ictree_eta actual) in Heq; + rewrite <- Hobs in Heq; + step in Heq; inversion Heq. + + Local Lemma erased_schedule_match_left_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ erased_schedule 0 v None -> + trans l actual t' -> + exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + - rewrite (trans_schedule_empty_ret v). apply trans_ret. + - rewrite Hsb. rewrite Hmid. reflexivity. + Qed. + + Local Lemma erased_schedule_match_left_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ erased_schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n (fun i => + erased_schedule (S n) v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (Br n (fun i => schedule (S n) v (Some i))). split. + - apply trans_schedule_no_focus_nonempty. + - rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n) + (replace_pool v i (k j)) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + exists (schedule (S n) (replace_pool v i (k j)) (Some i)). + split. + - apply trans_schedule_focused_br. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). split. + - apply trans_schedule_focused_fork. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n) + (replace_pool v i (k x)) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + exists (schedule (S n) (replace_pool v i (k x)) (Some i)). + split. + - apply trans_schedule_focused_user_event. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma schedule_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + schedule (S n) v (Some i) ≅ + Br b (fun j => schedule (S n) (replace_pool v i (k j)) (Some i)). + Proof. + intro Hbr. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma schedule_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + Proof. + intro Hfork. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_fork n v i k Hfork). + reflexivity. + Qed. + + Local Lemma schedule_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => schedule (S n) (replace_pool v i (k x)) (Some i)). + Proof. + intro Huser. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_user_event n v i e k Huser). + reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ schedule 0 v None -> + trans l actual t' -> + exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + assert (Hret : actual ~ Ret tt). + { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hret TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + assert (Hproj : Ret tt ~ erased_schedule 0 v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as + [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + set (sres := Br n (fun i => schedule (S n) v (Some i))). + set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). + assert (Hshape : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) + lres). + { apply trans_vis. } + assert (Hproj : + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ + erased_schedule (S n) v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans _ _ lres + (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v i) = BrF b k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun j => + schedule (S n) (replace_pool v i (k j)) (Some i)). + set (lres := fun j => + erased_schedule (S n) (replace_pool v i (k j)) (Some i)). + assert (Hshape : actual ~ Br b sres). + { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans tau (Br b lres) (lres j)). + { apply trans_br with (x := j). reflexivity. } + assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_br_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) + as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + set (lres := erased_schedule (S (S n)) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). + assert (Hshape : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres)) lres). + { apply trans_vis. } + assert (Hproj : + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres) ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } + destruct (sbisim_trans _ _ lres + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v i) = VisF (inr (inr e)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun x => + schedule (S n) (replace_pool v i (k x)) (Some i)). + set (lres := fun x => + erased_schedule (S n) (replace_pool v i (k x)) (Some i)). + assert (Hshape : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) sres). + { rewrite Hactual. + rewrite (schedule_focused_user_event_equ n v i e k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans + (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). + { apply trans_vis. } + assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres x) + (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ erased_schedule n v focus -> + exists u', trans l (schedule n v focus) u' /\ stR R t' u'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' (remove_pool v i) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule n' (remove_pool v i) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' (remove_pool v i) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_ret n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n') + (replace_pool v i (k j)) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid ->]]. + exists (schedule (S n') (replace_pool v i (k j)) (Some i)). + split. + -- apply trans_schedule_focused_br. exact Hvi. + -- rewrite Hsb. rewrite Hmid. apply Hch. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + assert (Ht : t ≅ + erased_schedule (S n') (replace_pool v i g) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') (replace_pool v i g) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_guard n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + (replace_pool v i (k tt)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule (S n') + (replace_pool v i (k tt)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') (replace_pool v i (k tt)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n')) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (schedule (S (S n')) + (cons_pool (k true) (replace_pool v i (k false))) + (Some (Fin.FS i))). split. + ++ apply trans_schedule_focused_fork. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + -- assert (Hproj : actual ~ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n') + (replace_pool v i (k x)) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + exists (schedule (S n') (replace_pool v i (k x)) (Some i)). + split. + ++ apply trans_schedule_focused_user_event. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + + destruct nn as [| n']. + * assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + -- rewrite (trans_schedule_empty_ret v). apply trans_ret. + -- rewrite Hsb. rewrite Hmid. reflexivity. + * assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n' (fun i => + erased_schedule (S n') v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (Br n' (fun i => schedule (S n') v (Some i))). split. + -- apply trans_schedule_no_focus_nonempty. + -- rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' (remove_pool v i) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_left_br; eauto. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (cons_pool (k0 true) (replace_pool v i (k0 false))) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + (replace_pool v i (k0 x)) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' (remove_pool v i) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + (replace_pool v i (k0 j)) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_left_fork; eauto. + -- eapply erased_schedule_match_left_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (erased_schedule n' (remove_pool v i) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + (replace_pool v i (k0 j)) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (cons_pool (k0 true) (replace_pool v i (k0 false))) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + (replace_pool v i (k0 x)) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + Qed. + + Local Lemma erased_schedule_match_right (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ schedule n v focus -> + exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' (remove_pool v i) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + assert (Ht : t ≅ schedule n' (remove_pool v i) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' (remove_pool v i) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_ret_equ n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + assert (Ht : t ≅ + schedule (S n') (replace_pool v i g) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') (replace_pool v i g) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_guard_equ n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + (replace_pool v i (k tt)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ schedule (S n') + (replace_pool v i (k tt)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') (replace_pool v i (k tt)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (erased_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' (remove_pool v i) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' (remove_pool v i) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (schedule n' (remove_pool v i) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') (replace_pool v i g) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + (replace_pool v i (k0 tt)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + Qed. + + Theorem forget_scheduler_offers_preserves_schedule + n (v : pool E n) focus : + forget_scheduler_offers (schedule_with_offers n v focus) ~ + schedule n v focus. + Proof. + change (erased_schedule n v focus ~ schedule n v focus). + revert n v focus. + coinduction R CH. + intros n v focus. + assert (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)). + { intros m w f. apply CH. } + split. + - intros l t' TR. + destruct (erased_schedule_match_left R Hch _ _ _ TR + (erased_schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + exact Hres. + + reflexivity. + - intros l t' TR. + destruct (erased_schedule_match_right R Hch _ _ _ TR + (schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + unfold Basics.flip. exact Hres. + + reflexivity. + Qed. + + Record ReturnSlotTransport {n : nat} + (v : pool E (S n)) (removed : LiveSlot (S n)) + (v' : pool E n) : Prop := { + return_new_slots_come_from_old_survivors : + forall j_new : LiveSlot n, + exists j_old : LiveSlot (S n), + j_old <> removed /\ v' j_new = v j_old; + return_old_survivors_reappear : + forall j_old : LiveSlot (S n), + j_old <> removed -> + exists j_new : LiveSlot n, v' j_new = v j_old + }. + + Theorem return_removes_live_slot n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v i) = RetF tt -> + ReturnSlotTransport v i (remove_pool v i). + Proof. + intro Hret; clear Hret. + revert v i. + induction n as [| n IH]; intros v i. + - constructor. + + intro j_new. + exact (Fin.case0 (fun j_new => exists j_old : LiveSlot 1, + j_old <> i /\ remove_pool v i j_new = v j_old) j_new). + + intros j_old Hneq. + contradiction Hneq. apply live_slot_one_eq. + - refine (Fin.caseS' i + (fun i => ReturnSlotTransport v i (remove_pool v i)) _ _). + + constructor. + * intro j_new. + exists (Fin.FS j_new). split. + -- discriminate. + -- reflexivity. + * intros j_old Hneq. + refine (Fin.caseS' j_old + (fun j => j <> Fin.F1 -> + exists j_new : LiveSlot (S n), + remove_pool v Fin.F1 j_new = v j) _ _ Hneq). + -- intro Hcontra. contradiction Hcontra; reflexivity. + -- intros j_new _. exists j_new. reflexivity. + + intro i_tail. + pose proof (IH (fun k => v (Fin.FS k)) i_tail) as IHt. + destruct IHt as [IHnew IHold]. + constructor. + * intro j_new. + refine (Fin.caseS' j_new + (fun j => exists j_old : LiveSlot (S (S n)), + j_old <> Fin.FS i_tail /\ + remove_pool v (Fin.FS i_tail) j = v j_old) _ _). + -- exists Fin.F1. split. + ++ discriminate. + ++ reflexivity. + -- intros j_new'. + destruct (IHnew j_new') as [j_old [Hneq Hv]]. + exists (Fin.FS j_old). split. + ++ intro Heq. apply Fin.FS_inj in Heq. + contradiction Hneq. + ++ cbn. rewrite !fin_cast_refl. exact Hv. + * intros j_old Hneq. + refine (Fin.caseS' j_old + (fun j => j <> Fin.FS i_tail -> + exists j_new : LiveSlot (S n), + remove_pool v (Fin.FS i_tail) j_new = v j) _ _ Hneq). + -- intros _. exists Fin.F1. reflexivity. + -- intros j_old' Hneq'. + assert (Hsurv : j_old' <> i_tail) by + (intro Heq; subst; apply Hneq'; reflexivity). + destruct (IHold j_old' Hsurv) as [j_new Hv]. + exists (Fin.FS j_new). + cbn. rewrite !fin_cast_refl. exact Hv. + Qed. + + Definition shift_live_slot_across_spawn {n : nat} + (i : LiveSlot n) : LiveSlot (S n) := + Fin.FS i. + + Lemma shift_live_slot_across_spawn_head {n} + (child : thread E) (v : pool E n) : + cons_pool child v Fin.F1 = child. + Proof. apply cons_pool_head. Qed. + + Lemma shift_live_slot_across_spawn_tail {n} + (child : thread E) (v : pool E n) (i : LiveSlot n) : + cons_pool child v (shift_live_slot_across_spawn i) = v i. + Proof. apply cons_pool_tail. Qed. + + Lemma shift_live_slot_across_spawn_parent_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + cons_pool (k true) (replace_pool v i (k false)) + (shift_live_slot_across_spawn i) = k false. + Proof. + rewrite shift_live_slot_across_spawn_tail. + apply replace_pool_hit. + Qed. + + Lemma shift_live_slot_across_spawn_other_slot n + (v : pool E (S n)) (i j : LiveSlot (S n)) k : + i <> j -> + cons_pool (k true) (replace_pool v i (k false)) + (shift_live_slot_across_spawn j) = v j. + Proof. + intro Hneq. + rewrite shift_live_slot_across_spawn_tail. + now apply replace_pool_miss. + Qed. + + Lemma transport_live_slots_across_spawn_head {n} + (child : thread E) (v : pool E n) : + cons_pool child v Fin.F1 = child. + Proof. apply shift_live_slot_across_spawn_head. Qed. + + Lemma transport_live_slots_across_spawn_tail {n} + (child : thread E) (v : pool E n) (i : LiveSlot n) : + cons_pool child v (shift_live_slot_across_spawn i) = v i. + Proof. apply shift_live_slot_across_spawn_tail. Qed. + + Lemma transport_live_slots_across_spawn_parent_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + cons_pool (k true) (replace_pool v i (k false)) + (shift_live_slot_across_spawn i) = k false. + Proof. apply shift_live_slot_across_spawn_parent_slot. Qed. + + Lemma transport_live_slots_across_spawn_other_slot n + (v : pool E (S n)) (i j : LiveSlot (S n)) k : + i <> j -> + cons_pool (k true) (replace_pool v i (k false)) + (shift_live_slot_across_spawn j) = v j. + Proof. apply shift_live_slot_across_spawn_other_slot. Qed. + + Record SpawnSlotTransport {n : nat} + (v : pool E (S n)) (parent : LiveSlot (S n)) + (k : bool -> thread E) (spawned : pool E (S (S n))) : Prop := { + spawn_child_at_head : spawned Fin.F1 = k true; + spawn_parent_at_shifted_slot : spawned (Fin.FS parent) = k false; + spawn_other_old_slots_shifted : + forall j : LiveSlot (S n), + j <> parent -> spawned (Fin.FS j) = v j + }. + + Theorem transport_live_slots_across_spawn n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + observe (v i) = VisF (inr (inl Fork)) k -> + SpawnSlotTransport v i k + (cons_pool (k true) (replace_pool v i (k false))). + Proof. + intro Hfork; clear Hfork. + constructor. + - apply cons_pool_head. + - rewrite cons_pool_tail. apply replace_pool_hit. + - intros j Hneq. + rewrite cons_pool_tail. + apply replace_pool_miss. congruence. + Qed. + + Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) + : observed_completed E -> Prop := + | offered_prefix_here t k : + observe t = VisF (inl (ObsOffered (live_slot_ref i))) k -> + offered_in_scheduler_prefix n i t + | offered_prefix_later t obs k : + observe t = VisF (inl obs) k -> + offered_in_scheduler_prefix n i (k tt) -> + offered_in_scheduler_prefix n i t. + + Lemma emit_live_slot_offers_into_then_offers m : + forall n (embed : LiveSlot n -> LiveSlot m) k (i : LiveSlot n), + offered_in_scheduler_prefix m (embed i) + (emit_live_slot_offers_into_then m n embed k). + Proof. + intros n embed k i. + induction i as [n' | n' i IH]. + - apply offered_prefix_here with + (k := fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun i => embed (Fin.FS i)) k). + reflexivity. + - apply offered_prefix_later with + (obs := ObsOffered (live_slot_ref (embed Fin.F1))) + (k := fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun j => embed (Fin.FS j)) k). + + reflexivity. + + apply (IH (fun j => embed (Fin.FS j))). + Qed. + + Lemma emit_live_slot_offers_then_offers n k (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers_then n k). + Proof. + unfold emit_live_slot_offers_then. + apply (emit_live_slot_offers_into_then_offers n n (fun i => i) k i). + Qed. + + Lemma emit_live_slot_offers_offers n (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers n). + Proof. + apply emit_live_slot_offers_then_offers. + Qed. + + Lemma emit_live_slot_offers_contains_every_slot n (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers n). + Proof. + apply emit_live_slot_offers_offers. + Qed. + + Lemma schedule_with_offers_offer_prefix_offers m : + forall n (embed : LiveSlot n -> LiveSlot m) (v : pool E m) + (i : LiveSlot n), + offered_in_scheduler_prefix m (embed i) + (schedule_with_offers_offer_prefix m n embed v). + Proof. + intros n embed v i. + induction i as [n' | n' i IH]. + - apply offered_prefix_here with + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun i => embed (Fin.FS i)) v). + apply schedule_with_offers_offer_prefix_succ. + - apply offered_prefix_later with + (obs := ObsOffered (live_slot_ref (embed Fin.F1))) + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun j => embed (Fin.FS j)) v). + + apply schedule_with_offers_offer_prefix_succ. + + apply (IH (fun j => embed (Fin.FS j))). + Qed. + + Lemma offer_live_slot_now n (i : LiveSlot n) + (t : observed_completed E) : + <( {t}, {Obs (inl (ObsOffered (live_slot_ref i))) tt} |= + {offer_live_slot n i} )>. + Proof. + unfold offer_live_slot. + split; [reflexivity | constructor]. + Qed. + + Lemma observed_equ_refl_no_eqdep (t : observed_completed E) : t ≅ t. + Proof. + unfold equ. + apply (leq_gfp (@fequ _ _ unit unit eq) + (fun u v : observed_completed E => u = v)). + - intros u v <-. cbn. destruct (observe u); constructor; auto. + - reflexivity. + Qed. + + Lemma observed_equ_step_no_eqdep (t u : observed_completed E) : + t ≅ u -> equF eq (equ eq) (observe t) (observe u). + Proof. + intro Htu. unfold equ in Htu. + exact (proj1 (gfp_fp (@fequ _ _ unit unit eq) t u) Htu). + Qed. + + Definition equF_scheduler_vis_result + (p q : ictree' (scheduler_observedE E) unit) : Prop := + match q with + | VisF (inl sched_obs) k_right => + exists k_left, + p = VisF (inl sched_obs) k_left /\ k_left tt ≅ k_right tt + | _ => True + end. + + Lemma equF_scheduler_vis_inv_no_eqdep p q : + equF eq (equ eq) p q -> equF_scheduler_vis_result p q. + Proof. + intro Hf. + destruct Hf as [x y Hxy | e k1 k2 Hk | t1 t2 Ht | + n k1 k2 Hk]; cbn; try exact I. + destruct e as [sched_obs | rest]; cbn; try exact I. + exists k1. split; [reflexivity | apply Hk]. + Qed. + + Lemma equ_scheduler_vis_inv_from_observe_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + t ≅ u -> + observe u = VisF (inl obs) k -> + exists k_t, observe t = VisF (inl obs) k_t /\ k_t tt ≅ k tt. + Proof. + intros Htu Hu. + pose proof (equF_scheduler_vis_inv_no_eqdep _ _ + (observed_equ_step_no_eqdep _ _ Htu)) as Hshape. + rewrite Hu in Hshape. + exact Hshape. + Qed. + + Lemma ktrans_vis_raw_inv_no_eqdep {X} (e : scheduler_observedE E) + (k : encode e -> ictree (scheduler_observedE E) X) + (w : World (scheduler_observedE E)) t' w' : + |Vis e k, w| ↦ |t', w'| -> + exists v (target : ictree (scheduler_observedE E) X), + w' = Obs e v /\ observe target = observe t' /\ + target ≅ k v /\ not_done w. + Proof. + intro Htr. + cbn in Htr. + refine (match Htr in ktrans_ ot w0 ot' w0' return + match ot with + | VisF e0 k0 => + exists v (target : ictree (scheduler_observedE E) X), + w0' = Obs e0 v /\ observe target = ot' /\ + target ≅ k0 v /\ not_done w0 + | _ => True + end with + | KtransObs e0 v k0 target w0 Hnd Heq => _ + | _ => I + end). + exists v, target. + split; [reflexivity | split; [reflexivity | split; assumption]]. + Qed. + + Lemma ktrans_scheduler_vis_inv_no_eqdep {X} (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + ictree (scheduler_observedE E) X) + (w : World (scheduler_observedE E)) t' w' : + |Vis (inl obs) k, w| ↦ |t', w'| -> + exists target : ictree (scheduler_observedE E) X, + w' = Obs (inl obs) tt /\ observe target = observe t' /\ + target ≅ k tt /\ not_done w. + Proof. + intro Htr. + destruct (ktrans_vis_raw_inv_no_eqdep _ _ _ _ _ Htr) as + [v [target [Hw [Ht [Heq Hnd]]]]]. + destruct v. + exists target. split; [exact Hw | split; [exact Ht | split; assumption]]. + Qed. + + Inductive SchedulerEquChain : + observed_completed E -> observed_completed E -> Prop := + | scheduler_equ_chain_refl t : SchedulerEquChain t t + | scheduler_equ_chain_cons t u v : + t ≅ u -> + SchedulerEquChain u v -> + SchedulerEquChain t v. + + Lemma scheduler_equ_chain_scheduler_vis_inv_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + SchedulerEquChain t u -> + observe u = VisF (inl obs) k -> + exists k_t, + observe t = VisF (inl obs) k_t /\ + SchedulerEquChain (k_t tt) (k tt). + Proof. + intros Hchain Hobs. + induction Hchain as [u | t mid u Htm _ IH]. + - exists k. split; [exact Hobs | constructor]. + - destruct (IH Hobs) as [k_mid [Hmid Hcont]]. + destruct (equ_scheduler_vis_inv_from_observe_no_eqdep obs k_mid + t mid Htm Hmid) as [k_t [Ht Hstep]]. + exists k_t. split; [exact Ht |]. + econstructor; [exact Hstep | exact Hcont]. + Qed. + + Lemma offered_in_scheduler_prefix_chain_implies_AF n + (i : LiveSlot n) (u actual bridge : observed_completed E) w : + observe bridge = observe actual -> + SchedulerEquChain bridge u -> + not_done w -> + offered_in_scheduler_prefix n i u -> + <( {actual}, w |= AF {offer_live_slot n i} )>. + Proof. + intros Hbridge Hchain Hnd Hprefix. + revert actual bridge w Hbridge Hchain Hnd. + induction Hprefix as [u k Hobs | u obs k Hobs _ IH]; + intros actual bridge w Hbridge Hchain Hnd. + - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep + (ObsOffered (live_slot_ref i)) k bridge u Hchain Hobs) as + [k_actual [Hactual Hcont]]. + rewrite unfold_entailsL. + apply StepA. + split. + + split; [exact I | exact Hnd]. + + split. + * exists (k_actual tt), + (Obs (inl (ObsOffered (live_slot_ref i))) tt). + cbn. rewrite <- Hbridge, Hactual. + constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. + * intros t' w' Htr. + cbn in Htr. + rewrite <- Hbridge, Hactual in Htr. + destruct (ktrans_scheduler_vis_inv_no_eqdep + (ObsOffered (live_slot_ref i)) k_actual w t' w' Htr) as + [target [Hw' [Htarget [Heqtarget Hsource]]]]. + subst w'. + apply MatchA. + unfold offer_live_slot. + split; [reflexivity | constructor]. + - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep + obs k bridge u Hchain Hobs) as [k_actual [Hactual Hcont]]. + rewrite unfold_entailsL. + apply StepA. + split. + + split; [exact I | exact Hnd]. + + split. + * exists (k_actual tt), (Obs (inl obs) tt). + cbn. rewrite <- Hbridge, Hactual. + constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. + * intros t' w' Htr. + cbn in Htr. + rewrite <- Hbridge, Hactual in Htr. + destruct (ktrans_scheduler_vis_inv_no_eqdep obs + k_actual w t' w' Htr) as + [target [Hw' [Htarget [Heqtarget Hsource]]]]. + subst w'. + specialize (IH t' target (Obs (inl obs) tt) Htarget + (scheduler_equ_chain_cons target (k_actual tt) (k tt) + Heqtarget Hcont) (NotDoneObs (inl obs) tt)). + rewrite unfold_entailsL in IH. + exact IH. + Qed. + + Theorem offered_in_scheduler_prefix_implies_AF n + (i : LiveSlot n) (t : observed_completed E) w : + not_done w -> + offered_in_scheduler_prefix n i t -> + <( {t}, w |= AF {offer_live_slot n i} )>. + Proof. + intros Hnd Hprefix. + eapply offered_in_scheduler_prefix_chain_implies_AF. + - reflexivity. + - constructor. + - exact Hnd. + - exact Hprefix. + Qed. + + Lemma show_no_focus_offers_every_live_slot_prefix n + (v : pool E (S n)) (i : LiveSlot (S n)) : + offered_in_scheduler_prefix (S n) i + (schedule_with_offers (S n) v None). + Proof. + eapply offered_prefix_later. + - apply schedule_with_offers_no_focus_nonempty. + - apply (schedule_with_offers_offer_prefix_offers (S n) (S n) + (fun i => i) v i). + Qed. + + Lemma no_focus_offers_every_live_slot_prefix n + (v : pool E (S n)) (i : LiveSlot (S n)) : + offered_in_scheduler_prefix (S n) i + (schedule_with_offers (S n) v None). + Proof. + apply show_no_focus_offers_every_live_slot_prefix. + Qed. + + Theorem show_no_focus_offers_every_live_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) : + <( {schedule_with_offers (S n) v None}, Pure |= + AF {offer_live_slot (S n) i} )>. + Proof. + apply offered_in_scheduler_prefix_implies_AF. + - constructor. + - apply show_no_focus_offers_every_live_slot_prefix. + Qed. + + Theorem no_focus_offers_every_live_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) : + <( {schedule_with_offers (S n) v None}, Pure |= + AF {offer_live_slot (S n) i} )>. + Proof. + apply show_no_focus_offers_every_live_slot. + Qed. + + Definition scheduling_point_offer_obligation + (t : observed_completed E) (w : World (scheduler_observedE E)) + : Prop := + forall n, + w = Obs (inl (ObsSchedulingPoint (S n))) tt -> + forall i : LiveSlot (S n), + <( {t}, w |= AF {offer_live_slot (S n) i} )>. + + Local Definition non_scheduling_point_world + (w : World (scheduler_observedE E)) : Prop := + forall n, + w = Obs (inl (ObsSchedulingPoint (S n))) tt -> False. + + Local Lemma pure_non_scheduling_point : + non_scheduling_point_world Pure. + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Local Lemma obs_offered_non_scheduling_point ref : + non_scheduling_point_world + (Obs (inl (ObsOffered ref) : scheduler_observedE E) tt). + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Local Lemma obs_non_scheduler_non_scheduling_point + (event : yieldE + (spawnE + E)) + (value : encode (inr event : scheduler_observedE E)) : + non_scheduling_point_world (Obs (inr event) value). + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Private Inductive SchedulerOfferCanonical + : observed_completed E -> World (scheduler_observedE E) -> Prop := + | scheduler_offer_canonical_schedule : forall n + (v : pool E n) focus w, + non_scheduling_point_world w -> + SchedulerOfferCanonical (schedule_with_offers n v focus) w + | scheduler_offer_canonical_prefix_at_point : forall n + (v : pool E (S n)), + SchedulerOfferCanonical + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v) + (Obs (inl (ObsSchedulingPoint (S n))) tt) + | scheduler_offer_canonical_prefix_elsewhere : forall m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w, + non_scheduling_point_world w -> + SchedulerOfferCanonical + (schedule_with_offers_offer_prefix m r embed v) w + | scheduler_offer_canonical_choice : forall n + (v : pool E (S n)) w, + non_scheduling_point_world w -> + SchedulerOfferCanonical + (Br n (fun i : fin' n => + schedule_with_offers (S n) v (Some i))) w + | scheduler_offer_canonical_done : forall t (x : unit), + SchedulerOfferCanonical t (Done x) + | scheduler_offer_canonical_finish : forall t + (event : scheduler_observedE E) (value : encode event) (x : unit), + SchedulerOfferCanonical t (Finish event value x). + + Local Definition SchedulerOfferShape + (t : observed_completed E) (w : World (scheduler_observedE E)) + : Prop := + exists u : observed_completed E, t ≅ u /\ SchedulerOfferCanonical u w. + + Local Lemma scheduler_offer_shape_canonical t w : + SchedulerOfferCanonical t w -> SchedulerOfferShape t w. + Proof. + intro Hcanonical. + exists t. split; [apply observed_equ_refl_no_eqdep | exact Hcanonical]. + Qed. + + Local Lemma scheduler_offer_shape_equ t u w : + t ≅ u -> SchedulerOfferShape u w -> SchedulerOfferShape t w. + Proof. + intros Htu [v [Huv Hcanonical]]. + exists v. split. + - transitivity u; assumption. + - exact Hcanonical. + Qed. + + Local Lemma observed_equ_of_observe_eq (t u : observed_completed E) : + observe t = observe u -> t ≅ u. + Proof. + intro Hobserve. + transitivity (go (observe t)). + - apply ictree_eta. + - rewrite Hobserve. + symmetry. apply ictree_eta. + Qed. + + Local Lemma scheduler_offer_shape_schedule n + (v : pool E n) focus w : + non_scheduling_point_world w -> + SchedulerOfferShape (schedule_with_offers n v focus) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_prefix_at_point n + (v : pool E (S n)) : + SchedulerOfferShape + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v) + (Obs (inl (ObsSchedulingPoint (S n))) tt). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_shape_prefix_elsewhere m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w : + non_scheduling_point_world w -> + SchedulerOfferShape + (schedule_with_offers_offer_prefix m r embed v) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_choice n + (v : pool E (S n)) w : + non_scheduling_point_world w -> + SchedulerOfferShape + (Br n (fun i : fin' n => + schedule_with_offers (S n) v (Some i))) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_done t (x : unit) : + SchedulerOfferShape t (Done x). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_shape_finish t + (event : scheduler_observedE E) (value : encode event) (x : unit) : + SchedulerOfferShape t (Finish event value x). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_canonical_obligation t w : + SchedulerOfferCanonical t w -> scheduling_point_offer_obligation t w. + Proof. + intro Hcanonical. + destruct Hcanonical as + [n v focus w Hworld | n v | m r embed v w Hworld | + n v w Hworld | t x | t event value x]. + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. + inversion Hsched; subst. + apply offered_in_scheduler_prefix_implies_AF. + + constructor. + + apply (schedule_with_offers_offer_prefix_offers (S k) (S k) + (fun j : LiveSlot (S k) => j) v i). + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. discriminate Hsched. + - intros k Hsched i. discriminate Hsched. + Qed. + + Local Lemma scheduler_offer_shape_obligation t w : + SchedulerOfferShape t w -> scheduling_point_offer_obligation t w. + Proof. + intros [u [Htu Hcanonical]] k Hsched i. + rewrite Htu. + eapply scheduler_offer_canonical_obligation; eauto. + Qed. + + Local Lemma scheduler_offer_shape_ret_step + (w : World (scheduler_observedE E)) t' w' : + |Ret tt, w| ↦ |t', w'| -> SchedulerOfferShape t' w'. + Proof. + intro Htr. + destruct w as [| event value | x | event value x]. + - apply ktrans_done in Htr as [-> _]. + apply scheduler_offer_shape_done. + - apply ktrans_finish in Htr as [-> _]. + apply scheduler_offer_shape_finish. + - apply ktrans_not_done in Htr. inversion Htr. + - apply ktrans_not_done in Htr. inversion Htr. + Qed. + + Local Lemma scheduler_offer_canonical_step t w t' w' : + SchedulerOfferCanonical t w -> + |t, w| ↦ |t', w'| -> + SchedulerOfferShape t' w'. + Proof. + intros Hcanonical Htr. + revert t w t' w' Hcanonical Htr. + fix IH 6. + intros t w t' w' Hcanonical Htr. + destruct Hcanonical as + [n v focus w Hworld | n v | m r embed v w Hworld | + n v w Hworld | t x | t event value x]. + - destruct focus as [slot |]. + + dependent destruction slot. + * set (focused_slot := (Fin.F1 : Fin.t (S n))). + destruct (observe (v focused_slot)) eqn:Hthread; + fold focused_slot in Htr. + -- destruct x. + cbn in Htr. + rewrite (schedule_with_offers_focused_ret + n v focused_slot Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_br + n v focused_slot n0 k Hthread) in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + ++ exact Htarget. + ++ apply scheduler_offer_shape_schedule. exact Hworld. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_guard + n v focused_slot t Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- destruct e as [yield_event | [spawn_event | user_event]]. + ++ destruct yield_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_yield + n v focused_slot k Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ** apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ** eapply IH. + --- apply scheduler_offer_canonical_schedule. + exact Hworld. + --- exact Htr. + ++ destruct spawn_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_fork + n v focused_slot k Hthread) in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + ++ cbn in Htr. + rewrite (schedule_with_offers_focused_user_event + n v focused_slot user_event k Hthread) in Htr. + apply ktrans_vis in Htr as [value [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + * set (focused_slot := Fin.FS slot). + destruct (observe (v focused_slot)) eqn:Hthread; + fold focused_slot in Htr. + -- destruct x. + cbn in Htr. + rewrite (schedule_with_offers_focused_ret + n v focused_slot Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_br + n v focused_slot n0 k Hthread) in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + ++ exact Htarget. + ++ apply scheduler_offer_shape_schedule. exact Hworld. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_guard + n v focused_slot t Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- destruct e as [yield_event | [spawn_event | user_event]]. + ++ destruct yield_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_yield + n v focused_slot k Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ** apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ** eapply IH. + --- apply scheduler_offer_canonical_schedule. + exact Hworld. + --- exact Htr. + ++ destruct spawn_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_fork + n v focused_slot k Hthread) in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + ++ cbn in Htr. + rewrite (schedule_with_offers_focused_user_event + n v focused_slot user_event k Hthread) in Htr. + apply ktrans_vis in Htr as [value [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + + destruct n as [| n']. + * cbn in Htr. + apply scheduler_offer_shape_ret_step with (w := w). + exact Htr. + * cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + -- symmetry. exact Htarget. + -- apply scheduler_offer_shape_prefix_at_point. + - cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + + symmetry. exact Htarget. + + apply scheduler_offer_shape_prefix_elsewhere. + apply obs_offered_non_scheduling_point. + - destruct r as [| r']. + + destruct m as [| m']. + * cbn in Htr. + apply scheduler_offer_shape_ret_step with (w := w). + exact Htr. + * cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + -- symmetry. exact Htarget. + -- apply scheduler_offer_shape_choice. + apply obs_non_scheduler_non_scheduling_point. + + cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + * symmetry. exact Htarget. + * apply scheduler_offer_shape_prefix_elsewhere. + apply obs_offered_non_scheduling_point. + - cbn in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + + exact Htarget. + + apply scheduler_offer_shape_schedule. exact Hworld. + - apply ktrans_not_done in Htr. inversion Htr. + - apply ktrans_not_done in Htr. inversion Htr. + Qed. + + Local Lemma scheduler_offer_shape_step t w t' w' : + SchedulerOfferShape t w -> + |t, w| ↦ |t', w'| -> + SchedulerOfferShape t' w'. + Proof. + intros [u [Htu Hcanonical]] Htr. + rewrite Htu in Htr. + eapply scheduler_offer_canonical_step; eauto. + Qed. + + CoInductive SchedulerProgress + : observed_completed E -> World (scheduler_observedE E) -> Prop := + | scheduler_progress_intro : forall t w, + can_step t w -> + (forall t' w', + |t, w| ↦ |t', w'| -> SchedulerProgress t' w') -> + SchedulerProgress t w. + + Lemma scheduler_progress_shape_implies_AG t w : + SchedulerProgress t w -> + SchedulerOfferShape t w -> + agc scheduling_point_offer_obligation t w. + Proof. + intros Hprogress0 Hshape0. + pose proof (leq_gfp (agcF scheduling_point_offer_obligation) + (fun t w => SchedulerProgress t w /\ SchedulerOfferShape t w)) + as Hcoind. + apply Hcoind. + - clear t w Hprogress0 Hshape0. + intros t w [Hprogress Hshape]. + destruct Hprogress as [t w Hstep Hnext]. + split. + + apply scheduler_offer_shape_obligation. exact Hshape. + + split. + * exact Hstep. + * intros t' w' Htr. + split. + -- apply Hnext. exact Htr. + -- eapply scheduler_offer_shape_step; eauto. + - split; assumption. + Qed. + + Theorem every_live_slot_is_eventually_offered_at_scheduling_points + n (v : pool E n) focus : + SchedulerProgress (schedule_with_offers n v focus) Pure -> + agc scheduling_point_offer_obligation + (schedule_with_offers n v focus) Pure. + Proof. + intro Hprogress. + eapply scheduler_progress_shape_implies_AG. + - exact Hprogress. + - apply scheduler_offer_shape_schedule. + apply pure_non_scheduling_point. + Qed. + + Theorem show_every_live_slot_is_eventually_offered_at_scheduling_points + n (v : pool E n) focus : + SchedulerProgress (schedule_with_offers n v focus) Pure -> + agc scheduling_point_offer_obligation + (schedule_with_offers n v focus) Pure. + Proof. + apply every_live_slot_is_eventually_offered_at_scheduling_points. + Qed. +End ObservedScheduler. From d058613a86763011111f6b707003b1aea54ae88e Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" Date: Tue, 22 Sep 2026 04:41:54 -0700 Subject: [PATCH 06/14] feat(csl): verify concurrent allocator liveness --- examples/CSL/Allocator/Execution.v | 2473 ++++++++++++++++ examples/CSL/Allocator/Layout.v | 524 ++++ examples/CSL/Allocator/Liveness.v | 2155 ++++++++++++++ examples/CSL/Allocator/Model.v | 1081 +++++++ examples/CSL/Allocator/NegativeTests.v | 848 ++++++ examples/CSL/Allocator/Program.v | 126 + examples/CSL/Allocator/Tests.v | 234 ++ examples/CSL/Compose.v | 429 +++ examples/CSL/Frame.v | 380 +++ examples/CSL/HeapQ.v | 842 ++++++ examples/CSL/HeapTests.v | 126 + examples/CSL/InterpTests.v | 417 +++ examples/CSL/Layout.v | 501 ++++ examples/CSL/Lex.v | 67 + examples/CSL/NegativeTests.v | 107 + examples/CSL/Overlap.v | 113 + examples/CSL/PcmTests.v | 30 + examples/CSL/Program.v | 506 ++++ examples/CSL/QLang.v | 265 ++ examples/CSL/Queue.v | 165 ++ examples/CSL/QueueTests.v | 403 +++ examples/CSL/README.md | 311 ++ examples/CSL/Recurrence.v | 417 +++ examples/CSL/RoundRobinTests.v | 104 + examples/CSL/SLang.v | 201 ++ examples/CSL/Sep2.v | 156 + examples/CSL/Trace.v | 130 + examples/Election.v | 2 +- examples/Queue.v | 3 +- examples/Sec.v | 2 +- examples/Toy.v | 4 +- theories/Events/YieldE.v | 24 + theories/ICTree/Eq/Bind.v | 9 + .../Yield/Events.v => ICTree/Events/Yield.v} | 35 +- theories/ICTree/Interp/Core.v | 66 +- theories/ICTree/Interp/Refine.v | 242 ++ .../ICTree/Interp/{State.v => State/Mod.v} | 0 theories/ICTree/Interp/Yield/Mod.v | 591 ++++ theories/ICTree/Interp/Yield/RoundRobin.v | 141 + theories/ICTree/Interp/Yield/SBisim.v | 938 ++++++ theories/ICTree/Logic/AF.v | 4 +- theories/ICTree/Logic/CanStep.v | 2 +- theories/ICTree/Logic/EF.v | 2 +- theories/ICTree/Logic/SchedulerFairness.v | 2513 ++++++++++++++++ theories/ICTree/Logic/Soundness.v | 14 +- theories/ICTree/Logic/State.v | 2 +- theories/ICTree/Logic/Yield.v | 345 +++ theories/Lang/CSL.v | 3 + theories/Lang/CSL/Denote.v | 100 + theories/Lang/CSL/Heap.v | 414 +++ theories/Lang/CSL/Interp.v | 840 ++++++ theories/Lang/CSL/Pcm.v | 515 ++++ theories/Lang/CSL/Syntax.v | 14 + theories/Lang/HeapImp.v | 4 +- theories/Lang/MeQ.v | 4 +- theories/Lang/MeS.v | 4 +- theories/Lang/StImp.v | 4 +- theories/Lang/Yield.v | 13 +- theories/Lang/Yield/Denote.v | 106 +- theories/Lang/Yield/Interp.v | 62 +- theories/Lang/Yield/SBisim.v | 945 +----- theories/Lang/Yield/Scheduler.v | 48 - theories/Lang/Yield/SchedulerFairness.v | 2533 +---------------- theories/Lang/Yield/Ticl.v | 943 ++---- theories/Lang/Yield/Vec.v | 55 - theories/Utils/Vectors.v | 42 + 66 files changed, 20344 insertions(+), 4355 deletions(-) create mode 100644 examples/CSL/Allocator/Execution.v create mode 100644 examples/CSL/Allocator/Layout.v create mode 100644 examples/CSL/Allocator/Liveness.v create mode 100644 examples/CSL/Allocator/Model.v create mode 100644 examples/CSL/Allocator/NegativeTests.v create mode 100644 examples/CSL/Allocator/Program.v create mode 100644 examples/CSL/Allocator/Tests.v create mode 100644 examples/CSL/Compose.v create mode 100644 examples/CSL/Frame.v create mode 100644 examples/CSL/HeapQ.v create mode 100644 examples/CSL/HeapTests.v create mode 100644 examples/CSL/InterpTests.v create mode 100644 examples/CSL/Layout.v create mode 100644 examples/CSL/Lex.v create mode 100644 examples/CSL/NegativeTests.v create mode 100644 examples/CSL/Overlap.v create mode 100644 examples/CSL/PcmTests.v create mode 100644 examples/CSL/Program.v create mode 100644 examples/CSL/QLang.v create mode 100644 examples/CSL/Queue.v create mode 100644 examples/CSL/QueueTests.v create mode 100644 examples/CSL/README.md create mode 100644 examples/CSL/Recurrence.v create mode 100644 examples/CSL/RoundRobinTests.v create mode 100644 examples/CSL/SLang.v create mode 100644 examples/CSL/Sep2.v create mode 100644 examples/CSL/Trace.v create mode 100644 theories/Events/YieldE.v rename theories/{Lang/Yield/Events.v => ICTree/Events/Yield.v} (51%) create mode 100644 theories/ICTree/Interp/Refine.v rename theories/ICTree/Interp/{State.v => State/Mod.v} (100%) create mode 100644 theories/ICTree/Interp/Yield/Mod.v create mode 100644 theories/ICTree/Interp/Yield/RoundRobin.v create mode 100644 theories/ICTree/Interp/Yield/SBisim.v create mode 100644 theories/ICTree/Logic/SchedulerFairness.v create mode 100644 theories/ICTree/Logic/Yield.v create mode 100644 theories/Lang/CSL.v create mode 100644 theories/Lang/CSL/Denote.v create mode 100644 theories/Lang/CSL/Heap.v create mode 100644 theories/Lang/CSL/Interp.v create mode 100644 theories/Lang/CSL/Pcm.v create mode 100644 theories/Lang/CSL/Syntax.v delete mode 100644 theories/Lang/Yield/Scheduler.v delete mode 100644 theories/Lang/Yield/Vec.v diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v new file mode 100644 index 0000000..1670374 --- /dev/null +++ b/examples/CSL/Allocator/Execution.v @@ -0,0 +1,2473 @@ +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. +From Stdlib Require Import Classes.Morphisms. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin Utils.Vectors. +From examples Require Import CSL.HeapQ CSL.Allocator.Layout + CSL.Allocator.Program CSL.Allocator.Model. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. + +Definition emit_list {X} (xs : list SObs) (t : ictreeW SObs X) : ictreeW SObs X := + List.fold_right (fun o k => log o;; k) t xs. +Definition turn_observations (event : option SObs) : list SObs := + match event with None => [] | Some o => [o] end. + +(** A finite derivation stops at the first source yield. The handler premise + is its actual effect semantics, not an allocator transition assumption. *) +Inductive ThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := +| segment_yield (k : unit -> thread sE) sigma : + ThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma +| segment_guard t sigma logs t' sigma' : + ThreadSegment t sigma logs t' sigma' -> + ThreadSegment (Guard t) sigma logs t' sigma' +| segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 + before after t' sigma' : + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> + ThreadSegment (k result) sigma1 after t' sigma' -> + ThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) + sigma (before ++ after) t' sigma' +| segment_equ t u sigma logs u' t' sigma' : + t ≅ u -> ThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> + ThreadSegment t sigma logs t' sigma'. + +(** Only finite leading guards and raw tree equivalence are forgotten. + A real [Br] node is never included in this closure. *) +Inductive guard_equ : thread sE -> thread sE -> Prop := +| guard_equ_equ t u : t ≅ u -> guard_equ t u +| guard_equ_left t u : guard_equ t u -> guard_equ (Guard t) u +| guard_equ_right t u : guard_equ t u -> guard_equ t (Guard u) +| guard_equ_sym t u : guard_equ t u -> guard_equ u t +| guard_equ_trans t u v : guard_equ t u -> guard_equ u v -> guard_equ t v. + +(** These are the actual [CUntilNone] continuations, including halt flow. *) +Definition until_tail {A} (body : CProg (option A)) + (K : option unit -> thread sE) (flow : option (option A)) : thread sE := + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end. + +Definition client_next base client : option (option unit) -> thread sE := + until_tail (client_round base client) (fun _ => Ret tt). +Definition remote_after_free base client (flow : option unit) : thread sE := + match flow with + | None => client_next base client None + | Some _ => + denote_flow (CBind CYield (fun _ => CRet (Some tt : option unit))) >>= + client_next base client + end. +Definition remote_cas_tail base block old : CProg (option unit) := + CBind (CCAS (remote_head base) old block) (fun success => + if success then + CBind (CEmit tag_retire block) (fun _ => CRet (None : option unit)) + else + CBind (CEmit tag_retry block) (fun _ => + CBind CYield (fun _ => CRet (Some tt : option unit)))). +Definition remote_link_tail base block old : CProg (option unit) := + CBind (CWrite block old) (fun _ => + CBind CYield (fun _ => remote_cas_tail base block old)). + +Definition remote_residual (base : nat) (client : bool) (pc : remote_pc) : thread sE := + match pc with + | RPoll => denote (remote_client base client) + | RRead block => denote_flow (remote_free base block) >>= remote_after_free base client + | RLink block old => denote_flow (remote_link_tail base block old) >>= + until_tail (remote_attempt base block) (remote_after_free base client) + | RCAS block old => denote_flow (remote_cas_tail base block old) >>= + until_tail (remote_attempt base block) (remote_after_free base client) + end. + +Definition owner_next base : option (option unit) -> thread sE := + until_tail (owner_round base) (fun _ => Ret tt). +Definition owner_offer_tail base (client : bool) : CProg (option unit) := + if client then + CBind (offer_block base true) (fun _ => CRet (Some tt : option unit)) + else + CBind (offer_block base false) (fun _ => + CBind (offer_block base true) (fun _ => CRet (Some tt : option unit))). +Definition owner_after_collect base (flow : option unit) : thread sE := + match flow with + | None => owner_next base None + | Some _ => denote_flow (owner_offer_tail base false) >>= owner_next base + end. +Definition owner_after_detach base (flow : option unit) : thread sE := + match flow with + | None => owner_after_collect base None + | Some _ => denote_flow (CUntilNone (reclaim_step base)) >>= owner_after_collect base + end. +Definition detach_cas_tail base old : CProg (option unit) := + CBind (CCAS (remote_head base) old 0) (fun success => + if success then + CBind (CWrite (drain_head base) old) (fun _ => + CBind CYield (fun _ => CRet (None : option unit))) + else CBind CYield (fun _ => CRet (Some tt : option unit))). + +Definition owner_residual (base : nat) (pc : owner_pc) : thread sE := + match pc with + | ORead => denote (CUntilNone (owner_round base)) + | OCAS old => denote_flow (detach_cas_tail base old) >>= + until_tail (detach_attempt base) (owner_after_detach base) + | ODrain => denote_flow (CUntilNone (reclaim_step base)) >>= owner_after_collect base + | OOffer client => denote_flow (owner_offer_tail base client) >>= owner_next base + end. +Definition allocator_pool (base : nat) (s : AState) : pool sE 3 := + [remote_residual base true (remote1_state s); + remote_residual base false (remote0_state s); + owner_residual base (owner_state s)]%vector. +Definition source_pool0 base : pool sE 3 := + [denote (remote_client base true); denote (remote_client base false); + denote (CUntilNone (owner_round base))]%vector. +Definition pool_guard_equ {n} (ts us : pool sE n) : Prop := + forall i, guard_equ (ts $ i) (us $ i). +Definition state_agrees (sigma : SSig) (s : AState) : Prop := + heq (fst sigma) (aheap s) /\ snd sigma = acount s. + +Lemma allocator_inv_state_equiv base capacity s t : + state_equiv s t -> allocator_inv base capacity s -> allocator_inv base capacity t. +Proof. + destruct s as [h c op r0 r1], t as [k d oq q0 q1]. + intros [Hh [Hc [Ho [H0 H1]]]]; cbn in Hh, Hc, Ho, H0, H1. + subst d oq q0 q1. + intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1). + cbn [aheap owner_state remote0_state remote1_state] in *. + unfold allocator_inv; cbn [aheap owner_state remote0_state remote1_state]. + split; [exact Hbase|]; split. + - intro x; rewrite <- Hh; apply Hback. + - exists L, R, D, m0, m1. + repeat split; try assumption; + try solve [rewrite <- Hh; assumption]; + try solve [eapply ai_free_chain_frame; + [eassumption|intros; symmetry; apply Hh]]; + try solve [eapply ai_cached_remote_frame; + [eassumption|intros; symmetry; apply Hh]]. +Qed. + +Definition source_reheap (sigma : SSig) (s : AState) : AState := + {| aheap := fst sigma; acount := snd sigma; + owner_state := owner_state s; + remote0_state := remote0_state s; remote1_state := remote1_state s |}. + +Lemma state_agrees_reheap sigma s : + state_agrees sigma s -> state_equiv s (source_reheap sigma s). +Proof. + intros [Hh Hc]; unfold state_equiv, source_reheap; cbn. + split; [now apply heq_sym|]; repeat split; congruence. +Qed. + +Lemma source_pool0_initial capacity c : + pool_equ (source_pool0 1) (allocator_pool 1 (initial_state capacity c)). +Proof. apply pool_equ_refl. Qed. + +Lemma execution_pool_guard_equ {n} (ts us : pool sE n) : + pool_equ ts us -> pool_guard_equ ts us. +Proof. intros H i; apply guard_equ_equ, H. Qed. + +Lemma execution_pool_guard_replace {n} (ts us : pool sE n) + (i : Fin.t n) t u : + pool_guard_equ ts us -> guard_equ t u -> + pool_guard_equ (ts @ i := t) (us @ i := u). +Proof. + intros Hpool Htu j; destruct (Fin.eq_dec j i) as [->|Hneq]. + - rewrite !Vector.nth_replace_eq; exact Htu. + - rewrite !Vector.nth_replace_neq by congruence; apply Hpool. +Qed. + +(** Silent checked writes, with the continuation held fixed while the state + handler is simplified. No congruence on a pool of bisimilar threads is + used here. *) +Local Lemma allocator_interp_rr_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c : + h a <> None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (upd h a v,c). +Proof. + intro Present. + pose proof (sinterp_wr' a h c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Local Lemma allocator_interp_nd_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c : + h a <> None -> + interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some tt)) + (Some i) (upd h a v,c). +Proof. + intro Present. + pose proof (sinterp_wr' a h c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) + first count (K : option unit -> thread sE) m h c : + (forall offset, Nat.lt offset (2 * count) -> + h (first + offset)%nat <> None) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (init_links_heap first count h,c). +Proof. + revert first h; induction count as [|count IH]; intros first h Allocated. + - cbn [init_links init_links_heap]; rewrite interp_rr_ret; reflexivity. + - cbn [init_links init_links_heap]; rewrite interp_rr_bind. + etransitivity. + + apply allocator_interp_rr_write_present. + specialize (Allocated 0 ltac:(cbn; lia)). + now rewrite Nat.add_0_r in Allocated. + + apply IH; intros offset O; apply upd_preserves_present. + replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. + apply Allocated; cbn; lia. +Qed. + +Lemma interp_nd_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) + first count (K : option unit -> thread sE) h c : + (forall offset, Nat.lt offset (2 * count) -> + h (first + offset)%nat <> None) -> + interp_nd (S n) + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some tt)) + (Some i) (init_links_heap first count h,c). +Proof. + revert first h; induction count as [|count IH]; intros first h Allocated. + - cbn [init_links init_links_heap]; rewrite interp_nd_source_ret; reflexivity. + - cbn [init_links init_links_heap]; rewrite interp_nd_source_bind. + etransitivity. + + apply allocator_interp_nd_write_present. + specialize (Allocated 0 ltac:(cbn; lia)). + now rewrite Nat.add_0_r in Allocated. + + apply IH; intros offset O; apply upd_preserves_present. + replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. + apply Allocated; cbn; lia. +Qed. + +(** The starting heap is the actual allocation overlay. In particular the + five metadata writes and every link write are checked against allocated + cells, and the untouched payloads retain the allocation's zeroes. *) +Lemma interp_rr_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) + base capacity (K : option unit -> thread sE) m h c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (init_page base capacity) >>= K)) + (Some i) m (hunion (hblock base (page_size capacity)) h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (page_heap base capacity h,c). +Proof. + unfold init_page, page_heap. + do 5 (rewrite interp_rr_bind; etransitivity; + [apply allocator_interp_rr_write_present; + repeat apply upd_preserves_present; + rewrite page_backing_in by + (unfold remote_head, drain_head, mailbox, local_head, page_size; lia); + discriminate |]). + apply interp_rr_init_links; intros offset O. + repeat apply upd_preserves_present. + rewrite page_backing_in by (unfold page_size; lia); discriminate. +Qed. + +Lemma interp_nd_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) + base capacity (K : option unit -> thread sE) h c : + interp_nd (S n) + (ts @ i := (denote_flow (init_page base capacity) >>= K)) + (Some i) (hunion (hblock base (page_size capacity)) h,c) ~ + interp_nd (S n) (ts @ i := K (Some tt)) + (Some i) (page_heap base capacity h,c). +Proof. + unfold init_page, page_heap. + do 5 (rewrite interp_nd_source_bind; etransitivity; + [apply allocator_interp_nd_write_present; + repeat apply upd_preserves_present; + rewrite page_backing_in by + (unfold remote_head, drain_head, mailbox, local_head, page_size; lia); + discriminate |]). + apply interp_nd_init_links; intros offset O. + repeat apply upd_preserves_present. + rewrite page_backing_in by (unfold page_size; lia); discriminate. +Qed. + +(** A first-fit equation is separated from the finite-heap existence proof, + so concrete initialized source programs can use a known fresh base. *) +Lemma interp_rr_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity base (K : option nat -> thread sE) m h c : + Nat.lt 0 base -> block_free h base (page_size capacity) -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> + ~ block_free h j (page_size capacity)) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some base)) + (Some i) m (page_heap base capacity h,c). +Proof. + intros Positive Free First. + pose proof (sinterp_alloc_first h (page_size capacity) base c + (fun a : nat => (Ret a : ictree sE nat)) + (page_size_positive capacity) Positive Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + unfold new_page; rewrite interp_rr_bind, interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + rewrite interp_rr_bind; etransitivity. + - apply interp_rr_init_page. + - rewrite interp_rr_ret; reflexivity. +Qed. + +Lemma interp_nd_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity base (K : option nat -> thread sE) h c : + Nat.lt 0 base -> block_free h base (page_size capacity) -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> + ~ block_free h j (page_size capacity)) -> + interp_nd (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some base)) + (Some i) (page_heap base capacity h,c). +Proof. + intros Positive Free First. + pose proof (sinterp_alloc_first h (page_size capacity) base c + (fun a : nat => (Ret a : ictree sE nat)) + (page_size_positive capacity) Positive Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + unfold new_page; rewrite interp_nd_source_bind, interp_nd_source_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + rewrite interp_nd_source_bind; etransitivity. + - apply interp_nd_init_page. + - rewrite interp_nd_source_ret; reflexivity. +Qed. + +Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (K : option nat -> thread sE) m h c : + heap_finite h -> + exists base, + Nat.lt 0 base /\ block_free h base (page_size capacity) /\ + (forall j, Nat.lt 0 j -> Nat.lt j base -> + ~ block_free h j (page_size capacity)) /\ + heap_finite (page_heap base capacity h) /\ + (forall x, h x <> None -> page_heap base capacity h x = h x) /\ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some base)) + (Some i) m (page_heap base capacity h,c). +Proof. + intro Finite. + destruct (sh_alloc_finite h (page_size capacity) c Finite + (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). + exists base; split; [exact Positive |]; split; [exact Free |]. + split; [exact First |]; split; [now apply page_heap_finite |]. + split; [now apply page_heap_old_frame |]. + apply interp_rr_new_page_first; assumption. +Qed. + +Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (K : option nat -> thread sE) h c : + heap_finite h -> + exists base, + Nat.lt 0 base /\ block_free h base (page_size capacity) /\ + (forall j, Nat.lt 0 j -> Nat.lt j base -> + ~ block_free h j (page_size capacity)) /\ + heap_finite (page_heap base capacity h) /\ + (forall x, h x <> None -> page_heap base capacity h x = h x) /\ + interp_nd (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some base)) + (Some i) (page_heap base capacity h,c). +Proof. + intro Finite. + destruct (sh_alloc_finite h (page_size capacity) c Finite + (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). + exists base; split; [exact Positive |]; split; [exact Free |]. + split; [exact First |]; split; [now apply page_heap_finite |]. + split; [now apply page_heap_old_frame |]. + apply interp_nd_new_page_first; assumption. +Qed. + +(** Empty heaps accept the very first candidate, even when capacity is zero: + the allocation request is always for at least the five metadata cells. *) +Lemma sh_alloc_page_hemp capacity c : + runStateT (sh (SAlloc (page_size capacity))) (hemp,c) ~ + Ret (1,(hunion (hblock 1 (page_size capacity)) hemp,c)). +Proof. + apply sh_alloc_first. + - apply page_size_positive. + - lia. + - intros offset O; reflexivity. + - intros j Positive Before; lia. +Qed. + +Lemma interp_rr_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (K : option nat -> thread sE) m c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) + (Some i) m (page_heap 1 capacity hemp,c). +Proof. + apply interp_rr_new_page_first. + - lia. + - intros offset O; reflexivity. + - intros j Positive Before; lia. +Qed. + +Lemma interp_nd_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (K : option nat -> thread sE) c : + interp_nd (S n) + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (hemp,c) ~ + interp_nd (S n) (ts @ i := K (Some 1)) + (Some i) (page_heap 1 capacity hemp,c). +Proof. + apply interp_nd_new_page_first. + - lia. + - intros offset O; reflexivity. + - intros j Positive Before; lia. +Qed. + +(** Source read probes after dynamic initialization. Instantiating [address] + with metadata, link, or payload addresses combines these equations with + the corresponding [page_heap_*] lookup laws, without assuming a fixture. *) +Local Lemma allocator_interp_rr_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c : + h a = Some value -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m (h,c). +Proof. + intro Lookup. + pose proof (sinterp_rd a h c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Local Lemma allocator_interp_nd_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c : + h a = Some value -> + interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some value)) (Some i) (h,c). +Proof. + intro Lookup. + pose proof (sinterp_rd a h c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (address : nat -> nat) value (K : option nat -> thread sE) m c : + page_heap 1 capacity hemp (address 1) = Some value -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind (new_page capacity) + (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) + (Some i) m (page_heap 1 capacity hemp,c). +Proof. + intro Lookup; rewrite interp_rr_bind, interp_rr_new_page_hemp. + apply allocator_interp_rr_read_value; exact Lookup. +Qed. + +Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (address : nat -> nat) value (K : option nat -> thread sE) c : + page_heap 1 capacity hemp (address 1) = Some value -> + interp_nd (S n) + (ts @ i := (denote_flow (CBind (new_page capacity) + (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ + interp_nd (S n) (ts @ i := K (Some value)) + (Some i) (page_heap 1 capacity hemp,c). +Proof. + intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. + apply allocator_interp_nd_read_value; exact Lookup. +Qed. + +Lemma interp_rr_new_page_read_missing n + (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (address : nat -> nat) (K : option nat -> thread sE) m c : + page_heap 1 capacity hemp (address 1) = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind (new_page capacity) + (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp, interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; + [exact (sinterp_srd_stuck (address 1) (page_heap 1 capacity hemp) c Missing) + |reflexivity|reflexivity] + |intro result; reflexivity] + |eapply equ_clos_sbisim_goal; [apply bind_stuck_equ|reflexivity|reflexivity]] + end. +Qed. + +Lemma interp_nd_new_page_read_missing n + (ts : pool sE (S n)) (i : Fin.t (S n)) + capacity (address : nat -> nat) (K : option nat -> thread sE) c : + page_heap 1 capacity hemp (address 1) = None -> + interp_nd (S n) + (ts @ i := (denote_flow (CBind (new_page capacity) + (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + rewrite interp_nd_source_bind, interp_nd_new_page_hemp, interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; + [exact (sinterp_srd_stuck (address 1) (page_heap 1 capacity hemp) c Missing) + |reflexivity|reflexivity] + |intro result; reflexivity] + |eapply equ_clos_sbisim_goal; [apply bind_stuck_equ|reflexivity|reflexivity]] + end. +Qed. + +(** The children are the actual scoped-fork children: their [None] branch + terminates rather than running the parent's remaining initialization. + Parent focus advances twice, but its cursor is unchanged until selection. *) +Theorem run_rr_allocator_initialized capacity c : + run_rr (allocator_program capacity) hemp c ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + (page_heap 1 capacity hemp,c). +Proof. + unfold run_rr. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,c) ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + (page_heap 1 capacity hemp,c)). + unfold allocator_program; rewrite interp_rr_bind, interp_rr_new_page_hemp. + rewrite interp_rr_bind, interp_rr_fork. + change (interp_schedule_rr sh 2 + ([denote (remote_client 1 false); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) + >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (page_heap 1 capacity hemp,c) ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + (page_heap 1 capacity hemp,c)). + rewrite interp_rr_bind, interp_rr_fork. + change (interp_schedule_rr sh 3 + ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector + @ Fin.FS (Fin.FS Fin.F1) := + (denote_flow (owner 1) >>= fun _ => Ret tt)) + (Some (Fin.FS (Fin.FS Fin.F1))) 0 (page_heap 1 capacity hemp,c) ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + (page_heap 1 capacity hemp,c)). + unfold owner; rewrite interp_rr_bind, interp_rr_yield; reflexivity. +Qed. + +Theorem run_nd_allocator_initialized capacity c : + run_nd (allocator_program capacity) hemp c ~ + interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c). +Proof. + unfold run_nd. + change (interp_nd 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,c) ~ + interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + unfold allocator_program; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. + rewrite interp_nd_source_bind, interp_nd_source_fork. + change (interp_nd 2 + ([denote (remote_client 1 false); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) + >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) (page_heap 1 capacity hemp,c) ~ + interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + rewrite interp_nd_source_bind, interp_nd_source_fork. + change (interp_nd 3 + ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector + @ Fin.FS (Fin.FS Fin.F1) := + (denote_flow (owner 1) >>= fun _ => Ret tt)) + (Some (Fin.FS (Fin.FS Fin.F1))) (page_heap 1 capacity hemp,c) ~ + interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + unfold owner; rewrite interp_nd_source_bind, interp_nd_source_yield; reflexivity. +Qed. + +From Stdlib Require Import List Program.Equality Classes.RelationClasses. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield + ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin + ICTree.Interp.Refine Utils.Vectors. + +Unset Implicit Arguments. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. + +Lemma emit_list_nil {X} (t : ictreeW SObs X) : emit_list [] t = t. +Proof. reflexivity. Qed. + +Lemma emit_list_cons {X} o xs (t : ictreeW SObs X) : + emit_list (o :: xs) t ≅ Vis (Log o) (fun _ => emit_list xs t). +Proof. + change ((log o ;; emit_list xs t) ≅ Vis (Log o) (fun _ => emit_list xs t)). + unfold log, ICtree.trigger; rewrite bind_vis. + step; constructor; intros []; rewrite bind_ret_l; reflexivity. +Qed. + +Lemma emit_list_app {X} xs ys (t : ictreeW SObs X) : + emit_list (xs ++ ys) t = emit_list xs (emit_list ys t). +Proof. unfold emit_list; rewrite List.fold_right_app; reflexivity. Qed. + +Lemma emit_list_equ {X} xs (t u : ictreeW SObs X) : + t ≅ u -> emit_list xs t ≅ emit_list xs u. +Proof. + intro E; induction xs as [|o xs IH]; [exact E|]. + rewrite !emit_list_cons; step; constructor; intro x; exact IH. +Qed. + +Lemma emit_list_sbisim {X} xs (t u : ictreeW SObs X) : + t ~ u -> emit_list xs t ~ emit_list xs u. +Proof. + intro E; induction xs as [|o xs IH]; [exact E|]. + rewrite !emit_list_cons; apply sb_vis; intro x; exact IH. +Qed. + +Lemma emit_list_bind {X Y} xs (t : ictreeW SObs X) + (k : X -> ictreeW SObs Y) : + emit_list xs t >>= k ≅ emit_list xs (t >>= k). +Proof. + induction xs as [|o xs IH]; [reflexivity|]. + change (((log o ;; emit_list xs t) >>= k) ≅ + (log o ;; emit_list xs (t >>= k))). + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros []; exact IH. +Qed. + +Lemma emit_list_ret_bind {X Y} xs (x : X) (k : X -> ictreeW SObs Y) : + emit_list xs (Ret x) >>= k ≅ emit_list xs (k x). +Proof. + etransitivity; [apply emit_list_bind|]. + apply emit_list_equ, bind_ret_l. +Qed. + +(** Return values are observable labels, including when they contain heaps. + This proves equality of actual responses; it never identifies merely + pointwise-equal heap functions. *) +Lemma emit_list_ret_injective {X} xs ys (x y : X) : + emit_list xs (Ret x) ~ emit_list ys (Ret y) -> xs = ys /\ x = y. +Proof. + revert ys; induction xs as [|o xs IH]; intros [|p ys] E. + - split; [reflexivity|]. exact (@sbisim_ret_inv (writerE SObs) _ X x y E). + - rewrite emit_list_cons in E. + exfalso; exact (@sbisim_ret_vis_inv (writerE SObs) _ X x (Log p) + (fun _ => emit_list ys (Ret y)) E). + - rewrite emit_list_cons in E. + exfalso; eapply (@sbisim_ret_vis_inv (writerE SObs) _ X y (Log o) + (fun _ => emit_list xs (Ret x))); symmetry; exact E. + - rewrite !emit_list_cons in E. + pose proof (@sbisim_vis_invT (writerE SObs) _ X + (Log o) (Log p) (fun _ => emit_list xs (Ret x)) + (fun _ => emit_list ys (Ret y)) tt E) as [_ Eo]. + injection Eo as Eo; subst p. + pose proof (@sbisim_vis_invE (writerE SObs) _ X (Log o) + (fun _ => emit_list xs (Ret x)) (fun _ => emit_list ys (Ret y)) + tt E tt) as Etail. + destruct (IH ys Etail) as [-> ->]; auto. +Qed. + +Lemma handler_response_unique (e : sE) (sigma : SSig) + (result : encode e) (sigma1 : SSig) (before : list SObs) + (result' : encode e) (sigma2 : SSig) (before' : list SObs) : + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> + runStateT (sh e) sigma ~ emit_list before' (Ret (result',sigma2)) -> + before = before' /\ result = result' /\ sigma1 = sigma2. +Proof. + intros E1 E2. + assert (E : emit_list before (Ret (result,sigma1)) ~ + emit_list before' (Ret (result',sigma2))). + { transitivity (runStateT (sh e) sigma); [symmetry; exact E1|exact E2]. } + destruct (emit_list_ret_injective _ _ _ _ E) as [Ex Er]. + inversion Er; subst; auto. +Qed. + +Lemma sbisim_stuck_is_stuck {E} {HE : Encode E} {X} (t : ictree E X) : + t ~ (stuck : ictree E X) -> is_stuck t. +Proof. + intros Ets [l [u Hstep]]. + destruct (sbisim_trans t stuck u l eq Ets Hstep) + as [l' [u' [Hbad _]]]. + eapply trans_stuck; exact Hbad. +Qed. + +Lemma emit_list_ret_not_stuck {X} xs (x : X) : + ~ (emit_list xs (Ret x) ~ (stuck : ictreeW SObs X)). +Proof. + intro E; apply sbisim_stuck_is_stuck in E. + destruct xs as [|o xs]. + - apply E; exists (val x), stuck; apply trans_ret. + - apply E; exists (obs (Log o) tt), (emit_list xs (Ret x)). + rewrite emit_list_cons. + exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => emit_list xs (Ret x))). +Qed. + +(** Raw congruence is allowed on both ends, but no source-side [sbisim] + congruence is used. *) +Lemma ThreadSegment_equ_input t u sigma xs residual sigma' : + t ≅ u -> ThreadSegment t sigma xs residual sigma' -> + ThreadSegment u sigma xs residual sigma'. +Proof. + intros E H; eapply segment_equ; [symmetry; exact E|exact H|reflexivity]. +Qed. + +Lemma ThreadSegment_equ_output t sigma xs residual residual' sigma' : + ThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> + ThreadSegment t sigma xs residual' sigma'. +Proof. intros H E; eapply segment_equ; [reflexivity|exact H|exact E]. Qed. + +Lemma ThreadSegment_yield_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : unit -> thread sE, + t ≅ Vis (inl Yield) k -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros k E; split; [reflexivity|]; split; [reflexivity|]. + symmetry; exact (equ_vis_invE E tt). + - intros k E; step in E; cbn in E; inversion E. + - intros k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - intros k E. + assert (Eu : u ≅ Vis (inl Yield) k). + { transitivity t; [symmetry; exact Etu|exact E]. } + destruct (IH k Eu) as [Ex [Es Ek]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; assumption. +Qed. + +Lemma ThreadSegment_yield_inv k sigma xs residual sigma' : + ThreadSegment (Vis (inl Yield) k) sigma xs residual sigma' -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. +Proof. intro H; eapply ThreadSegment_yield_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_guard_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall u, t ≅ Guard u -> ThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t v sigma xs v' residual sigma' Etv H IH Eout]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E; apply equ_guard_invE in E. + eapply ThreadSegment_equ_input; [exact E|exact H]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E. + eapply ThreadSegment_equ_output; [|exact Eout]. + apply IH; transitivity t; [symmetry; exact Etv|exact E]. +Qed. + +Lemma ThreadSegment_guard_inv t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' -> + ThreadSegment t sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' <-> + ThreadSegment t sigma xs residual sigma'. +Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. + +Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall (e : sE) (k : encode e -> thread sE), + t ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) -> + exists result sigma1 before after, + xs = before ++ after /\ + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ + ThreadSegment (k result) sigma1 after residual sigma'. +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e0 k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros e k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - intros e k E; step in E; cbn in E; inversion E. + - intros e k E. + pose proof (equ_vis_invT E) as [_ Ee]. + assert (Eevent : e0 = e) by congruence; subst e. + exists result, sigma1, before, after. + split; [reflexivity|]; split; [exact Eh|]. + eapply ThreadSegment_equ_input; [exact (equ_vis_invE E result)|exact H]. + - intros e k E. + assert (Eu : u ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k))). + { transitivity t; [symmetry; exact Etu|exact E]. } + destruct (IH e k Eu) as [r [sigma1 [before [after [Ex [Eh Htail]]]]]]. + exists r, sigma1, before, after; split; [exact Ex|]; split; [exact Eh|]. + eapply ThreadSegment_equ_output; eassumption. +Qed. + +Lemma ThreadSegment_user_inv (e : sE) (k : encode e -> thread sE) + sigma xs residual sigma' : + ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma' -> + exists result sigma1 before after, + xs = before ++ after /\ + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ + ThreadSegment (k result) sigma1 after residual sigma'. +Proof. intro H; eapply ThreadSegment_user_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_ret_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> ~ (t ≅ Ret tt). +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intro E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - apply IH; transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_ret_absurd sigma xs residual sigma' : + ~ ThreadSegment (Ret tt) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_ret_absurd_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_fork_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : bool -> thread sE, ~ (t ≅ Vis (inr (inl Fork)) k). +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros k E. + - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - step in E; cbn in E; inversion E. + - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - apply (IH k); transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_fork_absurd k sigma xs residual sigma' : + ~ ThreadSegment (Vis (inr (inl Fork)) k) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_fork_absurd_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_br_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall n (k : Fin.t (S n) -> thread sE), ~ (t ≅ Br n k). +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n k E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - apply (IH n k); transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_br_absurd n k sigma xs residual sigma' : + ~ ThreadSegment (Br n k) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_br_absurd_equ; [exact H|reflexivity]. Qed. + +(** A finite first-yield derivation cannot be manufactured by repeatedly + unfolding a divergent guard. A user case provides its actual response as + the witness needed for the first visible raw transition. *) +Lemma ThreadSegment_can_step t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> exists l u, trans l t u. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - exists (obs (inl Yield) tt), (k tt); apply trans_vis. + - destruct IH as [l [u Hstep]]; exists l, u; now apply trans_guard. + - exists (obs (inr (inr e) : CEff) result), (k result); apply trans_vis. + - destruct IH as [l [v Hstep]]; exists l, v; rewrite Etu; exact Hstep. +Qed. + +Lemma ThreadSegment_divergent_absurd t sigma xs residual sigma' : + is_stuck t -> ~ ThreadSegment t sigma xs residual sigma'. +Proof. intros Hdiv Hseg; apply Hdiv; eapply ThreadSegment_can_step; exact Hseg. Qed. + +Lemma ThreadSegment_stuck_absurd sigma xs residual sigma' : + ~ ThreadSegment (stuck : thread sE) sigma xs residual sigma'. +Proof. apply ThreadSegment_divergent_absurd, stuck_is_stuck. Qed. + +Lemma ThreadSegment_spin_absurd sigma xs residual sigma' : + ~ ThreadSegment (spin : thread sE) sigma xs residual sigma'. +Proof. + intro H; eapply ThreadSegment_br_absurd_equ; [exact H|]. + apply unfold_spin. +Qed. + +Lemma ThreadSegment_fault_absurd (e : sE) (k : encode e -> thread sE) + sigma xs residual sigma' : + runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)) -> + ~ ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma'. +Proof. + intros Ef Hseg. + destruct (ThreadSegment_user_inv e k sigma xs residual sigma' Hseg) + as [result [sigma1 [before [after [_ [Eh _]]]]]]. + apply (emit_list_ret_not_stuck before (result,sigma1)). + transitivity (runStateT (sh e) sigma); [symmetry; exact Eh|exact Ef]. +Qed. + +Lemma ThreadSegment_deterministic t sigma xs u sigma1 ys v sigma2 : + ThreadSegment t sigma xs u sigma1 -> + ThreadSegment t sigma ys v sigma2 -> + xs = ys /\ sigma1 = sigma2 /\ u ≅ v. +Proof. + intros H1; revert ys v sigma2. + induction H1 as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros ys v sigma2 H2. + - destruct (ThreadSegment_yield_inv k sigma ys v sigma2 H2) + as [Ex [Es Ek]]. + split; [symmetry; exact Ex|]; split; [symmetry; exact Es|exact Ek]. + - apply IH; now apply ThreadSegment_guard_inv in H2. + - destruct (ThreadSegment_user_inv e k sigma ys v sigma2 H2) + as [r [sigma0 [before0 [after0 [Ey [Eh0 Htail]]]]]]. + destruct (handler_response_unique e sigma result sigma1 before + r sigma0 before0 Eh Eh0) as [Eb [Er Es]]. + subst before0; subst r; subst sigma0. + destruct (IH after0 v sigma2 Htail) as [Ea [Es Er]]. + split; [subst ys; now rewrite Ea|]; split; assumption. + - assert (H2u : ThreadSegment u sigma ys v sigma2). + { eapply ThreadSegment_equ_input; [exact Etu|exact H2]. } + destruct (IH ys v sigma2 H2u) as [Ex [Es Er]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; [symmetry; exact Eout|exact Er]. +Qed. + +#[global] Instance guard_equ_Equivalence : Equivalence guard_equ. +Proof. + split. + - intro t; apply guard_equ_equ; reflexivity. + - intros t u; apply guard_equ_sym. + - intros t u v; apply guard_equ_trans. +Qed. + +Lemma guard_equ_sbisim t u : guard_equ t u -> t ~ u. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - rewrite E; reflexivity. + - rewrite sb_guard; exact IH. + - rewrite sb_guard; exact IH. + - symmetry; exact IH. + - transitivity u; assumption. +Qed. + +(** This stronger same-residual transport follows from the output-equ rule. + Symmetry in the finite guard closure is handled by proving both directions + together, rather than assuming a reverse simulation. *) +Lemma guard_equ_segment_iff t u : guard_equ t u -> + forall sigma xs residual sigma', + ThreadSegment t sigma xs residual sigma' <-> + ThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; + intros sigma xs residual sigma'. + - split; intro Hseg. + + eapply ThreadSegment_equ_input; [exact E|exact Hseg]. + + eapply ThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. + - rewrite ThreadSegment_guard_iff; apply IH. + - rewrite ThreadSegment_guard_iff; apply IH. + - symmetry; apply IH. + - transitivity (ThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. +Qed. + +Lemma guard_equ_segment t u sigma xs t' sigma' : + guard_equ t u -> ThreadSegment t sigma xs t' sigma' -> + exists u', ThreadSegment u sigma xs u' sigma' /\ guard_equ t' u'. +Proof. + intros E Hseg; exists t'; split. + - apply (proj1 (guard_equ_segment_iff t u E sigma xs t' sigma')); exact Hseg. + - apply guard_equ_equ; reflexivity. +Qed. + +Lemma guard_equ_br_yield_absurd n (k : Fin.t (S n) -> thread sE) + (ky : unit -> thread sE) : ~ guard_equ (Br n k) (Vis (inl Yield) ky). +Proof. + intro E; apply guard_equ_sbisim in E. + eapply (@sbisim_vis_br_inv CEff _ unit n (inl Yield) ky k); symmetry; exact E. +Qed. + +(** Equivalence of pools is used only for genuine raw [equ]. Guard removal + below is deliberately restricted to the focused slot. *) +Lemma segment_nd_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) + t u focus sigma : + t ≅ u -> + interp_nd (S n) (ts @ i := t) focus sigma ~ + interp_nd (S n) (ts @ i := u) focus sigma. +Proof. + intro E. + pose proof (interp_nd_equ (S n) (ts @ i := t) (ts @ i := u) + focus sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. + rewrite Ep; reflexivity. +Qed. + +Lemma segment_rr_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) + t u focus m sigma : + t ≅ u -> + interp_schedule_rr sh (S n) (ts @ i := t) focus m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := u) focus m sigma. +Proof. + intro E. + pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := t) (ts @ i := u) + focus m sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. + rewrite Ep; reflexivity. +Qed. + +Lemma segment_nd_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : + interp_nd (S n) (ts @ i := Guard t) (Some i) sigma ~ + interp_nd (S n) (ts @ i := t) (Some i) sigma. +Proof. + erewrite interp_nd_guard by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_rr_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t m sigma : + interp_schedule_rr sh (S n) (ts @ i := Guard t) (Some i) m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma. +Proof. + erewrite interp_schedule_rr_guard by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma guard_equ_focused_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) t u sigma : + guard_equ t u -> + interp_nd (S n) (ts @ i := t) (Some i) sigma ~ + interp_nd (S n) (ts @ i := u) (Some i) sigma. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_nd_replace_equ; exact E. + - etransitivity; [apply segment_nd_focused_guard|exact IH]. + - etransitivity; [exact IH|symmetry; apply segment_nd_focused_guard]. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. +Qed. + +Lemma guard_equ_focused_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) t u m sigma : + guard_equ t u -> + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := u) (Some i) m sigma. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_rr_replace_equ; exact E. + - etransitivity; [apply segment_rr_focused_guard|exact IH]. + - etransitivity; [exact IH|symmetry; apply segment_rr_focused_guard]. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. +Qed. + +Lemma segment_nd_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) sigma : + interp_nd (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) sigma ~ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + interp_nd (S n) (ts @ i := k x) (Some i) sigma'). +Proof. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_rr_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + interp_schedule_rr sh (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ~ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). +Proof. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_interp_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) + t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + interp_nd (S n) (ts @ i := t) (Some i) sigma ~ + emit_list xs (interp_nd (S n) (ts @ i := residual) None sigma'). +Proof. + intro H; revert n ts i. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. + - cbn [emit_list]. + erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_nd_focused_guard|apply IH]. + - etransitivity; [apply segment_nd_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => interp_nd (S n) (ts @ i := k x) (Some i) sigma0). + + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. +Qed. + +Lemma segment_interp_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ + emit_list xs (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'). +Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - cbn [emit_list]. + erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_rr_focused_guard|apply IH]. + - etransitivity; [apply segment_rr_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0). + + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. +Qed. + +(** Exact equations retain the finite administrative guard path. In particular + RR selection is not a visible branch after refinement: its three guards + must not be used as a guarded [sbisim] coinduction hypothesis. These laws + expose them for induction on an actual [trans_] derivation instead. *) +Lemma segment_rr_guard_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma : + observe (ts $ i) = GuardF t -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +Lemma segment_rr_yield_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + k m sigma : + observe (ts $ i) = VisF (inl Yield) k -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr sh (S n) (ts @ i := k tt) None m sigma). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +Lemma segment_rr_user_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + Guard (Guard (Guard + (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')))). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). + rewrite interp_erase_user, interp_state_vis. + apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] r <-; apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node, interp_state_tau. +Qed. + +Lemma segment_rr_select_exact n (ts : pool sE (S n)) m sigma : + interp_schedule_rr sh (S n) ts None m sigma ≅ + Guard (Guard (Guard + (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma))). +Proof. + unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, schedule_no_focus_nonempty. + rewrite interp_erase_yield. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + rewrite (unfold_run_round_robin + (Br n (fun i => schedule (S n) ts (Some i))) m). + change (interp_state sh + (interp_yield (interp_spawn + (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) sigma ≅ + Guard (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma)). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +(** A stronger certificate for the initialized workers: primitive handlers + return by raw equivalence. This retains finite administrative guards for + round-robin divergence matching; source validity still uses ThreadSegment. *) +Inductive ExactThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := +| exact_segment_yield (k : unit -> thread sE) sigma : + ExactThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma +| exact_segment_guard t sigma logs t' sigma' : + ExactThreadSegment t sigma logs t' sigma' -> + ExactThreadSegment (Guard t) sigma logs t' sigma' +| exact_segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 + before after t' sigma' : + runStateT (sh e) sigma ≅ emit_list before (Ret (result,sigma1)) -> + ExactThreadSegment (k result) sigma1 after t' sigma' -> + ExactThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) + sigma (before ++ after) t' sigma' +| exact_segment_equ t u sigma logs u' t' sigma' : + t ≅ u -> ExactThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> + ExactThreadSegment t sigma logs t' sigma'. + +Lemma ExactThreadSegment_segment t sigma xs residual sigma' : + ExactThreadSegment t sigma xs residual sigma' -> + ThreadSegment t sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - apply segment_yield. + - apply segment_guard; exact IH. + - eapply segment_user; [|exact IH]. + eapply equ_clos_sbisim_goal; [exact Eh|reflexivity|reflexivity]. + - eapply segment_equ; eassumption. +Qed. + +Lemma ExactThreadSegment_equ_input t u sigma xs residual sigma' : + t ≅ u -> ExactThreadSegment t sigma xs residual sigma' -> + ExactThreadSegment u sigma xs residual sigma'. +Proof. + intros E H; eapply exact_segment_equ; [symmetry; exact E|exact H|reflexivity]. +Qed. + +Lemma ExactThreadSegment_equ_output t sigma xs residual residual' sigma' : + ExactThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> + ExactThreadSegment t sigma xs residual' sigma'. +Proof. intros H E; eapply exact_segment_equ; [reflexivity|exact H|exact E]. Qed. + +Lemma ExactThreadSegment_guard_inv_equ t sigma xs residual sigma' : + ExactThreadSegment t sigma xs residual sigma' -> + forall u, t ≅ Guard u -> ExactThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t v sigma xs v' residual sigma' Etv H IH Eout]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E; apply equ_guard_invE in E. + eapply ExactThreadSegment_equ_input; [exact E|exact H]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E. + eapply ExactThreadSegment_equ_output; [|exact Eout]. + apply IH; transitivity t; [symmetry; exact Etv|exact E]. +Qed. + +Lemma ExactThreadSegment_guard_inv t sigma xs residual sigma' : + ExactThreadSegment (Guard t) sigma xs residual sigma' -> + ExactThreadSegment t sigma xs residual sigma'. +Proof. intro H; eapply ExactThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ExactThreadSegment_guard_iff t sigma xs residual sigma' : + ExactThreadSegment (Guard t) sigma xs residual sigma' <-> + ExactThreadSegment t sigma xs residual sigma'. +Proof. split; [apply ExactThreadSegment_guard_inv|apply exact_segment_guard]. Qed. + +Lemma guard_equ_exact_segment_iff t u : guard_equ t u -> + forall sigma xs residual sigma', + ExactThreadSegment t sigma xs residual sigma' <-> + ExactThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; + intros sigma xs residual sigma'. + - split; intro Hseg. + + eapply ExactThreadSegment_equ_input; [exact E|exact Hseg]. + + eapply ExactThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. + - rewrite ExactThreadSegment_guard_iff; apply IH. + - rewrite ExactThreadSegment_guard_iff; apply IH. + - symmetry; apply IH. + - transitivity (ExactThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. +Qed. + +(** Raw source equations retain the outer option; in particular a successful + remote publication must return through its caller before reaching Yield. *) +Lemma source_raw_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) : + (denote_flow (CBind p next) >>= K) ≅ + (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. +Qed. + +Lemma source_raw_ret {A} (x : A) (K : option A -> thread sE) : + (denote_flow (CRet x) >>= K) ≅ K (Some x). +Proof. cbn [denote_flow]; apply bind_ret_l. Qed. + +Lemma source_raw_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) : + (denote_flow (CUntilNone body) >>= K) ≅ + (denote_flow body >>= until_tail body K). +Proof. + set (loop_body := fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr (None : option unit)) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end). + change ((ICtree.iter loop_body tt >>= K) ≅ + (denote_flow body >>= fun flow => + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) + end)). + transitivity ((loop_body tt >>= fun lr => + match lr with + | inl j => Guard (ICtree.iter loop_body j) + | inr result => Ret result + end) >>= K). + - apply equ_clo_bind with (S := eq). + + apply unfold_iter. + + intros r r' <-; reflexivity. + - etransitivity; [apply bind_bind|]. + unfold loop_body at 1. + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros [[x|]|]; cbn. + + etransitivity; [apply bind_ret_l|]. apply bind_guard. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. +Qed. + +Lemma source_owner_read base : + owner_residual base ORead ≅ + (denote_flow (detach_remote base) >>= owner_after_detach base). +Proof. + unfold owner_residual, denote. + rewrite source_raw_until. + change ((denote_flow (owner_round base) >>= owner_next base) ≅ + (denote_flow (detach_remote base) >>= owner_after_detach base)). + unfold owner_round; rewrite source_raw_bind. + transitivity (denote_flow (collect_remote base) >>= owner_after_collect base). + - apply equ_clo_bind_eq; intros [[]|]; reflexivity. + - unfold collect_remote; rewrite source_raw_bind. + apply equ_clo_bind_eq; intros [[]|]; reflexivity. +Qed. + +Local Definition source_segment_to (t : thread sE) (sigma : SSig) + (logs : list SObs) (target : thread sE) (sigma' : SSig) : Prop := + exists residual, ExactThreadSegment t sigma logs residual sigma' /\ + guard_equ residual target. + +Local Lemma source_to_equ t u sigma logs target sigma' : + t ≅ u -> source_segment_to u sigma logs target sigma' -> + source_segment_to t sigma logs target sigma'. +Proof. + intros Htu (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ; [exact Htu|exact Hseg|reflexivity]. +Qed. + +Local Lemma source_to_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) sigma logs target sigma' : + source_segment_to (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end) + sigma logs target sigma' -> + source_segment_to (denote_flow (CBind p next) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply source_to_equ; [apply source_raw_bind|exact H]. +Qed. + +Local Lemma source_to_ret {A} (x : A) (K : option A -> thread sE) + sigma logs target sigma' : + source_segment_to (K (Some x)) sigma logs target sigma' -> + source_segment_to (denote_flow (CRet x) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply source_to_equ; [apply source_raw_ret|exact H]. +Qed. + +Local Lemma source_to_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) sigma logs target sigma' : + source_segment_to (denote_flow body >>= until_tail body K) + sigma logs target sigma' -> + source_segment_to (denote_flow (CUntilNone body) >>= K) + sigma logs target sigma'. +Proof. + intro H; eapply source_to_equ; [apply source_raw_until|exact H]. +Qed. + +Local Lemma source_to_read a v (K : option nat -> thread sE) + h c logs target sigma' : + h a = Some v -> + source_segment_to (K (Some v)) (h,c) logs target sigma' -> + source_segment_to (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (SRd a))) (fun v => K (Some v))). + - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. + - change (ExactThreadSegment (Vis (inr (inr (SRd a))) (fun v => K (Some v))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_rd_some a h c v Hr); reflexivity. + - reflexivity. +Qed. + +Local Lemma source_upd_present h a v x : h x <> None -> upd h a v x <> None. +Proof. + intro H; unfold upd; destruct (Nat.eqb x a); [discriminate|exact H]. +Qed. + +Local Lemma source_to_write a v (K : option unit -> thread sE) + h c logs target sigma' : + h a <> None -> + source_segment_to (K (Some tt)) (upd h a v,c) logs target sigma' -> + source_segment_to (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. +Proof. + intros Hp (residual & Hseg & Htail). + destruct (h a) as [w|] eqn:Hw; [|contradiction]. + exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). + - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + - change (ExactThreadSegment (Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (sh_wr_some a h c v w Hw); reflexivity. + - reflexivity. +Qed. + +Local Lemma source_to_emit tag block (K : option unit -> thread sE) + h c logs target sigma' : + source_segment_to (K (Some tt)) (h,S c) logs target sigma' -> + source_segment_to (denote_flow (CEmit tag block) >>= K) (h,c) + (SPop tag block c :: logs) target sigma'. +Proof. + intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (SEmit tag block))) (fun _ => K (Some tt))). + - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + - change (ExactThreadSegment + (Vis (inr (inr (SEmit tag block))) (fun _ => K (Some tt))) + (h,c) ([SPop tag block c] ++ logs) residual sigma'). + eapply exact_segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite sh_emit; reflexivity. + - reflexivity. +Qed. + +Local Lemma source_to_cas_success a expected desired + (K : option bool -> thread sE) h c logs target sigma' : + h a = Some expected -> + source_segment_to (K (Some true)) (upd h a desired,c) logs target sigma' -> + source_segment_to (denote_flow (CCAS a expected desired) >>= K) + (h,c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). + - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intro b; rewrite !bind_ret_l; reflexivity. + - change (ExactThreadSegment + (Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_cas_success a expected desired h c Hr); reflexivity. + - reflexivity. +Qed. + +Local Lemma source_to_cas_failure a expected desired current + (K : option bool -> thread sE) h c logs target sigma' : + h a = Some current -> current <> expected -> + source_segment_to (K (Some false)) (h,c) logs target sigma' -> + source_segment_to (denote_flow (CCAS a expected desired) >>= K) + (h,c) logs target sigma'. +Proof. + intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). + - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intro b; rewrite !bind_ret_l; reflexivity. + - change (ExactThreadSegment + (Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_cas_failure a expected desired current h c Hr Hne); + reflexivity. + - reflexivity. +Qed. + +Local Lemma source_to_yield (K : option unit -> thread sE) sigma target : + guard_equ (K (Some tt)) target -> + source_segment_to (denote_flow CYield >>= K) sigma [] target sigma. +Proof. + intro Htail; exists (K (Some tt)); split; [|exact Htail]. + eapply exact_segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). + - cbn [denote_flow]; unfold source_yield; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + - apply exact_segment_yield. + - reflexivity. +Qed. + +(** Finite syntax normalization is used only for raw equ and leading guards. + It never changes a scheduler focus or invokes pool sbisim congruence. *) +Ltac allocator_raw_equ := + cbn beta iota zeta; + first [reflexivity | + lazymatch goal with + | |- (denote_flow (CBind _ _) >>= _) ≅ _ => + etransitivity; [apply source_raw_bind|]; allocator_raw_equ + | |- (denote_flow (CRet _) >>= _) ≅ _ => + etransitivity; [apply source_raw_ret|]; allocator_raw_equ + | |- ((?t >>= ?k) >>= ?j) ≅ _ => + etransitivity; [apply bind_bind|]; allocator_raw_equ + | |- (Ret _ >>= _) ≅ _ => + etransitivity; [apply bind_ret_l|]; allocator_raw_equ + | |- _ ≅ (denote_flow (CBind _ _) >>= _) => symmetry; allocator_raw_equ + | |- _ ≅ (denote_flow (CRet _) >>= _) => symmetry; allocator_raw_equ + | |- _ ≅ ((_ >>= _) >>= _) => symmetry; allocator_raw_equ + | |- _ ≅ (Ret _ >>= _) => symmetry; allocator_raw_equ + | |- Guard _ ≅ Guard _ => apply guard_equ_node; allocator_raw_equ + end]. + +#[local] Instance source_guard_equ_proper : + Proper (equ eq ==> equ eq ==> iff) guard_equ. +Proof. + intros t t' Ht u u' Hu; split; intro H. + - eapply guard_equ_trans; [apply guard_equ_equ; symmetry; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; exact Hu]. + - eapply guard_equ_trans; [apply guard_equ_equ; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; symmetry; exact Hu]. +Qed. + +Ltac allocator_residual_raw := + unfold remote_residual, owner_residual, remote_free, remote_client, + detach_remote, remote_link_tail, remote_cas_tail, detach_cas_tail, + owner_offer_tail, denote, client_next, remote_after_free, + owner_next, owner_after_collect, owner_after_detach; + allocator_raw_equ. + +Ltac allocator_residual_alignment := + cbn beta iota zeta; + first [solve [apply guard_equ_equ; reflexivity] | + lazymatch goal with + | |- guard_equ (denote_flow (CRet _) >>= _) _ => + eapply guard_equ_trans; [apply guard_equ_equ; apply source_raw_ret|]; + allocator_residual_alignment + | |- guard_equ (denote_flow (CBind _ _) >>= _) _ => + eapply guard_equ_trans; [apply guard_equ_equ; apply source_raw_bind|]; + allocator_residual_alignment + | |- guard_equ (Ret _ >>= _) _ => + eapply guard_equ_trans; [apply guard_equ_equ; apply bind_ret_l|]; + allocator_residual_alignment + | |- guard_equ (Guard _) _ => apply guard_equ_left; allocator_residual_alignment + end | + solve [apply guard_equ_equ; allocator_residual_raw] | + rewrite source_owner_read; apply guard_equ_equ; allocator_residual_raw]. + +Ltac allocator_present := + first [congruence | apply source_upd_present; allocator_present]. + +Ltac allocator_segment_steps := + repeat first + [ progress (cbn beta iota zeta) + | match goal with + | H : Nat.eqb ?x ?y = ?b |- context [Nat.eqb ?x ?y] => rewrite H + end + | progress (rewrite Nat.eqb_refl) + | lazymatch goal with + | |- source_segment_to (denote_flow (CBind _ _) >>= _) _ _ _ _ => + apply source_to_bind + | |- source_segment_to (denote_flow (CRet _) >>= _) _ _ _ _ => + apply source_to_ret + | |- source_segment_to (denote_flow (CUntilNone _) >>= _) _ _ _ _ => + apply source_to_until + | |- source_segment_to (denote_flow (CRead _) >>= _) _ _ _ _ => + eapply source_to_read; [eassumption|] + | |- source_segment_to (denote_flow (CWrite _ _) >>= _) _ _ _ _ => + eapply source_to_write; [allocator_present|] + | |- source_segment_to (denote_flow (CEmit _ _) >>= _) _ _ _ _ => + apply source_to_emit + | |- source_segment_to (denote_flow (CCAS _ _ _) >>= _) _ _ _ _ => + first [eapply source_to_cas_success; [congruence|] | + eapply source_to_cas_failure; + [eassumption|apply Nat.eqb_neq; eassumption|]] + end + | progress ( + lazymatch goal with + | |- source_segment_to ?src ?sigma ?logs ?target ?sigma' => + let src' := eval cbv beta iota zeta delta + [remote_residual owner_residual denote remote_client remote_free + remote_attempt remote_link_tail remote_cas_tail client_round + owner_round collect_remote detach_remote detach_attempt + detach_cas_tail reclaim_step owner_offer_tail offer_block + until_tail client_next remote_after_free owner_next + owner_after_collect owner_after_detach] in src in + change (source_segment_to src' sigma logs target sigma') + end) ]; + apply source_to_yield; allocator_residual_alignment. + +(** The checked model branches provide precisely the successful heap reads. + Repeated checked writes remain allocated even if addresses coincide; no + heap extensionality, freshness assumption, or unchecked CAS is used here. *) +Local Opaque denote_flow ICtree.iter ICtree.bind. + +Lemma turn_source_exact_segment base who s t event : + turn base who s = Some (t,event) -> + exists residual, + ExactThreadSegment ((allocator_pool base s) $ slot_of_actor who) + (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + destruct s as [h c op r0 r1]; destruct who; + [destruct op|destruct r0|destruct r1]; intro Hturn; + cbn [turn aheap acount owner_state remote0_state remote1_state] in Hturn. + all: repeat match type of Hturn with + | context [match ?v with Some _ => _ | None => _ end] => + let Hv := fresh "Hcell" in destruct v eqn:Hv; try discriminate + | context [if ?b then _ else _] => + let Hb := fresh "Htest" in destruct b eqn:Hb; try discriminate + end. + all: inversion Hturn; subst t event; clear Hturn. + all: repeat match goal with + | H : Nat.eqb ?x ?y = true |- _ => + apply Nat.eqb_eq in H; subst + end. + all: cbn [allocator_pool slot_of_actor Vector.nth aheap acount + owner_state remote0_state remote1_state turn_observations]. + all: lazymatch goal with + | |- exists residual, ExactThreadSegment ?src ?sigma ?logs residual ?sigma' /\ + guard_equ residual ?target => + change (source_segment_to src sigma logs target sigma') + end. + all: allocator_segment_steps. +Qed. + +Local Transparent denote_flow ICtree.iter ICtree.bind. + +Lemma turn_source_segment_checked base who s t event : + turn base who s = Some (t,event) -> + exists residual, + ThreadSegment ((allocator_pool base s) $ slot_of_actor who) + (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + intro Hturn; destruct (turn_source_exact_segment base who s t event Hturn) + as (residual & Hseg & Htail). + exists residual; split; [now apply ExactThreadSegment_segment|exact Htail]. +Qed. + +Lemma turn_source_segment base capacity who s t event : + allocator_inv base capacity s -> turn base who s = Some (t,event) -> + exists residual, + ThreadSegment ((allocator_pool base s) $ slot_of_actor who) + (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. intros _; apply turn_source_segment_checked. Qed. + +Lemma turn_other_slots base who s t event : + turn base who s = Some (t,event) -> + forall j, j <> slot_of_actor who -> + ((allocator_pool base s) $ j) ≅ ((allocator_pool base t) $ j). +Proof. + intro Hturn; intro j. + rewrite <- (slot_of_actor_of_slot j). + destruct (actor_of_slot j) eqn:Hactor. + all: destruct s as [h c op r0 r1]; destruct who; + cbn [turn aheap acount owner_state remote0_state remote1_state] in Hturn; + intro Hne; try contradiction. + all: repeat match type of Hturn with + | context [match ?v with Some _ => _ | None => _ end] => + let Hv := fresh "Hcell" in destruct v eqn:Hv; try discriminate + | context [match ?v with + ORead => _ | OCAS _ => _ | ODrain => _ | OOffer _ => _ end] => destruct v + | context [match ?v with + RPoll => _ | RRead _ => _ | RLink _ _ => _ | RCAS _ _ => _ end] => destruct v + | context [if ?b then _ else _] => destruct b + end. + all: inversion Hturn; subst t event; reflexivity. +Qed. + +Lemma allocator_pool_state_equiv base s t : + state_equiv s t -> pool_equ (allocator_pool base s) (allocator_pool base t). +Proof. + intros [_ [_ [Ho [H0 H1]]]]. + unfold allocator_pool; rewrite Ho, H0, H1; apply pool_equ_refl. +Qed. + +(** The concrete segment is first built with the actual heap function. Only + the model transition and ownership invariant are transported pointwise. *) +Theorem selected_turn_source_segment base capacity (ts : pool sE 3) + sigma s who t event : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + turn base who s = Some (t,event) -> + exists residual sigma', + ThreadSegment (ts $ slot_of_actor who) sigma + (turn_observations event) residual sigma' /\ + state_agrees sigma' t /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + intros Hpool Hagree Hinv Hturn. + pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. + pose proof (allocator_inv_state_equiv base capacity s + (source_reheap sigma s) Hreheap Hinv) as Hactualinv. + destruct (turn_respects_heq_some base who s (source_reheap sigma s) + t event Hreheap Hturn) as (actual & Hactual & Hnext). + destruct (turn_source_segment base capacity who + (source_reheap sigma s) actual event Hactualinv Hactual) + as (canonical & Hseg & Htail). + change (ThreadSegment ((allocator_pool base s) $ slot_of_actor who) + (fst sigma,snd sigma) (turn_observations event) canonical + (aheap actual,acount actual)) in Hseg. + destruct sigma as [h c]; cbn [fst snd] in Hseg. + destruct (guard_equ_segment + ((allocator_pool base s) $ slot_of_actor who) + (ts $ slot_of_actor who) (h,c) (turn_observations event) + canonical (aheap actual,acount actual) + (guard_equ_sym _ _ (Hpool (slot_of_actor who))) Hseg) + as (residual & Hraw & Hrawtail). + exists residual, (aheap actual,acount actual); split; [exact Hraw|]; split. + - destruct Hnext as [Hheap [Hcount _]]. + split; cbn; [now apply heq_sym|symmetry; exact Hcount]. + - eapply guard_equ_trans; [apply guard_equ_sym; exact Hrawtail|]. + eapply guard_equ_trans; [exact Htail|]. + apply guard_equ_equ; symmetry. + apply (allocator_pool_state_equiv base t actual Hnext). +Qed. + +Theorem selected_source_segment_exact base capacity (ts : pool sE 3) + sigma s who t event logs residual sigma' : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + turn base who s = Some (t,event) -> + ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> + logs = turn_observations event /\ state_agrees sigma' t /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + intros Hpool Hagree Hinv Hturn Hseg. + destruct (selected_turn_source_segment base capacity ts sigma s who t event + Hpool Hagree Hinv Hturn) as (other & sigma2 & Hother & Hstate & Htail). + destruct (ThreadSegment_deterministic (ts $ slot_of_actor who) sigma + logs residual sigma' (turn_observations event) other sigma2 Hseg Hother) + as [Hlogs [Hsigma Hresidual]]. + subst sigma2; split; [exact Hlogs|]; split; [exact Hstate|]. + eapply guard_equ_trans; [apply guard_equ_equ; exact Hresidual|exact Htail]. +Qed. + +Theorem selected_source_segment_turn base capacity (ts : pool sE 3) + sigma s who logs residual sigma' : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> + exists t event, + turn base who s = Some (t,event) /\ + logs = turn_observations event /\ state_agrees sigma' t /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + intros Hpool Hagree Hinv Hseg. + destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). + exists t, event; split; [exact Hturn|]. + eapply selected_source_segment_exact; eauto. +Qed. + +Lemma selected_source_pool_update base (ts : pool sE 3) s who t event residual : + pool_guard_equ ts (allocator_pool base s) -> + turn base who s = Some (t,event) -> + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) -> + pool_guard_equ (ts @ slot_of_actor who := residual) (allocator_pool base t). +Proof. + intros Hpool Hturn Htail j. + destruct (Fin.eq_dec j (slot_of_actor who)) as [->|Hne]. + - rewrite Vector.nth_replace_eq; exact Htail. + - rewrite Vector.nth_replace_neq by congruence. + eapply guard_equ_trans; [apply Hpool|]. + apply guard_equ_equ; exact (turn_other_slots base who s t event Hturn j Hne). +Qed. + +(** This is a finite first-yield certificate, not a progress premise about + model runs. Its constructors cannot pass a yield or terminate in a + return, fork, branch, missing-cell fault, or divergent prefix. *) +Theorem initialized_worker_next_yield base capacity (ts : pool sE 3) + sigma s who : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + exists logs residual sigma', + ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma'. +Proof. + intros Hpool Hagree Hinv. + destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). + destruct (selected_turn_source_segment base capacity ts sigma s who t event + Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & _). + exists (turn_observations event), residual, sigma'; exact Hseg. +Qed. + +Theorem initialized_worker_no_terminal_prefix base capacity (ts : pool sE 3) + sigma s who : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + not (guard_equ (ts $ slot_of_actor who) (Ret tt)) /\ + (forall k : bool -> thread sE, + ~ guard_equ (ts $ slot_of_actor who) (Vis (inr (inl Fork)) k)) /\ + (forall n (k : Fin.t (S n) -> thread sE), + ~ guard_equ (ts $ slot_of_actor who) (Br n k)) /\ + not (guard_equ (ts $ slot_of_actor who) (stuck : thread sE)). +Proof. + intros Hpool Hagree Hinv. + destruct (initialized_worker_next_yield base capacity ts sigma s who + Hpool Hagree Hinv) as (logs & residual & sigma' & Hseg). + repeat split. + - intro Hbad. + destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_ret_absurd sigma logs u sigma' Hfalse). + - intros k Hbad. + destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_fork_absurd k sigma logs u sigma' Hfalse). + - intros n k Hbad. + destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_br_absurd n k sigma logs u sigma' Hfalse). + - intro Hbad. + destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_stuck_absurd sigma logs u sigma' Hfalse). +Qed. + +Theorem initialized_worker_no_fault_or_divergence base capacity (ts : pool sE 3) + sigma s who : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + not (is_stuck (ts $ slot_of_actor who)) /\ + not (guard_equ (ts $ slot_of_actor who) (spin : thread sE)) /\ + (forall (e : sE) (k : encode e -> thread sE), + guard_equ (ts $ slot_of_actor who) ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) -> + ~ (runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)))). +Proof. + intros Hpool Hagree Hinv. + destruct (initialized_worker_next_yield base capacity ts sigma s who + Hpool Hagree Hinv) as (logs & residual & sigma' & Hseg). + split. + - intro Hstuck; apply Hstuck; eapply ThreadSegment_can_step; exact Hseg. + - split. + + intro Hbad. + destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_spin_absurd sigma logs u sigma' Hfalse). + + intros e k Hhead Hfault. + destruct (guard_equ_segment _ _ _ _ _ _ Hhead Hseg) as (u & Hfalse & _). + exact (ThreadSegment_fault_absurd e k sigma logs u sigma' Hfault Hfalse). +Qed. + +Local Lemma source_replace_current n (ts : pool sE n) (i : Fin.t n) : + pool_equ (ts @ i := (ts $ i)) ts. +Proof. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + - rewrite Vector.nth_replace_eq; reflexivity. + - rewrite Vector.nth_replace_neq by congruence; reflexivity. +Qed. + +Local Lemma source_replace_turn base who s t event residual : + turn base who s = Some (t,event) -> + pool_equ (allocator_pool base s @ slot_of_actor who := residual) + (allocator_pool base t @ slot_of_actor who := residual). +Proof. + intros Hturn j; destruct (Fin.eq_dec j (slot_of_actor who)) as [->|Hne]. + - rewrite !Vector.nth_replace_eq; reflexivity. + - rewrite !Vector.nth_replace_neq by congruence. + exact (turn_other_slots base who s t event Hturn j Hne). +Qed. + +Local Lemma source_equ_sbisim {X} (t u : ictreeW SObs X) : t ≅ u -> t ~ u. +Proof. intro E; rewrite E; reflexivity. Qed. + +(** Each equation encompasses every branch of the phase table. The result + retains the actual residual at None focus: guard_equ is not silently + promoted to an unfocused-pool congruence. *) +Theorem turn_interp_nd base capacity who s t event : + allocator_inv base capacity s -> turn base who s = Some (t,event) -> + exists residual, + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ + interp_nd 3 (allocator_pool base s) (Some (slot_of_actor who)) + (aheap s,acount s) ~ + emit_list (turn_observations event) + (interp_nd 3 (allocator_pool base t @ slot_of_actor who := residual) + None (aheap t,acount t)). +Proof. + intros Hinv Hturn. + destruct (turn_source_segment base capacity who s t event Hinv Hturn) + as (residual & Hseg & Htail). + exists residual; split; [exact Htail|]. + etransitivity. + - symmetry; apply source_equ_sbisim, interp_nd_equ, source_replace_current. + - etransitivity. + + exact (segment_interp_nd 2 (allocator_pool base s) (slot_of_actor who) + ((allocator_pool base s) $ slot_of_actor who) (aheap s,acount s) + (turn_observations event) residual (aheap t,acount t) Hseg). + + apply emit_list_sbisim, source_equ_sbisim, interp_nd_equ. + exact (source_replace_turn base who s t event residual Hturn). +Qed. + +Theorem turn_interp_rr base capacity who s t event cursor : + allocator_inv base capacity s -> turn base who s = Some (t,event) -> + exists residual, + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ + interp_schedule_rr sh 3 (allocator_pool base s) (Some (slot_of_actor who)) + cursor (aheap s,acount s) ~ + emit_list (turn_observations event) + (interp_schedule_rr sh 3 + (allocator_pool base t @ slot_of_actor who := residual) + None cursor (aheap t,acount t)). +Proof. + intros Hinv Hturn. + destruct (turn_source_segment base capacity who s t event Hinv Hturn) + as (residual & Hseg & Htail). + exists residual; split; [exact Htail|]. + etransitivity. + - symmetry; apply source_equ_sbisim, interp_schedule_rr_equ, + source_replace_current. + - etransitivity. + + exact (segment_interp_rr 2 (allocator_pool base s) (slot_of_actor who) + ((allocator_pool base s) $ slot_of_actor who) cursor (aheap s,acount s) + (turn_observations event) residual (aheap t,acount t) Hseg). + + apply emit_list_sbisim, source_equ_sbisim, interp_schedule_rr_equ. + exact (source_replace_turn base who s t event residual Hturn). +Qed. + +Theorem selected_turn_interp_nd base capacity (ts : pool sE 3) + sigma s who t event : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + turn base who s = Some (t,event) -> + exists residual sigma', + state_agrees sigma' t /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ + interp_nd 3 ts (Some (slot_of_actor who)) sigma ~ + emit_list (turn_observations event) + (interp_nd 3 (ts @ slot_of_actor who := residual) None sigma'). +Proof. + intros Hpool Hagree Hinv Hturn. + destruct (selected_turn_source_segment base capacity ts sigma s who t event + Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). + exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. + etransitivity. + - symmetry; apply source_equ_sbisim, interp_nd_equ, source_replace_current. + - exact (segment_interp_nd 2 ts (slot_of_actor who) + (ts $ slot_of_actor who) sigma (turn_observations event) residual sigma' Hseg). +Qed. + +Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) + sigma s who t event cursor : + pool_guard_equ ts (allocator_pool base s) -> + state_agrees sigma s -> allocator_inv base capacity s -> + turn base who s = Some (t,event) -> + exists residual sigma', + state_agrees sigma' t /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ + interp_schedule_rr sh 3 ts (Some (slot_of_actor who)) cursor sigma ~ + emit_list (turn_observations event) + (interp_schedule_rr sh 3 (ts @ slot_of_actor who := residual) None cursor sigma'). +Proof. + intros Hpool Hagree Hinv Hturn. + destruct (selected_turn_source_segment base capacity ts sigma s who t event + Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). + exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. + etransitivity. + - symmetry; apply source_equ_sbisim, interp_schedule_rr_equ, + source_replace_current. + - exact (segment_interp_rr 2 ts (slot_of_actor who) + (ts $ slot_of_actor who) cursor sigma (turn_observations event) residual sigma' Hseg). +Qed. + +From Coinduction Require Import coinduction rel tactics. +Local Open Scope nat_scope. + +Fixpoint rr_guards {X} (n : nat) (t : ictreeW SObs X) : ictreeW SObs X := + match n with 0 => t | S n => Guard (rr_guards n t) end. + +Lemma rr_guards_trans {X} n l (t u : ictreeW SObs X) : + trans l t u -> trans l (rr_guards n t) u. +Proof. intro H; induction n; cbn [rr_guards]; [exact H|now apply trans_guard]. Qed. + +(** This proof relation consumes a guard on BOTH sides in a silent round. + Its finite prefixes cannot turn silent divergence into a visible event. *) +CoInductive rr_aligned {X} : ictreeW SObs X -> ictreeW SObs X -> Prop := +| rr_align_guard t u n m t' u' : + t ≅ rr_guards (S n) t' -> u ≅ rr_guards (S m) u' -> + rr_aligned t' u' -> rr_aligned t u +| rr_align_log t u n m o t' u' : + t ≅ rr_guards n (Vis (Log o) (fun _ => t')) -> + u ≅ rr_guards m (Vis (Log o) (fun _ => u')) -> + rr_aligned t' u' -> rr_aligned t u. + +Lemma rr_aligned_equ {X} (t u a b : ictreeW SObs X) : + t ≅ a -> u ≅ b -> rr_aligned t u -> rr_aligned a b. +Proof. + intros Et Eu H; destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. + - eapply rr_align_guard; [| |exact H]. + + transitivity t; [symmetry; exact Et|exact El]. + + transitivity u; [symmetry; exact Eu|exact Er]. + - eapply rr_align_log; [| |exact H]. + + transitivity t; [symmetry; exact Et|exact El]. + + transitivity u; [symmetry; exact Eu|exact Er]. +Qed. + +Lemma rr_aligned_sym {X} : forall t u : ictreeW SObs X, + rr_aligned t u -> rr_aligned u t. +Proof. + cofix IH; intros t u H; + destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. + - eapply rr_align_guard; [exact Er|exact El|apply IH; exact H]. + - eapply rr_align_log; [exact Er|exact El|apply IH; exact H]. +Qed. + +Lemma rr_aligned_match {X} l T U : + @trans_ (writerE SObs) _ X l T U -> + forall u, rr_aligned (go T) u -> + exists u', trans l u u' /\ rr_aligned (go U) u'. +Proof. + intro TR; induction TR as + [l inner target TR IH + |n pick k result Eresult + |e k answer result Eresult + |result value Eresult]; intros u A. + - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + apply equ_guard_invE in El; destruct n as [|n]. + * cbn [rr_guards] in El. + assert (Ai : rr_aligned (go (observe inner)) tr). + { eapply rr_aligned_equ; [|reflexivity|exact A]. + transitivity inner; [symmetry; exact El|apply ictree_eta]. } + destruct (IH tr Ai) as (next & Tnext & Anext). + exists next; split; [rewrite Er; now apply rr_guards_trans|exact Anext]. + * apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. + eapply rr_align_guard; eassumption. + + destruct n as [|n]. + * cbn [rr_guards] in El; step in El; cbn in El; inversion El. + * apply equ_guard_invE in El. + apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. + eapply rr_align_log; eassumption. + - inversion A as [left right p q tl tr El Er Hnext|left right p q o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct p; step in El; cbn [rr_guards] in El; inversion El. + - destruct e as [o]; destruct answer. + inversion A as [left right n m tl tr El Er Hnext|left right n m p tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct n as [|n]. + * cbn [rr_guards] in El. + pose proof (equ_vis_invT El) as [_ Ep]; injection Ep as Ep; subst p. + pose proof (equ_vis_invE El tt) as Ek. + exists tr; split. + -- rewrite Er; apply rr_guards_trans. + exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => tr)). + -- eapply rr_aligned_equ; [|reflexivity|exact A]. + transitivity (k tt); [symmetry; exact Ek|]. + transitivity result; [exact Eresult|apply ictree_eta]. + * step in El; cbn [rr_guards] in El; inversion El. + - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct n; step in El; cbn [rr_guards] in El; inversion El. +Qed. + +Lemma rr_aligned_trans {X} (t u next : ictreeW SObs X) l : + rr_aligned t u -> trans l t next -> + exists other, trans l u other /\ rr_aligned next other. +Proof. + intros A TR. + assert (Ae : rr_aligned (go (observe t)) u). + { eapply rr_aligned_equ; [apply ictree_eta|reflexivity|exact A]. } + destruct (rr_aligned_match l (observe t) (observe next) TR u Ae) + as (other & To & Ao). + exists other; split; [exact To|]. + eapply rr_aligned_equ; [symmetry; apply ictree_eta|reflexivity|exact Ao]. +Qed. + +Lemma rr_aligned_sbisim {X} : forall t u : ictreeW SObs X, + rr_aligned t u -> t ~ u. +Proof. + unfold sbisim; apply_coinduction; fold_sbisim. + intros R IH t u A; split; intros l next TR. + - destruct (rr_aligned_trans t u next l A TR) as (other & To & Ao). + exists l, other; split; [exact To|]; split; [now apply IH|reflexivity]. + - destruct (rr_aligned_trans u t next l (rr_aligned_sym t u A) TR) + as (other & To & Ao). + exists l, other; split; [exact To|]; split. + + apply IH, rr_aligned_sym; exact Ao. + + reflexivity. +Qed. + +Lemma rr_guards_equ {X} n (t u : ictreeW SObs X) : + t ≅ u -> rr_guards n t ≅ rr_guards n u. +Proof. + intro E; induction n; cbn [rr_guards]; [exact E|now apply guard_equ_node]. +Qed. +Lemma rr_guards_add {X} n m (t : ictreeW SObs X) : + rr_guards (n + m) t = rr_guards n (rr_guards m t). +Proof. induction n; cbn [rr_guards Nat.add]; [reflexivity|now rewrite IHn]. Qed. +Lemma rr_guards_guard {X} n (t : ictreeW SObs X) : + rr_guards n (Guard t) = rr_guards (S n) t. +Proof. induction n; cbn [rr_guards]; [reflexivity|now rewrite IHn]. Qed. + +(** A finite proof prefix, not an additional evaluator or scheduler. *) +Inductive rr_token := RRGuard | RRLog (o : SObs). +Fixpoint rr_prefix {X} (word : list rr_token) (t : ictreeW SObs X) : ictreeW SObs X := + match word with + | [] => t + | RRGuard :: rest => Guard (rr_prefix rest t) + | RRLog o :: rest => Vis (Log o) (fun _ => rr_prefix rest t) + end. +Fixpoint rr_prefix_events (word : list rr_token) : list SObs := + match word with + | [] => [] + | RRGuard :: rest => rr_prefix_events rest + | RRLog o :: rest => o :: rr_prefix_events rest + end. +Lemma rr_prefix_app {X} left right (t : ictreeW SObs X) : + rr_prefix (left ++ right) t = rr_prefix left (rr_prefix right t). +Proof. + induction left as [|[|o] rest IH]; cbn [List.app rr_prefix]; + [reflexivity|now rewrite IH|now rewrite IH]. +Qed. +Lemma rr_prefix_equ {X} word (t u : ictreeW SObs X) : + t ≅ u -> rr_prefix word t ≅ rr_prefix word u. +Proof. + intro E; induction word as [|[|o] rest IH]; cbn [rr_prefix]. + - exact E. + - now apply guard_equ_node. + - apply vis_equ_node; intros []; exact IH. +Qed. +Lemma rr_prefix_events_app left right : + rr_prefix_events (left ++ right) = rr_prefix_events left ++ rr_prefix_events right. +Proof. + induction left as [|[|o] rest IH]; cbn [List.app rr_prefix_events]; + [reflexivity|exact IH|now rewrite IH]. +Qed. +Lemma rr_prefix_events_logs logs : rr_prefix_events (List.map RRLog logs) = logs. +Proof. induction logs; cbn [List.map rr_prefix_events]; [reflexivity|now rewrite IHlogs]. Qed. +Lemma rr_prefix_emit {X} logs (t : ictreeW SObs X) : + rr_prefix (List.map RRLog logs) t ≅ emit_list logs t. +Proof. + induction logs as [|o rest IH]; [reflexivity|]. + cbn [List.map rr_prefix]; rewrite emit_list_cons. + apply vis_equ_node; intros []; exact IH. +Qed. +Lemma rr_prefix_no_events {X} word (t : ictreeW SObs X) : + rr_prefix_events word = [] -> rr_prefix word t = rr_guards (List.length word) t. +Proof. + induction word as [|[|o] rest IH]; cbn [rr_prefix_events rr_prefix List.length rr_guards]; + intro E; [reflexivity|now rewrite IH|discriminate]. +Qed. +Lemma rr_prefix_one_event {X} word o (t : ictreeW SObs X) : + rr_prefix_events word = [o] -> exists n m, + rr_prefix word t ≅ rr_guards n (Vis (Log o) (fun _ => rr_guards m t)). +Proof. + induction word as [|[|p] rest IH]; cbn [rr_prefix_events]; intro E; [discriminate| |]. + - destruct (IH E) as (n & m & H). + exists (S n), m; cbn [rr_prefix rr_guards]; now apply guard_equ_node. + - injection E as Ep Er; subst p. + exists 0, (List.length rest); cbn [rr_prefix rr_guards]. + apply vis_equ_node; intros []; rewrite (rr_prefix_no_events rest t Er); reflexivity. +Qed. + +Local Lemma exact_rr_user_replaced n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ≅ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')). +Proof. + etransitivity. + - eapply segment_rr_user_exact; rewrite Vector.nth_replace_eq; reflexivity. + - apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] y <-; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma exact_segment_rr_prefix n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma logs residual sigma' : + ExactThreadSegment t sigma logs residual sigma' -> + exists word, rr_prefix_events word = logs /\ + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ≅ + rr_prefix word (Guard + (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma')). +Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - exists []; split; [reflexivity|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_yield_exact; rewrite Vector.nth_replace_eq; reflexivity. + + rewrite Vector.replace_replace_eq; reflexivity. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (RRGuard :: word); split; [exact Ew|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_guard_exact; rewrite Vector.nth_replace_eq; reflexivity. + + apply guard_equ_node; rewrite Vector.replace_replace_eq; exact Et. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (List.map RRLog before ++ RRGuard :: RRGuard :: RRGuard :: word); split. + + rewrite rr_prefix_events_app, rr_prefix_events_logs; cbn [rr_prefix_events]. + now rewrite Ew. + + etransitivity; [apply exact_rr_user_replaced|]. + set (resume := fun response : (encode e * SSig)%type => + let '(x,sigma0) := response in + rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0)). + transitivity (emit_list before (Ret (result,sigma1)) >>= resume). + * apply equ_clo_bind with (S := eq); [exact Eh|intros x y <-; reflexivity]. + * etransitivity; [apply emit_list_ret_bind|]; unfold resume. + transitivity (emit_list before + (rr_guards 3 (rr_prefix word (Guard + (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'))))). + -- apply emit_list_equ, rr_guards_equ; exact Et. + -- rewrite rr_prefix_app; cbn [rr_prefix rr_guards]. + symmetry; apply rr_prefix_emit. + - destruct (IH n ts i m) as (word & Ew & Et). + exists word; split; [exact Ew|]. + etransitivity. + + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|exact Etu]. + + etransitivity; [exact Et|]. + apply rr_prefix_equ, guard_equ_node, interp_schedule_rr_equ, replace_pool_equ; + [apply pool_equ_refl|exact Eout]. +Qed. + +Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event : + pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> + exists residual, + ExactThreadSegment (ts $ slot_of_actor who) (aheap s,acount s) + (turn_observations event) residual (aheap t,acount t) /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who). +Proof. + intros Hpool Hturn. + destruct (turn_source_exact_segment base who s t event Hturn) as (residual & Hseg & Htail). + exists residual; split; [|exact Htail]. + apply (proj2 (guard_equ_exact_segment_iff + (ts $ slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) + (Hpool (slot_of_actor who)) (aheap s,acount s) (turn_observations event) + residual (aheap t,acount t))); exact Hseg. +Qed. + +Lemma selected_turn_rr_prefix base (ts : pool sE 3) s who t event cursor : + pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> + exists residual word, + rr_prefix_events word = turn_observations event /\ + guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ + interp_schedule_rr sh 3 ts (Some (slot_of_actor who)) cursor (aheap s,acount s) ≅ + rr_prefix word (Guard (interp_schedule_rr sh 3 + (ts @ slot_of_actor who := residual) None cursor (aheap t,acount t))). +Proof. + intros Hpool Hturn. + destruct (selected_turn_exact_segment base ts s who t event Hpool Hturn) + as (residual & Hseg & Htail). + destruct (exact_segment_rr_prefix 2 ts (slot_of_actor who) + (ts $ slot_of_actor who) cursor (aheap s,acount s) (turn_observations event) + residual (aheap t,acount t) Hseg) as (word & Ew & Et). + exists residual, word; split; [exact Ew|]; split; [exact Htail|]. + etransitivity; [|exact Et]. + symmetry; apply interp_schedule_rr_equ, source_replace_current. +Qed. + +Lemma allocator_pool_rr_aligned base capacity : forall s ts cursor, + allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> + rr_aligned + (interp_schedule_rr sh 3 ts None cursor (aheap s,acount s)) + (model_rr base s cursor). +Proof. + cofix IH; intros s ts cursor Hinv Hpool. + set (who := actor_of_slot (rr_pick 2 cursor)). + assert (Eslot : slot_of_actor who = rr_pick 2 cursor). + { unfold who; apply slot_of_actor_of_slot. } + destruct (turn_total base capacity who s Hinv) as (next & event & Hturn). + destruct (selected_turn_rr_prefix base ts s who next event (S cursor) Hpool Hturn) + as (residual & word & Ew & Htail & Eprefix). + set (next_tree := interp_schedule_rr sh 3 + (ts @ slot_of_actor who := residual) None (S cursor) (aheap next,acount next)). + set (next_model := model_rr base next (S cursor)). + assert (Hsource : interp_schedule_rr sh 3 ts None cursor (aheap s,acount s) ≅ + rr_guards 3 (rr_prefix word (Guard next_tree))). + { + etransitivity; [exact (segment_rr_select_exact 2 ts cursor (aheap s,acount s))|]. + apply (rr_guards_equ 3); rewrite <- Eslot; exact Eprefix. + } + assert (Hnextinv : allocator_inv base capacity next). + { eapply turn_preserves_inv; eauto. } + assert (Hnextpool : pool_guard_equ (ts @ slot_of_actor who := residual) + (allocator_pool base next)). + { eapply selected_source_pool_update; eauto. } + destruct event as [o|]; cbn [turn_observations] in Ew. + - destruct (rr_prefix_one_event word o (Guard next_tree) Ew) as (n & m & Eword). + eapply rr_align_log with (n := 3 + n) (m := 0) (o := o) + (t' := rr_guards m (Guard next_tree)) (u' := Guard next_model). + + etransitivity; [exact Hsource|]. + rewrite (rr_guards_add 3 n + (Vis (Log o) (fun _ => rr_guards m (Guard next_tree)))). + apply rr_guards_equ; exact Eword. + + rewrite (unfold_model_rr base s cursor); fold who; rewrite Hturn; reflexivity. + + eapply rr_align_guard with (n := m) (m := 0) + (t' := next_tree) (u' := next_model). + * rewrite rr_guards_guard; reflexivity. + * reflexivity. + * apply IH; assumption. + - eapply rr_align_guard with (n := 3 + List.length word) (m := 0) + (t' := next_tree) (u' := next_model). + + etransitivity; [exact Hsource|]. + rewrite (rr_prefix_no_events word (Guard next_tree) Ew). + rewrite <- (rr_guards_add 3 (List.length word) (Guard next_tree)). + rewrite rr_guards_guard; reflexivity. + + rewrite (unfold_model_rr base s cursor); fold who; rewrite Hturn; reflexivity. + + apply IH; assumption. +Qed. + +Lemma allocator_pool_rr_bisim base capacity s ts cursor : + allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> + interp_schedule_rr sh 3 ts None cursor (aheap s,acount s) ~ model_rr base s cursor. +Proof. + intros Hinv Hpool; apply rr_aligned_sbisim. + exact (allocator_pool_rr_aligned base capacity s ts cursor Hinv Hpool). +Qed. + +Theorem run_rr_allocator_bisim capacity c : + run_rr (allocator_program capacity) hemp c ~ model_rr 1 (initial_state capacity c) 0. +Proof. + rewrite run_rr_allocator_initialized. + apply (allocator_pool_rr_bisim 1 capacity (initial_state capacity c)). + - apply initial_state_inv. + - apply execution_pool_guard_equ, source_pool0_initial. +Qed. + +From Coinduction Require Import coinduction rel tactics. +Local Notation st L := (coinduction.t (sb L)). + +Lemma nd_st_emit_list {X} (R : ictreeW SObs X -> ictreeW SObs X -> Prop) + logs t u : + st eq R t u -> st eq R (emit_list logs t) (emit_list logs u). +Proof. + intro H; induction logs as [|o rest IH]; [exact H|]. + change (st eq R (log o ;; emit_list rest t) (log o ;; emit_list rest u)). + apply st_clo_bind_eq; [reflexivity|intros []; exact IH]. +Qed. + +Lemma allocator_pool_nd_bisim base capacity : forall s ts, + allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> + interp_nd 3 ts None (aheap s,acount s) ~ model_nd base s. +Proof. + unfold sbisim; apply_coinduction; fold_sbisim. + intros R IH s ts Hinv Hpool. + etransitivity; [apply (coinduction.gfp_bt (sb eq) R), interp_nd_select|]. + eapply equ_sbt_closed_goal; [reflexivity|apply unfold_model_nd|]. + apply step_sb_br_id; [reflexivity|intro i]. + destruct (turn_total base capacity (actor_of_slot i) s Hinv) + as (next & event & Hturn). + rewrite Hturn. + destruct (selected_turn_exact_segment base ts s (actor_of_slot i) next event + Hpool Hturn) as (residual & Hseg & Htail). + pose proof (selected_source_pool_update base ts s (actor_of_slot i) + next event residual Hpool Hturn Htail) as Hnextpool. + apply ExactThreadSegment_segment in Hseg. + pose proof (segment_interp_nd 2 ts (slot_of_actor (actor_of_slot i)) + (ts $ slot_of_actor (actor_of_slot i)) (aheap s,acount s) + (turn_observations event) residual (aheap next,acount next) Hseg) as Esegment. + rewrite slot_of_actor_of_slot in Esegment, Hnextpool. + assert (Efocus : interp_nd 3 ts (Some i) (aheap s,acount s) ~ + emit_list (turn_observations event) + (interp_nd 3 (ts @ i := residual) None (aheap next,acount next))). + { + etransitivity; [|exact Esegment]. + symmetry; apply source_equ_sbisim, interp_nd_equ, + source_replace_current. + } + assert (Hnextinv : allocator_inv base capacity next). + { eapply turn_preserves_inv; eauto. } + etransitivity; [apply (coinduction.gfp_t (sb eq) R); exact Efocus|]. + assert (Hcontinue : st eq R + (interp_nd 3 (ts @ i := residual) None (aheap next,acount next)) + (Guard (model_nd base next))). + { + etransitivity; [exact (IH next (ts @ i := residual) Hnextinv Hnextpool)|]. + apply (coinduction.gfp_t (sb eq) R); symmetry; exact (sb_guard (model_nd base next)). + } + destruct event as [o|]; cbn [turn_observations]. + - eapply equ_clos_st_goal; + [reflexivity|symmetry; exact (emit_list_cons o [] (Guard (model_nd base next)))|]. + apply (nd_st_emit_list R [o]); exact Hcontinue. + - exact Hcontinue. +Qed. + +Theorem run_nd_allocator_bisim capacity c : + run_nd (allocator_program capacity) hemp c ~ model_nd 1 (initial_state capacity c). +Proof. + rewrite run_nd_allocator_initialized. + apply (allocator_pool_nd_bisim 1 capacity (initial_state capacity c)). + - apply initial_state_inv. + - apply execution_pool_guard_equ, source_pool0_initial. +Qed. diff --git a/examples/CSL/Allocator/Layout.v b/examples/CSL/Allocator/Layout.v new file mode 100644 index 0000000..a763f70 --- /dev/null +++ b/examples/CSL/Allocator/Layout.v @@ -0,0 +1,524 @@ +(** * A finite link-first allocator page. + + The five metadata cells precede stride-two blocks. A block's first cell + is its free-list link; its successor cell is mutable client payload. + The imported [cells] operation is used only as a two-cell footprint: + none of the queue's ownership or chain predicates is used here. *) + +From Stdlib Require Import List Lia Arith.PeanoNat. +From examples Require Import CSL.HeapQ CSL.Layout. + +Import ListNotations. +Local Open Scope list_scope. + +Definition page_size (capacity : nat) : nat := 5 + 2 * capacity. +Definition remote_head (base : nat) : nat := base. +Definition local_head (base : nat) : nat := base + 1. +Definition drain_head (base : nat) : nat := base + 2. +Definition mailbox (base : nat) (client : bool) : nat := + base + 3 + (if client then 1 else 0). +Definition page_blocks (base capacity : nat) : list nat := + node_addrs (base + 5) capacity. +Definition tag_alloc : nat := 0. +Definition tag_retire : nat := 1. +Definition tag_reclaim : nat := 2. +Definition tag_retry : nat := 3. + +Definition page_metadata (base : nat) : list nat := + [remote_head base; local_head base; drain_head base; + mailbox base false; mailbox base true]. +Definition page_cells (base capacity : nat) : list nat := + page_metadata base ++ cells (page_blocks base capacity). + +Lemma page_size_positive capacity : Nat.lt 0 (page_size capacity). +Proof. unfold page_size; lia. Qed. + +Lemma page_blocks_in base capacity b : + In b (page_blocks base capacity) <-> + exists j, Nat.lt j capacity /\ b = base + 5 + 2 * j. +Proof. apply node_addrs_in. Qed. + +Lemma page_blocks_length base capacity : + length (page_blocks base capacity) = capacity. +Proof. apply node_addrs_length. Qed. + +Lemma page_blocks_nodup base capacity : + NoDup (page_blocks base capacity). +Proof. apply node_addrs_nodup. Qed. + +Lemma page_blocks_bounds base capacity b : + In b (page_blocks base capacity) -> + Nat.le (base + 5) b /\ Nat.lt (S b) (base + page_size capacity). +Proof. + intros Hin; apply page_blocks_in in Hin as (j & Hj & Hb). + unfold page_size; lia. +Qed. + +Lemma page_blocks_positive base capacity b : + In b (page_blocks base capacity) -> Nat.lt 0 b. +Proof. intro H; apply page_blocks_bounds in H; lia. Qed. + +Lemma page_blocks_nonnull base capacity : ~ In 0 (page_blocks base capacity). +Proof. intro H; apply page_blocks_positive in H; lia. Qed. + +Lemma node_addrs_link_payload_disjoint first count a b : + In a (node_addrs first count) -> In b (node_addrs first count) -> + a <> S b. +Proof. + intros Ha Hb. + apply node_addrs_in in Ha as (i & Hi & Ha). + apply node_addrs_in in Hb as (j & Hj & Hb). + lia. +Qed. + +Lemma page_blocks_link_payload_disjoint base capacity a b : + In a (page_blocks base capacity) -> In b (page_blocks base capacity) -> + a <> S b. +Proof. apply node_addrs_link_payload_disjoint. Qed. + +Lemma page_metadata_range base x : + In x (page_metadata base) <-> Nat.le base x /\ Nat.lt x (base + 5). +Proof. + unfold page_metadata, remote_head, local_head, drain_head, mailbox. + cbn [In]; lia. +Qed. + +Lemma page_metadata_nodup base : NoDup (page_metadata base). +Proof. + unfold page_metadata, remote_head, local_head, drain_head, mailbox. + repeat constructor; cbn [In]; intuition lia. +Qed. + +Lemma page_metadata_positive base x : + Nat.lt 0 base -> In x (page_metadata base) -> Nat.lt 0 x. +Proof. intros Hbase Hx; apply page_metadata_range in Hx; lia. Qed. + +Lemma mailbox_injective base client client' : + mailbox base client = mailbox base client' -> client = client'. +Proof. destruct client, client'; unfold mailbox; intros H; try reflexivity; lia. Qed. + +Lemma page_metadata_blocks_disjoint base capacity x b : + In x (page_metadata base) -> In b (page_blocks base capacity) -> + x <> b /\ x <> S b. +Proof. + intros Hx Hb; apply page_metadata_range in Hx. + apply page_blocks_bounds in Hb; lia. +Qed. + +Lemma page_block_cells_range base capacity x : + In x (cells (page_blocks base capacity)) <-> + Nat.le (base + 5) x /\ Nat.lt x (base + page_size capacity). +Proof. + unfold page_blocks; rewrite node_cells_range; unfold page_size; lia. +Qed. + +Lemma page_cells_range base capacity x : + In x (page_cells base capacity) <-> + Nat.le base x /\ Nat.lt x (base + page_size capacity). +Proof. + unfold page_cells; rewrite in_app_iff, page_metadata_range, page_block_cells_range. + unfold page_size; lia. +Qed. + +(** This is the addresswise coverage useful for splitting metadata, links, + and payloads in the ownership invariant. *) +Lemma page_interval_coverage base capacity x : + (Nat.le base x /\ Nat.lt x (base + page_size capacity)) <-> + In x (page_metadata base) \/ + exists b, In b (page_blocks base capacity) /\ (x = b \/ x = S b). +Proof. + rewrite <- page_cells_range; unfold page_cells. + rewrite in_app_iff, in_cells; reflexivity. +Qed. + +Local Lemma node_addrs_cells_nodup first count : + NoDup (cells (node_addrs first count)). +Proof. + revert first; induction count as [| count IH]; intro first. + - constructor. + - change (NoDup (first :: S first :: cells (node_addrs (first + 2) count))). + constructor. + + intros [H | H]; [lia | apply node_cells_range in H; lia]. + + constructor. + * intro H; apply node_cells_range in H; lia. + * apply IH. +Qed. + +Local Lemma nodup_disjoint_app (xs ys : list nat) : + NoDup xs -> NoDup ys -> + (forall x, In x xs -> ~ In x ys) -> NoDup (xs ++ ys). +Proof. + revert ys; induction xs as [| a xs IH]; intros ys Hxs Hys Hdisj. + - exact Hys. + - apply NoDup_cons_iff in Hxs as [Hnot Hxs]. + cbn [app]; constructor. + + rewrite in_app_iff; intros [Hin | Hin]. + * exact (Hnot Hin). + * exact (Hdisj a (or_introl eq_refl) Hin). + + apply IH; [exact Hxs | exact Hys |]. + intros x Hx; apply Hdisj; now right. +Qed. + +Lemma page_cells_nodup base capacity : NoDup (page_cells base capacity). +Proof. + unfold page_cells; apply nodup_disjoint_app. + - apply page_metadata_nodup. + - apply node_addrs_cells_nodup. + - intros x Hmeta Hblock. + apply page_metadata_range in Hmeta. + apply page_block_cells_range in Hblock; lia. +Qed. + +Lemma page_cells_positive base capacity x : + Nat.lt 0 base -> In x (page_cells base capacity) -> Nat.lt 0 x. +Proof. intros Hbase Hx; apply page_cells_range in Hx; lia. Qed. + +(** ** Pure counterparts of the checked initialization writes + + The order here is the source order: remote, drain, mailbox 0, mailbox 1, + local; then links from low to high. The allocation overlay installs the + zero payloads. Initialization never writes a payload cell. *) + +Fixpoint init_links_heap (first count : nat) (h : Heap) : Heap := + match count with + | 0 => h + | S rest => + init_links_heap (first + 2) rest + (upd h first (match rest with 0 => 0 | S _ => first + 2 end)) + end. + +Definition page_heap (base capacity : nat) (h : Heap) : Heap := + init_links_heap (base + 5) capacity + (upd + (upd + (upd + (upd + (upd (hunion (hblock base (page_size capacity)) h) + (remote_head base) 0) + (drain_head base) 0) + (mailbox base false) 0) + (mailbox base true) 0) + (local_head base) (match capacity with 0 => 0 | S _ => base + 5 end)). + +Lemma upd_preserves_present h a v x : + h x <> None -> upd h a v x <> None. +Proof. + intro H; destruct (Nat.eq_dec x a) as [-> | Hne]. + - rewrite upd_eq; discriminate. + - rewrite upd_neq by exact Hne; exact H. +Qed. + +Lemma upd_lookup_agree h f a v x : + h x = f x -> upd h a v x = upd f a v x. +Proof. + intro H; destruct (Nat.eq_dec x a) as [-> | Hne]. + - now rewrite !upd_eq. + - now rewrite !upd_neq by exact Hne. +Qed. + +Lemma init_links_heap_lookup_agree first count h f x : + h x = f x -> init_links_heap first count h x = init_links_heap first count f x. +Proof. + revert first h f; induction count as [| count IH]; intros first h f H. + - exact H. + - cbn [init_links_heap]; apply IH, upd_lookup_agree, H. +Qed. + +Lemma init_links_heap_heq first count h f : + heq h f -> heq (init_links_heap first count h) (init_links_heap first count f). +Proof. intros H x; apply init_links_heap_lookup_agree, H. Qed. + +Lemma init_links_heap_frame first count h x : + ~ In x (node_addrs first count) -> init_links_heap first count h x = h x. +Proof. + revert first h; induction count as [| count IH]; intros first h Hout. + - reflexivity. + - cbn [init_links_heap]; rewrite IH. + + apply upd_neq; intro H; apply Hout; cbn [node_addrs]; now left. + + intro Hin; apply Hout; cbn [node_addrs]; now right. +Qed. + +Lemma init_links_heap_out first count h x : + (Nat.lt x first \/ Nat.le (first + 2 * count) x) -> + init_links_heap first count h x = h x. +Proof. + intro Hout; apply init_links_heap_frame. + intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. +Qed. + +Lemma init_links_heap_payload first count h b : + In b (node_addrs first count) -> init_links_heap first count h (S b) = h (S b). +Proof. + intro Hb; apply init_links_heap_frame; intro Hin. + exact (node_addrs_link_payload_disjoint first count (S b) b Hin Hb eq_refl). +Qed. + +(** Without a checked-write premise the pure updater can extend a domain. + Its exact domain law makes that possibility explicit. *) +Lemma init_links_heap_dom first count h x : + init_links_heap first count h x <> None <-> + In x (node_addrs first count) \/ h x <> None. +Proof. + revert first h x; induction count as [| count IH]; intros first h x. + - cbn [init_links_heap node_addrs In]; tauto. + - cbn [init_links_heap node_addrs In]; rewrite IH; unfold upd. + destruct (Nat.eqb_spec x first) as [Hx | Hne]. + + subst x; split; intro H. + * left; now left. + * right; discriminate. + + intuition congruence. +Qed. + +Lemma init_links_heap_checked_dom first count h : + (forall b, In b (node_addrs first count) -> h b <> None) -> + forall x, init_links_heap first count h x <> None <-> h x <> None. +Proof. + intro Hchecked; intro x; rewrite init_links_heap_dom. + split; [intros [Hin | Hx]; [now apply Hchecked | exact Hx] | now right]. +Qed. + +(** A list-suffix lookup is independent of the incoming heap. In particular + it supplies exactly the head/tail equations for a later [free_chain] + proof, without defining that ownership predicate in this module. *) +Lemma init_links_heap_link first count h prefix b rest : + node_addrs first count = prefix ++ b :: rest -> + init_links_heap first count h b = Some (hd 0 rest). +Proof. + revert first h prefix b rest; induction count as [| count IH]; + intros first h prefix b rest Hnodes. + - destruct prefix; discriminate. + - destruct prefix as [| a prefix]. + + cbn [node_addrs app] in Hnodes. + injection Hnodes as Hb Hrest; subst b; subst rest. + cbn [init_links_heap]. + rewrite init_links_heap_out by (left; lia). + rewrite upd_eq; destruct count; reflexivity. + + cbn [node_addrs app] in Hnodes. + injection Hnodes as Ha Htail. + cbn [init_links_heap]; eapply IH; exact Htail. +Qed. + +Lemma init_links_heap_link_index first count h j : + Nat.lt j count -> + init_links_heap first count h (first + 2 * j) = + Some (if Nat.ltb (S j) count then first + 2 * S j else 0). +Proof. + revert first h j; induction count as [| count IH]; intros first h j Hj. + - lia. + - destruct j as [| j]. + + replace (first + 2 * 0) with first by lia. + cbn [init_links_heap]. + rewrite init_links_heap_out by (left; lia). + rewrite upd_eq; destruct count; reflexivity. + + cbn [init_links_heap]. + replace (first + 2 * S j) with (first + 2 + 2 * j) by lia. + rewrite IH by lia. + change (Some (if Nat.ltb (S j) count then first + 2 + 2 * S j else 0) = + Some (if Nat.ltb (S j) count then first + 2 * S (S j) else 0)). + destruct (Nat.ltb (S j) count); f_equal; lia. +Qed. + +Lemma init_links_heap_finite first count h : + heap_finite h -> heap_finite (init_links_heap first count h). +Proof. + revert first h; induction count as [| count IH]; intros first h Hh. + - exact Hh. + - cbn [init_links_heap]; apply IH, heap_finite_upd, Hh. +Qed. + +(** ** Backing storage, checked cells, and the old frame *) + +Lemma page_backing_in base capacity h x : + (Nat.le base x /\ Nat.lt x (base + page_size capacity)) -> + hunion (hblock base (page_size capacity)) h x = Some 0. +Proof. + intros [Hlo Hhi]; apply hunion_some. + replace x with (base + (x - base)) by lia; apply hblock_in; lia. +Qed. + +Lemma page_heap_frame base capacity h x : + (Nat.lt x base \/ Nat.le (base + page_size capacity) x) -> + page_heap base capacity h x = h x. +Proof. + intro Hout; unfold page_heap. + rewrite init_links_heap_out by (unfold page_size in Hout; lia). + unfold remote_head, local_head, drain_head, mailbox. + repeat rewrite upd_neq by (unfold page_size in Hout; lia). + apply hunion_none, hblock_out; exact Hout. +Qed. + +Lemma page_heap_in base capacity h x : + (Nat.le base x /\ Nat.lt x (base + page_size capacity)) -> + page_heap base capacity h x <> None. +Proof. + intro Hin; unfold page_heap; apply init_links_heap_dom; right. + repeat apply upd_preserves_present. + rewrite page_backing_in by exact Hin; discriminate. +Qed. + +Lemma page_heap_dom base capacity h x : + page_heap base capacity h x <> None <-> + (Nat.le base x /\ Nat.lt x (base + page_size capacity)) \/ h x <> None. +Proof. + destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. + - rewrite page_heap_frame by (now left); intuition lia. + - destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. + + split. + * intro H; left; split; assumption. + * intro H; apply page_heap_in; split; assumption. + + rewrite page_heap_frame by (now right); intuition lia. +Qed. + +Lemma page_heap_closed_dom base capacity x : + page_heap base capacity hemp x <> None <-> + Nat.le base x /\ Nat.lt x (base + page_size capacity). +Proof. + rewrite page_heap_dom; unfold hemp; split. + - intros [H | H]; [exact H | exfalso; apply H; reflexivity]. + - intro H; now left. +Qed. + +Lemma page_heap_closed_none base capacity x : + page_heap base capacity hemp x = None <-> + Nat.lt x base \/ Nat.le (base + page_size capacity) x. +Proof. + split. + - intro Hnone; destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. + + now left. + + destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. + * exfalso; apply (page_heap_in base capacity hemp x (conj Hlo Hhi)); exact Hnone. + * now right. + - intro Hout; rewrite page_heap_frame by exact Hout; reflexivity. +Qed. + +Lemma page_heap_null base capacity h : + Nat.lt 0 base -> page_heap base capacity h 0 = h 0. +Proof. intro Hbase; apply page_heap_frame; now left. Qed. + +Lemma page_heap_closed_null base capacity : + Nat.lt 0 base -> page_heap base capacity hemp 0 = None. +Proof. intro Hbase; apply page_heap_null; exact Hbase. Qed. + +Lemma page_heap_old_frame base capacity h : + block_free h base (page_size capacity) -> + forall x, h x <> None -> page_heap base capacity h x = h x. +Proof. + intros Hfree x Hx; destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. + - apply page_heap_frame; now left. + - destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. + + exfalso; apply Hx. + replace x with (base + (x - base)) by lia; apply Hfree; lia. + + apply page_heap_frame; now right. +Qed. + +Lemma page_heap_on_page base capacity h f x : + (Nat.le base x /\ Nat.lt x (base + page_size capacity)) -> + page_heap base capacity h x = page_heap base capacity f x. +Proof. + intro Hin; unfold page_heap; apply init_links_heap_lookup_agree. + repeat apply upd_lookup_agree. + rewrite (page_backing_in base capacity h x Hin). + rewrite (page_backing_in base capacity f x Hin); reflexivity. +Qed. + +Lemma page_heap_heq base capacity h f : + heq h f -> heq (page_heap base capacity h) (page_heap base capacity f). +Proof. + intros H x; unfold page_heap; apply init_links_heap_lookup_agree. + repeat apply upd_lookup_agree. + unfold hunion; now rewrite H. +Qed. + +Lemma page_heap_split base capacity h : + heq (page_heap base capacity h) (hunion (page_heap base capacity hemp) h). +Proof. + intro x; destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. + - rewrite hunion_none. + + apply page_heap_frame; now left. + + rewrite page_heap_frame by (now left); reflexivity. + - destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. + + rewrite hunion_eq by (apply page_heap_in; split; assumption). + apply page_heap_on_page; split; assumption. + + rewrite hunion_none. + * apply page_heap_frame; now right. + * rewrite page_heap_frame by (now right); reflexivity. +Qed. + +Lemma page_heap_disjoint base capacity h : + block_free h base (page_size capacity) -> + hdisj (page_heap base capacity hemp) h. +Proof. + intros Hfree x; destruct (page_heap base capacity hemp x) eqn:E. + - right. + assert (Hin : Nat.le base x /\ Nat.lt x (base + page_size capacity)). + { apply page_heap_closed_dom; rewrite E; discriminate. } + replace x with (base + (x - base)) by lia; apply Hfree; lia. + - now left. +Qed. + +Lemma page_heap_finite base capacity h : + heap_finite h -> heap_finite (page_heap base capacity h). +Proof. + intro Hh; unfold page_heap; apply init_links_heap_finite. + repeat apply heap_finite_upd. + apply heap_finite_hunion; [apply heap_finite_hblock | exact Hh]. +Qed. + +(** ** Initialized contents *) + +Lemma page_heap_remote base capacity h : + page_heap base capacity h (remote_head base) = Some 0. +Proof. + unfold page_heap, remote_head, local_head, drain_head, mailbox. + rewrite init_links_heap_out by (left; lia). + repeat rewrite upd_neq by lia; apply upd_eq. +Qed. + +Lemma page_heap_drain base capacity h : + page_heap base capacity h (drain_head base) = Some 0. +Proof. + unfold page_heap, remote_head, local_head, drain_head, mailbox. + rewrite init_links_heap_out by (left; lia). + repeat rewrite upd_neq by lia; apply upd_eq. +Qed. + +Lemma page_heap_mailbox base capacity h client : + page_heap base capacity h (mailbox base client) = Some 0. +Proof. + destruct client; unfold page_heap, remote_head, local_head, drain_head, mailbox; + rewrite init_links_heap_out by (left; lia); + repeat rewrite upd_neq by lia; apply upd_eq. +Qed. + +Lemma page_heap_local base capacity h : + page_heap base capacity h (local_head base) = + Some (match capacity with 0 => 0 | S _ => base + 5 end). +Proof. + unfold page_heap, local_head. + rewrite init_links_heap_out by (left; lia); apply upd_eq. +Qed. + +Lemma page_heap_local_blocks base capacity h : + page_heap base capacity h (local_head base) = Some (hd 0 (page_blocks base capacity)). +Proof. rewrite page_heap_local; destruct capacity; reflexivity. Qed. + +Lemma page_heap_payload base capacity h b : + In b (page_blocks base capacity) -> page_heap base capacity h (S b) = Some 0. +Proof. + intro Hb; pose proof (page_blocks_bounds base capacity b Hb) as Hbounds. + unfold page_heap; rewrite init_links_heap_payload by exact Hb. + unfold remote_head, local_head, drain_head, mailbox. + repeat rewrite upd_neq by lia. + apply page_backing_in; lia. +Qed. + +Lemma page_heap_link base capacity h prefix b rest : + page_blocks base capacity = prefix ++ b :: rest -> + page_heap base capacity h b = Some (hd 0 rest). +Proof. intro H; unfold page_heap; apply init_links_heap_link with (prefix := prefix); exact H. Qed. + +Lemma page_heap_link_index base capacity h j : + Nat.lt j capacity -> + page_heap base capacity h (base + 5 + 2 * j) = + Some (if Nat.ltb (S j) capacity then base + 5 + 2 * S j else 0). +Proof. intro H; unfold page_heap; apply init_links_heap_link_index, H. Qed. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v new file mode 100644 index 0000000..2972380 --- /dev/null +++ b/examples/CSL/Allocator/Liveness.v @@ -0,0 +1,2155 @@ +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Record AExecution := { + states : nat -> AState; + selected : nat -> Actor; + emitted : nat -> option SObs +}. +Definition valid_execution (capacity c : nat) (e : AExecution) : Prop := + states e 0 = initial_state capacity c /\ + forall k, turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). +Definition infinitely (P : nat -> Prop) : Prop := + forall n, exists k, n <= k /\ P k. +Definition event_is (tag : nat) (e : AExecution) (k : nat) : bool := + match emitted e k with None => false | Some o => Nat.eqb (stag o) tag end. +Definition pending_turn (e : AExecution) (k : nat) : bool := + match selected e k with + | Owner => false + | Remote0 => match remote0_state (states e k) with RPoll => false | _ => true end + | Remote1 => match remote1_state (states e k) with RPoll => false | _ => true end + end. +Definition count_if (p : nat -> bool) (lo len : nat) : nat := + List.length (List.filter p (List.seq lo len)). +Definition fair (e : AExecution) : Prop := + forall actor, infinitely (fun k => selected e k = actor). +Definition actor_eqb (a b : Actor) : bool := + match a,b with Owner,Owner | Remote0,Remote0 | Remote1,Remote1 => true | _,_ => false end. +Definition owner_turn (e : AExecution) (k : nat) : bool := actor_eqb (selected e k) Owner. + +(** The impossible branch is eliminated in Prop, then by False elimination. + No existential proof is eliminated into state data and there is no fallback. *) +Definition next_valid base capacity who s (Hinv : allocator_inv base capacity s) + : { result : (AState * option SObs)%type | + turn base who s = Some result /\ allocator_inv base capacity (fst result) }. +Proof. + destruct (turn base who s) as [[next event]|] eqn:Hturn. + - exists (next,event); split; [reflexivity|]. + eapply turn_preserves_inv; eauto. + - exfalso; destruct (turn_total base capacity who s Hinv) as (next & event & H). + rewrite Hturn in H; discriminate. +Defined. + +Fixpoint chosen_state (capacity c : nat) (picks : nat -> Actor) (k : nat) + : { s : AState | allocator_inv 1 capacity s } := + match k with + | 0 => exist _ (initial_state capacity c) (initial_state_inv capacity c) + | S j => + let prior := chosen_state capacity c picks j in + let next := next_valid 1 capacity (picks j) (proj1_sig prior) (proj2_sig prior) in + exist _ (fst (proj1_sig next)) (proj2 (proj2_sig next)) + end. +Definition execution_of_choices (capacity c : nat) (picks : nat -> Actor) : AExecution := + {| states := fun k => proj1_sig (chosen_state capacity c picks k); + selected := picks; + emitted := fun k => + let prior := chosen_state capacity c picks k in + snd (proj1_sig (next_valid 1 capacity (picks k) (proj1_sig prior) (proj2_sig prior))) |}. + +Lemma execution_of_choices_valid capacity c picks : + valid_execution capacity c (execution_of_choices capacity c picks). +Proof. + split; [reflexivity|]; intro k. + unfold execution_of_choices; cbn [states selected emitted chosen_state]. + destruct (next_valid 1 capacity (picks k) + (proj1_sig (chosen_state capacity c picks k)) + (proj2_sig (chosen_state capacity c picks k))) as [[next event] [Hturn Hinv]]. + exact Hturn. +Qed. +Lemma execution_of_choices_selected capacity c picks k : + selected (execution_of_choices capacity c picks) k = picks k. +Proof. reflexivity. Qed. + +Lemma execution_inv capacity c e k : + valid_execution capacity c e -> allocator_inv 1 capacity (states e k). +Proof. + intros [Hinit Hstep]; induction k as [|k IH]. + - rewrite Hinit; apply initial_state_inv. + - eapply turn_preserves_inv; [exact IH|apply Hstep]. +Qed. +Lemma execution_step capacity c e k : + valid_execution capacity c e -> + turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). +Proof. intros [_ H]; apply H. Qed. + +Lemma count_if_zero p lo : count_if p lo 0 = 0. +Proof. reflexivity. Qed. +Lemma count_if_succ p lo len : + count_if p lo (S len) = (if p lo then 1 else 0) + count_if p (S lo) len. +Proof. + unfold count_if; cbn [List.seq List.filter]; destruct (p lo); reflexivity. +Qed. +Lemma count_if_add p lo left right : + count_if p lo (left + right) = count_if p lo left + count_if p (lo + left) right. +Proof. + unfold count_if; rewrite List.seq_app, List.filter_app, List.length_app; reflexivity. +Qed. +Lemma actor_eqb_spec a b : actor_eqb a b = true <-> a = b. +Proof. destruct a,b; cbn [actor_eqb]; split; intro H; congruence. Qed. +Lemma owner_turn_spec e k : owner_turn e k = true <-> selected e k = Owner. +Proof. apply actor_eqb_spec. Qed. +Lemma event_is_spec tag e k : + event_is tag e k = true <-> exists block idx, emitted e k = Some (SPop tag block idx). +Proof. + unfold event_is; destruct (emitted e k) as [[kind block idx]|] eqn:E; cbn. + - rewrite Nat.eqb_eq; split. + + intro H; subst kind; now exists block, idx. + + intros (b & i & H); inversion H; reflexivity. + - split; [discriminate|intros (b & i & H); discriminate]. +Qed. + +Lemma execution_event_index capacity c e k o : + valid_execution capacity c e -> emitted e k = Some o -> + acount (states e (S k)) = S (acount (states e k)) /\ sidx o = acount (states e k). +Proof. + intros Hvalid Hobs. + pose proof (turn_counter 1 (selected e k) (states e k) (states e (S k)) + (emitted e k) (execution_step capacity c e k Hvalid)) as H. + now rewrite Hobs in H. +Qed. +Lemma execution_counter_mono capacity c e lo hi : + valid_execution capacity c e -> lo <= hi -> acount (states e lo) <= acount (states e hi). +Proof. + intros Hvalid Hle. + assert (Hstep : forall k, acount (states e k) <= acount (states e (S k))). + { + intro k; pose proof (turn_counter 1 (selected e k) (states e k) (states e (S k)) + (emitted e k) (execution_step capacity c e k Hvalid)) as H. + destruct (emitted e k); cbn in H; intuition lia. + } + induction Hle as [|hi Hle IH]; [lia|specialize (Hstep hi); lia]. +Qed. +Lemma execution_event_order capacity c e k j o p : + valid_execution capacity c e -> k < j -> + emitted e k = Some o -> emitted e j = Some p -> sidx o < sidx p. +Proof. + intros Hvalid Hkj Ho Hp. + pose proof (execution_event_index capacity c e k o Hvalid Ho) as [Hk Hi]. + pose proof (execution_event_index capacity c e j p Hvalid Hp) as [Hj Hjidx]. + pose proof (execution_counter_mono capacity c e (S k) j Hvalid ltac:(lia)); lia. +Qed. + +Lemma execution_run_turns capacity c e lo len : + valid_execution capacity c e -> + run_turns 1 (List.map (selected e) (List.seq lo len)) (states e lo) = + Some (states e (lo + len), + List.flat_map (fun k => turn_observations (emitted e k)) (List.seq lo len)). +Proof. + intro Hvalid; revert lo; induction len as [|len IH]; intro lo. + - cbn [List.seq List.map run_turns List.flat_map]; now rewrite Nat.add_0_r. + - cbn [List.seq List.map run_turns List.flat_map]. + rewrite (execution_step capacity c e lo Hvalid), IH. + replace (S lo + len) with (lo + S len) by lia. + destruct (emitted e lo); reflexivity. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL. +From examples Require Import CSL.HeapQ CSL.Allocator.Layout CSL.Allocator.Model. + +Import ListNotations. +Local Open Scope nat_scope. + +(** These are ghost potentials, not execution states. The default head is + immaterial on an invariant state, where the remote header is present. *) +Definition contention_head (s : AState) : nat := + match aheap s (remote_head 1) with Some current => current | None => 0 end. +Definition contention_stale (current : nat) (pc : remote_pc) : nat := + match pc with + | RLink _ old | RCAS _ old => if Nat.eqb current old then 0 else 1 + | _ => 0 + end. +Definition contention_phase (pc : remote_pc) : nat := + match pc with RPoll | RRead _ => 3 | RLink _ _ => 2 | RCAS _ _ => 1 end. +Definition contention_cost (current : nat) (pc : remote_pc) : nat := + contention_phase pc + 3 * contention_stale current pc. +Definition contention_pending_potential (current : nat) (p0 p1 : remote_pc) : nat := + contention_cost current p0 + contention_cost current p1 + + (if Nat.eqb current 0 then 0 else 6). +Definition contention_failure_potential (current : nat) (p0 p1 : remote_pc) : nat := + contention_stale current p0 + contention_stale current p1 + + (if Nat.eqb current 0 then 0 else 2). +Definition contention_pending_rank (s : AState) : nat := + contention_pending_potential (contention_head s) (remote0_state s) (remote1_state s). +Definition contention_failure_rank (s : AState) : nat := + contention_failure_potential (contention_head s) (remote0_state s) (remote1_state s). +Definition contention_pending (who : Actor) (s : AState) : bool := + match who with + | Owner => false + | Remote0 => match remote0_state s with RPoll => false | _ => true end + | Remote1 => match remote1_state s with RPoll => false | _ => true end + end. +Definition contention_tag (kind : nat) (event : option SObs) : bool := + match event with None => false | Some o => Nat.eqb (stag o) kind end. + +Lemma contention_stale_bound current pc : contention_stale current pc <= 1. +Proof. + destruct pc; cbn [contention_stale]; + repeat match goal with |- context [if ?b then _ else _] => destruct b end; lia. +Qed. +Lemma contention_cost_bound current pc : contention_cost current pc <= 5. +Proof. + destruct pc; unfold contention_cost; cbn [contention_phase contention_stale]; + repeat match goal with |- context [if ?b then _ else _] => destruct b end; lia. +Qed. +Lemma contention_pending_rank_bound s : contention_pending_rank s <= 16. +Proof. + unfold contention_pending_rank, contention_pending_potential. + pose proof (contention_cost_bound (contention_head s) (remote0_state s)). + pose proof (contention_cost_bound (contention_head s) (remote1_state s)). + destruct (Nat.eqb (contention_head s) 0); lia. +Qed. +Lemma contention_failure_rank_bound s : contention_failure_rank s <= 4. +Proof. + unfold contention_failure_rank, contention_failure_potential. + pose proof (contention_stale_bound (contention_head s) (remote0_state s)). + pose proof (contention_stale_bound (contention_head s) (remote1_state s)). + destruct (Nat.eqb (contention_head s) 0); lia. +Qed. + +Lemma contention_stale_reset current pc : + contention_stale 0 pc <= contention_stale current pc + 1. +Proof. pose proof (contention_stale_bound 0 pc); lia. Qed. +Lemma contention_cost_reset current pc : + contention_cost 0 pc <= contention_cost current pc + 3. +Proof. + unfold contention_cost; pose proof (contention_stale_reset current pc); lia. +Qed. +Lemma contention_reset_ranks current p0 p1 : + contention_pending_potential 0 p0 p1 <= contention_pending_potential current p0 p1 /\ + contention_failure_potential 0 p0 p1 <= contention_failure_potential current p0 p1. +Proof. + destruct (Nat.eqb current 0) eqn:Hcurrent. + - apply Nat.eqb_eq in Hcurrent; subst current; split; lia. + - unfold contention_pending_potential, contention_failure_potential. + rewrite Hcurrent; cbn [Nat.eqb]. + pose proof (contention_cost_reset current p0). + pose proof (contention_cost_reset current p1). + pose proof (contention_stale_reset current p0). + pose proof (contention_stale_reset current p1). + split; lia. +Qed. + +(** The separation side conditions below use the same partition/address + lemmas as invariant preservation. In particular no cached-head freshness + assumption is used: resetting a nonzero head pays for both stale bits. *) +Local Ltac contention_reduce_turn Hturn := + cbn [turn aheap acount owner_state remote0_state remote1_state] in Hturn. +Local Ltac contention_finish Hturn Hnoret Hr target event := + inversion Hturn; subst target event; clear Hturn; + cbn [contention_pending contention_tag stag tag_alloc tag_retire + tag_reclaim tag_retry aheap remote0_state remote1_state] in Hnoret |- *; + try discriminate; + unfold contention_pending_rank, contention_failure_rank, contention_head; + cbn [aheap remote0_state remote1_state]; + repeat first [rewrite upd_eq | rewrite upd_neq by ai_distinct]; + repeat rewrite Hr; + cbn. +Local Ltac contention_arithmetic := + unfold contention_pending_potential, contention_failure_potential, contention_cost; + cbn [contention_phase contention_stale]; + repeat match goal with + | E : Nat.eqb _ _ = _ |- _ => progress rewrite E + end; + repeat rewrite Nat.eqb_refl; + split; lia. + +Lemma turn_contention_ranks capacity who s t event : + allocator_inv 1 capacity s -> + turn 1 who s = Some (t,event) -> + contention_tag tag_retire event = false -> + (if contention_pending who s then 1 else 0) + contention_pending_rank t <= + contention_pending_rank s /\ + (if contention_tag tag_retry event then 1 else 0) + contention_failure_rank t <= + contention_failure_rank s. +Proof. + destruct s as [h count op p0 p1]. + cbn [allocator_inv aheap acount owner_state remote0_state remote1_state]. + intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) Hturn Hnoret. + cbn [aheap acount owner_state remote0_state remote1_state] in *. + destruct who. + - destruct op as [|old| |client]. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas. + * rewrite upd_neq in Hturn by ai_distinct; rewrite Hd in Hturn. + contention_finish Hturn Hnoret Hr t event; apply contention_reset_ranks. + * contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + destruct D as [|b D]. + * contention_reduce_turn Hturn; rewrite Hd in Hturn; cbn [hd Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + * cbn [free_chain] in CD; destruct CD as [Hnext CD]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn Hturn; rewrite Hd in Hturn; cbn [hd] in Hturn. + rewrite Eb, Hnext, Hl in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + destruct client. + * destruct m1 as [|m1]. + -- destruct L as [|b L ]. + ++ contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite Hl in Hturn; cbn [hd Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite Hl in Hturn; cbn [hd] in Hturn; rewrite Eb, Hnext in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + -- contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + * destruct m0 as [|m0]. + -- destruct L as [|b L ]. + ++ contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite Hl in Hturn; cbn [hd Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite Hl in Hturn; cbn [hd] in Hturn; rewrite Eb, Hnext in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + -- contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + - destruct p0 as [|b|b old|b old]. + + destruct m0 as [|m0]. + * contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + * contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite upd_neq in Hturn by ai_distinct. + destruct (h (S (S m0))) eqn:Hpayload; [|discriminate]. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; destruct (h b) eqn:Hlink; [|discriminate]. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas; + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + - destruct p1 as [|b|b old|b old]. + + destruct m1 as [|m1]. + * contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + * contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. + rewrite upd_neq in Hturn by ai_distinct. + destruct (h (S (S m1))) eqn:Hpayload; [|discriminate]. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; destruct (h b) eqn:Hlink; [|discriminate]. + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. + + contention_reduce_turn Hturn; rewrite Hr in Hturn. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas; + contention_finish Hturn Hnoret Hr t event; contention_arithmetic. +Qed. + +Lemma execution_contention_ranks capacity c e k : + valid_execution capacity c e -> event_is tag_retire e k = false -> + (if pending_turn e k then 1 else 0) + contention_pending_rank (states e (S k)) <= + contention_pending_rank (states e k) /\ + (if event_is tag_retry e k then 1 else 0) + contention_failure_rank (states e (S k)) <= + contention_failure_rank (states e k). +Proof. + intros Hvalid Hnone. + exact (turn_contention_ranks capacity (selected e k) (states e k) + (states e (S k)) (emitted e k) (execution_inv capacity c e k Hvalid) + (execution_step capacity c e k Hvalid) Hnone). +Qed. + +Lemma no_publication_contention_potential capacity c e lo len : + valid_execution capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> + count_if (pending_turn e) lo len + contention_pending_rank (states e (lo + len)) <= + contention_pending_rank (states e lo) /\ + count_if (event_is tag_retry e) lo len + contention_failure_rank (states e (lo + len)) <= + contention_failure_rank (states e lo). +Proof. + intros Hvalid; revert lo; induction len as [|len IH]; intros lo Hnone. + - rewrite !count_if_zero, Nat.add_0_r; cbn; split; lia. + - destruct (execution_contention_ranks capacity c e lo Hvalid + (Hnone lo ltac:(lia))) as [Hpending Hfailure]. + destruct (IH (S lo) ltac:(intros k Hk; apply Hnone; lia)) as [IHpending IHfailure]. + rewrite !count_if_succ. + replace (lo + S len) with (S lo + len) by lia. + split; lia. +Qed. + +(** Only a failed remote CAS emits [tag_retry]. Its unit stale-bit charge + proves the four-failure bound independently of the number of idle turns. *) +Theorem no_publication_failed_cas_bound capacity c e lo len : + valid_execution capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> + count_if (event_is tag_retry e) lo len <= 4. +Proof. + intros Hvalid Hnone. + destruct (no_publication_contention_potential capacity c e lo len Hvalid Hnone) + as [_ Hbound]. + pose proof (contention_failure_rank_bound (states e lo)); lia. +Qed. + +Theorem no_publication_pending_bound capacity c e lo len : + valid_execution capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> + count_if (pending_turn e) lo len <= 16. +Proof. + intros Hvalid Hnone. + destruct (no_publication_contention_potential capacity c e lo len Hvalid Hnone) + as [Hbound _]. + pose proof (contention_pending_rank_bound (states e lo)); lia. +Qed. + +(** Both searches are finite and constructive. In particular an unbounded + double-negation search for a future successful CAS is not used. *) +Lemma infinitely_count_if (p : nat -> bool) : + infinitely (fun k => p k = true) -> + forall wanted lo, exists len, wanted <= count_if p lo len. +Proof. + intros Hinf wanted; induction wanted as [|wanted IH]; intro lo. + - exists 0; rewrite count_if_zero; lia. + - destruct (Hinf lo) as [k [Hlo Hk]]. + destruct (IH (S k)) as [len Hlen]. + exists ((k - lo) + S len). + rewrite count_if_add. + replace (lo + (k - lo)) with k by lia. + rewrite count_if_succ, Hk; cbn; lia. +Qed. + +Lemma contention_finite_bool_search (p : nat -> bool) lo len : + (exists k, lo <= k < lo + len /\ p k = true) \/ + (forall k, lo <= k < lo + len -> p k = false). +Proof. + revert lo; induction len as [|len IH]; intro lo. + - right; intros k Hk; lia. + - destruct (p lo) eqn:Hlo. + + left; exists lo; split; [lia|exact Hlo]. + + destruct (IH (S lo)) as [[k [Hk Hp]]|Hnone]. + * left; exists k; split; [lia|exact Hp]. + * right; intros k Hk; destruct (Nat.eq_dec k lo) as [->|Hne]. + -- exact Hlo. + -- apply Hnone; lia. +Qed. + +Theorem remote_free_lockfree capacity c e : + valid_execution capacity c e -> + infinitely (fun k => pending_turn e k = true) -> + infinitely (fun k => event_is tag_retire e k = true). +Proof. + intros Hvalid Hpending lo. + destruct (infinitely_count_if (pending_turn e) Hpending 17 lo) as [len Hmany]. + destruct (contention_finite_bool_search (event_is tag_retire e) lo len) + as [[k [Hk Hevent]]|Hnone]. + - exists k; split; [lia|exact Hevent]. + - pose proof (no_publication_pending_bound capacity c e lo len Hvalid Hnone); lia. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Program.Equality. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Refine + Utils.Vectors. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Record SourceExecution := { + source_pools : nat -> pool sE 3; + source_states : nat -> SSig; + source_selected : nat -> Actor; + source_emitted : nat -> list SObs +}. +Definition valid_source_execution (capacity c : nat) (se : SourceExecution) : Prop := + pool_equ (source_pools se 0) (source_pool0 1) /\ + source_states se 0 = (page_heap 1 capacity hemp,c) /\ + forall k, exists residual, + ThreadSegment (source_pools se k $ slot_of_actor (source_selected se k)) + (source_states se k) (source_emitted se k) residual (source_states se (S k)) /\ + pool_equ (source_pools se (S k)) + (source_pools se k @ slot_of_actor (source_selected se k) := residual). + +(** A source scheduler records a physical branch slot, not an observation + guessed to identify its actor. Both inverse laws preserve that witness. *) +Definition source_execution_of_slots + (pools : nat -> pool sE 3) (sigmas : nat -> SSig) + (slots : nat -> Fin.t 3) (logs : nat -> list SObs) : SourceExecution := + {| source_pools := pools; source_states := sigmas; + source_selected := fun k => actor_of_slot (slots k); source_emitted := logs |}. + +Lemma source_execution_of_slots_selected pools sigmas slots logs k : + slot_of_actor (source_selected (source_execution_of_slots pools sigmas slots logs) k) = slots k. +Proof. apply slot_of_actor_of_slot. Qed. + +Theorem source_execution_of_slots_valid capacity c pools sigmas slots logs : + pool_equ (pools 0) (source_pool0 1) -> + sigmas 0 = (page_heap 1 capacity hemp,c) -> + (forall k, exists residual, + ThreadSegment (pools k $ slots k) (sigmas k) (logs k) residual (sigmas (S k)) /\ + pool_equ (pools (S k)) (pools k @ slots k := residual)) -> + valid_source_execution capacity c (source_execution_of_slots pools sigmas slots logs). +Proof. + intros Hpool Hstate Hsteps; split; [exact Hpool|]; split; [exact Hstate|]. + intro k; cbn [source_execution_of_slots source_selected source_pools source_states source_emitted]. + rewrite slot_of_actor_of_slot; apply Hsteps. +Qed. + +Lemma source_pool_equ_guard_trans {n} (ts us vs : pool sE n) : + pool_equ ts us -> pool_guard_equ us vs -> pool_guard_equ ts vs. +Proof. + intros E H i; eapply guard_equ_trans; [apply guard_equ_equ, E|apply H]. +Qed. + +Theorem source_execution_complete capacity c se : + valid_source_execution capacity c se -> + let e := execution_of_choices capacity c (source_selected se) in + valid_execution capacity c e /\ + (forall k, state_agrees (source_states se k) (states e k) /\ + pool_guard_equ (source_pools se k) (allocator_pool 1 (states e k))) /\ + (forall k, source_emitted se k = turn_observations (emitted e k)) /\ + (forall k, selected e k = source_selected se k). +Proof. + intros (Hpool0 & Hstate0 & Hsegments) e. + pose proof (execution_of_choices_valid capacity c (source_selected se)) as Hvalid. + change (valid_execution capacity c e) in Hvalid. + assert (Haligned : forall k, + state_agrees (source_states se k) (states e k) /\ + pool_guard_equ (source_pools se k) (allocator_pool 1 (states e k))). + { + intro k; induction k as [|k [Hstate Hpool]]. + - split. + + rewrite Hstate0; split; [apply heq_refl|reflexivity]. + + eapply source_pool_equ_guard_trans; [exact Hpool0|]. + apply execution_pool_guard_equ, source_pool0_initial. + - destruct (Hsegments k) as (residual & Hsegment & Hnextpool). + pose proof (execution_step capacity c e k Hvalid) as Hturn. + change (turn 1 (source_selected se k) (states e k) = + Some (states e (S k),emitted e k)) in Hturn. + destruct (selected_source_segment_exact 1 capacity (source_pools se k) + (source_states se k) (states e k) (source_selected se k) + (states e (S k)) (emitted e k) (source_emitted se k) + residual (source_states se (S k)) Hpool Hstate + (execution_inv capacity c e k Hvalid) Hturn Hsegment) + as (_ & Hstate' & Hresidual). + split; [exact Hstate'|]. + eapply source_pool_equ_guard_trans; [exact Hnextpool|]. + eapply selected_source_pool_update; eassumption. + } + split; [exact Hvalid|]; split; [exact Haligned|]; split. + - intro k; destruct (Haligned k) as [Hstate Hpool]. + destruct (Hsegments k) as (residual & Hsegment & _). + pose proof (execution_step capacity c e k Hvalid) as Hturn. + change (turn 1 (source_selected se k) (states e k) = + Some (states e (S k),emitted e k)) in Hturn. + exact (proj1 (selected_source_segment_exact 1 capacity (source_pools se k) + (source_states se k) (states e k) (source_selected se k) + (states e (S k)) (emitted e k) (source_emitted se k) + residual (source_states se (S k)) Hpool Hstate + (execution_inv capacity c e k Hvalid) Hturn Hsegment)). + - intro k; reflexivity. +Qed. + +(** Finite raw-source reachability has no model premise. It is useful before + an infinite schedule is supplied: every physical slot remains selectable. *) +Inductive ReachableSourcePool (capacity c : nat) : pool sE 3 -> SSig -> Prop := +| source_reachable_initial ts : + pool_equ ts (source_pool0 1) -> + ReachableSourcePool capacity c ts (page_heap 1 capacity hemp,c) +| source_reachable_step ts sigma (i : Fin.t 3) logs residual sigma' ts' : + ReachableSourcePool capacity c ts sigma -> + ThreadSegment (ts $ i) sigma logs residual sigma' -> + pool_equ ts' (ts @ i := residual) -> + ReachableSourcePool capacity c ts' sigma'. + +Lemma reachable_source_alignment capacity c ts sigma : + ReachableSourcePool capacity c ts sigma -> + exists s, allocator_inv 1 capacity s /\ state_agrees sigma s /\ + pool_guard_equ ts (allocator_pool 1 s). +Proof. + intro H; induction H as + [ts E|ts sigma i logs residual sigma' ts' Hreach IH Hseg E]. + - exists (initial_state capacity c); split; [apply initial_state_inv|]; split. + + split; [apply heq_refl|reflexivity]. + + eapply source_pool_equ_guard_trans; [exact E|]. + apply execution_pool_guard_equ, source_pool0_initial. + - destruct IH as (s & Hinv & Hagree & Hpool). + rewrite <- (slot_of_actor_of_slot i) in Hseg, E. + destruct (selected_source_segment_turn 1 capacity ts sigma s (actor_of_slot i) + logs residual sigma' Hpool Hagree Hinv Hseg) + as (next & event & Hturn & Hlogs & Hstate & Htail). + exists next; split; [eapply turn_preserves_inv; eassumption|]; split; + [exact Hstate|]. + eapply source_pool_equ_guard_trans; [exact E|]. + eapply selected_source_pool_update; eassumption. +Qed. + +Lemma source_execution_reachable capacity c se k : + valid_source_execution capacity c se -> + ReachableSourcePool capacity c (source_pools se k) (source_states se k). +Proof. + intros (Hp & Hs & Hsteps); induction k as [|k IH]. + - rewrite Hs; now apply source_reachable_initial. + - destruct (Hsteps k) as (residual & Hseg & E). + eapply source_reachable_step; eassumption. +Qed. + +Lemma ThreadSegment_branchfree t sigma logs residual sigma' : + ThreadSegment t sigma logs residual sigma' -> + BranchFree t -> BranchFree residual. +Proof. + intro H; induction H as + [k sigma|t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intro Hbf. + - apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; assumption. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - eapply branchfree_equ_impl; [exact Eout|]. + apply IH; eapply branchfree_equ_impl; eassumption. +Qed. + +Lemma source_pool0_branchfree i : BranchFree (source_pool0 1 $ i). +Proof. + rewrite <- (slot_of_actor_of_slot i); destruct (actor_of_slot i); + cbn [source_pool0 slot_of_actor Vector.nth]; apply denote_branchfree. +Qed. + +Lemma reachable_source_branchfree capacity c ts sigma : + ReachableSourcePool capacity c ts sigma -> forall i, BranchFree (ts $ i). +Proof. + intro H; induction H as + [ts E|ts sigma i logs residual sigma' ts' Hreach IH Hseg E]; intro j. + - eapply branchfree_equ_impl; [symmetry; apply E|apply source_pool0_branchfree]. + - eapply branchfree_equ_impl; [symmetry; apply E|]. + destruct (Fin.eq_dec j i) as [->|Hne]. + + rewrite Vector.nth_replace_eq; eapply ThreadSegment_branchfree; eauto. + + rewrite Vector.nth_replace_neq by congruence; apply IH. +Qed. + +Theorem every_reachable_source_slot_yields capacity c ts sigma (i : Fin.t 3) : + ReachableSourcePool capacity c ts sigma -> + BranchFree (ts $ i) /\ + (exists logs residual sigma', ThreadSegment (ts $ i) sigma logs residual sigma') /\ + not (guard_equ (ts $ i) (Ret tt)) /\ + (forall k : bool -> thread sE, ~ guard_equ (ts $ i) (Vis (inr (inl Fork)) k)) /\ + (forall n (k : Fin.t (S n) -> thread sE), ~ guard_equ (ts $ i) (Br n k)) /\ + not (guard_equ (ts $ i) (stuck : thread sE)) /\ + not (guard_equ (ts $ i) (spin : thread sE)). +Proof. + intro Hreach; split; [eapply reachable_source_branchfree; exact Hreach|]. + destruct (reachable_source_alignment capacity c ts sigma Hreach) + as (s & Hinv & Hstate & Hpool). + rewrite <- (slot_of_actor_of_slot i). + split; [eapply initialized_worker_next_yield; eassumption|]. + destruct (initialized_worker_no_terminal_prefix 1 capacity ts sigma s + (actor_of_slot i) Hpool Hstate Hinv) as (Hr & Hf & Hb & Hstuck). + destruct (initialized_worker_no_fault_or_divergence 1 capacity ts sigma s + (actor_of_slot i) Hpool Hstate Hinv) as (_ & Hspin & _). + repeat split; assumption. +Qed. + +(** The raw scheduler presents all three physical choices, including idle + polls. Its scheduling Yield is erased, whereas the following Br contributes + a genuine tau transition. Focus is retained through all source effects. *) +Lemma source_scheduler_offer (ts : pool sE 3) : + observe (schedule 3 ts None) = + VisF (inl Yield) (fun _ => Br 2 (fun i => schedule 3 ts (Some i))). +Proof. apply schedule_no_focus_nonempty. Qed. + +Lemma source_scheduler_choice (ts : pool sE 3) (i : Fin.t 3) : + trans tau (Br 2 (fun j => schedule 3 ts (Some j))) (schedule 3 ts (Some i)). +Proof. eapply trans_br with (x := i); reflexivity. Qed. + +Lemma source_scheduler_choice_inv (ts : pool sE 3) l next : + trans l (Br 2 (fun i => schedule 3 ts (Some i))) next -> + exists who, l = tau /\ next ≅ schedule 3 ts (Some (slot_of_actor who)). +Proof. + intro H; apply trans_br_inv in H as (i & E & ->). + exists (actor_of_slot i); split; [reflexivity|]. + rewrite slot_of_actor_of_slot; exact E. +Qed. + +Lemma source_scheduler_focused_yield (ts : pool sE 3) i k : + observe (ts $ i) = VisF (inl Yield) k -> + observe (schedule 3 ts (Some i)) = GuardF (schedule 3 (ts @ i := k tt) None). +Proof. apply schedule_focused_yield. Qed. +Lemma source_scheduler_focused_guard (ts : pool sE 3) i t : + observe (ts $ i) = GuardF t -> + observe (schedule 3 ts (Some i)) = GuardF (schedule 3 (ts @ i := t) (Some i)). +Proof. apply schedule_focused_guard. Qed. +Lemma source_scheduler_focused_user (ts : pool sE 3) i (e : sE) + (k : encode e -> thread sE) : + observe (ts $ i) = VisF (inr (inr e)) k -> + observe (schedule 3 ts (Some i)) = + VisF (inr (inr e)) (fun x => schedule 3 (ts @ i := k x) (Some i)). +Proof. apply schedule_focused_user_event. Qed. + +Inductive finite_steps {E : Type} {HE : Encode E} {X : Type} : + ictree E X -> list (@label E HE) -> ictree E X -> Prop := +| finite_steps_nil t : finite_steps t [] t +| finite_steps_cons t u v l labels : + trans l t u -> finite_steps u labels v -> finite_steps t (l :: labels) v. + +Definition turn_labels (event : option SObs) : list (@label (writerE SObs) _) := + match event with None => [tau] | Some o => [tau; obs (Log o) tt] end. + +Lemma turn_labels_nonempty event : turn_labels event <> []. +Proof. destruct event; discriminate. Qed. + +Lemma finite_steps_app {E : Type} {HE : Encode E} {X : Type} + (t u v : ictree E X) left right : + finite_steps t left u -> finite_steps u right v -> + finite_steps t (left ++ right) v. +Proof. + intros H; induction H; intro Htail; cbn [List.app]; + [exact Htail|econstructor; eauto]. +Qed. + +Lemma finite_steps_sbisim {E : Type} {HE : Encode E} {X : Type} + (t t' : ictree E X) labels : + finite_steps t labels t' -> forall u : ictree E X, t ~ u -> + exists u', finite_steps u labels u' /\ t' ~ u'. +Proof. + intro H; induction H as [t|t mid last l labels Hstep Htail IH]; intros u Eeq. + - exists u; split; [constructor|exact Eeq]. + - destruct (sbisim_trans t u mid l eq Eeq Hstep) + as (l' & mid' & Hstep' & El & Emid). + subst l'; destruct (IH mid' Emid) as (last' & Htail' & Elast). + exists last'; split; [econstructor; eassumption|exact Elast]. +Qed. + +Lemma finite_steps_emit_list {X} logs (t : ictreeW SObs X) : + finite_steps (emit_list logs t) (List.map (fun o => obs (Log o) tt) logs) t. +Proof. + induction logs as [|o logs IH]; [constructor|]. + cbn [List.map]; econstructor; [|exact IH]. + rewrite emit_list_cons. + exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => emit_list logs t)). +Qed. + +Lemma model_turn_finite_steps base who s next event : + turn base who s = Some (next,event) -> + finite_steps (model_nd base s) (turn_labels event) (Guard (model_nd base next)). +Proof. + intro Hturn; destruct event as [o|]; cbn [turn_labels]. + - eapply finite_steps_cons with + (u := Vis (Log o) (fun _ => Guard (model_nd base next))). + + rewrite (unfold_model_nd base s). + eapply trans_br with (x := slot_of_actor who). + rewrite actor_of_slot_of_actor, Hturn; reflexivity. + + econstructor; + [exact (@trans_vis (writerE SObs) _ (unit * SSig) (Log o) tt + (fun _ => Guard (model_nd base next)))|constructor]. + - econstructor; [|constructor]. + rewrite (unfold_model_nd base s). + eapply trans_br with (x := slot_of_actor who). + rewrite actor_of_slot_of_actor, Hturn; reflexivity. +Qed. + +CoInductive realizes (e : AExecution) (k : nat) + (t : ictreeW SObs (unit * SSig)) : Prop := +| realizes_next next : + finite_steps t (turn_labels (emitted e k)) next -> + realizes e (S k) next -> realizes e k t. + +Lemma valid_execution_realizes_model capacity c e : + valid_execution capacity c e -> + forall k t, t ~ model_nd 1 (states e k) -> realizes e k t. +Proof. + intro Hvalid; cofix CIH; intros k t E. + pose proof (model_turn_finite_steps 1 (selected e k) (states e k) + (states e (S k)) (emitted e k) + (execution_step capacity c e k Hvalid)) as Hmodel. + assert (Esym : model_nd 1 (states e k) ~ t) by (symmetry; exact E). + destruct (finite_steps_sbisim _ _ _ Hmodel t Esym) + as (next & Hsteps & Enext). + eapply realizes_next; [exact Hsteps|]. + apply CIH; transitivity (Guard (model_nd 1 (states e (S k)))); + [symmetry; exact Enext|apply sb_guard]. +Qed. + +Theorem valid_execution_realizes_source capacity c e : + valid_execution capacity c e -> + realizes e 0 (run_nd (allocator_program capacity) hemp c). +Proof. + intro Hvalid; eapply valid_execution_realizes_model; [exact Hvalid|]. + rewrite (proj1 Hvalid); apply run_nd_allocator_bisim. +Qed. + +(** Labels retain their interleaving: exactly one scheduling tau per actual + turn, followed by its zero or one source observation. *) +Fixpoint run_turn_labels (base : nat) (script : list Actor) (s : AState) + : option (list (@label (writerE SObs) _)) := + match script with + | [] => Some [] + | who :: rest => + match turn base who s with + | None => None + | Some (next,event) => + match run_turn_labels base rest next with + | None => None + | Some labels => Some (turn_labels event ++ labels) + end + end + end. + +Definition label_logs (labels : list (@label (writerE SObs) _)) : list SObs := + List.flat_map (fun l => match l with obs (Log o) _ => [o] | _ => [] end) labels. +Definition label_taus (labels : list (@label (writerE SObs) _)) : nat := + List.length (List.filter (fun l => match l with tau => true | _ => false end) labels). + +Lemma run_turns_labels base script : forall s last logs, + run_turns base script s = Some (last,logs) -> + exists labels, run_turn_labels base script s = Some labels /\ + label_logs labels = logs /\ label_taus labels = List.length script /\ + exists residual, finite_steps (model_nd base s) labels residual /\ + residual ~ model_nd base last. +Proof. + induction script as [|who rest IH]; intros s last logs Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst last logs. + exists []; repeat split; try reflexivity. + exists (model_nd base s); split; [constructor|reflexivity]. + - cbn [run_turns] in Hrun. + destruct (turn base who s) as [[next event]|] eqn:Hturn; [|discriminate]. + destruct (run_turns base rest next) as [[last' logs']|] eqn:Hrest; [|discriminate]. + inversion Hrun; subst last logs; clear Hrun. + destruct (IH next last' logs' Hrest) + as (labels & Hlabels & Hlogs & Htaus & residual & Hsteps & Eresidual). + exists (turn_labels event ++ labels); split. + + cbn [run_turn_labels]; rewrite Hturn, Hlabels; reflexivity. + + split. + * unfold label_logs in *; rewrite List.flat_map_app, Hlogs. + destruct event; reflexivity. + * split. + -- unfold label_taus in *; rewrite List.filter_app, List.length_app, Htaus. + destruct event; reflexivity. + -- assert (Eguard : model_nd base next ~ Guard (model_nd base next)). + { symmetry; apply sb_guard. } + destruct (finite_steps_sbisim _ _ _ Hsteps _ Eguard) + as (residual' & Hsteps' & Eresidual'). + exists residual'; split. + ++ eapply finite_steps_app; [eapply model_turn_finite_steps; exact Hturn|exact Hsteps']. + ++ transitivity residual; [symmetry; exact Eresidual'|exact Eresidual]. +Qed. + +Theorem run_turns_realizes_source capacity c script last logs : + run_turns 1 script (initial_state capacity c) = Some (last,logs) -> + exists labels residual, + run_turn_labels 1 script (initial_state capacity c) = Some labels /\ + label_logs labels = logs /\ label_taus labels = List.length script /\ + finite_steps (run_nd (allocator_program capacity) hemp c) labels residual /\ + residual ~ model_nd 1 last. +Proof. + intro Hrun; destruct (run_turns_labels 1 script (initial_state capacity c) + last logs Hrun) as (labels & Hlabels & Hlogs & Htaus & model & Hsteps & Emodel). + pose proof (run_nd_allocator_bisim capacity c) as Esource; symmetry in Esource. + destruct (finite_steps_sbisim _ _ _ Hsteps _ Esource) + as (residual & Hsource & Eresidual). + exists labels, residual; repeat split; try assumption. + transitivity model; [symmetry; exact Eresidual|exact Emodel]. +Qed. + +Lemma source_pool_replace_current n (ts : pool sE n) i : + pool_equ (ts @ i := (ts $ i)) ts. +Proof. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + - rewrite Vector.nth_replace_eq; reflexivity. + - rewrite Vector.nth_replace_neq by congruence; reflexivity. +Qed. + +Theorem source_segment_scheduler_steps (ts : pool sE 3) sigma i logs residual sigma' ts' : + ThreadSegment (ts $ i) sigma logs residual sigma' -> + pool_equ ts' (ts @ i := residual) -> + exists next, + finite_steps (interp_nd 3 ts None sigma) + (tau :: List.map (fun o => obs (Log o) tt) logs) next /\ + next ~ interp_nd 3 ts' None sigma'. +Proof. + intros Hseg Epool. + assert (Efocused : interp_nd 3 ts (Some i) sigma ~ + emit_list logs (interp_nd 3 ts' None sigma')). + { + transitivity (interp_nd 3 (ts @ i := (ts $ i)) (Some i) sigma). + - rewrite (interp_nd_equ 3 _ _ (Some i) sigma (source_pool_replace_current 3 ts i)); + reflexivity. + - transitivity (emit_list logs (interp_nd 3 (ts @ i := residual) None sigma')). + + eapply segment_interp_nd; exact Hseg. + + apply emit_list_sbisim. + rewrite <- (interp_nd_equ 3 _ _ None sigma' Epool); reflexivity. + } + assert (Hbranch : trans tau (Br 2 (fun j => interp_nd 3 ts (Some j) sigma)) + (interp_nd 3 ts (Some i) sigma)). + { eapply trans_br with (x := i); reflexivity. } + pose proof (interp_nd_select 2 ts sigma) as Eselect; symmetry in Eselect. + destruct (sbisim_trans _ _ _ tau eq Eselect Hbranch) + as (l & focused & Hchoose & El & Efocus); subst l. + assert (Eemit : emit_list logs (interp_nd 3 ts' None sigma') ~ focused). + { transitivity (interp_nd 3 ts (Some i) sigma); [symmetry; exact Efocused|exact Efocus]. } + destruct (finite_steps_sbisim _ _ _ + (finite_steps_emit_list logs (interp_nd 3 ts' None sigma')) focused Eemit) + as (next & Hlogs & Enext). + exists next; split; [econstructor; eassumption|symmetry; exact Enext]. +Qed. + +Theorem valid_source_execution_scheduler_steps capacity c se k : + valid_source_execution capacity c se -> + exists next, + finite_steps (interp_nd 3 (source_pools se k) None (source_states se k)) + (tau :: List.map (fun o => obs (Log o) tt) (source_emitted se k)) next /\ + next ~ interp_nd 3 (source_pools se (S k)) None (source_states se (S k)). +Proof. + intros (_ & _ & Hsteps); destruct (Hsteps k) as (residual & Hseg & Epool). + eapply source_segment_scheduler_steps; eassumption. +Qed. + +Definition source_pending capacity c se k : bool := + pending_turn (execution_of_choices capacity c (source_selected se)) k. + +(** A pending raw remote is one of the actual continuations after mailbox + pickup, and before remote_free returns through the successful CAS path. + This predicate mentions neither a model execution nor future publication. *) +Definition raw_remote_pending base client (t : thread sE) : Prop := + exists pc, pc <> RPoll /\ guard_equ t (remote_residual base client pc). +Definition selected_source_pending (se : SourceExecution) k : Prop := + match source_selected se k with + | Owner => False + | Remote0 => raw_remote_pending 1 false (source_pools se k $ slot_of_actor Remote0) + | Remote1 => raw_remote_pending 1 true (source_pools se k $ slot_of_actor Remote1) + end. + +Definition remote_first_event base client pc : sE := + match pc with + | RPoll => SRd (mailbox base client) + | RRead _ => SRd (remote_head base) + | RLink block old => SWr block old + | RCAS block old => SCAS (remote_head base) old block + end. + +Lemma source_raw_read_head a (K : option nat -> thread sE) : + (denote_flow (CRead a) >>= K) ≅ Vis (inr (inr (SRd a))) (fun v => K (Some v)). +Proof. + cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. +Lemma source_raw_write_head a v (K : option unit -> thread sE) : + (denote_flow (CWrite a v) >>= K) ≅ Vis (inr (inr (SWr a v))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. +Lemma source_raw_cas_head a old desired (K : option bool -> thread sE) : + (denote_flow (CCAS a old desired) >>= K) ≅ + Vis (inr (inr (SCAS a old desired))) (fun b => K (Some b)). +Proof. + cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma remote_residual_first_event base client pc : + exists k : encode (remote_first_event base client pc) -> thread sE, + remote_residual base client pc ≅ + @go CEff _ unit (VisF (inr (inr (remote_first_event base client pc)) : CEff) k). +Proof. + destruct pc; cbn [remote_first_event remote_residual]. + - unfold denote, remote_client; eexists. + etransitivity; [apply source_raw_until|]. + unfold client_round; etransitivity; [apply source_raw_bind|]. + apply source_raw_read_head. + - unfold remote_free; eexists. + etransitivity; [apply source_raw_until|]. + unfold remote_attempt; etransitivity; [apply source_raw_bind|]. + apply source_raw_read_head. + - unfold remote_link_tail; eexists. + etransitivity; [apply source_raw_bind|]; apply source_raw_write_head. + - unfold remote_cas_tail; eexists. + etransitivity; [apply source_raw_bind|]; apply source_raw_cas_head. +Qed. + +Lemma remote_poll_not_pending base client pc : + pc <> RPoll -> + not (guard_equ (remote_residual base client RPoll) (remote_residual base client pc)). +Proof. + intros Hpc E; apply guard_equ_sbisim in E. + destruct (remote_residual_first_event base client RPoll) as [kp Ep]. + destruct (remote_residual_first_event base client pc) as [kq Eq]. + rewrite Ep, Eq in E. + pose proof (@sbisim_vis_invT CEff _ unit + (inr (inr (remote_first_event base client RPoll))) + (inr (inr (remote_first_event base client pc))) kp kq 0 E) as [_ Eevent]. + destruct pc; cbn [remote_first_event] in Eevent; try contradiction; try discriminate. + unfold remote_head, mailbox in Eevent; destruct client; inversion Eevent; lia. +Qed. + +Lemma raw_remote_pending_alignment base client t pc : + guard_equ t (remote_residual base client pc) -> + (raw_remote_pending base client t <-> + match pc with RPoll => false | _ => true end = true). +Proof. + intro E; destruct pc as [|block|block old|block old]. + - split; [|discriminate]. + intros (pc & Hpc & Hraw); exfalso; apply (remote_poll_not_pending base client pc Hpc). + eapply guard_equ_trans; [apply guard_equ_sym; exact E|exact Hraw]. + - split; [reflexivity|intros _; exists (RRead block); split; [discriminate|exact E]]. + - split; [reflexivity|intros _; exists (RLink block old); split; [discriminate|exact E]]. + - split; [reflexivity|intros _; exists (RCAS block old); split; [discriminate|exact E]]. +Qed. + +Theorem source_pending_raw_spec capacity c se k : + valid_source_execution capacity c se -> + (source_pending capacity c se k = true <-> selected_source_pending se k). +Proof. + intro Hvalid; destruct (source_execution_complete capacity c se Hvalid) + as (_ & Haligned & _). + destruct (Haligned k) as [_ Hpool]. + unfold source_pending, pending_turn; rewrite execution_of_choices_selected. + unfold selected_source_pending; destruct (source_selected se k). + - split; [discriminate|contradiction]. + - symmetry; apply raw_remote_pending_alignment. + exact (Hpool (slot_of_actor Remote0)). + - symmetry; apply raw_remote_pending_alignment. + exact (Hpool (slot_of_actor Remote1)). +Qed. + +Lemma execution_of_choices_prefix capacity c picks other k : + (forall j, j < k -> picks j = other j) -> + states (execution_of_choices capacity c picks) k = + states (execution_of_choices capacity c other) k. +Proof. + induction k as [|k IH]; intro Hprefix; [reflexivity|]. + assert (E : states (execution_of_choices capacity c picks) k = + states (execution_of_choices capacity c other) k). + { apply IH; intros j Hj; apply Hprefix; lia. } + pose proof (execution_step capacity c (execution_of_choices capacity c picks) k + (execution_of_choices_valid capacity c picks)) as Hp. + pose proof (execution_step capacity c (execution_of_choices capacity c other) k + (execution_of_choices_valid capacity c other)) as Hq. + rewrite execution_of_choices_selected in Hp, Hq. + rewrite E, (Hprefix k ltac:(lia)), Hq in Hp; now inversion Hp. +Qed. + +Lemma source_pending_finite_history capacity c se other k : + (forall j, j <= k -> source_selected se j = source_selected other j) -> + source_pending capacity c se k = source_pending capacity c other k. +Proof. + intro Hprefix; unfold source_pending, pending_turn. + rewrite !execution_of_choices_selected. + rewrite (Hprefix k ltac:(lia)). + rewrite (execution_of_choices_prefix capacity c (source_selected se) + (source_selected other) k ltac:(intros j Hj; apply Hprefix; lia)). + reflexivity. +Qed. + +Definition source_has_event (kind block : nat) (se : SourceExecution) (k : nat) : Prop := + exists idx, List.In (SPop kind block idx) (source_emitted se k). + +Theorem source_remote_free_lockfree capacity c se : + valid_source_execution capacity c se -> + infinitely (fun k => source_pending capacity c se k = true) -> + infinitely (fun k => exists block, source_has_event tag_retire block se k). +Proof. + intros Hvalid Hpending. + destruct (source_execution_complete capacity c se Hvalid) + as (Hmodel & Haligned & Hlogs & Hselected). + pose proof (remote_free_lockfree capacity c + (execution_of_choices capacity c (source_selected se)) Hmodel Hpending) as Hlive. + intro n; destruct (Hlive n) as (k & Hnk & Hevent). + apply event_is_spec in Hevent as (block & idx & Hevent). + exists k; split; [exact Hnk|]; exists block, idx. + rewrite Hlogs, Hevent; cbn [turn_observations]; now left. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. +From TICL Require Import Lang.CSL. +From examples Require Import CSL.HeapQ CSL.Allocator.Layout CSL.Allocator.Model + CSL.Allocator.Execution. +Import ListNotations. +Local Open Scope nat_scope. +Local Open Scope list_scope. + +(* The ghost lists are witnesses of the existing invariant, not additional + executable state. They are used only inside propositions. *) +Definition owner_lists (capacity : nat) (s : AState) (L R D : list nat) : Prop := + 0 < 1 /\ backing 1 capacity (aheap s) /\ + exists m0 m1, + aheap s (remote_head 1) = Some (List.hd 0 R) /\ + aheap s (local_head 1) = Some (List.hd 0 L) /\ + aheap s (drain_head 1) = Some (List.hd 0 D) /\ + free_chain (aheap s) L /\ free_chain (aheap s) R /\ free_chain (aheap s) D /\ + aheap s (mailbox 1 false) = Some m0 /\ + aheap s (mailbox 1 true) = Some m1 /\ + Permutation (L ++ R ++ D ++ mailbox_nodes m0 ++ mailbox_nodes m1 ++ + held (remote0_state s) ++ held (remote1_state s)) (page_blocks 1 capacity) /\ + (match owner_state s with ODrain => True | _ => D = [] end) /\ + (match owner_state s with OCAS old => old = 0 \/ In old (page_blocks 1 capacity) + | _ => True end) /\ + cached_remote 1 capacity (aheap s) (remote0_state s) /\ + cached_remote 1 capacity (aheap s) (remote1_state s). + +Lemma owner_lists_inv capacity s L R D : + owner_lists capacity s L R D -> allocator_inv 1 capacity s. +Proof. + intros (Hb & Hback & m0 & m1 & H). + split; [exact Hb|]; split; [exact Hback|]. + exists L, R, D, m0, m1; exact H. +Qed. +Lemma inv_owner_lists capacity s : + allocator_inv 1 capacity s -> exists L R D, owner_lists capacity s L R D. +Proof. + intros (Hb & Hback & L & R & D & m0 & m1 & H). + exists L, R, D; split; [exact Hb|]; split; [exact Hback|]. + exists m0, m1; exact H. +Qed. +Lemma owner_lists_lengths capacity s L R D : + owner_lists capacity s L R D -> List.length L + List.length R + List.length D <= capacity. +Proof. + intros (_ & _ & m0 & m1 & _ & _ & _ & _ & _ & _ & _ & _ & Hp & _). + apply Permutation_length in Hp. + repeat rewrite List.length_app in Hp. + rewrite page_blocks_length in Hp; lia. +Qed. +Lemma owner_lists_disjoint capacity s L R D b : + owner_lists capacity s L R D -> In b (R ++ D) -> ~ In b L. +Proof. + intros (_ & _ & m0 & m1 & _ & _ & _ & _ & _ & _ & _ & _ & Hp & _) Hrd Hl. + pose proof (ai_partition_count 1 capacity _ Hp b) as Hcount. + repeat rewrite List.count_occ_app in Hcount. + apply (proj1 (List.count_occ_In Nat.eq_dec L b)) in Hl. + rewrite List.in_app_iff in Hrd; destruct Hrd as [Hr|Hd]. + - apply (proj1 (List.count_occ_In Nat.eq_dec R b)) in Hr; lia. + - apply (proj1 (List.count_occ_In Nat.eq_dec D b)) in Hd; lia. +Qed. + +Definition owner_after_offer (client : bool) := if client then ORead else OOffer true. +Definition owner_weight (who : Actor) : nat := match who with Owner => 1 | _ => 0 end. +Definition owner_boundary (who : Actor) (pc : owner_pc) : bool := + match who, pc with Owner, OOffer true => true | _, _ => false end. +Definition collection_phase (pc : owner_pc) : bool := + match pc with ORead | OCAS _ => true | _ => false end. +Definition owner_rank (capacity : nat) (pc : owner_pc) (R D : list nat) : nat := + match pc with + | ORead => 2 * (capacity - List.length R) + capacity + 5 + | OCAS old => 2 * (capacity - List.length R) + capacity + + (if Nat.eqb (List.hd 0 R) old then 4 else 6) + | ODrain => List.length D + 3 + | OOffer false => 2 + | OOffer true => 1 + end. +Definition owner_round_bound capacity := 3 * capacity + 5. +Definition block_event (tag block : nat) (event : option SObs) : Prop := + exists idx, event = Some (SPop tag block idx). + +(* Every constructor below is a projection of an actual executable turn. + In particular detach uses the current R, and publication prepends to R. *) +Inductive ownership_transition : + Actor -> owner_pc -> owner_pc -> option SObs -> + list nat -> list nat -> list nat -> list nat -> list nat -> list nat -> Prop := +| ownership_read L R : + ownership_transition Owner ORead (OCAS (List.hd 0 R)) None L R [] L R [] +| ownership_cas_fail old L R : + List.hd 0 R <> old -> + ownership_transition Owner (OCAS old) ORead None L R [] L R [] +| ownership_detach L R : + ownership_transition Owner (OCAS (List.hd 0 R)) ODrain None L R [] L [] R +| ownership_drain_empty L R : + ownership_transition Owner ODrain (OOffer false) None L R [] L R [] +| ownership_drain L R b D idx : + ownership_transition Owner ODrain ODrain (Some (SPop tag_reclaim b idx)) + L R (b :: D) (b :: L) R D +| ownership_offer_empty client L R : + ownership_transition Owner (OOffer client) (owner_after_offer client) None + L R [] L R [] +| ownership_offer client L R b idx : + ownership_transition Owner (OOffer client) (owner_after_offer client) + (Some (SPop tag_alloc b idx)) (b :: L) R [] L R [] +| ownership_remote who pc event L R D : + who <> Owner -> + (event = None \/ exists b idx, event = Some (SPop tag_retry b idx)) -> + ownership_transition who pc pc event L R D L R D +| ownership_publish who pc L R D b idx : + who <> Owner -> + ownership_transition who pc pc (Some (SPop tag_retire b idx)) + L R D L (b :: R) D. + +Local Ltac owner_finish T h L R D m0 m1 := + cbn [aheap acount owner_state remote0_state remote1_state] in *; + try rewrite Nat.eqb_refl in T; + repeat match goal with + | E : Nat.eqb _ _ = _ |- _ => progress rewrite E in T + end; + inversion T; subst; clear T; + exists L, R, D; split; + [ unfold owner_lists; + cbn [aheap acount owner_state remote0_state remote1_state]; + split; [assumption|]; split; [ai_backing|]; + exists m0, m1; cbn [List.hd held]; repeat split; ai_obligation h + | cbn [owner_state]; + first [apply ownership_read | apply ownership_detach | + apply ownership_drain_empty | apply ownership_drain | + apply ownership_offer_empty | apply ownership_offer | + apply ownership_cas_fail; now apply Nat.eqb_neq | + apply ownership_publish; discriminate | + apply ownership_remote; [discriminate|left; reflexivity] | + apply ownership_remote; [discriminate|right; do 2 eexists; reflexivity]] ]. + +Lemma owner_lists_step capacity who s t event L R D : + owner_lists capacity s L R D -> turn 1 who s = Some (t,event) -> + exists L' R' D', owner_lists capacity t L' R' D' /\ + ownership_transition who (owner_state s) (owner_state t) event L R D L' R' D'. +Proof. + destruct s as [h count op p0 p1]. + cbn [owner_lists aheap acount owner_state remote0_state remote1_state]. + intros (Hbase & Hback & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) T. + cbn [aheap acount owner_state remote0_state remote1_state] in *. + destruct who. + - destruct op as [|old| |client]. + + cbn in Hop; subst D. contention_reduce_turn T; rewrite Hr in T. + owner_finish T h L R (@nil nat) m0 m1. + + cbn in Hop; subst D. contention_reduce_turn T; rewrite Hr in T. + destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old. + try rewrite Nat.eqb_refl in T. + rewrite upd_neq in T by ai_distinct; rewrite Hd in T. + owner_finish T h L (@nil nat) R m0 m1. + * try rewrite Ecas in T. owner_finish T h L R (@nil nat) m0 m1. + + destruct D as [|b D]. + * contention_reduce_turn T; rewrite Hd in T; cbn [List.hd Nat.eqb] in T. + owner_finish T h L R (@nil nat) m0 m1. + * cbn [free_chain] in CD; destruct CD as [Hnext CD]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn T; rewrite Hd in T; cbn [List.hd] in T; + rewrite Eb, Hnext, Hl in T. + owner_finish T h (b :: L) R D m0 m1. + + cbn in Hop; subst D; destruct client. + * destruct m1 as [|m1]. + -- destruct L as [|b L ]. + ++ contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T; + rewrite Hl in T; cbn [List.hd Nat.eqb] in T. + owner_finish T h (@nil nat) R (@nil nat) m0 0. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T; + rewrite Hl in T; cbn [List.hd] in T; rewrite Eb, Hnext in T. + owner_finish T h L R (@nil nat) m0 b. + -- contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. + owner_finish T h L R (@nil nat) m0 (S m1). + * destruct m0 as [|m0]. + -- destruct L as [|b L ]. + ++ contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T; + rewrite Hl in T; cbn [List.hd Nat.eqb] in T. + owner_finish T h (@nil nat) R (@nil nat) 0 m1. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). + contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T; + rewrite Hl in T; cbn [List.hd] in T; rewrite Eb, Hnext in T. + owner_finish T h L R (@nil nat) b m1. + -- contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. + owner_finish T h L R (@nil nat) (S m0) m1. + - destruct p0 as [|b|b old|b old]. + + destruct m0 as [|m0]. + * contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. + owner_finish T h L R D 0 m1. + * assert (Hcell : exists v, h (S (S m0)) = Some v). + { eapply ai_backing_present; [exact Hback|ai_interval]. } + destruct Hcell as [v Hv]. + contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. + rewrite upd_neq in T by ai_distinct; rewrite Hv in T. + owner_finish T h L R D 0 m1. + + contention_reduce_turn T; rewrite Hr in T. owner_finish T h L R D m0 m1. + + cbn [cached_remote] in Hc0; destruct Hc0 as [Hbound Hneq]. + assert (Hcell : exists v, h b = Some v). + { eapply ai_backing_present; [exact Hback|ai_interval]. } + destruct Hcell as [v Hv]. contention_reduce_turn T; rewrite Hv in T. + owner_finish T h L R D m0 m1. + + cbn [cached_remote] in Hc0; destruct Hc0 as [Hbound [Hneq Hlink]]. + contention_reduce_turn T; rewrite Hr in T. + destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old; try rewrite Nat.eqb_refl in T. + owner_finish T h L (b :: R) D m0 m1. + * try rewrite Ecas in T. owner_finish T h L R D m0 m1. + - destruct p1 as [|b|b old|b old]. + + destruct m1 as [|m1]. + * contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. + owner_finish T h L R D m0 0. + * assert (Hcell : exists v, h (S (S m1)) = Some v). + { eapply ai_backing_present; [exact Hback|ai_interval]. } + destruct Hcell as [v Hv]. + contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. + rewrite upd_neq in T by ai_distinct; rewrite Hv in T. + owner_finish T h L R D m0 0. + + contention_reduce_turn T; rewrite Hr in T. owner_finish T h L R D m0 m1. + + cbn [cached_remote] in Hc1; destruct Hc1 as [Hbound Hneq]. + assert (Hcell : exists v, h b = Some v). + { eapply ai_backing_present; [exact Hback|ai_interval]. } + destruct Hcell as [v Hv]. contention_reduce_turn T; rewrite Hv in T. + owner_finish T h L R D m0 m1. + + cbn [cached_remote] in Hc1; destruct Hc1 as [Hbound [Hneq Hlink]]. + contention_reduce_turn T; rewrite Hr in T. + destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old; try rewrite Nat.eqb_refl in T. + owner_finish T h L (b :: R) D m0 m1. + * try rewrite Ecas in T. owner_finish T h L R D m0 m1. +Qed. + +Lemma ownership_rank_step capacity who pc pc' event L R D L' R' D' : + ownership_transition who pc pc' event L R D L' R' D' -> + List.length R <= capacity -> List.length D <= capacity -> + List.length R' <= capacity -> List.length D' <= capacity -> + if owner_boundary who pc + then owner_rank capacity pc' R' D' <= owner_round_bound capacity + else owner_weight who + owner_rank capacity pc' R' D' <= owner_rank capacity pc R D. +Proof. + intros Hstep Hr Hd Hr' Hd'; destruct Hstep; + cbn [owner_boundary owner_weight owner_rank owner_after_offer List.length List.hd] in *. + - rewrite Nat.eqb_refl; lia. + - assert (E : Nat.eqb (List.hd 0 R) old = false) by now apply Nat.eqb_neq. + rewrite E; lia. + - rewrite Nat.eqb_refl; lia. + - lia. + - lia. + - destruct client; cbn [owner_boundary owner_weight owner_rank owner_after_offer]; + unfold owner_round_bound; lia. + - destruct client; cbn [owner_boundary owner_weight owner_rank owner_after_offer]; + unfold owner_round_bound; lia. + - destruct who; [contradiction| |]; cbn [owner_boundary owner_weight]; lia. + - destruct who; [contradiction| |]; cbn [owner_boundary owner_weight]; + destruct pc; cbn [owner_rank List.length List.hd] in *; + repeat match goal with + | |- context [if ?b then _ else _] => destruct b eqn:? + end; lia. +Qed. +Lemma owner_rank_positive capacity pc R D : 0 < owner_rank capacity pc R D. +Proof. + destruct pc as [|old| |client]; cbn [owner_rank]; + repeat match goal with |- context [if ?b then _ else _] => destruct b end; lia. +Qed. +Lemma owner_weight_count e k : + (if owner_turn e k then 1 else 0) = owner_weight (selected e k). +Proof. unfold owner_turn; destruct (selected e k); reflexivity. Qed. + +Lemma owner_lists_step_bounded capacity who s t event L R D : + owner_lists capacity s L R D -> + owner_rank capacity (owner_state s) R D <= owner_round_bound capacity -> + turn 1 who s = Some (t,event) -> + exists L' R' D', owner_lists capacity t L' R' D' /\ + owner_rank capacity (owner_state t) R' D' <= owner_round_bound capacity /\ + ownership_transition who (owner_state s) (owner_state t) event L R D L' R' D'. +Proof. + intros Hview Hbound Hturn. + destruct (owner_lists_step capacity who s t event L R D Hview Hturn) + as (L' & R' & D' & Hview' & Hstep). + pose proof (owner_lists_lengths capacity s L R D Hview) as Hlen. + pose proof (owner_lists_lengths capacity t L' R' D' Hview') as Hlen'. + pose proof (ownership_rank_step capacity who (owner_state s) (owner_state t) + event L R D L' R' D' Hstep ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia)) as Hrank. + exists L', R', D'; split; [exact Hview'|]; split; [|exact Hstep]. + destruct (owner_boundary who (owner_state s)); lia. +Qed. +Lemma execution_owner_rank capacity c e k : + valid_execution capacity c e -> exists L R D, + owner_lists capacity (states e k) L R D /\ + owner_rank capacity (owner_state (states e k)) R D <= owner_round_bound capacity. +Proof. + intro Hv; induction k as [|k IH]. + - destruct (inv_owner_lists capacity (states e 0) (execution_inv capacity c e 0 Hv)) + as (L & R & D & Hview). + exists L, R, D; split; [exact Hview|]. + rewrite (proj1 Hv); cbn [initial_state owner_state owner_rank]. + unfold owner_round_bound; lia. + - destruct IH as (L & R & D & Hview & Hrank). + destruct (owner_lists_step_bounded capacity (selected e k) (states e k) + (states e (S k)) (emitted e k) L R D Hview Hrank + (execution_step capacity c e k Hv)) as (L' & R' & D' & Hview' & Hrank' & _). + now exists L', R', D'. +Qed. + +Definition round_completion (e : AExecution) k := + owner_boundary (selected e k) (owner_state (states e k)) = true. + +Lemma owner_round_interval_descent capacity c e lo len L R D : + valid_execution capacity c e -> owner_lists capacity (states e lo) L R D -> + (forall j, lo <= j < lo + len -> ~ round_completion e j) -> + exists L' R' D', owner_lists capacity (states e (lo + len)) L' R' D' /\ + count_if (owner_turn e) lo len + + owner_rank capacity (owner_state (states e (lo + len))) R' D' <= + owner_rank capacity (owner_state (states e lo)) R D. +Proof. + revert lo L R D; induction len as [|len IH]; intros lo L R D Hv Hview Hnone. + - rewrite Nat.add_0_r, count_if_zero; now exists L, R, D. + - destruct (owner_lists_step capacity (selected e lo) (states e lo) + (states e (S lo)) (emitted e lo) L R D Hview + (execution_step capacity c e lo Hv)) as (L1 & R1 & D1 & Hview1 & Hstep). + destruct (IH (S lo) L1 R1 D1 Hv Hview1 ltac:(intros j Hj; apply Hnone; lia)) + as (L' & R' & D' & Hview' & Hrest). + pose proof (owner_lists_lengths capacity _ _ _ _ Hview) as Hlen. + pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen1. + pose proof (ownership_rank_step capacity _ _ _ _ _ _ _ _ _ _ Hstep + ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia)) as Hrank. + assert (Hnb : owner_boundary (selected e lo) (owner_state (states e lo)) = false). + { destruct (owner_boundary (selected e lo) (owner_state (states e lo))) eqn:E; + [exfalso; apply (Hnone lo ltac:(lia)); exact E|reflexivity]. } + rewrite Hnb in Hrank. + replace (lo + S len) with (S lo + len) by lia. + exists L', R', D'; split; [exact Hview'|]. + rewrite count_if_succ, owner_weight_count; lia. +Qed. + +Theorem no_round_completion_owner_bound capacity c e lo len : + valid_execution capacity c e -> + (forall j, lo <= j < lo + len -> ~ round_completion e j) -> + count_if (owner_turn e) lo len < 3 * capacity + 5. +Proof. + intros Hv Hnone. + destruct (execution_owner_rank capacity c e lo Hv) as (L & R & D & Hview & Hbound). + destruct (owner_round_interval_descent capacity c e lo len L R D Hv Hview Hnone) + as (L' & R' & D' & _ & Hrank). + pose proof (owner_rank_positive capacity (owner_state (states e (lo + len))) R' D'). + unfold owner_round_bound in Hbound; lia. +Qed. + +Lemma owner_finite_first (P : nat -> Prop) + (dec : forall j, sumbool (P j) (not (P j))) lo len : + (forall j, lo <= j < lo + len -> ~ P j) \/ + exists j, lo <= j < lo + len /\ P j /\ forall i, lo <= i < j -> ~ P i. +Proof. + revert lo; induction len as [|len IH]; intro lo. + - left; intros; lia. + - destruct (dec lo) as [Hyes|Hno]. + + right; exists lo; split; [lia|]; split; [exact Hyes|]. + intros i Hi; lia. + + destruct (IH (S lo)) as [Hnone|(j & Hj & HP & Hfirst)]. + * left; intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; + [exact Hno|apply Hnone; lia]. + * right; exists j; split; [lia|]; split; [exact HP|]. + intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; + [exact Hno|apply Hfirst; lia]. +Qed. +Definition round_completion_dec e k : + sumbool (round_completion e k) (not (round_completion e k)). +Proof. + unfold round_completion; destruct (owner_boundary (selected e k) (owner_state (states e k))); + [left; reflexivity|right; discriminate]. +Defined. + +Theorem owner_round_selection_bound capacity c e lo len : + valid_execution capacity c e -> 3 * capacity + 5 <= count_if (owner_turn e) lo len -> + exists j, lo <= j < lo + len /\ round_completion e j /\ + count_if (owner_turn e) lo (S j - lo) <= 3 * capacity + 5. +Proof. + intros Hv Hcount. + destruct (owner_finite_first (round_completion e) (round_completion_dec e) lo len) + as [Hnone|(j & Hj & Hdone & Hfirst)]. + - pose proof (no_round_completion_owner_bound capacity c e lo len Hv Hnone); lia. + - exists j; split; [exact Hj|]; split; [exact Hdone|]. + pose proof (no_round_completion_owner_bound capacity c e lo (j-lo) Hv + ltac:(intros i Hi; apply Hfirst; lia)) as Hbefore. + replace (S j-lo) with ((j-lo)+1) by lia. + rewrite count_if_add, count_if_succ, count_if_zero. + destruct (owner_turn e (lo + (j-lo))); lia. +Qed. + +Inductive reclaim_credit (capacity block : nat) (pc : owner_pc) (R D : list nat) : nat -> Prop := +| reclaim_remote : In block R -> + reclaim_credit capacity block pc R D + (owner_rank capacity pc R D + + (if collection_phase pc then 0 else owner_round_bound capacity)) +| reclaim_detached : In block D -> + reclaim_credit capacity block pc R D (List.length D). + +Lemma reclaim_credit_positive capacity block pc R D credit : + reclaim_credit capacity block pc R D credit -> 0 < credit. +Proof. + intro H; inversion H; subst. + - pose proof (owner_rank_positive capacity pc R D); + destruct (collection_phase pc); lia. + - destruct D; cbn in *; [contradiction|lia]. +Qed. +Lemma reclaim_credit_member capacity block pc R D credit : + reclaim_credit capacity block pc R D credit -> In block (R ++ D). +Proof. intro H; inversion H; subst; apply List.in_app_iff; auto. Qed. +Lemma reclaim_credit_bound capacity block pc R D credit : + reclaim_credit capacity block pc R D credit -> + owner_rank capacity pc R D <= owner_round_bound capacity -> + List.length D <= capacity -> credit <= 2 * owner_round_bound capacity. +Proof. + intros Hcredit Hrank Hd; inversion Hcredit; subst; + unfold owner_round_bound in *; destruct (collection_phase pc); lia. +Qed. + +Lemma ownership_retire_member who pc pc' event L R D L' R' D' block : + ownership_transition who pc pc' event L R D L' R' D' -> + block_event tag_retire block event -> In block R'. +Proof. + intros Hstep [idx Hevent]; destruct Hstep; try discriminate. + - destruct H0 as [Hnone|(b & i & Hretry)]; rewrite Hnone in Hevent || + rewrite Hretry in Hevent; discriminate. + - inversion Hevent; subst; now left. +Qed. +Lemma ownership_no_premature_alloc who pc pc' event L R D L' R' D' block : + ownership_transition who pc pc' event L R D L' R' D' -> + ~ In block L -> ~ block_event tag_alloc block event. +Proof. + intros Hstep Hnot [idx Hevent]; destruct Hstep; try discriminate. + - inversion Hevent; subst; apply Hnot; now left. + - destruct H0 as [Hnone|(b & i & Hretry)]; rewrite Hnone in Hevent || + rewrite Hretry in Hevent; discriminate. +Qed. + +Lemma ownership_reclaim_credit_step capacity who pc pc' event L R D L' R' D' block credit : + ownership_transition who pc pc' event L R D L' R' D' -> + List.length R <= capacity -> List.length D <= capacity -> + List.length R' <= capacity -> List.length D' <= capacity -> + reclaim_credit capacity block pc R D credit -> + ~ block_event tag_reclaim block event -> + exists credit', reclaim_credit capacity block pc' R' D' credit' /\ + owner_weight who + credit' <= credit. +Proof. + intros Hstep Hr Hd Hr' Hd' Hcredit Hno. + destruct Hstep. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + cbn [owner_weight owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + assert (E : Nat.eqb (List.hd 0 R) old = false) by now apply Nat.eqb_neq. + cbn [owner_weight owner_rank collection_phase]; rewrite E; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_detached; eassumption|]. + cbn [owner_weight owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + cbn [owner_weight owner_rank collection_phase]; lia. + - inversion Hcredit; subst. + + eexists; split; [apply reclaim_remote; eassumption|]. + cbn [owner_weight owner_rank collection_phase List.length]; lia. + + assert (Htail : In block D). + { match goal with Hin : In block (_ :: D) |- _ => destruct Hin as [Heq|Hin] end. + - subst; exfalso; apply Hno; eexists; reflexivity. + - assumption. } + eexists; split; [apply reclaim_detached; exact Htail|]. + cbn [owner_weight List.length]; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + destruct client; cbn [owner_weight owner_rank collection_phase owner_after_offer]; + unfold owner_round_bound; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + destruct client; cbn [owner_weight owner_rank collection_phase owner_after_offer]; + unfold owner_round_bound; lia. + - exists credit; split; [exact Hcredit|]. + destruct who; cbn [owner_weight]; [contradiction|lia|lia]. + - inversion Hcredit; subst. + + eexists; split; [apply reclaim_remote; now right|]. + destruct who; [contradiction| |]; cbn [owner_weight]; + destruct pc; cbn [owner_rank collection_phase List.length List.hd] in *; + repeat match goal with + | |- context [if ?b then _ else _] => destruct b eqn:? + end; lia. + + eexists; split; [apply reclaim_detached; eassumption|]. + destruct who; cbn [owner_weight]; [contradiction|lia|lia]. +Qed. + +Lemma execution_retired_credit capacity c e k block idx : + valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> + exists L R D credit, + owner_lists capacity (states e (S k)) L R D /\ + reclaim_credit capacity block (owner_state (states e (S k))) R D credit /\ + credit <= 2 * owner_round_bound capacity. +Proof. + intros Hv Hevent. + destruct (execution_owner_rank capacity c e k Hv) as (L & R & D & Hview & Hrank). + destruct (owner_lists_step_bounded capacity (selected e k) (states e k) + (states e (S k)) (emitted e k) L R D Hview Hrank (execution_step capacity c e k Hv)) + as (L' & R' & D' & Hview' & Hrank' & Hstep). + pose proof (ownership_retire_member _ _ _ _ _ _ _ _ _ _ block Hstep + ltac:(exists idx; exact Hevent)) as Hin. + pose proof (reclaim_remote capacity block (owner_state (states e (S k))) R' D' Hin) as Hcredit. + exists L', R', D', (owner_rank capacity (owner_state (states e (S k))) R' D' + + (if collection_phase (owner_state (states e (S k))) then 0 else owner_round_bound capacity)). + split; [exact Hview'|]; split; [exact Hcredit|]. + eapply reclaim_credit_bound; [exact Hcredit|exact Hrank'|]. + pose proof (owner_lists_lengths capacity _ _ _ _ Hview'); lia. +Qed. + +Lemma reclaim_interval_descent capacity c e lo len L R D block credit : + valid_execution capacity c e -> owner_lists capacity (states e lo) L R D -> + reclaim_credit capacity block (owner_state (states e lo)) R D credit -> + (forall j, lo <= j < lo + len -> ~ block_event tag_reclaim block (emitted e j)) -> + exists L' R' D' credit', + owner_lists capacity (states e (lo + len)) L' R' D' /\ + reclaim_credit capacity block (owner_state (states e (lo + len))) R' D' credit' /\ + count_if (owner_turn e) lo len + credit' <= credit. +Proof. + revert lo L R D credit; induction len as [|len IH]; + intros lo L R D credit Hv Hview Hcredit Hnone. + - rewrite Nat.add_0_r, count_if_zero; exists L, R, D, credit; auto. + - destruct (owner_lists_step capacity (selected e lo) (states e lo) + (states e (S lo)) (emitted e lo) L R D Hview (execution_step capacity c e lo Hv)) + as (L1 & R1 & D1 & Hview1 & Hstep). + pose proof (owner_lists_lengths capacity _ _ _ _ Hview) as Hlen. + pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen1. + destruct (ownership_reclaim_credit_step capacity _ _ _ _ _ _ _ _ _ _ block credit Hstep + ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia) Hcredit (Hnone lo ltac:(lia))) + as [credit1 [Hcredit1 Hrank]]. + destruct (IH (S lo) L1 R1 D1 credit1 Hv Hview1 Hcredit1 + ltac:(intros j Hj; apply Hnone; lia)) as (L' & R' & D' & credit' & Hview' & Hcredit' & Hrest). + replace (lo + S len) with (S lo + len) by lia. + exists L', R', D', credit'; split; [exact Hview'|]; split; [exact Hcredit'|]. + rewrite count_if_succ, owner_weight_count; lia. +Qed. + +Definition block_event_dec tag block event : + sumbool (block_event tag block event) (not (block_event tag block event)). +Proof. + destruct event as [[kind b idx]|]. + - destruct (Nat.eq_dec kind tag) as [->|Hkind]; + destruct (Nat.eq_dec b block) as [->|Hb]. + + left; exists idx; reflexivity. + + right; intros [i H]; inversion H; contradiction. + + right; intros [i H]; inversion H; contradiction. + + right; intros [i H]; inversion H; contradiction. + - right; intros [i H]; discriminate. +Defined. + +Theorem no_reclaim_owner_bound capacity c e k block idx len : + valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> + (forall j, S k <= j < S k + len -> ~ block_event tag_reclaim block (emitted e j)) -> + count_if (owner_turn e) (S k) len < 6 * capacity + 10. +Proof. + intros Hv Hevent Hnone. + destruct (execution_retired_credit capacity c e k block idx Hv Hevent) + as (L & R & D & credit & Hview & Hcredit & Hbound). + destruct (reclaim_interval_descent capacity c e (S k) len L R D block credit + Hv Hview Hcredit Hnone) as (L' & R' & D' & credit' & _ & Hcredit' & Hrank). + pose proof (reclaim_credit_positive _ _ _ _ _ _ Hcredit'). + unfold owner_round_bound in Hbound; lia. +Qed. + +Theorem retired_reclaimed_owner_selection_bound capacity c e k block idx len : + valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> + 6 * capacity + 10 <= count_if (owner_turn e) (S k) len -> + exists j idx', k < j /\ j < S k + len /\ idx < idx' /\ + emitted e j = Some (SPop tag_reclaim block idx') /\ + count_if (owner_turn e) (S k) (j-k) <= 6 * capacity + 10. +Proof. + intros Hv Hret Hcount. + destruct (owner_finite_first (fun j => block_event tag_reclaim block (emitted e j)) + (fun j => block_event_dec tag_reclaim block (emitted e j)) (S k) len) + as [Hnone|(j & Hj & [idx' Hreclaim] & Hfirst)]. + - pose proof (no_reclaim_owner_bound capacity c e k block idx len Hv Hret Hnone); lia. + - exists j, idx'; split; [lia|]; split; [lia|]; split. + + exact (execution_event_order capacity c e k j _ _ Hv ltac:(lia) Hret Hreclaim). + + split; [exact Hreclaim|]. + pose proof (no_reclaim_owner_bound capacity c e k block idx (j-S k) Hv Hret + ltac:(intros q Hq; apply Hfirst; lia)) as Hbefore. + replace (j-k) with ((j-S k)+1) by lia. + rewrite count_if_add, count_if_succ, count_if_zero. + destruct (owner_turn e (S k + (j-S k))); lia. +Qed. + +Lemma infinitely_owner_count e : + infinitely (fun k => selected e k = Owner) -> + forall lo n, exists len, n <= count_if (owner_turn e) lo len. +Proof. + intros Hinf lo n; induction n as [|n IH]. + - exists 0; rewrite count_if_zero; lia. + - destruct IH as [len Hlen]. + destruct (Hinf (lo+len)) as (k & Hk & Howner). + exists (len + ((k-(lo+len))+1)). + rewrite count_if_add, count_if_add. + replace (lo + len + (k - (lo + len))) with k by lia. + rewrite count_if_succ, count_if_zero. + assert (Heq : owner_turn e k = true) by (apply owner_turn_spec; exact Howner). + rewrite Heq; lia. +Qed. + +Theorem retired_eventually_reclaimed capacity c e : + valid_execution capacity c e -> + infinitely (fun k => selected e k = Owner) -> + forall k block idx, + emitted e k = Some (SPop tag_retire block idx) -> + exists j idx', k < j /\ idx < idx' /\ + emitted e j = Some (SPop tag_reclaim block idx'). +Proof. + intros Hv Howner k block idx Hret. + destruct (infinitely_owner_count e Howner (S k) (6*capacity+10)) as [len Hlen]. + destruct (retired_reclaimed_owner_selection_bound capacity c e k block idx len + Hv Hret Hlen) as (j & idx' & Hkj & _ & Hidx & Hevent & _). + now exists j, idx'. +Qed. + +Theorem retired_not_reallocated_before_reclaim capacity c e k block idx j : + valid_execution capacity c e -> + emitted e k = Some (SPop tag_retire block idx) -> k < j -> + (forall q idx', k < q < j -> emitted e q <> Some (SPop tag_reclaim block idx')) -> + forall idx', emitted e j <> Some (SPop tag_alloc block idx'). +Proof. + intros Hv Hret Hkj Hnone idx' Halloc. + destruct (execution_retired_credit capacity c e k block idx Hv Hret) + as (L & R & D & credit & Hview & Hcredit & Hbound). + destruct (reclaim_interval_descent capacity c e (S k) (j-S k) L R D block credit + Hv Hview Hcredit ltac:(intros q Hq [i Hi]; apply (Hnone q i); [lia|exact Hi])) + as (Lj & Rj & Dj & creditj & Hviewj & Hcreditj & _). + replace (S k + (j-S k)) with j in Hviewj, Hcreditj by lia. + pose proof (reclaim_credit_member _ _ _ _ _ _ Hcreditj) as Hin. + pose proof (owner_lists_disjoint capacity (states e j) Lj Rj Dj block Hviewj Hin) as Hnot. + destruct (owner_lists_step capacity (selected e j) (states e j) + (states e (S j)) (emitted e j) Lj Rj Dj Hviewj (execution_step capacity c e j Hv)) + as (L' & R' & D' & _ & Hstep). + eapply (ownership_no_premature_alloc _ _ _ _ _ _ _ _ _ _ block Hstep Hnot). + exists idx'; exact Halloc. +Qed. + +Theorem retired_reallocation_requires_reclaim capacity c e k j block idx alloc_idx : + valid_execution capacity c e -> k < j -> + emitted e k = Some (SPop tag_retire block idx) -> + emitted e j = Some (SPop tag_alloc block alloc_idx) -> + exists q reclaim_idx, k < q /\ q < j /\ idx < reclaim_idx /\ + reclaim_idx < alloc_idx /\ emitted e q = Some (SPop tag_reclaim block reclaim_idx). +Proof. + intros Hv Hkj Hret Halloc. + destruct (owner_finite_first (fun q => block_event tag_reclaim block (emitted e q)) + (fun q => block_event_dec tag_reclaim block (emitted e q)) (S k) (j-S k)) + as [Hnone|(q & Hq & [qi Hreclaim] & _)]. + - exfalso; eapply retired_not_reallocated_before_reclaim; + [exact Hv|exact Hret|exact Hkj| |exact Halloc]. + intros q qi Hq Hreclaim; apply (Hnone q ltac:(lia)); now exists qi. + - exists q, qi; split; [lia|]; split; [lia|]; split. + + exact (execution_event_order capacity c e k q _ _ Hv ltac:(lia) Hret Hreclaim). + + split; [|exact Hreclaim]. + exact (execution_event_order capacity c e q j _ _ Hv ltac:(lia) Hreclaim Halloc). +Qed. + +Theorem source_retired_eventually_reclaimed capacity c se : + valid_source_execution capacity c se -> + infinitely (fun k => source_selected se k = Owner) -> + forall k block idx, + List.In (SPop tag_retire block idx) (source_emitted se k) -> + exists j idx', k < j /\ idx < idx' /\ + List.In (SPop tag_reclaim block idx') (source_emitted se j). +Proof. + intros Hvalid Howner k block idx Hretire. + destruct (source_execution_complete capacity c se Hvalid) + as (Hmodel & Haligned & Hlogs & Hselected). + set (e := execution_of_choices capacity c (source_selected se)) in *. + assert (Howner' : infinitely (fun j => selected e j = Owner)). + { + intro n; destruct (Howner n) as (j & Hnj & Hwho). + exists j; split; [exact Hnj|now rewrite Hselected]. + } + assert (Eretire : emitted e k = Some (SPop tag_retire block idx)). + { + rewrite Hlogs in Hretire. + destruct (emitted e k) as [o|] eqn:E; cbn [turn_observations] in Hretire; + [destruct Hretire as [<-|[]]; reflexivity|contradiction]. + } + destruct (retired_eventually_reclaimed capacity c e Hmodel Howner' + k block idx Eretire) as (j & idx' & Hkj & Hij & Ereclaim). + exists j, idx'; repeat split; try assumption. + rewrite Hlogs, Ereclaim; cbn [turn_observations]; now left. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Eq.Bind ICTree.Logic.AF ICTree.Logic.AG + ICTree.Logic.AX ICTree.Logic.Bind ICTree.Logic.Iter ICTree.Logic.State Logic.Core. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. +Local Typeclasses Transparent equ sbisim. + +(** These lists use left numerals so that symbolic counters compute without + inspecting the counter. [n+c] is, of course, the prescribed [c+n]. *) +Definition demo_prefix (c : nat) : list SObs := + [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); + SPop tag_retire 6 (2+c); SPop tag_retry 8 (3+c); + SPop tag_retire 8 (4+c); SPop tag_reclaim 8 (5+c); + SPop tag_reclaim 6 (6+c); SPop tag_alloc 6 (7+c); + SPop tag_alloc 8 (8+c)]. + +Definition demo_cycle_logs (c : nat) : list SObs := + [SPop tag_retire 6 c; SPop tag_retry 8 (1+c); + SPop tag_retire 8 (2+c); SPop tag_reclaim 8 (3+c); + SPop tag_reclaim 6 (4+c); SPop tag_alloc 6 (5+c); + SPop tag_alloc 8 (6+c)]. + +Definition demo_rr_script (cursor len : nat) : list Actor := + List.map (fun k => actor_of_slot (rr_pick 2 k)) (List.seq cursor len). + +(** Only a pointwise representative; no execution ever resets its heap to it. *) +Definition demo_boundary_heap : Heap := fun x => + match x with + | 1 => Some 0 | 2 => Some 0 | 3 => Some 0 | 4 => Some 0 + | 5 => Some 8 | 6 => Some 8 | 7 => Some 1 | 8 => Some 0 + | 9 => Some 2 | _ => None + end. +Definition demo_boundary (c : nat) : AState := + {| aheap := demo_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RRead 6; + remote1_state := RPoll |}. + +Lemma demo_prefix_run c : exists last, + run_turns 1 (demo_rr_script 0 57) (initial_state 2 c) = + Some (last,demo_prefix c) /\ + state_equiv last (demo_boundary (c+9)). +Proof. + replace (c+9) with (9+c) by lia. + eexists; split; [vm_compute; reflexivity|]. + unfold state_equiv; split. + - intro x. + do 10 (destruct x as [|x]; [vm_compute; reflexivity|]). + vm_compute; reflexivity. + - vm_compute; repeat split; reflexivity. +Qed. + +Lemma demo_cycle_run c : exists last, + run_turns 1 (demo_rr_script 0 42) (demo_boundary c) = + Some (last,demo_cycle_logs c) /\ + state_equiv last (demo_boundary (c+7)). +Proof. + replace (c+7) with (7+c) by lia. + eexists; split; [vm_compute; reflexivity|]. + unfold state_equiv; split. + - intro x. + do 10 (destruct x as [|x]; [vm_compute; reflexivity|]). + vm_compute; reflexivity. + - vm_compute; repeat split; reflexivity. +Qed. + +(** The actual returned heap is passed to the following cycle. *) +Lemma demo_cycle_run_actual c s : + state_equiv s (demo_boundary c) -> + exists last, + run_turns 1 (demo_rr_script 0 42) s = Some (last,demo_cycle_logs c) /\ + state_equiv last (demo_boundary (c+7)). +Proof. + intro Hs; destruct (demo_cycle_run c) as (last & Hrun & Hlast). + destruct (run_turns_respects_heq_some 1 (demo_rr_script 0 42) + (demo_boundary c) s last (demo_cycle_logs c) + (state_equiv_sym _ _ Hs) Hrun) as (actual & Hactual & Heq). + exists actual; split; [exact Hactual|]. + eapply state_equiv_trans; [apply state_equiv_sym; exact Heq|exact Hlast]. +Qed. + +Lemma demo_cycle_cursor cursor : (cursor+42) mod 3 = cursor mod 3. +Proof. + rewrite Nat.Div0.add_mod. + change ((cursor mod 3 + 0) mod 3 = cursor mod 3). + rewrite Nat.add_0_r, Nat.Div0.mod_mod; reflexivity. +Qed. + +Lemma demo_rr_run_turns base len cursor s last logs : + run_turns base (demo_rr_script cursor len) s = Some (last,logs) -> + model_rr base s cursor ~ emit_list logs (model_rr base last (cursor+len)). +Proof. + revert cursor s last logs. + induction len as [|len IH]; intros cursor s last logs Hrun. + - cbn [demo_rr_script List.seq List.map run_turns] in Hrun. + inversion Hrun; subst; rewrite Nat.add_0_r; reflexivity. + - cbn [demo_rr_script List.seq List.map run_turns] in Hrun. + destruct (turn base (actor_of_slot (rr_pick 2 cursor)) s) + as [[next event]|] eqn:Hturn; [|discriminate]. + destruct (run_turns base + (List.map (fun k => actor_of_slot (rr_pick 2 k)) (List.seq (S cursor) len)) next) + as [[last' suffix]|] eqn:Hrest; [|discriminate]. + inversion Hrun; subst last' logs. + replace (cursor+S len) with (S cursor+len) by lia. + rewrite unfold_model_rr, Hturn. + destruct event as [o|]. + + rewrite emit_list_cons; apply sb_vis; intros []. + rewrite sb_guard; eapply IH; exact Hrest. + + rewrite sb_guard; eapply IH; exact Hrest. +Qed. + +Lemma demo_rr_period c : + model_rr 1 (demo_boundary c) 0 ~ + emit_list (demo_cycle_logs c) (model_rr 1 (demo_boundary (c+7)) 0). +Proof. + destruct (demo_cycle_run c) as (last & Hrun & Hlast). + etransitivity; [exact (demo_rr_run_turns 1 42 0 _ _ _ Hrun)|]. + apply emit_list_sbisim, model_rr_respects_heq; [exact Hlast|reflexivity]. +Qed. + +Definition demo_cycle (c : nat) : ictreeW SObs (unit * SSig) := + ICtree.iter (fun n => emit_list (demo_cycle_logs n) + (Ret (@inl nat (unit * SSig) (n+7)))) c. + +Lemma demo_cycle_unfold c : + demo_cycle c ~ emit_list (demo_cycle_logs c) (demo_cycle (c+7)). +Proof. + unfold demo_cycle at 1; rewrite sb_unfold_iter. + rewrite emit_list_ret_bind; reflexivity. +Qed. + +Lemma demo_rr_cycle_bisim : forall c, + model_rr 1 (demo_boundary c) 0 ~ demo_cycle c. +Proof. + unfold sbisim; apply_coinduction; fold_sbisim; intros R IH c. + etransitivity; [apply (coinduction.gfp_bt (sb eq) R), demo_rr_period|]. + etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; + apply demo_cycle_unfold]. + change (coinduction.bt (sb eq) R + (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) + (model_rr 1 (demo_boundary (c+7)) 0)) + (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) + (demo_cycle (c+7)))). + eapply equ_sbt_closed_goal; [apply emit_list_cons|apply emit_list_cons|]. + apply step_sb_vis. + - intros []; exists tt; split; [|reflexivity]. + apply nd_st_emit_list; apply IH. + - intros []; exists tt; split; [|reflexivity]. + apply nd_st_emit_list; apply IH. +Qed. + +Theorem run_rr_allocator_demo_bisim c : + run_rr (allocator_program 2) hemp c ~ + emit_list (demo_prefix c) (demo_cycle (c+9)). +Proof. + rewrite run_rr_allocator_bisim. + destruct (demo_prefix_run c) as (last & Hrun & Hlast). + etransitivity; [exact (demo_rr_run_turns 1 57 0 _ _ _ Hrun)|]. + apply emit_list_sbisim. + etransitivity; [apply (model_rr_respects_heq 1 last (demo_boundary (c+9)) 57 0); + [exact Hlast|reflexivity]|]. + apply demo_rr_cycle_bisim. +Qed. + +Fixpoint after_logs (xs : list SObs) (w : WorldW SObs) : WorldW SObs := + match xs with + | [] => w + | o :: rest => after_logs rest (Obs (Log o) tt) + end. + +Lemma after_logs_not_done xs w : not_done w -> not_done (after_logs xs w). +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd; cbn [after_logs]. + - exact Hd. + - apply IH; constructor. +Qed. + +Lemma af_emit_list {X} xs (t : ictreeW SObs X) w P : + not_done w -> + <( t, {after_logs xs w} |= AF visW {P} )> -> + <( {emit_list xs t}, w |= AF visW {P} )>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. + change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; [exact Hd|]. + apply IH; [constructor|exact H]. +Qed. + +Lemma agaf_emit_list {X} xs (t : ictreeW SObs X) w P : + not_done w -> + <( t, {after_logs xs w} |= AG (AF visW {P}) )> -> + <( {emit_list xs t}, w |= AG (AF visW {P}) )>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. + assert (Htail : <( {emit_list rest t}, {Obs (Log o) tt} + |= AG (AF visW {P}) )>). + { apply IH; [constructor|exact H]. } + assert (Haf : <( {emit_list rest t}, {Obs (Log o) tt} |= AF visW {P} )>). + { pose proof Htail as HH; cdestruct HH; assumption. } + assert (Hprefix : <( {emit_list (o :: rest) t}, w |= AF visW {P} )>). + { change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; assumption. } + rewrite emit_list_cons in Hprefix |- *. + apply (proj1 (@ag_vis (writerE SObs) _ X (Log o) + (fun _ => emit_list rest t) tt w _)); split. + - exact Hprefix. + - intros []; exact Htail. +Qed. + +Lemma af_emit_list_member {X} xs (t : ictreeW SObs X) w P o : + not_done w -> List.In o xs -> P o -> + <( {emit_list xs t}, w |= AF visW {P} )>. +Proof. + revert w; induction xs as [|a rest IH]; intros w Hd Hin HP; + [contradiction|]. + change <( {log a ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; [exact Hd|]. + destruct Hin as [<-|Hin]. + - cleft; apply ticll_vis; constructor; exact HP. + - apply IH; [constructor|exact Hin|exact HP]. +Qed. + +Lemma af_emit_list_ret {X} xs (r : X) w (Q : X -> WorldW SObs -> Prop) : + not_done w -> Q r (after_logs xs w) -> + <[ {emit_list xs (Ret r)}, w |= AF AX done {Q} ]>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd HQ. + - cleft; apply axr_ret; assumption. + - change <[ {log o ;; emit_list rest (Ret r)}, w |= AF AX done {Q} ]>. + apply afr_log; [exact Hd|]. + apply IH; [constructor|exact HQ]. +Qed. + +Lemma demo_cycle_fresh_member c kind : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> + exists o, List.In o (demo_cycle_logs c) /\ stag o = kind /\ c <= sidx o. +Proof. + intros [<-|[<-|[<-|[]]]]. + - exists (SPop tag_alloc 6 (5+c)); cbn [demo_cycle_logs List.In stag sidx]; + repeat split; intuition lia. + - exists (SPop tag_retire 6 c); cbn [demo_cycle_logs List.In stag sidx]; + repeat split; intuition lia. + - exists (SPop tag_reclaim 8 (3+c)); cbn [demo_cycle_logs List.In stag sidx]; + repeat split; intuition lia. +Qed. + +Lemma demo_cycle_af c kind kb w : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> + <( {demo_cycle c}, w |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. +Proof. + intros Hkind Hd; unfold demo_cycle. + eapply aul_iter_nat with (Ri := fun (_ : nat) (_ : WorldW SObs) => True) + (f := fun n (_ : WorldW SObs) => kb-n). + - exact Hd. + - exact I. + - intros n v Hv _; destruct (Nat.le_gt_cases kb n) as [Hle|Hlt]. + + left; destruct (demo_cycle_fresh_member n kind Hkind) as (o & Hin & Htag & Hidx). + eapply af_emit_list_member; [exact Hv|exact Hin|]. + split; [exact Htag|lia]. + + right; apply af_emit_list_ret; [exact Hv|]. + exists (n+7); split; [reflexivity|]. + split; [apply after_logs_not_done; exact Hv|]. + split; [exact I|lia]. +Qed. + +(** A proof-only presentation which exposes a single observation per body. + [ag_iter] requires its invariant at *finite-body* residuals. Splitting the + body at logs allows their eventuality proof to use the next complete cycle, + instead of incorrectly asking the finite seven-log body to publish again. *) +Definition demo_log_body (p : list SObs * nat) + : ictreeW SObs ((list SObs * nat) + (unit * SSig)) := + let '(xs,c) := p in + match xs with + | [] => log (SPop tag_retire 6 c);; + Ret (inl (List.tl (demo_cycle_logs c),c+7)) + | o :: rest => log o;; Ret (inl (rest,c)) + end. +Definition demo_log_loop (xs : list SObs) (c : nat) + : ictreeW SObs (unit * SSig) := ICtree.iter demo_log_body (xs,c). + +Lemma demo_log_loop_unfold xs c : + demo_log_loop xs c ~ + match xs with + | [] => log (SPop tag_retire 6 c);; + demo_log_loop (List.tl (demo_cycle_logs c)) (c+7) + | o :: rest => log o;; demo_log_loop rest c + end. +Proof. + unfold demo_log_loop at 1; rewrite sb_unfold_iter. + unfold demo_log_body; destruct xs as [|o rest]; cbn beta iota zeta. + all: rewrite bind_bind; apply sbisim_clo_bind_eq; [reflexivity|]. + all: intros []; rewrite bind_ret_l; reflexivity. +Qed. + +Lemma demo_log_loop_bisim : forall xs c, + demo_log_loop xs c ~ emit_list xs (demo_cycle c). +Proof. + unfold sbisim; apply_coinduction; fold_sbisim; intros R IH xs c. + etransitivity; [apply (coinduction.gfp_bt (sb eq) R), demo_log_loop_unfold|]. + destruct xs as [|o rest]. + - cbn [emit_list List.fold_right]. + etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; + apply demo_cycle_unfold]. + change (coinduction.bt (sb eq) R + (log (SPop tag_retire 6 c);; + demo_log_loop (List.tl (demo_cycle_logs c)) (c+7)) + (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) + (demo_cycle (c+7)))). + eapply equ_sbt_closed_goal; + [apply (emit_list_cons (SPop tag_retire 6 c) [] _)|apply emit_list_cons|]. + apply step_sb_vis. + + intros []; exists tt; split; [apply IH|reflexivity]. + + intros []; exists tt; split; [apply IH|reflexivity]. + - eapply equ_sbt_closed_goal; + [apply (emit_list_cons o [] _)|apply emit_list_cons|]. + apply step_sb_vis. + + intros []; exists tt; split; [apply IH|reflexivity]. + + intros []; exists tt; split; [apply IH|reflexivity]. +Qed. + +Lemma demo_log_loop_af xs c kind kb w : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> + <( {demo_log_loop xs c}, w |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. +Proof. + intros Hkind Hd; rewrite demo_log_loop_bisim. + apply af_emit_list; [exact Hd|]. + apply demo_cycle_af; [exact Hkind|]. + apply after_logs_not_done; exact Hd. +Qed. + +Lemma demo_log_loop_agaf xs c kind kb w : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> + <( {demo_log_loop xs c}, w |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. +Proof. + intros Hkind Hd; unfold demo_log_loop. + eapply ag_iter with (R := fun (_ : list SObs * nat) v => not_done v). + - exact Hd. + - intros [ys n] v Hv; split. + + change <( {demo_log_loop ys n}, v + |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. + apply demo_log_loop_af; assumption. + + unfold demo_log_body; cbn beta iota zeta. + destruct ys as [|o rest]. + * apply axr_log; [exact Hv|]. + cleft; apply axr_ret; [constructor|]. + exists (List.tl (demo_cycle_logs n),n+7); split; [reflexivity|constructor]. + * apply axr_log; [exact Hv|]. + cleft; apply axr_ret; [constructor|]. + exists (rest,n); split; [reflexivity|constructor]. +Qed. + +Lemma demo_cycle_agaf c kind kb w : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> + <( {demo_cycle c}, w |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. +Proof. + intros Hkind Hd. + change <( {emit_list [] (demo_cycle c)}, w + |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. + rewrite <- (demo_log_loop_bisim [] c). + apply demo_log_loop_agaf; assumption. +Qed. + +Theorem allocator_demo_agaf_fresh c kind kb : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> + <( {run_rr (allocator_program 2) hemp c}, Pure + |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. +Proof. + intro Hkind; rewrite run_rr_allocator_demo_bisim. + apply agaf_emit_list; [constructor|]. + apply demo_cycle_agaf; [exact Hkind|]. + apply after_logs_not_done; constructor. +Qed. diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v new file mode 100644 index 0000000..8e72e5e --- /dev/null +++ b/examples/CSL/Allocator/Model.v @@ -0,0 +1,1081 @@ +From Stdlib Require Import List Lia Arith.PeanoNat Fin Sorting.Permutation. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Interp.Refine. +From examples Require Import CSL.HeapQ CSL.Allocator.Layout. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. + +Inductive Actor := Owner | Remote0 | Remote1. +Inductive owner_pc := ORead | OCAS (old : nat) | ODrain | OOffer (client : bool). +Inductive remote_pc := RPoll | RRead (block : nat) + | RLink (block old : nat) | RCAS (block old : nat). +Record AState := { + aheap : Heap; + acount : nat; + owner_state : owner_pc; + remote0_state : remote_pc; + remote1_state : remote_pc +}. + +(** One selected source segment, ending at its first yield. The helpers + below only assemble this example's result; missing checked cells fault. *) +Definition turn (base : nat) (who : Actor) (s : AState) + : option (AState * option SObs) := + let finish (h : Heap) (op : owner_pc) (r0 r1 : remote_pc) + (event : option (nat * nat)) := + Some ({| aheap := h; + acount := match event with None => acount s | Some _ => S (acount s) end; + owner_state := op; remote0_state := r0; remote1_state := r1 |}, + match event with None => None + | Some (tag,block) => Some (SPop tag block (acount s)) end) in + let own pc h event := finish h pc (remote0_state s) (remote1_state s) event in + let remote (client : bool) := + let pc := if client then remote1_state s else remote0_state s in + let done pc h event := + if client then finish h (owner_state s) (remote0_state s) pc event + else finish h (owner_state s) pc (remote1_state s) event in + match pc with + | RPoll => + match aheap s (mailbox base client) with + | None => None + | Some block => + if Nat.eqb block 0 then done RPoll (aheap s) None + else + let h := upd (aheap s) (mailbox base client) 0 in + match h (S block) with + | None => None + | Some _ => done (RRead block) + (upd h (S block) (if client then 2 else 1)) None + end + end + | RRead block => + match aheap s (remote_head base) with + | None => None + | Some old => done (RLink block old) (aheap s) None + end + | RLink block old => + match aheap s block with + | None => None + | Some _ => done (RCAS block old) (upd (aheap s) block old) None + end + | RCAS block old => + match aheap s (remote_head base) with + | None => None + | Some current => + if Nat.eqb current old + then done RPoll (upd (aheap s) (remote_head base) block) + (Some (tag_retire,block)) + else done (RRead block) (aheap s) (Some (tag_retry,block)) + end + end in + match who with + | Remote0 => remote false + | Remote1 => remote true + | Owner => + match owner_state s with + | ORead => + match aheap s (remote_head base) with + | None => None + | Some old => own (OCAS old) (aheap s) None + end + | OCAS old => + match aheap s (remote_head base) with + | None => None + | Some current => + if Nat.eqb current old then + let h := upd (aheap s) (remote_head base) 0 in + match h (drain_head base) with + | None => None + | Some _ => own ODrain (upd h (drain_head base) old) None + end + else own ORead (aheap s) None + end + | ODrain => + match aheap s (drain_head base) with + | None => None + | Some block => + if Nat.eqb block 0 then own (OOffer false) (aheap s) None + else + match aheap s block, aheap s (local_head base) with + | Some next, Some local => + own ODrain + (upd (upd (upd (aheap s) block local) + (local_head base) block) (drain_head base) next) + (Some (tag_reclaim,block)) + | _, _ => None + end + end + | OOffer client => + let next := if client then ORead else OOffer true in + match aheap s (mailbox base client) with + | None => None + | Some offered => + if Nat.eqb offered 0 then + match aheap s (local_head base) with + | None => None + | Some block => + if Nat.eqb block 0 then own next (aheap s) None + else + match aheap s block with + | None => None + | Some successor => + own next + (upd (upd (aheap s) (local_head base) successor) + (mailbox base client) block) + (Some (tag_alloc,block)) + end + end + else own next (aheap s) None + end + end + end. + +Definition initial_state (capacity c : nat) : AState := + {| aheap := page_heap 1 capacity hemp; acount := c; + owner_state := ORead; remote0_state := RPoll; remote1_state := RPoll |}. + +Fixpoint free_chain (h : Heap) (nodes : list nat) : Prop := + match nodes with + | [] => True + | block :: rest => h block = Some (hd 0 rest) /\ free_chain h rest + end. + +Definition held (pc : remote_pc) : list nat := + match pc with RPoll => [] | RRead block | RLink block _ | RCAS block _ => [block] end. +Definition mailbox_nodes (block : nat) : list nat := + if Nat.eqb block 0 then [] else [block]. +Definition cached_remote (base capacity : nat) (h : Heap) (pc : remote_pc) : Prop := + match pc with + | RPoll | RRead _ => True + | RLink block old => + (old = 0 \/ In old (page_blocks base capacity)) /\ old <> block + | RCAS block old => + (old = 0 \/ In old (page_blocks base capacity)) /\ old <> block /\ + h block = Some old + end. +Definition backing (base capacity : nat) (h : Heap) : Prop := + forall x, h x <> None <-> base <= x /\ x < base + page_size capacity. + +Definition allocator_inv (base capacity : nat) (s : AState) : Prop := + 0 < base /\ backing base capacity (aheap s) /\ + exists (L R D : list nat) (m0 m1 : nat), + aheap s (remote_head base) = Some (hd 0 R) /\ + aheap s (local_head base) = Some (hd 0 L) /\ + aheap s (drain_head base) = Some (hd 0 D) /\ + free_chain (aheap s) L /\ free_chain (aheap s) R /\ free_chain (aheap s) D /\ + aheap s (mailbox base false) = Some m0 /\ + aheap s (mailbox base true) = Some m1 /\ + Permutation (L ++ R ++ D ++ mailbox_nodes m0 ++ mailbox_nodes m1 ++ + held (remote0_state s) ++ held (remote1_state s)) (page_blocks base capacity) /\ + (match owner_state s with ODrain => True | _ => D = [] end) /\ + (match owner_state s with + | OCAS old => old = 0 \/ In old (page_blocks base capacity) + | _ => True end) /\ + cached_remote base capacity (aheap s) (remote0_state s) /\ + cached_remote base capacity (aheap s) (remote1_state s). + +Definition state_equiv (s t : AState) : Prop := + heq (aheap s) (aheap t) /\ acount s = acount t /\ + owner_state s = owner_state t /\ remote0_state s = remote0_state t /\ + remote1_state s = remote1_state t. + +Fixpoint run_turns (base : nat) (script : list Actor) (s : AState) + : option (AState * list SObs) := + match script with + | [] => Some (s,[]) + | who :: rest => + match turn base who s with + | None => None + | Some (next,event) => + match run_turns base rest next with + | None => None + | Some (last,logs) => + Some (last,match event with None => logs | Some o => o :: logs end) + end + end + end. + +Lemma init_chain_links h nodes : + (forall prefix block rest, nodes = prefix ++ block :: rest -> + h block = Some (hd 0 rest)) -> free_chain h nodes. +Proof. + induction nodes as [|block rest IH]; intro Links; [exact I|]. + split. + - exact (Links [] block rest eq_refl). + - apply IH; intros prefix next tail E. + apply (Links (block :: prefix) next tail); cbn; now rewrite E. +Qed. + +Lemma initial_state_inv capacity c : + allocator_inv 1 capacity (initial_state capacity c). +Proof. + unfold allocator_inv, initial_state; cbn [aheap owner_state remote0_state remote1_state]. + split; [lia|]; split. + - intro x; apply page_heap_closed_dom. + - exists (page_blocks 1 capacity), [], [], 0, 0. + split; [apply page_heap_remote|]. + split; [apply page_heap_local_blocks|]. + split; [apply page_heap_drain|]. + split. + + apply init_chain_links; intros prefix block rest E. + eapply page_heap_link; exact E. + + split; [exact I|]; split; [exact I|]. + split; [apply page_heap_mailbox|]. + split; [apply page_heap_mailbox|]. + split. + * cbn [mailbox_nodes held app]; rewrite app_nil_r; reflexivity. + * repeat split. +Qed. + +Lemma turn_counter base who s t event : + turn base who s = Some (t,event) -> + match event with + | None => acount t = acount s + | Some o => acount t = S (acount s) /\ sidx o = acount s + end. +Proof. + destruct s as [h c op r0 r1]; destruct who; + cbn [turn aheap acount owner_state remote0_state remote1_state]; + [destruct op|destruct r0|destruct r1]; cbn; intro T; + repeat match type of T with + | context [match ?v with Some _ => _ | None => _ end] => destruct v eqn:? + | context [if ?v then _ else _] => destruct v eqn:? + end; + try discriminate; inversion T; subst; cbn; auto. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat Fin + Classes.RelationClasses Program.Equality. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Interp.Refine. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Typeclasses Transparent equ. + +Lemma state_equiv_refl s : state_equiv s s. +Proof. + unfold state_equiv; split; [apply heq_refl | repeat split; reflexivity]. +Qed. + +Lemma state_equiv_sym s t : state_equiv s t -> state_equiv t s. +Proof. + intros [Hh [Hc [Ho [H0 H1]]]]. + unfold state_equiv; split; [now apply heq_sym |]. + repeat split; symmetry; assumption. +Qed. + +Lemma state_equiv_trans s t u : + state_equiv s t -> state_equiv t u -> state_equiv s u. +Proof. + intros [Hh [Hc [Ho [H0 H1]]]] [Kh [Kc [Ko [K0 K1]]]]. + unfold state_equiv; split; [eapply heq_trans; eauto |]. + repeat split; congruence. +Qed. + +#[global] Instance state_equiv_equivalence : Equivalence state_equiv. +Proof. + split. + - exact state_equiv_refl. + - exact state_equiv_sym. + - exact state_equiv_trans. +Qed. + +Local Lemma trees_upd_heq h k a v : + heq h k -> heq (upd h a v) (upd k a v). +Proof. + intros H x; unfold upd; destruct (Nat.eqb x a); [reflexivity | apply H]. +Qed. + +Local Lemma trees_upd_lookup h a v x : + upd h a v x = if Nat.eqb x a then Some v else h x. +Proof. reflexivity. Qed. + +(** Both faults and successful turns are preserved. In particular this + statement does not assume the ownership invariant or heap finiteness. *) +Lemma turn_respects_heq base who s t : + state_equiv s t -> + match turn base who s, turn base who t with + | None, None => True + | Some (s',event), Some (t',event') => + state_equiv s' t' /\ event = event' + | _, _ => False + end. +Proof. + destruct s as [h c op r0 r1], t as [k d oq q0 q1]. + intros [Hh [Hc [Ho [H0 H1]]]]. + cbn in Hh, Hc, Ho, H0, H1. + subst d oq q0 q1. + destruct who; [destruct op | destruct r0 | destruct r1]; + cbn [turn]. + all: repeat first + [ progress (rewrite trees_upd_lookup) + | progress (rewrite <- Hh) + | progress (cbn [aheap acount owner_state remote0_state remote1_state]) + | match goal with + | Hheap : heq ?left ?right |- context [?left ?x] => + let Hr := fresh "Hread" in destruct (left x) eqn:Hr + | |- context [if ?b then _ else _] => + let Hb := fresh "Htest" in destruct b eqn:Hb + end ]. + all: try exact I. + all: split; [|reflexivity]. + all: unfold state_equiv; + cbn [aheap acount owner_state remote0_state remote1_state]. + all: split; + [ repeat apply trees_upd_heq; exact Hh + | repeat split; reflexivity ]. +Qed. + +Corollary turn_respects_heq_some base who s t s' event : + state_equiv s t -> turn base who s = Some (s',event) -> + exists t', turn base who t = Some (t',event) /\ state_equiv s' t'. +Proof. + intros Hst Hstep. + pose proof (turn_respects_heq base who s t Hst) as H. + rewrite Hstep in H. + destruct (turn base who t) as [[t' event']|] eqn:Ht; + cbn in H; [|contradiction]. + destruct H as [Hnext Hevent]; subst event'. + exists t'; split; [assumption || reflexivity | exact Hnext]. +Qed. + +Corollary turn_respects_heq_none base who s t : + state_equiv s t -> (turn base who s = None <-> turn base who t = None). +Proof. + intro Hst; pose proof (turn_respects_heq base who s t Hst) as H. + destruct (turn base who s) as [[s' event]|]; + destruct (turn base who t) as [[t' event']|]; + cbn in H; try contradiction; split; intro Hnone; + try discriminate; reflexivity. +Qed. + +(** Physical source-pool order is [client1; client0; owner]. *) +Definition actor_of_slot (i : Fin.t 3) : Actor := + match i with + | Fin.F1 => Remote1 + | Fin.FS Fin.F1 => Remote0 + | Fin.FS (Fin.FS _) => Owner + end. + +Definition slot_of_actor (who : Actor) : Fin.t 3 := + match who with + | Owner => Fin.FS (Fin.FS Fin.F1) + | Remote0 => Fin.FS Fin.F1 + | Remote1 => Fin.F1 + end. + +Lemma actor_of_slot_of_actor who : actor_of_slot (slot_of_actor who) = who. +Proof. destruct who; reflexivity. Qed. + +Lemma slot_of_actor_of_slot i : slot_of_actor (actor_of_slot i) = i. +Proof. + refine (Fin.caseS' i + (fun j => slot_of_actor (actor_of_slot j) = j) _ _). + - reflexivity. + - intro j; refine (Fin.caseS' j + (fun k => slot_of_actor (actor_of_slot (Fin.FS k)) = Fin.FS k) _ _). + + reflexivity. + + intro k; refine (Fin.caseS' k + (fun z => slot_of_actor (actor_of_slot (Fin.FS (Fin.FS z))) = + Fin.FS (Fin.FS z)) _ _). + * reflexivity. + * intro impossible; inversion impossible. +Qed. + +(** Every nondeterministic turn begins with exactly one real branch node. + The post-effect guards are invisible, not additional scheduling choices. *) +CoFixpoint model_nd (base : nat) (s : AState) + : ictreeW SObs (unit * SSig) := + Br 2 (fun i => + match turn base (actor_of_slot i) s with + | None => stuck + | Some (next,None) => Guard (model_nd base next) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_nd base next)) + end). + +CoFixpoint model_rr (base : nat) (s : AState) (cursor : nat) + : ictreeW SObs (unit * SSig) := + match turn base (actor_of_slot (rr_pick 2 cursor)) s with + | None => stuck + | Some (next,None) => Guard (model_rr base next (S cursor)) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_rr base next (S cursor))) + end. + +Lemma unfold_model_nd base s : + model_nd base s ≅ + Br 2 (fun i => + match turn base (actor_of_slot i) s with + | None => stuck + | Some (next,None) => Guard (model_nd base next) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_nd base next)) + end). +Proof. step; now cbn. Qed. + +Lemma unfold_model_rr base s cursor : + model_rr base s cursor ≅ + match turn base (actor_of_slot (rr_pick 2 cursor)) s with + | None => stuck + | Some (next,None) => Guard (model_rr base next (S cursor)) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_rr base next (S cursor))) + end. +Proof. step; now cbn. Qed. + +Lemma model_nd_respects_heq_equ base : forall s t, + state_equiv s t -> model_nd base s ≅ model_nd base t. +Proof. + coinduction R IH; intros s t Hst. + rewrite !unfold_model_nd. + constructor; intro i. + pose proof (turn_respects_heq base (actor_of_slot i) s t Hst) as Hturn. + destruct (turn base (actor_of_slot i) s) as [[s' event]|]; + destruct (turn base (actor_of_slot i) t) as [[t' event']|]; + cbn in Hturn; try contradiction. + - destruct Hturn as [Hnext Hevent]; subst event'. + destruct event as [o|]. + + step; cbn; constructor; intros []. + step; cbn; constructor; apply IH; exact Hnext. + + step; cbn; constructor; apply IH; exact Hnext. + - reflexivity. +Qed. + +Lemma model_nd_respects_heq base s t : + state_equiv s t -> model_nd base s ~ model_nd base t. +Proof. + intro Hst. + eapply equ_clos_sbisim_goal; + [apply model_nd_respects_heq_equ; exact Hst | reflexivity | reflexivity]. +Qed. + +(** The proof compares finite indices through their numeric values, never + through equality of proof fields in [Fin.of_nat_lt]. *) +Local Lemma trees_rr_pick_three_congr cursor cursor' : + cursor mod 3 = cursor' mod 3 -> rr_pick 2 cursor = rr_pick 2 cursor'. +Proof. + intro Hmod; apply Fin.to_nat_inj; unfold rr_pick. + rewrite !Fin.to_nat_of_nat; exact Hmod. +Qed. + +Local Lemma trees_succ_mod_three cursor cursor' : + cursor mod 3 = cursor' mod 3 -> S cursor mod 3 = S cursor' mod 3. +Proof. + intro Hmod. + replace (S cursor) with (cursor + 1)%nat by lia. + replace (S cursor') with (cursor' + 1)%nat by lia. + rewrite (Nat.Div0.add_mod cursor 1 3), (Nat.Div0.add_mod cursor' 1 3). + now rewrite Hmod. +Qed. + +Lemma model_rr_respects_heq_equ base : forall s t cursor cursor', + state_equiv s t -> cursor mod 3 = cursor' mod 3 -> + model_rr base s cursor ≅ model_rr base t cursor'. +Proof. + coinduction R IH; intros s t cursor cursor' Hst Hmod. + rewrite !unfold_model_rr. + rewrite <- (trees_rr_pick_three_congr cursor cursor' Hmod). + pose proof (turn_respects_heq base + (actor_of_slot (rr_pick 2 cursor)) s t Hst) as Hturn. + destruct (turn base (actor_of_slot (rr_pick 2 cursor)) s) + as [[s' event]|]; + destruct (turn base (actor_of_slot (rr_pick 2 cursor)) t) + as [[t' event']|]; + cbn in Hturn; try contradiction. + - destruct Hturn as [Hnext Hevent]; subst event'. + destruct event as [o|]; cbn. + + constructor; intros []. + step; cbn; constructor; apply IH; + [exact Hnext | now apply trees_succ_mod_three]. + + constructor; apply IH; + [exact Hnext | now apply trees_succ_mod_three]. + - reflexivity. +Qed. + +Lemma model_rr_respects_heq base s t cursor cursor' : + state_equiv s t -> cursor mod 3 = cursor' mod 3 -> + model_rr base s cursor ~ model_rr base t cursor'. +Proof. + intros Hst Hmod. + eapply equ_clos_sbisim_goal; + [exact (model_rr_respects_heq_equ base s t cursor cursor' Hst Hmod) + | reflexivity | reflexivity]. +Qed. + +(** The finite fold uses the actual result of each turn; faults propagate. *) +Lemma run_turns_append base left right s : + run_turns base (left ++ right) s = + match run_turns base left s with + | None => None + | Some (middle,first) => + match run_turns base right middle with + | None => None + | Some (last,second) => Some (last,first ++ second) + end + end. +Proof. + revert s; induction left as [|who left IH]; intro s. + - cbn [run_turns app]. + destruct (run_turns base right s) as [[last logs]|]; reflexivity. + - cbn [run_turns app]. + destruct (turn base who s) as [[next event]|]; [|reflexivity]. + rewrite IH. + destruct (run_turns base left next) as [[middle first]|]; [|reflexivity]. + destruct (run_turns base right middle) as [[last second]|]; [|reflexivity]. + destruct event; reflexivity. +Qed. + +Corollary run_turns_compose base left right s middle last first second : + run_turns base left s = Some (middle,first) -> + run_turns base right middle = Some (last,second) -> + run_turns base (left ++ right) s = Some (last,first ++ second). +Proof. + intros Hleft Hright; rewrite run_turns_append, Hleft, Hright; reflexivity. +Qed. + +Lemma run_turns_append_inv base left right s last logs : + run_turns base (left ++ right) s = Some (last,logs) -> + exists middle first second, + run_turns base left s = Some (middle,first) /\ + run_turns base right middle = Some (last,second) /\ + logs = first ++ second. +Proof. + rewrite run_turns_append; intro Hrun. + destruct (run_turns base left s) as [[middle first]|] eqn:Hleft; + [|discriminate]. + destruct (run_turns base right middle) as [[last' second]|] eqn:Hright; + [|discriminate]. + inversion Hrun; subst. + exists middle, first, second; repeat split; assumption || reflexivity. +Qed. + +Lemma run_turns_counter base script s last logs : + run_turns base script s = Some (last,logs) -> + acount last = (acount s + length logs)%nat. +Proof. + revert s last logs; induction script as [|who rest IH]; + intros s last logs Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst; cbn; lia. + - cbn [run_turns] in Hrun. + destruct (turn base who s) as [[next event]|] eqn:Hstep; + [|discriminate]. + destruct (run_turns base rest next) as [[last' suffix]|] eqn:Hrest; + [|discriminate]. + pose proof (IH next last' suffix Hrest) as Hsuffix. + pose proof (turn_counter base who s next event Hstep) as Hcounter. + destruct event as [o|]; cbn in Hrun, Hcounter. + + destruct Hcounter as [Hcount Hindex]. + inversion Hrun; subst; cbn; lia. + + inversion Hrun; subst; cbn; lia. +Qed. + +Lemma run_turns_respects_heq base script s t : + state_equiv s t -> + match run_turns base script s, run_turns base script t with + | None, None => True + | Some (s',logs), Some (t',logs') => + state_equiv s' t' /\ logs = logs' + | _, _ => False + end. +Proof. + revert s t; induction script as [|who rest IH]; intros s t Hst. + - cbn [run_turns]; split; [exact Hst | reflexivity]. + - cbn [run_turns]. + pose proof (turn_respects_heq base who s t Hst) as Hturn. + destruct (turn base who s) as [[next event]|]; + destruct (turn base who t) as [[next' event']|]; + cbn in Hturn; try contradiction. + + destruct Hturn as [Hnext Hevent]; subst event'. + specialize (IH next next' Hnext). + destruct (run_turns base rest next) as [[last logs]|]; + destruct (run_turns base rest next') as [[last' logs']|]; + cbn in IH; try contradiction. + * destruct IH as [Hlast Hlogs]; subst logs'. + split; [exact Hlast | reflexivity]. + * exact I. + + exact I. +Qed. + +Corollary run_turns_respects_heq_some base script s t last logs : + state_equiv s t -> run_turns base script s = Some (last,logs) -> + exists last', run_turns base script t = Some (last',logs) /\ + state_equiv last last'. +Proof. + intros Hst Hrun. + pose proof (run_turns_respects_heq base script s t Hst) as H. + rewrite Hrun in H. + destruct (run_turns base script t) as [[last' logs']|] eqn:Ht; + cbn in H; [|contradiction]. + destruct H as [Hlast Hlogs]; subst logs'. + exists last'; split; [assumption || reflexivity | exact Hlast]. +Qed. + +Corollary run_turns_respects_heq_none base script s t : + state_equiv s t -> + (run_turns base script s = None <-> run_turns base script t = None). +Proof. + intro Hst; pose proof (run_turns_respects_heq base script s t Hst) as H. + destruct (run_turns base script s) as [[last logs]|]; + destruct (run_turns base script t) as [[last' logs']|]; + cbn in H; try contradiction; split; intro Hnone; + try discriminate; reflexivity. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. +From TICL Require Import Lang.CSL. +From examples Require Import CSL.HeapQ CSL.Allocator.Layout. + +Import ListNotations. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Lemma ai_free_chain_frame h h' xs : + free_chain h xs -> + (forall b, In b xs -> h' b = h b) -> + free_chain h' xs. +Proof. + revert h h'; induction xs as [|b xs IH]; intros h h' Hchain Hframe. + - exact I. + - cbn [free_chain] in *; destruct Hchain as [Hb Hxs]; split. + + rewrite Hframe; [exact Hb | now left]. + + eapply IH; [exact Hxs | intros x Hx; apply Hframe; now right]. +Qed. + +Lemma ai_free_chain_upd h xs a v : + free_chain h xs -> + (forall b, In b xs -> b <> a) -> + free_chain (upd h a v) xs. +Proof. + intros Hchain Haway; eapply ai_free_chain_frame; [exact Hchain |]. + intros b Hb; apply upd_neq, Haway, Hb. +Qed. + +Lemma ai_cached_remote_frame base capacity h h' pc : + cached_remote base capacity h pc -> + (forall b, In b (held pc) -> h' b = h b) -> + cached_remote base capacity h' pc. +Proof. + destruct pc; cbn [cached_remote held]; intros H Hframe; try exact H. + destruct H as [Hbound [Hneq Hlink]]; repeat split; try assumption. + rewrite Hframe; [exact Hlink | now left]. +Qed. + +Lemma ai_partition_member base capacity xs x : + Permutation xs (page_blocks base capacity) -> + In x xs -> In x (page_blocks base capacity). +Proof. intros Hp Hx; eapply Permutation_in; eauto. Qed. + +Lemma ai_partition_nodup base capacity xs : + Permutation xs (page_blocks base capacity) -> NoDup xs. +Proof. + intro Hp; eapply Permutation_NoDup; [apply Permutation_sym, Hp |]. + apply page_blocks_nodup. +Qed. + +Lemma ai_partition_count base capacity xs : + Permutation xs (page_blocks base capacity) -> + forall x, count_occ Nat.eq_dec xs x <= 1. +Proof. + intro Hp; apply (proj1 (NoDup_count_occ Nat.eq_dec xs)). + now apply (ai_partition_nodup base capacity). +Qed. + +Lemma ai_partition_disjoint base capacity xs ys zs : + Permutation (xs ++ ys ++ zs) (page_blocks base capacity) -> + forall b, In b xs -> ~ In b ys. +Proof. + intros Hp b Hx Hy. + pose proof (ai_partition_count base capacity _ Hp b) as Hcount. + repeat rewrite count_occ_app in Hcount. + apply (proj1 (count_occ_In Nat.eq_dec xs b)) in Hx. + apply (proj1 (count_occ_In Nat.eq_dec ys b)) in Hy. + lia. +Qed. + +Lemma ai_head_bound base capacity xs : + (forall b, In b xs -> In b (page_blocks base capacity)) -> + hd 0 xs = 0 \/ In (hd 0 xs) (page_blocks base capacity). +Proof. + destruct xs as [|b xs]; cbn; intro H; [now left | right; apply H; now left]. +Qed. + +Lemma ai_head_distinct xs b : + ~ In b xs -> 0 <> b -> hd 0 xs <> b. +Proof. + destruct xs as [|a xs]; cbn; intros Hnot Hzero; [exact Hzero |]. + intro E; apply Hnot; now left. +Qed. + +Lemma ai_backing_present base capacity h x : + backing base capacity h -> + base <= x /\ x < base + page_size capacity -> + exists v, h x = Some v. +Proof. + intros Hback Hrange. + pose proof (proj2 (Hback x) Hrange) as Hpresent. + destruct (h x) as [v|]; [now exists v | contradiction]. +Qed. + +Lemma ai_backing_upd base capacity h a v : + backing base capacity h -> + base <= a /\ a < base + page_size capacity -> + backing base capacity (upd h a v). +Proof. + intros Hback Ha x. + rewrite upd_dom; [apply Hback | now apply (proj2 (Hback a))]. +Qed. + +Lemma allocator_inv_backing base capacity s : + allocator_inv base capacity s -> backing base capacity (aheap s). +Proof. intros [_ [H _]]; exact H. Qed. + +Lemma allocator_inv_null base capacity s : + allocator_inv base capacity s -> aheap s 0 = None. +Proof. + intros [Hbase [Hback _]]. + destruct (aheap s 0) as [v|] eqn:E; [|reflexivity]. + assert (Hpresent : aheap s 0 <> None) by (rewrite E; discriminate). + apply Hback in Hpresent; lia. +Qed. + +Lemma allocator_inv_outside base capacity s x : + allocator_inv base capacity s -> + (x < base \/ base + page_size capacity <= x) -> aheap s x = None. +Proof. + intros [_ [Hback _]] Hout. + destruct (aheap s x) as [v|] eqn:E; [|reflexivity]. + assert (Hpresent : aheap s x <> None) by (rewrite E; discriminate). + apply Hback in Hpresent; lia. +Qed. + +Lemma allocator_inv_held_member base capacity s (client : bool) b : + allocator_inv base capacity s -> + In b (held (if client then remote1_state s else remote0_state s)) -> + In b (page_blocks base capacity). +Proof. + intros (_ & _ & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) Hin. + eapply ai_partition_member; [exact Hp |]. + repeat rewrite in_app_iff; destruct client; tauto. +Qed. + +(* These small tactics only discharge finite ownership arithmetic. In + particular, a cached head is never used as a freshness witness. *) +Ltac ai_member := + match goal with + | Hp : Permutation ?xs (page_blocks ?base ?capacity) + |- In ?x (page_blocks _ _) => + apply (ai_partition_member base capacity xs x Hp); + repeat rewrite in_app_iff; cbn [held mailbox_nodes Nat.eqb In]; intuition congruence + end. + +Ltac ai_block_bounds x := + match goal with + | Hp : Permutation _ (page_blocks ?base ?capacity) |- _ => + let Hx := fresh "Hblock" in + assert (Hx : In x (page_blocks base capacity)) by ai_member; + apply page_blocks_bounds in Hx + end. + +Ltac ai_interval := + first + [ solve [unfold remote_head, local_head, drain_head, mailbox, page_size; lia] + | match goal with + | |- _ <= S ?b /\ _ => + solve [ai_block_bounds b; unfold page_size in *; lia] + | |- _ <= ?b /\ _ => + solve [ai_block_bounds b; unfold page_size in *; lia] + end ]. + +Ltac ai_count_contradiction x := + match goal with + | Hp : Permutation ?xs (page_blocks ?base ?capacity) |- _ => + let Hcount := fresh "Hcount" in + pose proof (ai_partition_count base capacity xs Hp x) as Hcount; + repeat rewrite count_occ_app in Hcount; + try unfold mailbox_nodes in Hcount; + repeat match goal with + | E : Nat.eqb ?a ?b = ?v |- _ => progress rewrite E in Hcount + end; + cbn [held count_occ Nat.eqb] in Hcount; + repeat match type of Hcount with + | context [Nat.eq_dec ?a ?b] => + destruct (Nat.eq_dec a b); try congruence + end; + repeat match goal with + | Hin : In x ?ys |- _ => + apply (proj1 (count_occ_In Nat.eq_dec ys x)) in Hin + end; + lia + end. + +Ltac ai_distinct := + first + [ solve [unfold remote_head, local_head, drain_head, mailbox; lia] + | match goal with + | |- ?a <> S ?b => + solve [eapply page_blocks_link_payload_disjoint; ai_member] + | |- S ?b <> ?a => + solve [let E := fresh "Ealias" in intro E; symmetry in E; + let H := fresh "Hdisjoint" in + assert (H : a <> S b) by + (eapply page_blocks_link_payload_disjoint; ai_member); + contradiction] + end + | match goal with + | |- ?a <> ?b => + first + [ solve [ai_block_bounds a; + unfold remote_head, local_head, drain_head, mailbox in *; lia] + | solve [ai_block_bounds b; + unfold remote_head, local_head, drain_head, mailbox in *; lia] + | solve [match a with S ?x => ai_block_bounds x end; + unfold remote_head, local_head, drain_head, mailbox in *; lia] + | solve [match b with S ?x => ai_block_bounds x end; + unfold remote_head, local_head, drain_head, mailbox in *; lia] + | let E := fresh "Ealias" in + intro E; rewrite E in *; ai_count_contradiction b ] + end ]. + +Ltac ai_heap := + repeat first [rewrite upd_eq | rewrite upd_neq by ai_distinct]; + first [assumption | reflexivity]. + +Ltac ai_chain := + first [assumption | exact I | + eapply ai_free_chain_upd; [ai_chain | intros; ai_distinct]]. + +Ltac ai_backing := + first [assumption | + eapply ai_backing_upd; [ai_backing | ai_interval]]. + +Ltac ai_permutation := + match goal with + | Hp : Permutation ?old ?page |- Permutation ?new ?page => + eapply Permutation_trans; [|exact Hp]; + apply (proj2 (Permutation_count_occ Nat.eq_dec new old)); + let x := fresh "x" in intro x; + repeat rewrite count_occ_app; + try unfold mailbox_nodes; + repeat match goal with + | E : Nat.eqb ?a ?b = ?v |- _ => progress rewrite E + end; + cbn [held count_occ Nat.eqb]; + repeat match goal with + | |- context [Nat.eq_dec ?a ?b] => destruct (Nat.eq_dec a b) + end; lia + end. + +Ltac ai_cached h := + eapply ai_cached_remote_frame with (h := h); + [assumption | intros; ai_heap]. + +Ltac ai_obligation h := + first + [ assumption | reflexivity | exact I + | solve [ai_backing] + | solve [ai_heap] + | solve [ai_chain] + | solve [ai_cached h] + | solve [ai_permutation] + | solve [ai_member] + | solve [apply ai_head_bound; intros; ai_member] + | match goal with + | |- hd 0 ?xs <> ?b => + solve [apply ai_head_distinct; + [intro; ai_count_contradiction b | ai_distinct]] + end + | solve [ai_distinct] ]. + +Local Ltac ai_reduce_turn := + cbn [turn aheap acount owner_state remote0_state remote1_state]. + +Ltac ai_finish h L R D m0 m1 := + cbn [aheap acount owner_state remote0_state remote1_state]; + try rewrite Nat.eqb_refl; + repeat match goal with + | E : Nat.eqb _ _ = _ |- _ => progress rewrite E + end; + do 2 eexists; split; [reflexivity |]; + unfold allocator_inv; cbn [aheap acount owner_state remote0_state remote1_state]; + split; [assumption |]; split; [ai_backing |]; + exists L, R, D, m0, m1; + cbn [hd held]; + repeat split; ai_obligation h. + +Lemma ai_turn_complete base capacity who s : + allocator_inv base capacity s -> + exists t event, turn base who s = Some (t,event) /\ + allocator_inv base capacity t. +Proof. + destruct s as [h count op p0 p1]. + cbn [allocator_inv aheap acount owner_state remote0_state remote1_state]. + intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1). + cbn [aheap acount owner_state remote0_state remote1_state] in *. + destruct who. + - destruct op as [|old| |client]. + + cbn in Hop; subst D. + ai_reduce_turn; rewrite Hr. + ai_finish h L R (@nil nat) m0 m1. + + cbn in Hop; subst D. + ai_reduce_turn; rewrite Hr. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old. + rewrite upd_neq by ai_distinct; rewrite Hd. + ai_finish h L (@nil nat) R m0 m1. + * ai_finish h L R (@nil nat) m0 m1. + + destruct D as [|b D]. + * ai_reduce_turn; rewrite Hd; cbn [hd Nat.eqb]. + ai_finish h L R (@nil nat) m0 m1. + * cbn [free_chain] in CD; destruct CD as [Hnext CD]. + assert (Eb : Nat.eqb b 0 = false) by + (apply Nat.eqb_neq; ai_distinct). + ai_reduce_turn; rewrite Hd; cbn [hd]; rewrite Eb, Hnext, Hl. + ai_finish h (b :: L) R D m0 m1. + + cbn in Hop; subst D; destruct client. + * destruct m1 as [|m1]. + -- destruct L as [|b L ]. + ++ ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]; rewrite Hl; + cbn [hd Nat.eqb]. + ai_finish h (@nil nat) R (@nil nat) m0 0. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by + (apply Nat.eqb_neq; ai_distinct). + ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]; rewrite Hl; + cbn [hd]; rewrite Eb, Hnext. + ai_finish h L R (@nil nat) m0 b. + -- ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]. + ai_finish h L R (@nil nat) m0 (S m1). + * destruct m0 as [|m0]. + -- destruct L as [|b L ]. + ++ ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]; rewrite Hl; + cbn [hd Nat.eqb]. + ai_finish h (@nil nat) R (@nil nat) 0 m1. + ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + assert (Eb : Nat.eqb b 0 = false) by + (apply Nat.eqb_neq; ai_distinct). + ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]; rewrite Hl; + cbn [hd]; rewrite Eb, Hnext. + ai_finish h L R (@nil nat) b m1. + -- ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]. + ai_finish h L R (@nil nat) (S m0) m1. + - destruct p0 as [|b|b old|b old]. + + destruct m0 as [|m0]. + * ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]. + ai_finish h L R D 0 m1. + * assert (Hcell : exists v, h (S (S m0)) = Some v). + { eapply ai_backing_present; [exact Hback | ai_interval]. } + destruct Hcell as [v Hv]. + ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]. + rewrite upd_neq by ai_distinct; rewrite Hv. + ai_finish h L R D 0 m1. + + ai_reduce_turn; rewrite Hr. + ai_finish h L R D m0 m1. + + cbn [cached_remote] in Hc0; destruct Hc0 as [Hbound Hneq]. + assert (Hcell : exists v, h b = Some v). + { eapply ai_backing_present; [exact Hback | ai_interval]. } + destruct Hcell as [v Hv]. + ai_reduce_turn; rewrite Hv. + ai_finish h L R D m0 m1. + + cbn [cached_remote] in Hc0; + destruct Hc0 as [Hbound [Hneq Hlink]]. + ai_reduce_turn; rewrite Hr. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old. + ai_finish h L (b :: R) D m0 m1. + * ai_finish h L R D m0 m1. + - destruct p1 as [|b|b old|b old]. + + destruct m1 as [|m1]. + * ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]. + ai_finish h L R D m0 0. + * assert (Hcell : exists v, h (S (S m1)) = Some v). + { eapply ai_backing_present; [exact Hback | ai_interval]. } + destruct Hcell as [v Hv]. + ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]. + rewrite upd_neq by ai_distinct; rewrite Hv. + ai_finish h L R D m0 0. + + ai_reduce_turn; rewrite Hr. + ai_finish h L R D m0 m1. + + cbn [cached_remote] in Hc1; destruct Hc1 as [Hbound Hneq]. + assert (Hcell : exists v, h b = Some v). + { eapply ai_backing_present; [exact Hback | ai_interval]. } + destruct Hcell as [v Hv]. + ai_reduce_turn; rewrite Hv. + ai_finish h L R D m0 m1. + + cbn [cached_remote] in Hc1; + destruct Hc1 as [Hbound [Hneq Hlink]]. + ai_reduce_turn; rewrite Hr. + destruct (Nat.eqb (hd 0 R) old) eqn:Ecas. + * apply Nat.eqb_eq in Ecas; subst old. + ai_finish h L (b :: R) D m0 m1. + * ai_finish h L R D m0 m1. +Qed. + +Lemma turn_total base capacity who s : + allocator_inv base capacity s -> + exists t event, turn base who s = Some (t,event). +Proof. + intro Hinv; destruct (ai_turn_complete base capacity who s Hinv) + as (t & event & Hturn & Hnext). + now exists t, event. +Qed. + +Lemma turn_preserves_inv base capacity who s t event : + allocator_inv base capacity s -> + turn base who s = Some (t,event) -> allocator_inv base capacity t. +Proof. + intros Hinv Hturn. + destruct (ai_turn_complete base capacity who s Hinv) + as (t' & event' & Hturn' & Hnext). + rewrite Hturn in Hturn'; inversion Hturn'; subst; exact Hnext. +Qed. + +Lemma turn_preserves_backing base capacity who s t event : + allocator_inv base capacity s -> + turn base who s = Some (t,event) -> + forall x, aheap t x <> None <-> aheap s x <> None. +Proof. + intros Hinv Hturn x. + pose proof (turn_preserves_inv base capacity who s t event Hinv Hturn) as Hnext. + pose proof (allocator_inv_backing base capacity s Hinv) as Hbefore. + pose proof (allocator_inv_backing base capacity t Hnext) as Hafter. + rewrite (Hbefore x), (Hafter x); reflexivity. +Qed. + +Lemma run_turns_preserves_inv base capacity script s last logs : + allocator_inv base capacity s -> + run_turns base script s = Some (last,logs) -> + allocator_inv base capacity last. +Proof. + revert s last logs; induction script as [|who rest IH]; + intros s last logs Hinv Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst; exact Hinv. + - cbn [run_turns] in Hrun. + destruct (turn base who s) as [[next event]|] eqn:Hstep; + [|discriminate]. + destruct (run_turns base rest next) as [[last' suffix]|] eqn:Hrest; + [|discriminate]. + inversion Hrun; subst. + eapply IH; [eapply turn_preserves_inv; eauto | exact Hrest]. +Qed. + +Lemma run_turns_total base capacity script s : + allocator_inv base capacity s -> + exists last logs, run_turns base script s = Some (last,logs). +Proof. + revert s; induction script as [|who rest IH]; intros s Hinv. + - exists s, []; reflexivity. + - destruct (turn_total base capacity who s Hinv) as (next & event & Hstep). + assert (Hnext : allocator_inv base capacity next). + { eapply turn_preserves_inv; eauto. } + destruct (IH next Hnext) as (last & logs & Hrest). + exists last, (match event with None => logs | Some o => o :: logs end). + cbn [run_turns]; rewrite Hstep, Hrest; reflexivity. +Qed. diff --git a/examples/CSL/Allocator/NegativeTests.v b/examples/CSL/Allocator/NegativeTests.v new file mode 100644 index 0000000..ebd9e7c --- /dev/null +++ b/examples/CSL/Allocator/NegativeTests.v @@ -0,0 +1,848 @@ +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Definition has_event (kind block : nat) (e : AExecution) (k : nat) : Prop := + exists idx, emitted e k = Some (SPop kind block idx). + +(** The cycle is nonempty by construction. Every state is still obtained + by executing the preceding turns through [execution_of_choices]. *) +Definition periodic_choices (prefix : list Actor) (first : Actor) (rest : list Actor) + (k : nat) : Actor := + if Nat.ltb k (List.length prefix) + then List.nth k prefix first + else List.nth ((k - List.length prefix) mod (S (List.length rest))) (first :: rest) first. + +Definition starvation_cycle : list Actor := + [Remote1; Remote1; Remote0; Remote0; Remote0; Remote0; Remote1; + Owner; Owner; Owner; Owner; Owner; Owner]. +Definition starvation_prefix : list Actor := + [Owner; Owner; Owner; Owner; Owner; Remote1] ++ starvation_cycle. +Definition starvation_choices : nat -> Actor := + periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle). +Definition starvation_execution : AExecution := execution_of_choices 2 0 starvation_choices. + +Definition owner_stall_prefix : list Actor := + List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 4. +Definition owner_stall_cycle : list Actor := [Remote0; Remote1]. +Definition owner_stall_choices : nat -> Actor := + periodic_choices owner_stall_prefix Remote0 [Remote1]. +Definition owner_stall_execution : AExecution := execution_of_choices 2 0 owner_stall_choices. + +Lemma periodic_choices_before prefix first rest k : + k < List.length prefix -> + periodic_choices prefix first rest k = List.nth k prefix first. +Proof. + intro Hk; unfold periodic_choices; apply Nat.ltb_lt in Hk; now rewrite Hk. +Qed. +Lemma periodic_choices_after prefix first rest k : + periodic_choices prefix first rest (List.length prefix + k) = + List.nth (k mod (S (List.length rest))) (first :: rest) first. +Proof. + unfold periodic_choices. + assert (E : Nat.ltb (List.length prefix + k) (List.length prefix) = false) + by (apply Nat.ltb_ge; lia). + rewrite E; f_equal; f_equal; lia. +Qed. +Lemma periodic_choices_nth prefix first rest rounds i : + i < S (List.length rest) -> + periodic_choices prefix first rest + (List.length prefix + rounds * S (List.length rest) + i) = + List.nth i (first :: rest) first. +Proof. + intro Hi. + replace (List.length prefix + rounds * S (List.length rest) + i) + with (List.length prefix + (i + rounds * S (List.length rest))) by lia. + rewrite periodic_choices_after, Nat.Div0.mod_add. + now rewrite Nat.mod_small by exact Hi. +Qed. + +Lemma witness_map_seq_nth {A} len start (f : nat -> A) xs d : + List.length xs = len -> + (forall i, i < len -> f (start+i) = List.nth i xs d) -> + List.map f (List.seq start len) = xs. +Proof. + intros Hlen Hnth; apply List.nth_ext with (d := f start) (d' := d). + - rewrite List.length_map, List.length_seq; symmetry; exact Hlen. + - intros i Hi; rewrite List.length_map, List.length_seq in Hi. + rewrite List.map_nth, List.seq_nth by exact Hi; now apply Hnth. +Qed. +Lemma periodic_prefix_script prefix first rest : + List.map (periodic_choices prefix first rest) (List.seq 0 (List.length prefix)) = prefix. +Proof. + apply (witness_map_seq_nth _ _ _ _ first); [reflexivity|]. + intros i Hi; cbn [Nat.add]; now apply periodic_choices_before. +Qed. +Lemma periodic_cycle_script prefix first rest rounds : + List.map (periodic_choices prefix first rest) + (List.seq (List.length prefix + rounds * S (List.length rest)) + (S (List.length rest))) = first :: rest. +Proof. + apply (witness_map_seq_nth _ _ _ _ first); [reflexivity|]. + intros i Hi; now apply periodic_choices_nth. +Qed. + +Lemma starvation_execution_valid : valid_execution 2 0 starvation_execution. +Proof. apply execution_of_choices_valid. Qed. +Lemma owner_stall_execution_valid : valid_execution 2 0 owner_stall_execution. +Proof. apply execution_of_choices_valid. Qed. + +Lemma witness_window_state capacity c e start script s last logs : + valid_execution capacity c e -> state_equiv (states e start) s -> + List.map (selected e) (List.seq start (List.length script)) = script -> + run_turns 1 script s = Some (last,logs) -> + state_equiv (states e (start + List.length script)) last. +Proof. + intros Hvalid Hstate Hchoices Hrun. + destruct (run_turns_respects_heq_some 1 script s (states e start) last logs + (state_equiv_sym _ _ Hstate) Hrun) as (actual & Hactual & Hlast). + pose proof (execution_run_turns capacity c e start (List.length script) Hvalid) as Hexec. + rewrite Hchoices in Hexec; rewrite Hexec in Hactual. + inversion Hactual; subst actual; now apply state_equiv_sym. +Qed. + +Lemma witness_turn_observation capacity c e k s next event : + valid_execution capacity c e -> state_equiv (states e k) s -> + turn 1 (selected e k) s = Some (next,event) -> + emitted e k = event /\ state_equiv (states e (S k)) next. +Proof. + intros Hvalid Hstate Hturn. + destruct (turn_respects_heq_some 1 (selected e k) s (states e k) next event + (state_equiv_sym _ _ Hstate) Hturn) as (actual & Hactual & Hnext). + rewrite (execution_step capacity c e k Hvalid) in Hactual. + inversion Hactual; subst actual event; split; [reflexivity|now apply state_equiv_sym]. +Qed. + +Lemma witness_firstn_seq start n len : + n <= len -> List.firstn n (List.seq start len) = List.seq start n. +Proof. + revert start len; induction n as [|n IH]; intros start len H; [reflexivity|]. + destruct len; [lia|]. cbn [List.firstn List.seq]; now rewrite IH by lia. +Qed. + +Lemma witness_window_prefix e start script n : + n <= List.length script -> + List.map (selected e) (List.seq start (List.length script)) = script -> + List.map (selected e) (List.seq start n) = List.firstn n script. +Proof. + intros Hn Hscript. + rewrite <- (witness_firstn_seq start n (List.length script) Hn), + <- List.firstn_map, Hscript; reflexivity. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Definition starve_prefix_logs (c : nat) : list SObs := + [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); + SPop tag_retire 6 (2+c); SPop tag_retry 8 (3+c); + SPop tag_reclaim 6 (4+c); SPop tag_alloc 6 (5+c)]. +Definition starve_cycle_logs (c : nat) : list SObs := + [SPop tag_retire 6 c; SPop tag_retry 8 (1+c); + SPop tag_reclaim 6 (2+c); SPop tag_alloc 6 (3+c)]. + +(** A pointwise representative only: the infinite witness always retains + the actual heap returned by its preceding turn. *) +Definition starve_boundary_heap : Heap := fun x => + match x with + | 1 => Some 0 | 2 => Some 0 | 3 => Some 0 | 4 => Some 6 + | 5 => Some 0 | 6 => Some 0 | 7 => Some 1 | 8 => Some 0 + | 9 => Some 2 | _ => None + end. +Definition starve_boundary (c : nat) : AState := + {| aheap := starve_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RPoll; + remote1_state := RRead 8 |}. + +Lemma starve_prefix_run c : exists last, + run_turns 1 starvation_prefix (initial_state 2 c) = + Some (last,starve_prefix_logs c) /\ + state_equiv last (starve_boundary (6+c)). +Proof. + eexists; split; [vm_compute; reflexivity|]. + unfold state_equiv; split. + - intro x. + do 10 (destruct x as [|x]; [vm_compute; reflexivity|]). + vm_compute; reflexivity. + - vm_compute; repeat split; reflexivity. +Qed. + +Lemma starve_cycle_run c : exists last, + run_turns 1 starvation_cycle (starve_boundary c) = + Some (last,starve_cycle_logs c) /\ + state_equiv last (starve_boundary (4+c)). +Proof. + eexists; split; [vm_compute; reflexivity|]. + unfold state_equiv; split. + - intro x. + do 10 (destruct x as [|x]; [vm_compute; reflexivity|]). + vm_compute; reflexivity. + - vm_compute; repeat split; reflexivity. +Qed. + +Lemma starve_cycle_run_actual c s : + state_equiv s (starve_boundary c) -> + exists last, + run_turns 1 starvation_cycle s = Some (last,starve_cycle_logs c) /\ + state_equiv last (starve_boundary (4+c)). +Proof. + intro Hs; destruct (starve_cycle_run c) as (last & Hrun & Hlast). + destruct (run_turns_respects_heq_some 1 starvation_cycle + (starve_boundary c) s last (starve_cycle_logs c) + (state_equiv_sym _ _ Hs) Hrun) as (actual & Hactual & Heq). + exists actual; split; [exact Hactual|]. + eapply state_equiv_trans; [apply state_equiv_sym; exact Heq|exact Hlast]. +Qed. + +(** The observation of each individual turn, including every silent turn. *) +Definition starve_prefix_event (c i : nat) : option SObs := + match i with + | 3 => Some (SPop tag_alloc 6 c) + | 4 => Some (SPop tag_alloc 8 (1+c)) + | 11 => Some (SPop tag_retire 6 (2+c)) + | 12 => Some (SPop tag_retry 8 (3+c)) + | 15 => Some (SPop tag_reclaim 6 (4+c)) + | 17 => Some (SPop tag_alloc 6 (5+c)) + | _ => None + end. +Definition starve_cycle_event (c i : nat) : option SObs := + match i with + | 5 => Some (SPop tag_retire 6 c) + | 6 => Some (SPop tag_retry 8 (1+c)) + | 9 => Some (SPop tag_reclaim 6 (2+c)) + | 11 => Some (SPop tag_alloc 6 (3+c)) + | _ => None + end. + +Lemma starve_prefix_position c i : i < 19 -> + exists middle logs next, + run_turns 1 (List.firstn i starvation_prefix) (initial_state 2 c) = + Some (middle,logs) /\ + turn 1 (List.nth i starvation_prefix Remote1) middle = + Some (next,starve_prefix_event c i). +Proof. + intro Hi. + do 19 (destruct i as [|i]; + [eexists; eexists; eexists; split; vm_compute; reflexivity|]). + lia. +Qed. + +Lemma starve_cycle_position c i : i < 13 -> + exists middle logs next, + run_turns 1 (List.firstn i starvation_cycle) (starve_boundary c) = + Some (middle,logs) /\ + held (remote1_state middle) = [8] /\ + turn 1 (List.nth i starvation_cycle Remote1) middle = + Some (next,starve_cycle_event c i). +Proof. + intro Hi. + do 13 (destruct i as [|i]; + [eexists; eexists; eexists; split; + [vm_compute; reflexivity|]; split; + [vm_compute; reflexivity|vm_compute; reflexivity]|]). + lia. +Qed. + +Lemma starve_prefix_script : + List.map (selected starvation_execution) + (List.seq 0 (List.length starvation_prefix)) = starvation_prefix. +Proof. + change (List.map + (periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle)) + (List.seq 0 (List.length starvation_prefix)) = starvation_prefix). + apply periodic_prefix_script. +Qed. + +Lemma starve_selected_prefix k : k < 19 -> + selected starvation_execution k = List.nth k starvation_prefix Remote1. +Proof. + intro Hk; change (starvation_choices k = List.nth k starvation_prefix Remote1). + unfold starvation_choices; apply periodic_choices_before; exact Hk. +Qed. + +Lemma starve_selected_cycle n i : i < 13 -> + selected starvation_execution (19+13*n+i) = + List.nth i starvation_cycle Remote1. +Proof. + intro Hi. + change (periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle) + (19+13*n+i) = List.nth i starvation_cycle Remote1). + replace (19+13*n+i) with + (List.length starvation_prefix + n * S (List.length (List.tl starvation_cycle)) + i) + by (cbn [starvation_prefix starvation_cycle List.length List.tl List.app]; lia). + apply periodic_choices_nth; exact Hi. +Qed. + +Lemma starve_cycle_script n : + List.map (selected starvation_execution) + (List.seq (19+13*n) (List.length starvation_cycle)) = starvation_cycle. +Proof. + apply (witness_map_seq_nth _ _ _ _ Remote1); [reflexivity|]. + intros i Hi; apply starve_selected_cycle; exact Hi. +Qed. + +Lemma starve_initial_equiv : + state_equiv (states starvation_execution 0) (initial_state 2 0). +Proof. + rewrite (proj1 starvation_execution_valid); apply state_equiv_refl. +Qed. + +Lemma starve_boundaries n : + state_equiv (states starvation_execution (19+13*n)) + (starve_boundary (6+4*n)). +Proof. + induction n as [|n IH]. + - destruct (starve_prefix_run 0) as (last & Hrun & Hlast). + eapply state_equiv_trans; [|exact Hlast]. + change (state_equiv + (states starvation_execution (0+List.length starvation_prefix)) last). + eapply witness_window_state with (capacity := 2) (c := 0) + (s := initial_state 2 0) (logs := starve_prefix_logs 0). + + exact starvation_execution_valid. + + exact starve_initial_equiv. + + exact starve_prefix_script. + + exact Hrun. + - destruct (starve_cycle_run (6+4*n)) as (last & Hrun & Hlast). + replace (6+4*S n) with (4+(6+4*n)) by lia. + eapply state_equiv_trans; [|exact Hlast]. + replace (19+13*S n) with + ((19+13*n)+List.length starvation_cycle) + by (cbn [starvation_cycle List.length]; lia). + eapply witness_window_state with (capacity := 2) (c := 0) + (s := starve_boundary (6+4*n)) (logs := starve_cycle_logs (6+4*n)). + + exact starvation_execution_valid. + + exact IH. + + exact (starve_cycle_script n). + + exact Hrun. +Qed. + +Lemma starve_actual_cycle_run n : exists last, + run_turns 1 starvation_cycle (states starvation_execution (19+13*n)) = + Some (last,starve_cycle_logs (6+4*n)) /\ + state_equiv last (starve_boundary (6+4*S n)). +Proof. + replace (6+4*S n) with (4+(6+4*n)) by lia. + apply starve_cycle_run_actual; apply starve_boundaries. +Qed. + +(** Every intermediate state is the result of a finite fold from the actual + returned boundary, not from a periodically reset representative. *) +Lemma starve_actual_cycle_position n i : i < 13 -> + exists logs next, + run_turns 1 (List.firstn i starvation_cycle) + (states starvation_execution (19+13*n)) = + Some (states starvation_execution (19+13*n+i),logs) /\ + held (remote1_state (states starvation_execution (19+13*n+i))) = [8] /\ + turn 1 (List.nth i starvation_cycle Remote1) + (states starvation_execution (19+13*n+i)) = + Some (next,starve_cycle_event (6+4*n) i). +Proof. + intro Hi. + destruct (starve_cycle_position (6+4*n) i Hi) + as (middle & logs & next & Hrun & Hheld & Hturn). + destruct (run_turns_respects_heq_some 1 (List.firstn i starvation_cycle) + (starve_boundary (6+4*n)) (states starvation_execution (19+13*n)) + middle logs (state_equiv_sym _ _ (starve_boundaries n)) Hrun) + as (actual & Hactual & Heq). + assert (Hscript : List.map (selected starvation_execution) + (List.seq (19+13*n) i) = List.firstn i starvation_cycle). + { + eapply witness_window_prefix. + - change (i <= 13); lia. + - exact (starve_cycle_script n). + } + pose proof (execution_run_turns 2 0 starvation_execution (19+13*n) i + starvation_execution_valid) as Hwindow. + rewrite Hscript, Hactual in Hwindow. + assert (Estate : actual = states starvation_execution (19+13*n+i)) + by congruence. + subst actual. + destruct (turn_respects_heq_some 1 (List.nth i starvation_cycle Remote1) + middle (states starvation_execution (19+13*n+i)) next + (starve_cycle_event (6+4*n) i) Heq Hturn) + as (actual_next & Hnext & Hnext_eq). + exists logs, actual_next; split; [exact Hactual|]; split; [|exact Hnext]. + destruct Heq as (_ & _ & _ & _ & Hremote1). + rewrite <- Hremote1; exact Hheld. +Qed. + +Lemma starve_cycle_emitted n i : i < 13 -> + emitted starvation_execution (19+13*n+i) = starve_cycle_event (6+4*n) i. +Proof. + intro Hi. + destruct (starve_actual_cycle_position n i Hi) + as (logs & next & Hrun & Hheld & Hturn). + pose proof (execution_step 2 0 starvation_execution (19+13*n+i) + starvation_execution_valid) as Hstep. + rewrite (starve_selected_cycle n i Hi), Hturn in Hstep; congruence. +Qed. + +Lemma starve_prefix_emitted i : i < 19 -> + emitted starvation_execution i = starve_prefix_event 0 i. +Proof. + intro Hi. + destruct (starve_prefix_position 0 i Hi) as (middle & logs & next & Hrun & Hturn). + assert (Hlen : List.length (List.firstn i starvation_prefix) = i). + { + rewrite List.length_firstn; apply Nat.min_l; change (i <= 19); lia. + } + assert (Hscript : List.map (selected starvation_execution) + (List.seq 0 (List.length (List.firstn i starvation_prefix))) = + List.firstn i starvation_prefix). + { + rewrite Hlen; eapply witness_window_prefix. + - change (i <= 19); lia. + - exact starve_prefix_script. + } + pose proof (witness_window_state 2 0 starvation_execution 0 + (List.firstn i starvation_prefix) (initial_state 2 0) middle logs + starvation_execution_valid starve_initial_equiv Hscript Hrun) as Heq. + rewrite Hlen, Nat.add_0_l in Heq. + rewrite <- (starve_selected_prefix i Hi) in Hturn. + exact (proj1 (witness_turn_observation 2 0 starvation_execution i middle next + (starve_prefix_event 0 i) starvation_execution_valid Heq Hturn)). +Qed. + +Lemma starve_cycle_event_offsets n : + emitted starvation_execution (19+13*n+5) = Some (SPop tag_retire 6 (6+4*n)) /\ + emitted starvation_execution (19+13*n+6) = Some (SPop tag_retry 8 (1+(6+4*n))) /\ + emitted starvation_execution (19+13*n+9) = Some (SPop tag_reclaim 6 (2+(6+4*n))) /\ + emitted starvation_execution (19+13*n+11) = Some (SPop tag_alloc 6 (3+(6+4*n))). +Proof. + split; [exact (starve_cycle_emitted n 5 ltac:(lia))|]. + split; [exact (starve_cycle_emitted n 6 ltac:(lia))|]. + split; [exact (starve_cycle_emitted n 9 ltac:(lia))|]. + exact (starve_cycle_emitted n 11 ltac:(lia)). +Qed. + +Lemma starve_index k : 19 <= k -> + exists n i, i < 13 /\ k = 19+13*n+i. +Proof. + intro Hk; exists ((k-19)/13), ((k-19) mod 13); split. + - apply Nat.mod_upper_bound; lia. + - pose proof (Nat.div_mod (k-19) 13 ltac:(lia)); lia. +Qed. + +Lemma starve_fair : fair starvation_execution. +Proof. + intros actor lo; destruct actor. + - exists (19+13*lo+7); split; [lia|]. + exact (starve_selected_cycle lo 7 ltac:(lia)). + - exists (19+13*lo+2); split; [lia|]. + exact (starve_selected_cycle lo 2 ltac:(lia)). + - exists (19+13*lo+0); split; [lia|]. + exact (starve_selected_cycle lo 0 ltac:(lia)). +Qed. + +Lemma starve_held_forever k : 19 <= k -> + held (remote1_state (states starvation_execution k)) = [8]. +Proof. + intro Hk; destruct (starve_index k Hk) as (n & i & Hi & ->). + destruct (starve_actual_cycle_position n i Hi) + as (logs & next & Hrun & Hheld & Hturn); exact Hheld. +Qed. + +Lemma starve_prefix_never_retire8 c i idx : i < 19 -> + starve_prefix_event c i <> Some (SPop tag_retire 8 idx). +Proof. + intro Hi. + do 19 (destruct i as [|i]; [vm_compute; discriminate|]). + lia. +Qed. +Lemma starve_cycle_never_retire8 c i idx : i < 13 -> + starve_cycle_event c i <> Some (SPop tag_retire 8 idx). +Proof. + intro Hi. + do 13 (destruct i as [|i]; [vm_compute; discriminate|]). + lia. +Qed. + +Lemma starve_never_retire8 k : ~ has_event tag_retire 8 starvation_execution k. +Proof. + intros [idx Hevent]; destruct (Nat.lt_ge_cases k 19) as [Hprefix|Hcycle]. + - rewrite (starve_prefix_emitted k Hprefix) in Hevent. + exact (starve_prefix_never_retire8 0 k idx Hprefix Hevent). + - destruct (starve_index k Hcycle) as (n & i & Hi & ->). + rewrite (starve_cycle_emitted n i Hi) in Hevent. + exact (starve_cycle_never_retire8 (6+4*n) i idx Hi Hevent). +Qed. + +Lemma starve_infinitely_retry8 : infinitely (has_event tag_retry 8 starvation_execution). +Proof. + intro lo; exists (19+13*lo+6); split; [lia|]. + exists (1+(6+4*lo)); exact (starve_cycle_emitted lo 6 ltac:(lia)). +Qed. +Lemma starve_infinitely_retire6 : infinitely (has_event tag_retire 6 starvation_execution). +Proof. + intro lo; exists (19+13*lo+5); split; [lia|]. + exists (6+4*lo); exact (starve_cycle_emitted lo 5 ltac:(lia)). +Qed. +Lemma starve_infinitely_reclaim6 : infinitely (has_event tag_reclaim 6 starvation_execution). +Proof. + intro lo; exists (19+13*lo+9); split; [lia|]. + exists (2+(6+4*lo)); exact (starve_cycle_emitted lo 9 ltac:(lia)). +Qed. +Lemma starve_infinitely_alloc6 : infinitely (has_event tag_alloc 6 starvation_execution). +Proof. + intro lo; exists (19+13*lo+11); split; [lia|]. + exists (3+(6+4*lo)); exact (starve_cycle_emitted lo 11 ltac:(lia)). +Qed. + +Theorem fair_starvation_exists : exists e, + valid_execution 2 0 e /\ fair e /\ + (forall k, 19 <= k -> held (remote1_state (states e k)) = [8]) /\ + infinitely (has_event tag_retry 8 e) /\ + (forall k, ~ has_event tag_retire 8 e k) /\ + infinitely (has_event tag_retire 6 e) /\ + infinitely (has_event tag_reclaim 6 e) /\ + infinitely (has_event tag_alloc 6 e) /\ + realizes e 0 (run_nd (allocator_program 2) hemp 0). +Proof. + exists starvation_execution. + split; [exact starvation_execution_valid|]. + split; [exact starve_fair|]. + split; [exact starve_held_forever|]. + split; [exact starve_infinitely_retry8|]. + split; [exact starve_never_retire8|]. + split; [exact starve_infinitely_retire6|]. + split; [exact starve_infinitely_reclaim6|]. + split; [exact starve_infinitely_alloc6|]. + apply valid_execution_realizes_source; exact starvation_execution_valid. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Definition stalled_prefix_logs (c : nat) : list SObs := + [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); + SPop tag_retire 6 (2+c); SPop tag_retire 8 (3+c)]. + +Definition stalled_prefix_observations : list (option SObs) := + [None; None; None; Some (SPop tag_alloc 6 0); + Some (SPop tag_alloc 8 1); None; None; None; + Some (SPop tag_retire 6 2); None; None; None; + Some (SPop tag_retire 8 3)]. + +(** This is only a pointwise representative of the returned heap. The + predefined execution always runs the actual preceding turn. *) +Definition stalled_boundary_heap : Heap := fun x => + match x with + | 1 => Some 8 | 2 => Some 0 | 3 => Some 0 | 4 => Some 0 + | 5 => Some 0 | 6 => Some 0 | 7 => Some 1 | 8 => Some 6 + | 9 => Some 2 | _ => None + end. +Definition stalled_boundary (c : nat) : AState := + {| aheap := stalled_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RPoll; + remote1_state := RPoll |}. + +Lemma stalled_prefix_run c : exists last, + run_turns 1 owner_stall_prefix (initial_state 2 c) = + Some (last,stalled_prefix_logs c) /\ + state_equiv last (stalled_boundary (c+4)). +Proof. + replace (c+4) with (4+c) by lia. + eexists; split; [vm_compute; reflexivity|]. + unfold state_equiv; split. + - intro x. + do 10 (destruct x as [ | x ]; [vm_compute; reflexivity|]). + vm_compute; reflexivity. + - vm_compute; repeat split; reflexivity. +Qed. + +Lemma stalled_polling_turn c who : + who = Remote0 \/ who = Remote1 -> + turn 1 who (stalled_boundary c) = Some (stalled_boundary c,None). +Proof. + intros [-> | ->]; vm_compute; reflexivity. +Qed. + +Lemma stalled_cycle_run c : + run_turns 1 owner_stall_cycle (stalled_boundary c) = + Some (stalled_boundary c,[]). +Proof. reflexivity. Qed. + +(** Transfer the finite polling calculation to the actual accumulated heap; + neither this lemma nor the infinite witness resets that heap. *) +Lemma stalled_cycle_run_actual c s : + state_equiv s (stalled_boundary c) -> + exists last, run_turns 1 owner_stall_cycle s = Some (last,[]) /\ + state_equiv last s. +Proof. + intro Hs. + destruct (run_turns_respects_heq_some 1 owner_stall_cycle + (stalled_boundary c) s (stalled_boundary c) [] + (state_equiv_sym _ _ Hs) (stalled_cycle_run c)) + as (last & Hrun & Hlast). + exists last; split; [exact Hrun|]. + eapply state_equiv_trans; [apply state_equiv_sym; exact Hlast|]. + apply state_equiv_sym; exact Hs. +Qed. + +Lemma stalled_prefix_script : + List.map (selected owner_stall_execution) + (List.seq 0 (List.length owner_stall_prefix)) = owner_stall_prefix. +Proof. + change (List.map (periodic_choices owner_stall_prefix Remote0 [Remote1]) + (List.seq 0 (List.length owner_stall_prefix)) = owner_stall_prefix). + apply periodic_prefix_script. +Qed. + +Lemma stalled_initial_equiv : + state_equiv (states owner_stall_execution 0) (initial_state 2 0). +Proof. + rewrite (proj1 owner_stall_execution_valid); apply state_equiv_refl. +Qed. + +Lemma stalled_prefix_state : + state_equiv (states owner_stall_execution 13) (stalled_boundary 4). +Proof. + destruct (stalled_prefix_run 0) as (last & Hrun & Hlast). + pose proof (witness_window_state 2 0 owner_stall_execution 0 + owner_stall_prefix (initial_state 2 0) last (stalled_prefix_logs 0) + owner_stall_execution_valid stalled_initial_equiv + stalled_prefix_script Hrun) as Hstate. + change (state_equiv (states owner_stall_execution 13) last) in Hstate. + eapply state_equiv_trans; [exact Hstate|exact Hlast]. +Qed. + +Lemma stalled_prefix_observation k : k < 13 -> + emitted owner_stall_execution k = + List.nth k stalled_prefix_observations None. +Proof. + intro Hk. + assert (Hfinite : exists before after logs, + run_turns 1 (List.firstn k owner_stall_prefix) (initial_state 2 0) = + Some (before,logs) /\ + turn 1 (owner_stall_choices k) before = + Some (after,List.nth k stalled_prefix_observations None)). + { + do 13 (destruct k as [ | k ]; + [eexists; eexists; eexists; split; vm_compute; reflexivity|]). + lia. + } + destruct Hfinite as (before & after & logs & Hrun & Hturn). + assert (Hlen : List.length (List.firstn k owner_stall_prefix) = k). + { + rewrite List.length_firstn. + change (Nat.min k 13 = k). + apply Nat.min_l; lia. + } + assert (Hscript : List.map (selected owner_stall_execution) + (List.seq 0 (List.length (List.firstn k owner_stall_prefix))) = + List.firstn k owner_stall_prefix). + { + rewrite Hlen. + apply witness_window_prefix with (script := owner_stall_prefix). + - change (k <= 13); lia. + - exact stalled_prefix_script. + } + pose proof (witness_window_state 2 0 owner_stall_execution 0 + (List.firstn k owner_stall_prefix) (initial_state 2 0) before logs + owner_stall_execution_valid stalled_initial_equiv Hscript Hrun) as Hstate. + cbn [Nat.add] in Hstate; rewrite Hlen in Hstate. + change (turn 1 (selected owner_stall_execution k) before = + Some (after,List.nth k stalled_prefix_observations None)) in Hturn. + exact (proj1 (witness_turn_observation 2 0 owner_stall_execution k + before after (List.nth k stalled_prefix_observations None) + owner_stall_execution_valid Hstate Hturn)). +Qed. + +Lemma stalled_prefix_events : + List.map (emitted owner_stall_execution) (List.seq 0 13) = + stalled_prefix_observations. +Proof. + apply (witness_map_seq_nth 13 0 _ _ None); [reflexivity|]. + intros i Hi; cbn [Nat.add]; now apply stalled_prefix_observation. +Qed. + +Lemma stalled_retire6 : + emitted owner_stall_execution 8 = Some (SPop tag_retire 6 2). +Proof. exact (stalled_prefix_observation 8 ltac:(lia)). Qed. + +Lemma stalled_retire8 : + emitted owner_stall_execution 12 = Some (SPop tag_retire 8 3). +Proof. exact (stalled_prefix_observation 12 ltac:(lia)). Qed. + +Lemma stalled_tail_choices n : + selected owner_stall_execution (13+n) = + List.nth (n mod 2) owner_stall_cycle Remote0. +Proof. + change (periodic_choices owner_stall_prefix Remote0 [Remote1] + (List.length owner_stall_prefix+n) = + List.nth (n mod 2) owner_stall_cycle Remote0). + rewrite periodic_choices_after; reflexivity. +Qed. + +Lemma stalled_tail_client n : + selected owner_stall_execution (13+n) = Remote0 \/ + selected owner_stall_execution (13+n) = Remote1. +Proof. + rewrite stalled_tail_choices. + pose proof (Nat.mod_upper_bound n 2 ltac:(lia)) as Hbound. + remember (n mod 2) as r eqn:Hr. + destruct r as [ | r ]; [left; reflexivity|]. + destruct r as [ | r ]; [right; reflexivity|lia]. +Qed. + +Lemma stalled_cycle_selection n i : i < 2 -> + selected owner_stall_execution (13+n*2+i) = + List.nth i owner_stall_cycle Remote0. +Proof. + intro Hi. + change (periodic_choices owner_stall_prefix Remote0 [Remote1] + (List.length owner_stall_prefix+n*S (List.length [Remote1])+i) = + List.nth i (Remote0 :: [Remote1]) Remote0). + apply periodic_choices_nth; exact Hi. +Qed. + +Lemma stalled_no_owner k : 5 <= k -> + selected owner_stall_execution k <> Owner. +Proof. + intro Hfive; destruct (Nat.lt_ge_cases k 13) as [Hprefix|Htail]. + - change (owner_stall_choices k <> Owner). + do 13 (destruct k as [ | k ]; [vm_compute; congruence || lia|]). + lia. + - replace k with (13+(k-13)) by lia. + destruct (stalled_tail_client (k-13)) as [-> | ->]; discriminate. +Qed. + +Lemma stalled_remote0_infinitely : + infinitely (fun k => selected owner_stall_execution k = Remote0). +Proof. + intro n; exists (13+n*2); split; [lia|]. + replace (13+n*2) with (13+n*2+0) by lia. + exact (stalled_cycle_selection n 0 ltac:(lia)). +Qed. + +Lemma stalled_remote1_infinitely : + infinitely (fun k => selected owner_stall_execution k = Remote1). +Proof. + intro n; exists (13+n*2+1); split; [lia|]. + exact (stalled_cycle_selection n 1 ltac:(lia)). +Qed. + +Lemma stalled_suffix_state n : + state_equiv (states owner_stall_execution (13+n)) (stalled_boundary 4). +Proof. + induction n as [ | n IH ]. + - exact stalled_prefix_state. + - replace (13+S n) with (S (13+n)) by lia. + exact (proj2 (witness_turn_observation 2 0 owner_stall_execution (13+n) + (stalled_boundary 4) (stalled_boundary 4) None + owner_stall_execution_valid IH + (stalled_polling_turn 4 _ (stalled_tail_client n)))). +Qed. + +Lemma stalled_suffix_silent n : emitted owner_stall_execution (13+n) = None. +Proof. + exact (proj1 (witness_turn_observation 2 0 owner_stall_execution (13+n) + (stalled_boundary 4) (stalled_boundary 4) None + owner_stall_execution_valid (stalled_suffix_state n) + (stalled_polling_turn 4 _ (stalled_tail_client n)))). +Qed. + +Lemma stalled_suffix_stable n : + state_equiv (states owner_stall_execution (13+n)) + (states owner_stall_execution 13) /\ + emitted owner_stall_execution (13+n) = None. +Proof. + split; [|apply stalled_suffix_silent]. + eapply state_equiv_trans; [apply stalled_suffix_state|]. + apply state_equiv_sym; exact stalled_prefix_state. +Qed. + +Lemma stalled_remote_chain n : + aheap (states owner_stall_execution (13+n)) (remote_head 1) = Some 8 /\ + free_chain (aheap (states owner_stall_execution (13+n))) [8;6] /\ + acount (states owner_stall_execution (13+n)) = 4 /\ + owner_state (states owner_stall_execution (13+n)) = ORead /\ + remote0_state (states owner_stall_execution (13+n)) = RPoll /\ + remote1_state (states owner_stall_execution (13+n)) = RPoll. +Proof. + destruct (stalled_suffix_state n) as (Hheap & Hcount & Howner & Hzero & Hone). + split; [rewrite Hheap; reflexivity|]. + split. + - cbn [free_chain List.hd]; repeat split; rewrite Hheap; reflexivity. + - exact (conj Hcount (conj Howner (conj Hzero Hone))). +Qed. + +Lemma stalled_no_reclaim k block : + ~ has_event tag_reclaim block owner_stall_execution k. +Proof. + intros [idx Hobs]; destruct (Nat.lt_ge_cases k 13) as [Hprefix|Htail]. + - rewrite (stalled_prefix_observation k Hprefix) in Hobs. + do 13 (destruct k as [ | k ]; [vm_compute in Hobs; discriminate|]). + lia. + - replace k with (13+(k-13)) in Hobs by lia. + rewrite stalled_suffix_silent in Hobs; discriminate. +Qed. + +Lemma stalled_prefix_source : exists last labels residual, + run_turns 1 owner_stall_prefix (initial_state 2 0) = + Some (last,stalled_prefix_logs 0) /\ + state_equiv last (stalled_boundary 4) /\ + label_logs labels = stalled_prefix_logs 0 /\ + label_taus labels = 13 /\ + finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + residual ~ model_nd 1 last. +Proof. + destruct (stalled_prefix_run 0) as (last & Hrun & Hstate). + destruct (run_turns_realizes_source 2 0 owner_stall_prefix last + (stalled_prefix_logs 0) Hrun) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Hresidual). + exists last, labels, residual; split; [exact Hrun|]. + split; [exact Hstate|]. + split; [exact Hlogs|]. + split; [exact Htaus|]. + split; [exact Hsteps|exact Hresidual]. +Qed. + +(** Every silent polling choice still consumes one real scheduler tau. *) +Lemma stalled_tail_source_tau n t : + realizes owner_stall_execution (13+n) t -> + exists next, finite_steps t [tau] next /\ + realizes owner_stall_execution (S (13+n)) next. +Proof. + intros [next Hsteps Hrest]. + exists next; split; [|exact Hrest]. + rewrite stalled_suffix_silent in Hsteps; exact Hsteps. +Qed. + +Theorem owner_stall_prevents_reclamation : exists e, + valid_execution 2 0 e /\ + (forall k, 5 <= k -> selected e k <> Owner) /\ + infinitely (fun k => selected e k = Remote0) /\ + infinitely (fun k => selected e k = Remote1) /\ + emitted e 8 = Some (SPop tag_retire 6 2) /\ + (forall k, ~ has_event tag_reclaim 6 e k) /\ + realizes e 0 (run_nd (allocator_program 2) hemp 0). +Proof. + exists owner_stall_execution; split; [exact owner_stall_execution_valid|]. + split; [exact stalled_no_owner|]. + split; [exact stalled_remote0_infinitely|]. + split; [exact stalled_remote1_infinitely|]. + split; [exact stalled_retire6|]. + split; [intro k; apply stalled_no_reclaim|]. + apply valid_execution_realizes_source; exact owner_stall_execution_valid. +Qed. diff --git a/examples/CSL/Allocator/Program.v b/examples/CSL/Allocator/Program.v new file mode 100644 index 0000000..9854ed7 --- /dev/null +++ b/examples/CSL/Allocator/Program.v @@ -0,0 +1,126 @@ +From Stdlib Require Import Arith.PeanoNat. +From TICL Require Import Lang.CSL.Syntax. +From examples Require Import CSL.Allocator.Layout. + +(* Link-first remote frees and owner collection, scoped from mimalloc v2.5.2: + https://raw.githubusercontent.com/microsoft/mimalloc/v2.5.2/src/free.c + https://raw.githubusercontent.com/microsoft/mimalloc/v2.5.2/src/page.c + This model omits delayed-free flags and abandoned-page recovery. *) + +Fixpoint init_links (first count : nat) {struct count} : CProg unit := + match count with + | 0 => CRet tt + | S rest => + CBind (CWrite first + (match rest with 0 => 0 | S _ => first + 2 end)) (fun _ => + init_links (first + 2) rest) + end. + +Definition init_page (base capacity : nat) : CProg unit := + CBind (CWrite (remote_head base) 0) (fun _ => + CBind (CWrite (drain_head base) 0) (fun _ => + CBind (CWrite (mailbox base false) 0) (fun _ => + CBind (CWrite (mailbox base true) 0) (fun _ => + CBind (CWrite (local_head base) + (match capacity with 0 => 0 | S _ => base + 5 end)) (fun _ => + init_links (base + 5) capacity))))). + +Definition new_page (capacity : nat) : CProg nat := + CBind (CAlloc (page_size capacity)) (fun base => + CBind (init_page base capacity) (fun _ => CRet base)). + +Definition remote_attempt (base block : nat) : CProg (option unit) := + CBind (CRead (remote_head base)) (fun old => + CBind CYield (fun _ => + CBind (CWrite block old) (fun _ => + CBind CYield (fun _ => + CBind (CCAS (remote_head base) old block) (fun success => + if success then + CBind (CEmit tag_retire block) (fun _ => + CRet (None : option unit)) + else + CBind (CEmit tag_retry block) (fun _ => + CBind CYield (fun _ => + CRet (Some tt : option unit)))))))). + +Definition remote_free (base block : nat) : CProg unit := + CUntilNone (remote_attempt base block). + +Definition detach_attempt (base : nat) : CProg (option unit) := + CBind (CRead (remote_head base)) (fun old => + CBind CYield (fun _ => + CBind (CCAS (remote_head base) old 0) (fun success => + if success then + CBind (CWrite (drain_head base) old) (fun _ => + CBind CYield (fun _ => + CRet (None : option unit))) + else + CBind CYield (fun _ => + CRet (Some tt : option unit))))). + +Definition detach_remote (base : nat) : CProg unit := + CUntilNone (detach_attempt base). + +Definition reclaim_step (base : nat) : CProg (option unit) := + CBind (CRead (drain_head base)) (fun block => + if Nat.eqb block 0 then + CBind CYield (fun _ => CRet (None : option unit)) + else + CBind (CRead block) (fun next => + CBind (CRead (local_head base)) (fun local => + CBind (CWrite block local) (fun _ => + CBind (CWrite (local_head base) block) (fun _ => + CBind (CWrite (drain_head base) next) (fun _ => + CBind (CEmit tag_reclaim block) (fun _ => + CBind CYield (fun _ => + CRet (Some tt : option unit))))))))). + +Definition collect_remote (base : nat) : CProg unit := + CBind (detach_remote base) (fun _ => + CUntilNone (reclaim_step base)). + +Definition offer_block (base : nat) (client : bool) : CProg unit := + CBind (CRead (mailbox base client)) (fun offered => + if Nat.eqb offered 0 then + CBind (CRead (local_head base)) (fun block => + if Nat.eqb block 0 then + CBind CYield (fun _ => CRet tt) + else + CBind (CRead block) (fun next => + CBind (CWrite (local_head base) next) (fun _ => + CBind (CWrite (mailbox base client) block) (fun _ => + CBind (CEmit tag_alloc block) (fun _ => + CBind CYield (fun _ => CRet tt)))))) + else + CBind CYield (fun _ => CRet tt)). + +Definition client_round (base : nat) (client : bool) : CProg (option unit) := + CBind (CRead (mailbox base client)) (fun block => + if Nat.eqb block 0 then + CBind CYield (fun _ => CRet (Some tt : option unit)) + else + CBind (CWrite (mailbox base client) 0) (fun _ => + CBind (CWrite (S block) (if client then 2 else 1)) (fun _ => + CBind CYield (fun _ => + CBind (remote_free base block) (fun _ => + (* Publication has returned; the client no longer accesses block. *) + CBind CYield (fun _ => + CRet (Some tt : option unit))))))). + +Definition remote_client (base : nat) (client : bool) : CProg unit := + CUntilNone (client_round base client). + +Definition owner_round (base : nat) : CProg (option unit) := + CBind (collect_remote base) (fun _ => + CBind (offer_block base false) (fun _ => + CBind (offer_block base true) (fun _ => + CRet (Some tt : option unit)))). + +Definition owner (base : nat) : CProg unit := + CBind CYield (fun _ => CUntilNone (owner_round base)). + +Definition allocator_program (capacity : nat) : CProg unit := + CBind (new_page capacity) (fun base => + CBind (CFork (remote_client base false)) (fun _ => + CBind (CFork (remote_client base true)) (fun _ => + owner base))). diff --git a/examples/CSL/Allocator/Tests.v b/examples/CSL/Allocator/Tests.v new file mode 100644 index 0000000..d7f6675 --- /dev/null +++ b/examples/CSL/Allocator/Tests.v @@ -0,0 +1,234 @@ +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Sorting.Permutation. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.Yield.RoundRobin + ICTree.Logic.State Logic.Core Utils.Vectors. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness + CSL.Allocator.NegativeTests. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. +Local Open Scope ticl_scope. +Local Open Scope nat_scope. + +(** These probes execute allocation and checked initialization before reading. + The arbitrary continuation observes the returned base/value, exact heap, + unchanged counter, and unchanged scheduling focus/cursor. *) +Example new_page_two_source n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) cursor c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_page 2) >>= K)) (Some i) cursor (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) (Some i) cursor + (page_heap 1 2 hemp,c). +Proof. apply interp_rr_new_page_hemp. Qed. + +Example new_page_two_source_reads n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) cursor c : + List.Forall (fun '(offset,value) => + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind (new_page 2) + (fun base => CRead (base+offset))) >>= K)) (Some i) cursor (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) cursor + (page_heap 1 2 hemp,c)) + [(0,0);(1,6);(2,0);(3,0);(4,0);(5,8);(6,0);(7,0);(8,0)]. +Proof. + repeat constructor; apply interp_rr_new_page_read; reflexivity. +Qed. + +Example new_page_two_exact_domain x : + page_heap 1 2 hemp x <> None <-> 1 <= x /\ x <= 9. +Proof. rewrite page_heap_closed_dom; unfold page_size; lia. Qed. + +Example new_page_two_source_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) cursor c : + List.Forall (fun address => + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind (new_page 2) + (fun _ => CRead address)) >>= K)) (Some i) cursor (hemp,c) ~ + (stuck : ictreeW SObs (unit * SSig))) [0;10]. +Proof. + repeat constructor; apply interp_rr_new_page_read_missing; reflexivity. +Qed. + +Example new_page_zero_source n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) c : + interp_nd (S n) + (ts @ i := (denote_flow (new_page 0) >>= K)) (Some i) (hemp,c) ~ + interp_nd (S n) (ts @ i := K (Some 1)) (Some i) (page_heap 1 0 hemp,c). +Proof. apply interp_nd_new_page_hemp. Qed. + +Example new_page_zero_source_reads n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) c : + List.Forall (fun offset => + interp_nd (S n) + (ts @ i := (denote_flow (CBind (new_page 0) + (fun base => CRead (base+offset))) >>= K)) (Some i) (hemp,c) ~ + interp_nd (S n) (ts @ i := K (Some 0)) (Some i) (page_heap 1 0 hemp,c)) + [0;1;2;3;4]. +Proof. + repeat constructor; apply interp_nd_new_page_read; reflexivity. +Qed. + +Example new_page_zero_exact_domain x : + page_heap 1 0 hemp x <> None <-> 1 <= x /\ x <= 5. +Proof. rewrite page_heap_closed_dom; unfold page_size; lia. Qed. + +Definition fixture_events (result : option (AState * list SObs)) : option (list SObs) := + match result with None => None | Some (_,logs) => Some logs end. +Definition fixture_cells (addresses : list nat) (result : option (AState * list SObs)) + : option (list (option nat)) := + match result with None => None | Some (s,_) => Some (List.map (aheap s) addresses) end. +Definition fixture_counter (result : option (AState * list SObs)) : option nat := + match result with None => None | Some (s,_) => Some (acount s) end. +Definition fixture_controls (result : option (AState * list SObs)) + : option (owner_pc * remote_pc * remote_pc) := + match result with None => None + | Some (s,_) => Some (owner_state s,remote0_state s,remote1_state s) end. + +Definition rr_prefix_fixture := + run_turns 1 (demo_rr_script 0 57) (initial_state 2 0). +Definition rr_cycle_fixture := + match rr_prefix_fixture with None => None | Some (s,_) => + run_turns 1 (demo_rr_script 57 42) s end. +Definition aba_before_reuse := + List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 3. +Definition aba_before_commit := + aba_before_reuse ++ List.repeat Owner 6 ++ List.repeat Remote0 4. +Definition aba_script := aba_before_commit ++ [Remote1]. +Definition aba_fixture := run_turns 1 aba_script (initial_state 2 0). +Definition starvation_prefix_fixture := + run_turns 1 starvation_prefix (initial_state 2 0). +Definition starvation_cycle_fixture := + match starvation_prefix_fixture with None => None | Some (s,_) => + run_turns 1 starvation_cycle s end. +Definition owner_stall_prefix_fixture := + run_turns 1 owner_stall_prefix (initial_state 2 0). +Definition owner_stall_polling_fixture := + match owner_stall_prefix_fixture with None => None | Some (s,_) => + run_turns 1 owner_stall_cycle s end. + +Example rr_prefix_events : fixture_events rr_prefix_fixture = Some + [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 3 8 3; SPop 1 8 4; + SPop 2 8 5; SPop 2 6 6; SPop 0 6 7; SPop 0 8 8]. +Proof. vm_compute; reflexivity. Qed. +Example rr_prefix_state : + fixture_cells (List.seq 1 9) rr_prefix_fixture = + Some (List.map (@Some nat) [0;0;0;0;8;8;1;0;2]) /\ + fixture_counter rr_prefix_fixture = Some 9 /\ + fixture_controls rr_prefix_fixture = Some (ORead,RRead 6,RPoll). +Proof. vm_compute; repeat split; reflexivity. Qed. +Example rr_next_cycle_events : fixture_events rr_cycle_fixture = Some + [SPop 1 6 9; SPop 3 8 10; SPop 1 8 11; SPop 2 8 12; + SPop 2 6 13; SPop 0 6 14; SPop 0 8 15]. +Proof. vm_compute; reflexivity. Qed. +Example rr_next_cycle_state : + fixture_cells (List.seq 1 9) rr_cycle_fixture = fixture_cells (List.seq 1 9) rr_prefix_fixture /\ + fixture_controls rr_cycle_fixture = fixture_controls rr_prefix_fixture /\ + fixture_counter rr_cycle_fixture = Some 16. +Proof. vm_compute; repeat split; reflexivity. Qed. +Example rr_actual_source : + run_rr (allocator_program 2) hemp 0 ~ emit_list (demo_prefix 0) (demo_cycle 9). +Proof. exact (run_rr_allocator_demo_bisim 0). Qed. + +Definition aba_logs : list SObs := + [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 2 6 3; + SPop 0 6 4; SPop 1 6 5; SPop 1 8 6]. +Example aba_snapshot_survives_reuse : + fixture_controls (run_turns 1 aba_before_reuse (initial_state 2 0)) = + Some (ORead,RPoll,RCAS 8 6) /\ + fixture_controls (run_turns 1 aba_before_commit (initial_state 2 0)) = + Some (ORead,RPoll,RCAS 8 6) /\ + fixture_cells [1] (run_turns 1 aba_before_reuse (initial_state 2 0)) = Some [Some 6] /\ + fixture_cells [1] (run_turns 1 aba_before_commit (initial_state 2 0)) = Some [Some 6]. +Proof. vm_compute; repeat split; reflexivity. Qed. +Example aba_events : fixture_events aba_fixture = Some aba_logs. +Proof. vm_compute; reflexivity. Qed. +Example aba_links_and_counter : + fixture_cells [1;8;6] aba_fixture = Some [Some 8;Some 6;Some 0] /\ + fixture_counter aba_fixture = Some 7. +Proof. vm_compute; split; reflexivity. Qed. +Lemma aba_run_no_loss : exists last, + aba_fixture = Some (last,aba_logs) /\ + allocator_inv 1 2 last /\ + aheap last (remote_head 1) = Some 8 /\ free_chain (aheap last) [8;6] /\ + NoDup [8;6] /\ Permutation [8;6] (page_blocks 1 2). +Proof. + assert (Hrun : exists last, aba_fixture = Some (last,aba_logs)). + { eexists; vm_compute; reflexivity. } + destruct Hrun as [last Hrun]; exists last; split; [exact Hrun|]; split. + - eapply run_turns_preserves_inv; [apply initial_state_inv|exact Hrun]. + - vm_compute in Hrun; inversion Hrun; subst last. + split; [reflexivity|]; split; [repeat split; reflexivity|]; split. + + repeat constructor; cbn; intuition congruence. + + change (Permutation [8;6] [6;8]); apply perm_swap. +Qed. +Theorem aba_actual_source_no_loss : exists last labels residual, + aba_fixture = Some (last,aba_logs) /\ allocator_inv 1 2 last /\ + aheap last (remote_head 1) = Some 8 /\ free_chain (aheap last) [8;6] /\ + label_logs labels = aba_logs /\ label_taus labels = 23 /\ + finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + residual ~ model_nd 1 last. +Proof. + destruct aba_run_no_loss as (last & Hrun & Hinv & Hhead & Hchain & Hnd & Hp). + destruct (run_turns_realizes_source 2 0 aba_script last aba_logs Hrun) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). + exists last, labels, residual; repeat first [assumption | split]. +Qed. + +Example starvation_prefix_events : fixture_events starvation_prefix_fixture = Some + [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 3 8 3; SPop 2 6 4; SPop 0 6 5]. +Proof. vm_compute; reflexivity. Qed. +Example starvation_cycle_events : fixture_events starvation_cycle_fixture = Some + [SPop 1 6 6; SPop 3 8 7; SPop 2 6 8; SPop 0 6 9]. +Proof. vm_compute; reflexivity. Qed. +Example starvation_chained_cycle_state : + fixture_cells (List.seq 1 9) starvation_prefix_fixture = + Some (List.map (@Some nat) [0;0;0;6;0;0;1;0;2]) /\ + fixture_cells (List.seq 1 9) starvation_cycle_fixture = + fixture_cells (List.seq 1 9) starvation_prefix_fixture /\ + fixture_controls starvation_cycle_fixture = Some (ORead,RPoll,RRead 8) /\ + fixture_counter starvation_cycle_fixture = Some 10. +Proof. vm_compute; repeat split; reflexivity. Qed. +Theorem starvation_chained_cycle_actual_source : exists last labels residual, + run_turns 1 (starvation_prefix ++ starvation_cycle) (initial_state 2 0) = + Some (last,starve_prefix_logs 0 ++ starve_cycle_logs 6) /\ + label_logs labels = starve_prefix_logs 0 ++ starve_cycle_logs 6 /\ + label_taus labels = 32 /\ + finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + residual ~ model_nd 1 last. +Proof. + destruct (starve_prefix_run 0) as (first & Hprefix & Hfirst). + destruct (starve_cycle_run_actual 6 first Hfirst) as (last & Hcycle & Hlast). + pose proof (run_turns_compose 1 starvation_prefix starvation_cycle + (initial_state 2 0) first last (starve_prefix_logs 0) (starve_cycle_logs 6) + Hprefix Hcycle) as Hrun. + destruct (run_turns_realizes_source 2 0 (starvation_prefix ++ starvation_cycle) + last (starve_prefix_logs 0 ++ starve_cycle_logs 6) Hrun) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). + exists last, labels, residual; repeat first [assumption | split]. +Qed. + +Example owner_stall_prefix_events : fixture_events owner_stall_prefix_fixture = Some + [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 1 8 3]. +Proof. vm_compute; reflexivity. Qed. +Example owner_stall_polling_retains_remote_list : + fixture_events owner_stall_polling_fixture = Some [] /\ + fixture_cells [1;8;6] owner_stall_polling_fixture = Some [Some 8;Some 6;Some 0] /\ + fixture_counter owner_stall_polling_fixture = Some 4 /\ + fixture_controls owner_stall_polling_fixture = Some (ORead,RPoll,RPoll). +Proof. vm_compute; repeat split; reflexivity. Qed. + +Example allocator_allocation_recurs_fresh : + <( {run_rr (allocator_program 2) hemp 0}, Pure + |= AG (AF visW {fun o => stag o = tag_alloc /\ 100 <= sidx o}) )>. +Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. +Example allocator_remote_free_recurs_fresh : + <( {run_rr (allocator_program 2) hemp 0}, Pure + |= AG (AF visW {fun o => stag o = tag_retire /\ 100 <= sidx o}) )>. +Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. +Example allocator_reclamation_recurs_fresh : + <( {run_rr (allocator_program 2) hemp 0}, Pure + |= AG (AF visW {fun o => stag o = tag_reclaim /\ 100 <= sidx o}) )>. +Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. diff --git a/examples/CSL/Compose.v b/examples/CSL/Compose.v new file mode 100644 index 0000000..519486f --- /dev/null +++ b/examples/CSL/Compose.v @@ -0,0 +1,429 @@ +(** * Compose: recurring per-queue progress for TWO ACTIVE queues. + + This is the experiment's positive result. Both queues are running, under + the nonpreemptive cyclic scheduler that is part of the program + ([SLang.sbody]), and each one still satisfies the nested recurrence + formula of the frozen single-queue theorem. + + The claim is deliberately NOT "the second queue is a frame". A frame is a + resource nobody touches; here the other queue is rewritten on every second + turn. The proof is organised to make the difference visible: + + - [step_focus] / [step_foreign] are the two resource-level turn lemmas. + [step_foreign] is where active composition differs from framing: the + focused queue's representation must survive a step of the OTHER + component, and that is [Sep2.foreign_pres], not a frame rule. + + - the temporal layer reuses the frozen loop rules unchanged + ([ICTree.Logic.State.ag_state_iter] for the outer [AG] and + [Recurrence.owned_aul_iter_ghost] for the inner [AF]). No fixed point + is unfolded anywhere in this file. + + - the variant is the reused natural position rank plus ONE new component, + the scheduler phase ([Lex.rank3]). The phase component is what makes a + foreign turn count as progress; without it the composition does not + close. It is still a [nat]: no ordinal is used or needed. + + The whole development is stated for an arbitrary FOCUS, so the two + per-queue theorems are two instantiations of one proof rather than a + copied proof. *) + +From Stdlib Require Import + List + Lia + Bool + Arith.PeanoNat + Arith.Wf_nat + Relations. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame CSL.Recurrence CSL.Sep2 CSL.SLang CSL.Lex. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** A queue that still contains an element is non-empty. Used to keep the + focused queue's node list non-empty across a FOREIGN turn without + destructing it. *) +Lemma qrep_find_nonnil: forall hdr ns vs h nl d, + qrep hdr ns vs h -> find nl vs = Some d -> ns <> []. +Proof. + intros hdr ns vs h nl d Hq Hf C; subst ns. + apply qrep_len in Hq; cbn in Hq. + destruct vs as [| x vs]; [cbn in Hf; discriminate | cbn in Hq; discriminate]. +Qed. + +Section Composition. + (** [u]/[v] are the two headers the PROGRAM alternates between. [fh] is the + header of the queue whose progress we are proving, [gh] the other one, + and [fturn] the (program-computed) predicate saying whose turn it is. + The four hypotheses connect the focus to the scheduler; they are + discharged by [Nat.even] / [negb ∘ Nat.even] at the two instantiations + below, so no scheduling assumption survives into the theorems. *) + Context (u v: nat) (fq fh gh: nat) (fturn: nat -> bool) + (Hfh: forall n, fturn n = true -> hdrof u v n = fh) + (Hgh: forall n, fturn n = false -> hdrof u v n = gh) + (Hft: forall n, fturn n = true -> tagof n = fq) + (Hflip: forall n, fturn (S n) = negb (fturn n)). + + Lemma fturn_t: forall n, fturn n = true -> fturn (S n) = false. + Proof. intros n H; rewrite Hflip, H; reflexivity. Qed. + + Lemma fturn_f: forall n, fturn n = false -> fturn (S n) = true. + Proof. intros n H; rewrite Hflip, H; reflexivity. Qed. + + (** ** The two resource-level turn lemmas *) + + (** A turn of the FOCUSED queue. Reused: [HeapQ.rot_heap_spec]. New: the + foreign queue must survive it ([Sep2.foreign_pres_rot]) and footprint + disjointness must be transported ([HeapQ.qcells_rot]). *) + Lemma step_focus: forall nsf vsf nsg vsg a pv h, + qrep fh (a :: nsf) (pv :: vsf) h -> + qrep gh nsg vsg h -> + Disj fh (a :: nsf) gh nsg -> + qrep fh (nsf ++ [a]) (vsf ++ [pv]) + (rot_heap fh a (hdf nsf 0) (zof fh nsf) h) + /\ qrep gh nsg vsg (rot_heap fh a (hdf nsf 0) (zof fh nsf) h) + /\ Disj fh (nsf ++ [a]) gh nsg. + Proof. + intros nsf vsf nsg vsg a pv h Hqf Hqg Hdj. + split; [apply (rot_heap_spec fh a nsf pv vsf h Hqf) |]. + split. + - exact (foreign_pres_rot fh a nsf (pv :: vsf) gh nsg vsg h Hqf Hqg Hdj). + - intros x Hx; apply Hdj, (qcells_rot fh a nsf x), Hx. + Qed. + + (** A turn of the FOREIGN queue. This is the statement that has no + counterpart in the unused-frame experiment: the focused queue's + representation, AT THE SAME abstract queue, survives a step of a + component that is itself active. *) + Lemma step_foreign: forall nsf vsf nsg vsg b pw h, + qrep fh nsf vsf h -> nsf <> [] -> + qrep gh (b :: nsg) (pw :: vsg) h -> + Disj fh nsf gh (b :: nsg) -> + qrep fh nsf vsf (rot_heap gh b (hdf nsg 0) (zof gh nsg) h) + /\ qrep gh (nsg ++ [b]) (vsg ++ [pw]) + (rot_heap gh b (hdf nsg 0) (zof gh nsg) h) + /\ Disj fh nsf gh (nsg ++ [b]). + Proof. + intros nsf vsf nsg vsg b pw h Hqf Hnef Hqg Hdj. + split. + - exact (foreign_pres_rot gh b nsg (pw :: vsg) fh nsf vsf h Hqg Hqf + (Disj_sym _ _ _ _ Hdj)). + - split; [apply (rot_heap_spec gh b nsg pw vsg h Hqg) |]. + intros x Hx Hy; apply (Hdj x Hx), (qcells_rot gh b nsg x), Hy. + Qed. + + (** ** The invariants *) + + (** The [AG] invariant: BOTH queues are represented in the shared heap, their + footprints are disjoint, and each still contains its observed element. + The abstract queues are existentially quantified, exactly as in the + frozen single-queue proof. *) + Definition Iq (nlf nlg: nat) (h: Heap) : Prop := + exists nsf vsf nsg vsg df dg, + qrep fh nsf vsf h /\ qrep gh nsg vsg h /\ Disj fh nsf gh nsg + /\ find nlf vsf = Some df /\ find nlg vsg = Some dg. + + (** The ghost invariant of the inner eventuality. The rank is + (occurrence bound left, position in the focused queue, scheduler phase). + Neither the heap nor the world appears in it. *) + Definition Ig (nlf nlg kb: nat) (m: nat * (nat * nat)) (n: nat) (s: SSig) + : Prop := + exists nsf vsf nsg vsg df dg, + qrep fh nsf vsf (fst s) /\ qrep gh nsg vsg (fst s) /\ Disj fh nsf gh nsg + /\ find nlf vsf = Some df /\ find nlg vsg = Some dg + /\ m = (kb - snd s, (df, if fturn n then 0 else 1)). + + (** ** The inner eventuality: the focused queue pops its element again *) + + Section Inner. + Context (nlf nlg kb: nat) (P: SObs -> Prop) + (HP: forall j, Nat.le kb j -> P (SPop fq nlf j)). + + Lemma inner_af: forall n h c w, + not_done w -> + Iq nlf nlg h -> + <( {interp_state sh (sched u v n) (h, c)}, w |= AF visW {P} )>. + Proof. + intros n h c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). + unfold sched. + apply (owned_aul_iter_ghost sh rank3 (Ig nlf nlg kb) (sbody u v) _ _ + rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n (h, c) w Hd). + - exists nsf, vsf, nsg, vsg, df, dg; cbn. + split; [exact Hqf |]; split; [exact Hqg |]; split; [exact Hdj |]; + split; [exact Hff |]; split; [exact Hfg | reflexivity]. + - clear n h c w Hd nsf vsf nsg vsg df dg Hqf Hqg Hdj Hff Hfg. + intros m n s w Hd + (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg & Hm). + destruct s as (h, c); cbn in Hqf, Hqg, Hm. + destruct (fturn n) eqn:Eph. + + (* --- the FOCUSED queue's turn --- *) + destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. + destruct nsf as [| a nsf']; + [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. + pose proof (sbody_spec u v n a nsf' pv vsf' h c) as Hspec. + rewrite (Hfh n Eph), (Hft n Eph) in Hspec. + specialize (Hspec Hqf). + destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) + as (Hqf' & Hqg' & Hdj'). + assert (Hstep: forall df', + find nlf (vsf' ++ [pv]) = Some df' -> + rank3 (kb - S c, (df', 1)) m -> + (exists g' i' s' w', + not_done w' + /\ <[ {interp_state sh ((sbody u v) n) (h, c)}, w + |= ⊤ AU AX done= {(@inl nat unit i', s')} w' ]> + /\ Ig nlf nlg kb g' i' s' + /\ rank3 g' m)). + { intros df' Hdf' Hlex. + exists (kb - S c, (df', 1)), (S n), + (rot_heap fh a (hdf nsf' 0) (zof fh nsf') h, S c), + (Obs (Log (SPop fq pv c)) tt). + split; [constructor |]. + split. + { rewrite Hspec; apply aur_log; + [cleft; apply axr_ret; [constructor | split; reflexivity] + | apply ticll_top; assumption]. } + split; [| exact Hlex]. + exists (nsf' ++ [a]), (vsf' ++ [pv]), nsg, vsg, df', dg; cbn. + split; [exact Hqf' |]; split; [exact Hqg' |]; split; [exact Hdj' |]; + split; [exact Hdf' |]; split; [exact Hfg |]. + rewrite (fturn_t n Eph); reflexivity. } + destruct df as [| d0]. + * (* the element is at the head of the focused queue *) + pose proof (find_head _ _ _ Hff) as Hv; subst pv. + destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. + -- (* and the occurrence bound is met: observe it now *) + left. + rewrite Hspec. + apply afl_log; [assumption |]. + cleft; apply ticll_vis; constructor; now apply HP. + -- (* the bound is not met yet: rotate, the bound gets closer *) + right. + destruct (find_last_ex nlf vsf') as (df' & Hdf'). + apply (Hstep df'); [exact Hdf' | rewrite Hm; apply rank3_bound; lia]. + * (* the element is deeper: rotate, its position falls *) + right. + apply (Hstep d0). + -- rewrite <- rotl_cons; eapply find_rotl; exact Hff. + -- rewrite Hm; destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. + ++ replace (kb - S c) with (kb - c) by lia. + apply rank3_pos; lia. + ++ apply rank3_bound; lia. + + (* --- the FOREIGN queue's turn --- *) + assert (Hnef: nsf <> []) by (eapply qrep_find_nonnil; eassumption). + destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. + destruct nsg as [| b nsg']; + [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. + pose proof (sbody_spec u v n b nsg' pw vsg' h c) as Hspec. + rewrite (Hgh n Eph) in Hspec. + specialize (Hspec Hqg). + destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) + as (Hqf' & Hqg' & Hdj'). + destruct (find_rotl_pres _ _ _ _ Hfg) as (dg' & Hdg'). + rewrite rotl_cons in Hdg'. + right. + exists (kb - S c, (df, 0)), (S n), + (rot_heap gh b (hdf nsg' 0) (zof gh nsg') h, S c), + (Obs (Log (SPop (tagof n) pw c)) tt). + split; [constructor |]. + split. + { rewrite Hspec; apply aur_log; + [cleft; apply axr_ret; [constructor | split; reflexivity] + | apply ticll_top; assumption]. } + split. + { exists nsf, vsf, (nsg' ++ [b]), (vsg' ++ [pw]), df, dg'; cbn. + split; [exact Hqf' |]; split; [exact Hqg' |]; split; [exact Hdj' |]; + split; [exact Hff |]; split; [exact Hdg' |]. + rewrite (fturn_f n Eph); reflexivity. } + rewrite Hm; destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. + * replace (kb - S c) with (kb - c) by lia. + apply rank3_phase; lia. + * apply rank3_bound; lia. + Qed. + + (** ** The recurrence theorem for the focused queue *) + Theorem sched_agaf: forall n h c w, + not_done w -> + Iq nlf nlg h -> + <( {interp_state sh (sched u v n) (h, c)}, w |= AG (AF visW {P}) )>. + Proof. + intros n h c w Hd HI. + unfold sched. + apply (ag_state_iter sh (h, c) + (fun (_: nat) (s: SSig) (_: WorldW SObs) => Iq nlf nlg (fst s)) + n w); [assumption | exact HI |]. + clear n h c w Hd HI. + intros n s w Hd HI. + destruct s as (h, c); cbn in HI. + split; [now apply inner_af |]. + destruct HI + as (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). + destruct (fturn n) eqn:Eph. + - (* focused turn *) + destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. + destruct nsf as [| a nsf']; + [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. + pose proof (sbody_spec u v n a nsf' pv vsf' h c) as Hspec. + rewrite (Hfh n Eph), (Hft n Eph) in Hspec. + specialize (Hspec Hqf). + destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) + as (Hqf' & Hqg' & Hdj'). + destruct (find_rotl_pres _ _ _ _ Hff) as (df' & Hdf'). + rewrite rotl_cons in Hdf'. + rewrite Hspec. + apply anr_log; [| apply ticll_top; assumption]. + cleft; apply axr_ret; [constructor |]. + exists (S n); split; [reflexivity | split; [constructor |]]. + exists (nsf' ++ [a]), (vsf' ++ [pv]), nsg, vsg, df', dg; cbn. + split; [exact Hqf' |]; split; [exact Hqg' |]; split; [exact Hdj' |]; + split; [exact Hdf' | exact Hfg]. + - (* foreign turn *) + assert (Hnef: nsf <> []) by (eapply qrep_find_nonnil; eassumption). + destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. + destruct nsg as [| b nsg']; + [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. + pose proof (sbody_spec u v n b nsg' pw vsg' h c) as Hspec. + rewrite (Hgh n Eph) in Hspec. + specialize (Hspec Hqg). + destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) + as (Hqf' & Hqg' & Hdj'). + destruct (find_rotl_pres _ _ _ _ Hfg) as (dg' & Hdg'). + rewrite rotl_cons in Hdg'. + rewrite Hspec. + apply anr_log; [| apply ticll_top; assumption]. + cleft; apply axr_ret; [constructor |]. + exists (S n); split; [reflexivity | split; [constructor |]]. + exists nsf, vsf, (nsg' ++ [b]), (vsg' ++ [pw]), df, dg'; cbn. + split; [exact Hqf' |]; split; [exact Hqg' |]; split; [exact Hdj' |]; + split; [exact Hff | exact Hdg']. + Qed. + End Inner. +End Composition. + +(** ** The two per-queue theorems. + + Both are instantiations of ONE proof: the focus is a parameter, and the + scheduler hypotheses are discharged by [Nat.even] and its negation. Note + the quantification over the turn counter [n]: the theorems hold from + EITHER starting scheduler phase, and from any point of the schedule. *) + +Lemma even_true_hdr: forall u v n, Nat.even n = true -> hdrof u v n = u. +Proof. exact hdrof_even. Qed. + +Lemma neg_even_true: forall n, negb (Nat.even n) = true -> Nat.even n = false. +Proof. intros n H; now apply negb_true_iff in H. Qed. + +Lemma neg_even_false: forall n, negb (Nat.even n) = false -> Nat.even n = true. +Proof. intros n H; now apply negb_false_iff in H. Qed. + +Lemma neg_even_flip: forall n, negb (Nat.even (S n)) = negb (negb (Nat.even n)). +Proof. intro n; now rewrite even_flip. Qed. + +(** *** Queue 1 (the one the scheduler serves on even turns) *) + +Theorem sched_agaf_q1_gen: forall u v nl1 nl2 kb (P: SObs -> Prop), + (forall j, Nat.le kb j -> P (SPop 1 nl1 j)) -> + forall n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. +Proof. + intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + unfold srun. + apply (sched_agaf u v 1 u v Nat.even + (fun n H => hdrof_even u v n H) + (fun n H => hdrof_odd u v n H) + (fun n H => tagof_even n H) + even_flip nl1 nl2 kb P HP n h c Pure); + [constructor |]. + exists ns1, vs1, ns2, vs2, d1, d2. + split; [exact Hq1 |]; split; [exact Hq2 |]; split; [exact Hdj |]; + split; [exact Hf1 | exact Hf2]. +Qed. + +Theorem sched_agaf_q1: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {spopped 1 nl1}) )>. +Proof. + intros. + eapply (sched_agaf_q1_gen u v nl1 nl2 0 (spopped 1 nl1)); + [intros j _; split; reflexivity | eassumption .. ]. +Qed. + +Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {spopped_after 1 nl1 k}) )>. +Proof. + intros. + eapply (sched_agaf_q1_gen u v nl1 nl2 k (spopped_after 1 nl1 k)); + [intros j Hj; split; [reflexivity | split; [reflexivity | exact Hj]] + | eassumption .. ]. +Qed. + +(** *** Queue 2 (the one the scheduler serves on odd turns) *) + +Theorem sched_agaf_q2_gen: forall u v nl1 nl2 kb (P: SObs -> Prop), + (forall j, Nat.le kb j -> P (SPop 2 nl2 j)) -> + forall n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. +Proof. + intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + unfold srun. + apply (sched_agaf u v 2 v u (fun n => negb (Nat.even n)) + (fun n H => hdrof_odd u v n (neg_even_true n H)) + (fun n H => hdrof_even u v n (neg_even_false n H)) + (fun n H => tagof_odd n (neg_even_true n H)) + neg_even_flip nl2 nl1 kb P HP n h c Pure); + [constructor |]. + exists ns2, vs2, ns1, vs1, d2, d1. + split; [exact Hq2 |]; split; [exact Hq1 |]; + split; [now apply Disj_sym | split; [exact Hf2 | exact Hf1]]. +Qed. + +Theorem sched_agaf_q2: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {spopped 2 nl2}) )>. +Proof. + intros. + eapply (sched_agaf_q2_gen u v nl1 nl2 0 (spopped 2 nl2)); + [intros j _; split; reflexivity | eassumption .. ]. +Qed. + +Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {spopped_after 2 nl2 k}) )>. +Proof. + intros. + eapply (sched_agaf_q2_gen u v nl1 nl2 k (spopped_after 2 nl2 k)); + [intros j Hj; split; [reflexivity | split; [reflexivity | exact Hj]] + | eassumption .. ]. +Qed. diff --git a/examples/CSL/Frame.v b/examples/CSL/Frame.v new file mode 100644 index 0000000..1773da6 --- /dev/null +++ b/examples/CSL/Frame.v @@ -0,0 +1,380 @@ +(** * Frame: the separation-logic layer over the frozen recurrence proof. + + This file adds the RESOURCE reasoning that the recurrence experiment did + not need, and nothing else. It is used by the LOCAL proof family only; + the whole-state family in [Whole.v] never imports it. + + - the PRECISE representation predicate [qrepX = qrep /\ qex] and the + transport theorem [qrepX_frame]: a heap that IS the queue, disjointly + extended by any null-avoiding frame, is a heap that CONTAINS the queue; + + - the converse [qrep_decompose]: every heap containing the queue splits, + UNIQUELY ([qrep_decompose_unique]), as (queue * frame). Together these + say [qrep = qrepX * True] with [qrepX] precise, so "the frame" is a + function of the state rather than a re-chosen existential; + + - the transport COROLLARIES, which are four-line applications of the + byte-frozen theorems of [Recurrence.v]. No temporal invariant, rank, + induction or coinduction is reopened: the corollaries only supply a + weaker precondition to an already-proved theorem; + + - frame PRESERVATION: the run's heap after any number of rotations agrees + with the initial heap outside the queue's footprint ([qstepN_agree]), so + any assertion holding of the frame holds forever + ([frame_assertion_preserved]). [Trace.run_stepN] is what makes "after + n rotations" the same thing as "n observations into the run". + + Nothing here mentions a particular frame. The frames live in the + per-variant files [variants/v*/FrameDef.v]. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From examples Require Import CSL.HeapQ CSL.QLang CSL.Recurrence CSL.Trace CSL.Layout. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** The precise representation predicate *) + +Definition qrepX (hdr: nat) (ns vs: list nat) (h: Heap) : Prop := + qrep hdr ns vs h /\ qex hdr ns h. + +Lemma qrepX_qrep: forall hdr ns vs h, qrepX hdr ns vs h -> qrep hdr ns vs h. +Proof. intros ? ? ? ? (H & _); exact H. Qed. + +(** *** The transport theorem on the PRECONDITION. + + [f] is an arbitrary heap. The two compatibility conditions are exactly + [hdisj h f] -- the frame owns no cell of the queue -- and [f 0 = None] -- + the frame does not allocate the null address, which the language treats as + the end-of-list terminator. Both are refuted by counterexample in + [Overlap.v]. *) +Theorem qrepX_frame: forall hdr ns vs h f, + qrepX hdr ns vs h -> + hdisj h f -> + f 0 = None -> + qrep hdr ns vs (hunion h f). +Proof. + intros hdr ns vs h f ((Hwf & Hhd & Htl & Hch & Hnull & Hfp) & Hex) Hdisj Hf0. + split; [exact Hwf | split; [| split; [| split]]]. + - now apply hunion_some. + - unfold tailok in Htl |- *; destruct ns as [| a ns]. + + now apply hunion_dom. + + now apply hunion_some. + - eapply chain_mono; [exact Hch |]. + intros x Hx; apply hunion_eq; eapply chain_dom; eauto. + - split. + + rewrite hunion_none; assumption. + + intros x Hx; apply hunion_dom, Hfp, Hx. +Qed. + +(** A precise queue owns nothing outside its footprint. *) +Lemma qex_out: forall hdr ns h x, + qex hdr ns h -> ~ In x (qcells hdr ns) -> h x = None. +Proof. + intros hdr ns h x Hex Hout; destruct (h x) eqn:E; + [exfalso; apply Hout, Hex; congruence | reflexivity]. +Qed. + +(** [qrep] only looks at the footprint and at the null cell, so it survives any + change that leaves both alone. This is what turns [qstepN_agree] (the + rotating queue touches nothing outside ITS footprint) into "the unused + second queue is still there, at every reachable state". *) +Lemma qrep_agree_fp: forall hdr ns vs h h', + qrep hdr ns vs h -> + (forall x, In x (qcells hdr ns) -> h' x = h x) -> + h' 0 = None -> + qrep hdr ns vs h'. +Proof. + intros hdr ns vs h h' (Hwf & Hhd & Htl & Hch & Hnull & Hfp) Hag H0. + assert (Hcells: forall x, In x (cells ns) -> h' x = h x) + by (intros x Hx; apply Hag, in_cons, in_cons, Hx). + split; [exact Hwf | split; [| split; [| split]]]. + - rewrite Hag; [exact Hhd | apply in_cons, in_eq]. + - unfold tailok in Htl |- *; destruct ns as [| a ns]; + rewrite Hag by apply in_eq; exact Htl. + - eapply chain_mono; [exact Hch | exact Hcells]. + - split; [exact H0 | intros x Hx; rewrite Hag by exact Hx; now apply Hfp]. +Qed. + +(** ** The canonical decomposition, and its uniqueness *) + +Definition inqb (hdr: nat) (ns: list nat) (x: nat) : bool := + if in_dec Nat.eq_dec x (qcells hdr ns) then true else false. + +Lemma inqb_true: forall hdr ns x, inqb hdr ns x = true <-> In x (qcells hdr ns). +Proof. + intros hdr ns x; unfold inqb; destruct (in_dec Nat.eq_dec x (qcells hdr ns)); + split; intro H; auto; discriminate. +Qed. + +Lemma inqb_false: forall hdr ns x, inqb hdr ns x = false <-> ~ In x (qcells hdr ns). +Proof. + intros hdr ns x; unfold inqb; destruct (in_dec Nat.eq_dec x (qcells hdr ns)); + split; intro H; auto; [discriminate | contradiction]. +Qed. + +Definition qloc (hdr: nat) (ns: list nat) (H: Heap) : Heap := + fun x => if inqb hdr ns x then H x else None. + +Definition qfrm (hdr: nat) (ns: list nat) (H: Heap) : Heap := + fun x => if inqb hdr ns x then None else H x. + +Lemma qloc_in: forall hdr ns H x, In x (qcells hdr ns) -> qloc hdr ns H x = H x. +Proof. intros; unfold qloc; now rewrite (proj2 (inqb_true hdr ns x)). Qed. + +Lemma qloc_out: forall hdr ns H x, ~ In x (qcells hdr ns) -> qloc hdr ns H x = None. +Proof. intros; unfold qloc; now rewrite (proj2 (inqb_false hdr ns x)). Qed. + +Lemma qfrm_in: forall hdr ns H x, In x (qcells hdr ns) -> qfrm hdr ns H x = None. +Proof. intros; unfold qfrm; now rewrite (proj2 (inqb_true hdr ns x)). Qed. + +Lemma qfrm_out: forall hdr ns H x, ~ In x (qcells hdr ns) -> qfrm hdr ns H x = H x. +Proof. intros; unfold qfrm; now rewrite (proj2 (inqb_false hdr ns x)). Qed. + +Theorem qrep_decompose: forall hdr ns vs H, + qrep hdr ns vs H -> + qrepX hdr ns vs (qloc hdr ns H) + /\ hdisj (qloc hdr ns H) (qfrm hdr ns H) + /\ heq H (hunion (qloc hdr ns H) (qfrm hdr ns H)) + /\ qfrm hdr ns H 0 = None. +Proof. + intros hdr ns vs H Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hnull & Hfp). + assert (Hhdr: In hdr (qcells hdr ns)) by apply in_eq. + assert (Hshdr: In (S hdr) (qcells hdr ns)) by (apply in_cons, in_eq). + assert (Hcells: forall x, In x (cells ns) -> In x (qcells hdr ns)) + by (intros x Hx; apply in_cons, in_cons, Hx). + split; [split; [split; [exact Hwf | split; [| split; [| split]]] |] | split; [| split]]. + - rewrite qloc_in; assumption. + - unfold tailok in Htl |- *; destruct ns as [| a ns]; rewrite qloc_in; assumption. + - eapply chain_mono; [exact Hch |]; intros x Hx; apply qloc_in, Hcells, Hx. + - split. + + destruct (in_dec Nat.eq_dec 0 (qcells hdr ns)) as [Hin | Hout]; + [now rewrite qloc_in | now rewrite qloc_out]. + + intros x Hx; rewrite qloc_in by exact Hx; now apply Hfp. + - intros x Hx; unfold qloc in Hx; destruct (inqb hdr ns x) eqn:E; + [now apply inqb_true | congruence]. + - intro x; unfold qloc, qfrm; destruct (inqb hdr ns x); [now right | now left]. + - intro x; unfold hunion, qloc, qfrm; destruct (inqb hdr ns x); + [destruct (H x); reflexivity | reflexivity]. + - destruct (in_dec Nat.eq_dec 0 (qcells hdr ns)) as [Hin | Hout]; + [now rewrite qfrm_in | now rewrite qfrm_out]. +Qed. + +(** Precision: the split is UNIQUE. This is what makes "the frame" a function + of the state, so that "the same [f] throughout execution" is a statement + about one resource rather than a fresh existential at every step. *) +Theorem qrep_decompose_unique: forall hdr ns vs H h f, + qrepX hdr ns vs h -> + hdisj h f -> + heq H (hunion h f) -> + heq h (qloc hdr ns H) /\ heq f (qfrm hdr ns H). +Proof. + intros hdr ns vs H h f (Hq & Hex) Hdisj Heqh. + pose proof (qrep_fp _ _ _ _ Hq) as Hfp. + split; intro x; destruct (in_dec Nat.eq_dec x (qcells hdr ns)) as [Hin | Hout]. + - rewrite qloc_in by exact Hin; rewrite Heqh, hunion_eq by now apply Hfp. + reflexivity. + - rewrite qloc_out by exact Hout. + destruct (h x) eqn:E; [exfalso; apply Hout, Hex; congruence | reflexivity]. + - rewrite qfrm_in by exact Hin. + destruct (Hdisj x) as [Hh | Hf]; [| exact Hf]. + exfalso; apply (Hfp x Hin); exact Hh. + - rewrite qfrm_out by exact Hout; rewrite Heqh, hunion_none; + [reflexivity |]. + destruct (h x) eqn:E; [exfalso; apply Hout, Hex; congruence | reflexivity]. +Qed. + +(** ** The transport corollaries. + + Each of these is an application of a BYTE-FROZEN theorem of + [Recurrence.v] to a weaker precondition. The temporal invariant [Rq], the + ghost invariant [InvQ], the lexicographic rank [lexnat] and the loop rule + [owned_aul_iter_ghost] are untouched, and no fixed point is unfolded. *) + +Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f c, + qrepX hdr ns vs h -> + hdisj h f -> + f 0 = None -> + find nlv vs = Some d -> + <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {popped nlv}) )>. +Proof. + intros hdr nlv ns vs d h f c Hx Hd Hf Hfind. + eapply rotate_agaf_pop_heap; [eapply qrepX_frame; eassumption | exact Hfind]. +Qed. + +Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f c k, + qrepX hdr ns vs h -> + hdisj h f -> + f 0 = None -> + find nlv vs = Some d -> + <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {popped_after nlv k}) )>. +Proof. + intros hdr nlv ns vs d h f c k Hx Hd Hf Hfind. + eapply rotate_agaf_pop_fresh; [eapply qrepX_frame; eassumption | exact Hfind]. +Qed. + +(** The control that separates "the payload is somewhere in the global heap" + from "the payload is popped": an element absent from the OWNED queue is + never observed, no matter what the frame stores. *) +Theorem absent_never_observed_framed: forall hdr ns vs nlv h f c, + qrepX hdr ns vs h -> + hdisj h f -> + f 0 = None -> + ns <> [] -> + ~ In nlv vs -> + <( {run hdr (hunion h f) c}, Pure |= AG (now {obs_sat (fun x => x <> nlv)}) )>. +Proof. + intros hdr ns vs nlv h f c Hx Hd Hf Hne Hnin. + eapply absent_never_observed; + [eapply qrepX_frame; eassumption | exact Hne | exact Hnin]. +Qed. + +(** The stuck control transports too: an empty owned queue is stuck even when + the frame is a large populated heap. *) +Theorem empty_queue_no_ag_framed: forall hdr vs h f c w phi, + qrepX hdr [] vs h -> + hdisj h f -> + f 0 = None -> + ~ <( {run hdr (hunion h f) c}, w |= AG phi )>. +Proof. + intros hdr vs h f c w phi Hx Hd Hf. + eapply empty_queue_no_ag; eapply qrepX_frame; eassumption. +Qed. + +(** ** Frame preservation *) + +Lemma qcells_writes: forall hdr a ns, + In hdr (qcells hdr (a :: ns)) + /\ In (S hdr) (qcells hdr (a :: ns)) + /\ In (S a) (qcells hdr (a :: ns)) + /\ In (S (zof hdr ns)) (qcells hdr (a :: ns)). +Proof. + intros hdr a ns. + split; [apply in_eq |]. + split; [apply in_cons, in_eq |]. + split; [apply in_cons, in_cons, in_cells; exists a; split; [apply in_eq | now right] |]. + destruct ns as [| b ns']. + - cbn [zof]; apply in_cons, in_eq. + - apply in_cons, in_cons, in_cells; exists (zof hdr (b :: ns')); split; [| now right]. + cbn [zof]; apply in_cons, last_in; discriminate. +Qed. + +Lemma qstep_agree: forall hdr ns vs h, + qrep hdr ns vs h -> ns <> [] -> + agree_out (qcells hdr ns) h (qstep hdr ns h). +Proof. + intros hdr ns vs h Hq Hne. + destruct ns as [| a ns']; [contradiction |]. + destruct (qcells_writes hdr a ns') as (H1 & H2 & H3 & H4). + intros x Hx; cbn [qstep]; apply rot_heap_other; + intro C; subst x; contradiction. +Qed. + +Lemma qcells_rotl: forall hdr ns x, + ns <> [] -> (In x (qcells hdr (rotl ns)) <-> In x (qcells hdr ns)). +Proof. + intros hdr [| a ns'] x Hne; [contradiction |]; cbn [rotl]; apply qcells_rot. +Qed. + +Theorem qstepN_agree: forall n hdr ns vs h, + qrep hdr ns vs h -> ns <> [] -> + agree_out (qcells hdr ns) h (qstepN hdr n ns h). +Proof. + induction n as [| n IH]; intros hdr ns vs h Hq Hne. + - intros x Hx; reflexivity. + - intros x Hx; cbn [qstepN]. + rewrite (IH hdr (rotl ns) (rotl vs) (qstep hdr ns h) + (qstep_qrep _ _ _ _ Hq Hne) (rotl_nonnil _ Hne) x). + + now apply (qstep_agree hdr ns vs h Hq Hne). + + intro C; apply Hx, (qcells_rotl hdr ns x Hne), C. +Qed. + +(** The frame sub-heap is preserved POINTWISE, for every number of rotations. *) +Theorem frame_preserved: forall n hdr ns vs h, + qrep hdr ns vs h -> ns <> [] -> + heq (qfrm hdr ns h) (qfrm hdr ns (qstepN hdr n ns h)). +Proof. + intros n hdr ns vs h Hq Hne x. + destruct (in_dec Nat.eq_dec x (qcells hdr ns)) as [Hin | Hout]. + - now rewrite !qfrm_in. + - rewrite !qfrm_out by exact Hout. + symmetry; now apply (qstepN_agree n hdr ns vs h Hq Hne). +Qed. + +Corollary frame_assertion_preserved: forall (A: Heap -> Prop) n hdr ns vs h, + (forall h1 h2, heq h1 h2 -> A h1 -> A h2) -> + qrep hdr ns vs h -> ns <> [] -> + A (qfrm hdr ns h) -> + A (qfrm hdr ns (qstepN hdr n ns h)). +Proof. + intros A n hdr ns vs h HA Hq Hne HAf. + eapply HA; [eapply frame_preserved; eassumption | exact HAf]. +Qed. + +(** The version stated on the ORIGINAL frame [f] of a [*]-decomposition, which + is what the transport corollaries hand the client. *) +Corollary frame_assertion_preserved_sep: forall (A: Heap -> Prop) n hdr ns vs h f, + (forall h1 h2, heq h1 h2 -> A h1 -> A h2) -> + qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> ns <> [] -> + A f -> + A (qfrm hdr ns (qstepN hdr n ns (hunion h f))). +Proof. + intros A n hdr ns vs h f HA Hx Hd Hf Hne HAf. + pose proof (qrepX_frame _ _ _ _ _ Hx Hd Hf) as HqH. + destruct (qrep_decompose_unique hdr ns vs (hunion h f) h f Hx Hd + (fun x => eq_refl)) as (_ & Hfeq). + eapply frame_assertion_preserved; [exact HA | exact HqH | exact Hne |]. + eapply HA; [exact Hfeq | exact HAf]. +Qed. + +(** ** Instantiating the compatibility conditions from an address bound. + + Every frame variant is described by "I allocate only addresses at least + 8"; the owned queue lives below 8 ([Layout.h1_low]). These two lemmas turn + that numeric statement into the two compatibility conditions, once. *) + +Lemma qrepX1: qrepX hdr1 ns1 vs1 h1. +Proof. split; [apply qrep1 | apply qex1]. Qed. + +(** A newly initialized queue owns its block beside the unchanged old heap. *) +Lemma new_queue_heap_owned hdr values h : + Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> + asep (qrepX hdr (queue_nodes hdr (length values)) values) + (fun frame => heq frame h) + (new_queue_heap hdr values h). +Proof. + intros Hhdr Hfree. + exists (qheap hdr (queue_nodes hdr (length values)) values), h. + split; [now apply new_queue_heap_disjoint |]. + split; [now apply new_queue_heap_agrees |]. + split. + - split; [now apply qheap_queue_nodes_rep | apply qheap_qex]. + - intro x; reflexivity. +Qed. diff --git a/examples/CSL/HeapQ.v b/examples/CSL/HeapQ.v new file mode 100644 index 0000000..9737233 --- /dev/null +++ b/examples/CSL/HeapQ.v @@ -0,0 +1,842 @@ +(** * HeapQ: a heap-backed rotating queue -- resource model and pure theory. + + This file contains NO temporal reasoning. It fixes + + - the resource model: a partial map [Heap = nat -> option nat], with + disjointness, union and a domain predicate; + - the representation predicate [qrep hdr ns vs h]: the heap [h] holds a + null-terminated singly linked list of two-cell nodes at the DISTINCT + addresses [ns] carrying the payloads [vs], anchored at a two-cell header + [hdr] (tail pointer) / [S hdr] (head pointer); + - the pure list theory the temporal proof consumes: [chain] append/split, + the footprint permutation, and the [find] lemmas restated at [nat]. + + Design notes, and why they are not free choices: + + - Payloads may REPEAT. [vs] is an arbitrary [list nat]; nothing below + assumes the payloads are distinct. Node ADDRESSES must be distinct and + non-overlapping, which is [qwf]. + + - [qwf] states non-overlap directly ([a <> S b] for any two node names) + rather than through an allocation policy. [qwf_aligned] shows that + two-word alignment is a sufficient concrete policy. No allocation + happens anywhere in this development; [qwf] is a precondition on a + PREALLOCATED structure. + + - The tail pointer is constrained only when the queue is non-empty. That + is what makes the intermediate ownership split of [Rotate.v] uniform: at + the instant the head node is detached, the remaining queue is a genuine + [qrep] even when it has become empty and the tail pointer is stale. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat + Sorting.Permutation. + +Import ListNotations. + +(* Implicit arguments are deliberately OFF: every lemma below is applied + positionally in the rotation proof. *) + +(** ** The resource model *) + +From TICL Require Export Lang.CSL.Heap. + +Lemma upd_eq: forall h a v, upd h a v a = Some v. +Proof. intros; unfold upd; now rewrite Nat.eqb_refl. Qed. + +Lemma upd_neq: forall h a v x, x <> a -> upd h a v x = h x. +Proof. intros; unfold upd; now apply Nat.eqb_neq in H as ->. Qed. + +Lemma upd_dom: forall h a v x, h a <> None -> (upd h a v x <> None <-> h x <> None). +Proof. + intros h a v x Ha; unfold upd; destruct (Nat.eqb_spec x a) as [-> | Hne]. + - split; [intros _; exact Ha | intros _; discriminate]. + - reflexivity. +Qed. +(** ** Cells, footprints and well-formedness *) + +(** The two cells of a node named [a]: the payload cell [a] and the link cell + [S a]. *) +Definition cells (l: list nat) : list nat := flat_map (fun a => [a; S a]) l. + +(** The footprint of a queue: the header's two cells plus every node's two + cells. *) +Definition qcells (hdr: nat) (ns: list nat) : list nat := hdr :: S hdr :: cells ns. + +Lemma in_cells: forall x l, In x (cells l) <-> exists a, In a l /\ (x = a \/ x = S a). +Proof. + intros x l; unfold cells; rewrite in_flat_map; split. + - intros (a & Ha & Hx); exists a; split; [assumption |]. + cbn in Hx; destruct Hx as [Heq | [Heq | []]]; [left | right]; congruence. + - intros (a & Ha & Hx); exists a; split; [assumption |]. + cbn; destruct Hx as [-> | ->]; auto. +Qed. + +Lemma cells_app: forall l1 l2, cells (l1 ++ l2) = cells l1 ++ cells l2. +Proof. intros; apply flat_map_app. Qed. + +(** Well-formedness of the node NAMES: distinct, non-null, and non-overlapping + (no node's payload cell is another node's link cell). Payloads are + unconstrained. *) +Definition qwf (hdr: nat) (ns: list nat) : Prop := + NoDup (hdr :: ns) + /\ ~ In 0 (hdr :: ns) + /\ (forall a b, In a (hdr :: ns) -> In b (hdr :: ns) -> a <> S b). + +(** Two-word alignment is a sufficient concrete policy for the non-overlap + condition. It is offered as evidence that [qwf] is satisfiable by a + standard layout, not used anywhere below. *) +Lemma qwf_aligned: forall hdr ns, + NoDup (hdr :: ns) -> ~ In 0 (hdr :: ns) -> + Forall Nat.Even (hdr :: ns) -> + qwf hdr ns. +Proof. + intros hdr ns Hnd H0 Hev; split; [assumption | split; [assumption |]]. + intros a b Ha Hb ->. + rewrite Forall_forall in Hev. + destruct (Hev _ Ha) as (m & Hm); destruct (Hev _ Hb) as (k & Hk); lia. +Qed. + +Lemma qwf_perm: forall hdr ns ns', Permutation ns ns' -> qwf hdr ns -> qwf hdr ns'. +Proof. + intros hdr ns ns' Hp (Hnd & H0 & Hov). + assert (Hp': Permutation (hdr :: ns) (hdr :: ns')) by now constructor. + split; [| split]. + - eapply Permutation_NoDup; eauto. + - intro Hin; apply H0; eapply Permutation_in; [apply Permutation_sym|]; eauto. + - intros a b Ha Hb; apply Hov; + eapply Permutation_in; [apply Permutation_sym; exact Hp' | exact Ha + | apply Permutation_sym; exact Hp' | exact Hb]. +Qed. + +(** The inequality shapes the rotation proof needs, extracted once. *) +Lemma qwf_hdr_cells: forall hdr ns, qwf hdr ns -> ~ In hdr (cells ns). +Proof. + intros hdr ns (Hnd & H0 & Hov) Hin. + apply NoDup_cons_iff in Hnd as (Hni & _). + apply in_cells in Hin as (a & Ha & [Heq | Heq]). + - subst; contradiction. + - eapply Hov with (a := hdr) (b := a); cbn; auto. +Qed. + +Lemma qwf_shdr_cells: forall hdr ns, qwf hdr ns -> ~ In (S hdr) (cells ns). +Proof. + intros hdr ns (Hnd & H0 & Hov) Hin. + apply NoDup_cons_iff in Hnd as (Hni & _). + apply in_cells in Hin as (a & Ha & [Heq | Heq]). + - eapply Hov with (a := a) (b := hdr); cbn; auto. + - assert (a = hdr) by lia; subst; contradiction. +Qed. + +Lemma qwf_node_cells: forall hdr ns a, + qwf hdr (a :: ns) -> ~ In a (cells ns) /\ ~ In (S a) (cells ns). +Proof. + intros hdr ns a (Hnd & H0 & Hov). + apply NoDup_cons_iff in Hnd as (_ & Hnd). + apply NoDup_cons_iff in Hnd as (Hni & _). + split; intro Hin; apply in_cells in Hin as (b & Hb & [Heq | Heq]). + - subst; contradiction. + - eapply Hov with (a := a) (b := b); cbn; auto. + - eapply Hov with (a := b) (b := a); cbn; auto. + - assert (a = b) by lia; subst; contradiction. +Qed. + +Lemma qwf_zero: forall hdr ns, qwf hdr ns -> ~ In 0 (qcells hdr ns). +Proof. + intros hdr ns (Hnd & H0 & Hov) [Hc | [Hc | Hc]]. + - apply H0; cbn; auto. + - lia. + - apply in_cells in Hc as (a & Ha & [Heq | Heq]); [| lia]. + apply H0; cbn; subst; auto. +Qed. + +(** ** The chain of nodes *) + +Definition hdf (l: list nat) (f: nat) : nat := match l with nil => f | a :: _ => a end. + +Lemma hdf_app: forall l1 l2 f, hdf (l1 ++ l2) f = hdf l1 (hdf l2 f). +Proof. now intros [| a l1] l2 f. Qed. + +(** [chain h ns vs fin]: the addresses [ns] carry the payloads [vs] and are + linked in order, the last link holding [fin]. The terminator is a + PARAMETER: that is what lets the rotation retarget the last link by + [chain_split] + [chain_app] instead of a bespoke surgery lemma. *) +Fixpoint chain (h: Heap) (ns vs: list nat) (fin: nat) : Prop := + match ns, vs with + | nil, nil => True + | a :: ns', v :: vs' => + h a = Some v /\ h (S a) = Some (hdf ns' fin) /\ chain h ns' vs' fin + | _, _ => False + end. + +Lemma chain_len: forall h ns vs f, chain h ns vs f -> length ns = length vs. +Proof. + induction ns as [| a ns IH]; intros [| v vs] f Hc; cbn in *; try contradiction; auto. + destruct Hc as (_ & _ & Hc); f_equal; eauto. +Qed. + +Lemma chain_dom: forall h ns vs f x, chain h ns vs f -> In x (cells ns) -> h x <> None. +Proof. + induction ns as [| a ns IH]; intros [| v vs] f x Hc Hin; cbn in *; + try contradiction; try tauto. + destruct Hc as (Ha & Hsa & Hc). + destruct Hin as [Heq | [Heq | Hin]]; [subst; now rewrite Ha | subst; now rewrite Hsa |]. + eapply IH; eauto. +Qed. + +Definition agree_out (m: list nat) (h h': Heap) : Prop := + forall x, ~ In x m -> h' x = h x. + +Lemma chain_frame: forall h h' m ns vs f, + chain h ns vs f -> + agree_out m h h' -> + (forall x, In x m -> ~ In x (cells ns)) -> + chain h' ns vs f. +Proof. + intros h h' m; induction ns as [| a ns IH]; intros [| v vs] f Hc Hag Hm; + cbn in *; try contradiction; auto. + destruct Hc as (Ha & Hsa & Hc). + split; [| split]. + - rewrite Hag; auto. intro Hin; eapply Hm; eauto; cbn; auto. + - rewrite Hag; auto. intro Hin; eapply Hm; eauto; cbn; auto. + - eapply IH; eauto. intros x Hx Hin; eapply Hm; eauto; cbn; auto. +Qed. + +Lemma chain_app: forall h ns1 vs1 ns2 vs2 f, + chain h ns1 vs1 (hdf ns2 f) -> + chain h ns2 vs2 f -> + chain h (ns1 ++ ns2) (vs1 ++ vs2) f. +Proof. + intros h; induction ns1 as [| a ns1 IH]; intros [| v vs1] ns2 vs2 f H1 H2; + cbn in *; try contradiction; auto. + destruct H1 as (Ha & Hsa & Hc). + split; [assumption | split; [rewrite Hsa; now rewrite hdf_app | now apply IH]]. +Qed. + +Lemma chain_split: forall h ns1 vs1 ns2 vs2 f, + length ns1 = length vs1 -> + chain h (ns1 ++ ns2) (vs1 ++ vs2) f -> + chain h ns1 vs1 (hdf ns2 f) /\ chain h ns2 vs2 f. +Proof. + intros h; induction ns1 as [| a ns1 IH]; intros [| v vs1] ns2 vs2 f Hl Hc; + cbn in *; try discriminate; auto. + destruct Hc as (Ha & Hsa & Hc). + apply IH in Hc as (H1 & H2); [| lia]. + split; [| assumption]. + split; [assumption | split; [rewrite Hsa; now rewrite hdf_app | assumption]]. +Qed. + +(** ** The representation predicate *) + +Definition tailok (hdr: nat) (ns: list nat) (h: Heap) : Prop := + match ns with + | nil => h hdr <> None + | _ => h hdr = Some (last ns 0) + end. + +(** *** MODIFIED FOR THE FRAME EXPERIMENT (one-time resource-layer cost). + + The recurrence experiment's clause 5 was the EXACT domain condition + + [forall x, h x <> None <-> In x (qcells hdr ns)] + + which is a PRECISE assertion: it pins the heap down to the queue's own + footprint and is therefore false of any heap that also holds an unrelated + frame. Under it the recurrence theorem cannot even be STATED about a + framed heap, let alone transported to one. + + Clause 5 is weakened here to the two things the development actually + uses -- null is unallocated, and the footprint is allocated -- so that + [qrep] becomes the INTUITIONISTIC ("heap contains this queue") reading. + The exact reading is retained under the name [qrepX] in [Frame.v], and + [Frame.qrepX_frame] proves [qrepX hdr ns vs h -> hdisj h f -> f 0 = None + -> qrep hdr ns vs (hunion h f)], so nothing proved in the recurrence + experiment is weakened: every old hypothesis still implies the new one + ([Frame.qrepX_qrep]). + + The arity of the conjunction is unchanged, so every destructuring pattern + [(Hwf & Hhd & Htl & Hch & Hdom)] downstream still typechecks. [QLang.v] + and [Recurrence.v] are byte-identical to the recurrence experiment. *) +Definition qrep (hdr: nat) (ns vs: list nat) (h: Heap) : Prop := + qwf hdr ns + /\ h (S hdr) = Some (hdf ns 0) + /\ tailok hdr ns h + /\ chain h ns vs 0 + /\ (h 0 = None /\ forall x, In x (qcells hdr ns) -> h x <> None). + +Lemma qrep_len: forall hdr ns vs h, qrep hdr ns vs h -> length ns = length vs. +Proof. intros ? ? ? ? (_ & _ & _ & Hc & _); eapply chain_len; eauto. Qed. + +(** The null address is never allocated: this is what makes an out-of-footprint + dereference of the null head pointer STUCK under the safe handler. It is + now an explicit clause rather than a consequence of exactness, because a + frame must be allowed to allocate cells the queue does not own -- but NOT + the null cell. That is the first of the two compatibility conditions the + transport theorem needs. *) +Lemma qrep_null: forall hdr ns vs h, qrep hdr ns vs h -> h 0 = None. +Proof. intros hdr ns vs h (_ & _ & _ & _ & Hd); exact (proj1 Hd). Qed. + +Lemma qrep_fp: forall hdr ns vs h, + qrep hdr ns vs h -> forall x, In x (qcells hdr ns) -> h x <> None. +Proof. intros hdr ns vs h (_ & _ & _ & _ & Hd); exact (proj2 Hd). Qed. + +(** *** ADDED FOR THE FRAME EXPERIMENT. + + [qex hdr ns h] is the EXACTNESS side condition that clause 5 used to carry + inside [qrep]. Keeping it separate is what makes framing expressible: + [qrep] says "this heap CONTAINS the queue", [qrep /\ qex] says "this heap + IS the queue". In separation-logic terms [qrep = qrepX * True] and + [qrepX] is the precise assertion; [Frame.v] proves both directions. *) +Definition qex (hdr: nat) (ns: list nat) (h: Heap) : Prop := + forall x, h x <> None -> In x (qcells hdr ns). + +Lemma qrep_head_null_iff: forall hdr ns vs h, + qrep hdr ns vs h -> (hdf ns 0 = 0 <-> ns = []). +Proof. + intros hdr ns vs h (Hwf & _ & _ & _ & _); destruct Hwf as (_ & H0 & _). + destruct ns as [| a ns]; cbn; split; intro Hx; auto. + - exfalso; apply H0; cbn; tauto. + - discriminate. +Qed. + +(** ** Rotation on the abstract lists *) + +Definition rotl {A} (l: list A) : list A := + match l with nil => nil | x :: xs => xs ++ [x] end. + +Lemma rotl_perm: forall {A} (l: list A), Permutation l (rotl l). +Proof. + intros A [| x xs]; cbn; [constructor |]. + apply Permutation_cons_app; rewrite app_nil_r; apply Permutation_refl. +Qed. + +Lemma qcells_rot: forall hdr a ns x, + In x (qcells hdr (ns ++ [a])) <-> In x (qcells hdr (a :: ns)). +Proof. + intros hdr a ns x; unfold qcells. + assert (Hc: forall y, In y (cells (ns ++ [a])) <-> In y (cells (a :: ns))). + { intro y; rewrite cells_app. + replace (cells (a :: ns)) with (cells [a] ++ cells ns) by reflexivity. + rewrite !in_app_iff; tauto. } + split; intros [H | [H | H]]. + - now left. + - now right; left. + - right; right; now apply Hc. + - now left. + - now right; left. + - right; right; now apply Hc. +Qed. + +(** ** [find], restated at [nat]. + + The reference proof [examples/Queue.v] states these over the abstract + payload type [T] of the module [MeQ.ME] with a [RelDec] instance. That + module's [T] is an opaque parameter, so the lemmas cannot be instantiated; + the statements and proof structure are reproduced here at [nat] with + [Nat.eqb]. This is a REPRESENTATION-SPECIFIC ADAPTATION, recorded as such + in the reuse report. *) + +Fixpoint find (t: nat) (l: list nat) : option nat := + match l with + | nil => None + | h :: ts => if Nat.eqb h t then Some 0 else option_map S (find t ts) + end. + +Lemma unfold_find_hd: forall t h ts, + find t (h :: ts) = (if Nat.eqb h t then Some 0 else option_map S (find t ts)). +Proof. reflexivity. Qed. + +Lemma find_last_ex: forall nl ts, exists i0 : nat, find nl (ts ++ [nl]) = Some i0. +Proof. + induction ts as [| a ts IH]; cbn. + - exists 0; now rewrite Nat.eqb_refl. + - destruct IH as (x & Hx); destruct (Nat.eqb_spec a nl) as [-> |]. + + now exists 0. + + exists (S x); now rewrite Hx. +Qed. + +Lemma find_app_l: forall nl ts n l, find nl ts = Some n -> find nl (ts ++ l) = Some n. +Proof. + induction ts as [| a ts IH]; intros n l H; cbn in *; [discriminate |]. + destruct (Nat.eqb a nl); auto. + destruct (find nl ts) eqn:Hf; cbn in *; [| discriminate]. + erewrite IH; eauto. +Qed. + +Lemma find_in: forall nl l n, find nl l = Some n -> In nl l. +Proof. + induction l as [| a l IH]; intros n H; cbn in *; [discriminate |]. + destruct (Nat.eqb_spec a nl) as [-> |]; auto. + destruct (find nl l) eqn:Hf; cbn in *; [| discriminate]; eauto. +Qed. + +Lemma find_nonnil: forall nl l n, find nl l = Some n -> l <> []. +Proof. intros nl [| a l] n H; cbn in *; [discriminate | congruence]. Qed. + +(** The position of [nl] after one rotation: this is the natural rank of the + reference proof, restated here so that the temporal file never re-derives + it. If [nl] is at position [S d] it moves to [d]; if it is at position [0] + it is popped now. *) +Lemma find_rotl: forall nl v vs d, + find nl (v :: vs) = Some (S d) -> find nl (rotl (v :: vs)) = Some d. +Proof. + intros nl v vs d H; cbn in *. + destruct (Nat.eqb_spec v nl) as [-> | Hne]; [discriminate |]. + destruct (find nl vs) as [m |] eqn:Hf; cbn in *; [| discriminate]. + assert (m = d) by congruence; subst. + now apply find_app_l. +Qed. + +Lemma find_rotl_pres: forall nl v vs d, + find nl (v :: vs) = Some d -> exists d', find nl (rotl (v :: vs)) = Some d'. +Proof. + intros nl v vs [| d] H. + - cbn in H; destruct (Nat.eqb_spec v nl) as [-> |]; [| destruct (find nl vs); cbn in H; congruence]. + cbn; apply find_last_ex. + - eexists; eapply find_rotl; eauto. +Qed. + +(** ** The rotation, as heap surgery. + + [rot_heap hdr a n z h] is the heap after the four writes the rotation + performs, in program order: + + 1. [S hdr := n] detach: the head pointer skips the old head node [a]; + 2. [S z := a] append: the old last node (or the header, when the + queue has become empty) links to [a]; + 3. [S a := 0] [a] is now the last node; + 4. [hdr := a] the tail pointer is [a]. + + No cell outside the queue's footprint is touched, and no cell is created: + [rot_heap_dom] states exactly that. *) + +Definition rot_heap (hdr a n z: nat) (h: Heap) : Heap := + upd (upd (upd (upd h (S hdr) n) (S z) a) (S a) 0) hdr a. + +(** The node the append phase links to: the old last node, or the header + itself when detaching emptied the queue. *) +Definition zof (hdr: nat) (ns: list nat) : nat := + match ns with nil => hdr | _ => last ns 0 end. + +Lemma zof_snoc: forall hdr l a, zof hdr (l ++ [a]) = a. +Proof. + intros hdr l a; unfold zof; destruct (l ++ [a]) eqn:E. + - exfalso; apply app_eq_nil in E as (_ & C); discriminate. + - rewrite <- E; apply last_last. +Qed. + +Lemma rot_heap_hdr: forall hdr a n z h, rot_heap hdr a n z h hdr = Some a. +Proof. intros; unfold rot_heap; apply upd_eq. Qed. + +Lemma rot_heap_sa: forall hdr a n z h, + S a <> hdr -> rot_heap hdr a n z h (S a) = Some 0. +Proof. intros; unfold rot_heap; rewrite upd_neq by assumption; apply upd_eq. Qed. + +Lemma rot_heap_sz: forall hdr a n z h, + S z <> hdr -> z <> a -> rot_heap hdr a n z h (S z) = Some a. +Proof. + intros; unfold rot_heap. + rewrite upd_neq by assumption. + rewrite upd_neq by (intro C; apply H0; now injection C). + apply upd_eq. +Qed. + +Lemma rot_heap_shdr: forall hdr a n z h, + hdr <> a -> hdr <> z -> rot_heap hdr a n z h (S hdr) = Some n. +Proof. + intros; unfold rot_heap. + rewrite upd_neq by (intro C; lia). + rewrite upd_neq by (intro C; apply H; now injection C). + rewrite upd_neq by (intro C; apply H0; now injection C). + apply upd_eq. +Qed. + +Lemma rot_heap_other: forall hdr a n z h x, + x <> hdr -> x <> S a -> x <> S z -> x <> S hdr -> + rot_heap hdr a n z h x = h x. +Proof. + intros; unfold rot_heap. + rewrite upd_neq by assumption. + rewrite upd_neq by assumption. + rewrite upd_neq by assumption. + rewrite upd_neq by assumption. + reflexivity. +Qed. + +Lemma rot_heap_dom: forall hdr a n z h, + h (S hdr) <> None -> h (S z) <> None -> h (S a) <> None -> h hdr <> None -> + forall x, rot_heap hdr a n z h x <> None <-> h x <> None. +Proof. + intros hdr a n z h H1 H2 H3 H4 x; unfold rot_heap. + assert (E1: forall y, upd h (S hdr) n y <> None <-> h y <> None) + by (intro; now apply upd_dom). + assert (E2: forall y, upd (upd h (S hdr) n) (S z) a y <> None <-> h y <> None). + { intro y; rewrite upd_dom; [now apply E1 | now apply E1]. } + assert (E3: forall y, upd (upd (upd h (S hdr) n) (S z) a) (S a) 0 y <> None + <-> h y <> None). + { intro y; rewrite upd_dom; [now apply E2 | now apply E2]. } + rewrite upd_dom; [now apply E3 | now apply E3]. +Qed. + +(** *** The intermediate ownership split. + + Between the detach (write 1) and the append (write 2) the heap splits into + two DISJOINT parts: a well-formed queue holding the remaining nodes [ns], + and the two cells of the detached node [a], which the program still owns. + This is the separating conjunction the rotation transfers across, and it is + uniform: when [ns] is empty the remaining queue is still a [qrep], with an + unconstrained (stale) tail pointer. *) + +Definition nodeat (a v nx: nat) (h: Heap) : Prop := + h a = Some v /\ h (S a) = Some nx /\ (forall x, h x <> None <-> (x = a \/ x = S a)). + +(** The address inequalities the rotation needs, derived once from [qwf]. *) +Definition nodeb (a x: nat) : bool := orb (Nat.eqb x a) (Nat.eqb x (S a)). + +Lemma nodeb_true: forall a x, nodeb a x = true <-> (x = a \/ x = S a). +Proof. + intros a x; unfold nodeb; rewrite Bool.orb_true_iff, !Nat.eqb_eq; reflexivity. +Qed. + +Lemma nodeb_false: forall a x, nodeb a x = false <-> (x <> a /\ x <> S a). +Proof. + intros a x; unfold nodeb; rewrite Bool.orb_false_iff, !Nat.eqb_neq; reflexivity. +Qed. + +Lemma qwf_neqs: forall hdr a ns, + qwf hdr (a :: ns) -> + hdr <> a /\ S hdr <> a /\ hdr <> S a /\ S hdr <> S a /\ hdr <> S hdr. +Proof. + intros hdr a ns (Hnd & H0 & Hov). + apply NoDup_cons_iff in Hnd as (Hni & Hnd'). + assert (Hha: hdr <> a) by (intro C; apply Hni; subst; apply in_eq). + split; [exact Hha |]. + split; [intro C; apply (Hov a hdr); + [apply in_cons, in_eq | apply in_eq | congruence] |]. + split; [apply (Hov hdr a); [apply in_eq | apply in_cons, in_eq] |]. + split; [intro C; apply Hha; now injection C |]. + apply (Hov hdr hdr); apply in_eq. +Qed. + +Lemma qwf_neqs_mem: forall hdr a ns z, + qwf hdr (a :: ns) -> In z ns -> + z <> hdr /\ z <> a /\ z <> S hdr /\ z <> S a + /\ S z <> hdr /\ S z <> a /\ S z <> S hdr /\ S z <> S a. +Proof. + intros hdr a ns z (Hnd & H0 & Hov) Hz. + assert (HzL: In z (hdr :: a :: ns)) by (apply in_cons, in_cons; assumption). + apply NoDup_cons_iff in Hnd as (Hni & Hnd'). + apply NoDup_cons_iff in Hnd' as (Hnia & Hnd''). + assert (Hzh: z <> hdr) by (intro C; apply Hni; subst; apply in_cons; assumption). + assert (Hza: z <> a) by (intro C; apply Hnia; subst; assumption). + split; [exact Hzh |]. + split; [exact Hza |]. + split; [apply (Hov z hdr); [assumption | apply in_eq] |]. + split; [apply (Hov z a); [assumption | apply in_cons, in_eq] |]. + split; [intro C; apply (Hov hdr z); [apply in_eq | assumption | congruence] |]. + split; [intro C; apply (Hov a z); + [apply in_cons, in_eq | assumption | congruence] |]. + split; [intro C; apply Hzh; now injection C |]. + intro C; apply Hza; now injection C. +Qed. + +Lemma qwf_tail: forall hdr a ns, qwf hdr (a :: ns) -> qwf hdr ns. +Proof. + intros hdr a ns (Hnd & H0 & Hov); split; [| split]. + - apply NoDup_cons_iff in Hnd as (Hni & Hnd'). + apply NoDup_cons_iff in Hnd' as (_ & Hnd'). + constructor; [intro C; apply Hni; now apply in_cons | assumption]. + - intro C; apply H0; cbn in C |- *; tauto. + - intros x y Hx Hy; apply Hov; cbn in Hx, Hy |- *; tauto. +Qed. + +(** The two halves of the intermediate split, as explicit heaps: the queue + that remains after the head node is detached, and the detached node + itself. They are given as functions rather than existential witnesses so + that the append phase can be stated as consuming exactly [qnode]. *) +Definition qres (hdr a n: nat) (h: Heap) : Heap := + fun x => if nodeb a x then None else upd h (S hdr) n x. + +Definition qnode (a: nat) (h: Heap) : Heap := + fun x => if nodeb a x then h x else None. + +(** The intermediate ownership split needs the EXACT reading: [qnode] is + claimed to own exactly two cells, which is only true if [h] owned exactly + the queue to begin with. The extra [qex] hypothesis and conclusion are + what clause 5 used to supply implicitly. *) +Theorem rot_detach_split: forall hdr a ns v vs h, + qrep hdr (a :: ns) (v :: vs) h -> + qex hdr (a :: ns) h -> + hdisj (qres hdr a (hdf ns 0) h) (qnode a h) + /\ heq (upd h (S hdr) (hdf ns 0)) (hunion (qres hdr a (hdf ns 0) h) (qnode a h)) + /\ (qrep hdr ns vs (qres hdr a (hdf ns 0) h) + /\ qex hdr ns (qres hdr a (hdf ns 0) h)) + /\ nodeat a v (hdf ns 0) (qnode a h). +Proof. + intros hdr a ns v vs h Hq Hex. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom0). + assert (Hdom: forall x, h x <> None <-> In x (qcells hdr (a :: ns))) + by (intro x; split; [apply Hex | apply (proj2 Hdom0)]). + destruct Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). + pose proof (qwf_tail _ _ _ Hwf) as Hwfns. + pose proof (qwf_shdr_cells _ _ Hwfns) as Hshdrnc. + assert (Hhdrdom: h hdr <> None) by (apply Hdom; apply in_eq). + assert (Ea: nodeb a a = true) by (apply nodeb_true; now left). + assert (Esa: nodeb a (S a) = true) by (apply nodeb_true; now right). + assert (Ehdr: nodeb a hdr = false) by (apply nodeb_false; split; congruence). + assert (Eshdr: nodeb a (S hdr) = false) by (apply nodeb_false; split; congruence). + assert (Hqshdr: qres hdr a (hdf ns 0) h (S hdr) = Some (hdf ns 0)) + by (unfold qres; rewrite Eshdr; apply upd_eq). + assert (Hqhdr: qres hdr a (hdf ns 0) h hdr = h hdr) + by (unfold qres; rewrite Ehdr; rewrite upd_neq by congruence; reflexivity). + split; [| split; [| split]]. + - intro x; unfold qres, qnode; destruct (nodeb a x); [now left | now right]. + - intro x; unfold qres, qnode, hunion; destruct (nodeb a x) eqn:E. + + apply nodeb_true in E as [-> | ->]; rewrite upd_neq by congruence; reflexivity. + + destruct (upd h (S hdr) (hdf ns 0) x); reflexivity. + - (* the remaining queue is a genuine representation; when the detach has + emptied it, the tail pointer is stale and [tailok] does not constrain it *) + assert (Hres: forall x, qres hdr a (hdf ns 0) h x <> None + <-> In x (qcells hdr ns)). + { intro x; unfold qres; split. + - destruct (nodeb a x) eqn:E; [congruence |]. + apply nodeb_false in E as (Exa & Exsa); intro Hx. + destruct (Nat.eqb_spec x (S hdr)) as [-> | Hne]; [apply in_cons, in_eq |]. + rewrite upd_neq in Hx by assumption. + apply Hdom in Hx; unfold qcells in Hx |- *. + destruct Hx as [C | [C | Hx]]; + [subst; apply in_eq | subst; apply in_cons, in_eq |]. + apply in_cons, in_cons. + cbn in Hx; destruct Hx as [C | [C | Hx]]; [congruence | congruence | exact Hx]. + - intro Hx. + assert (Hnb: nodeb a x = false). + { apply nodeb_false; unfold qcells in Hx. + destruct Hx as [C | [C | Hx]]. + - subst; split; congruence. + - subst; split; congruence. + - split; intro C; subst; contradiction. } + rewrite Hnb. + destruct (Nat.eqb_spec x (S hdr)) as [-> | Hne]; [rewrite upd_eq; congruence |]. + rewrite upd_neq by assumption; apply Hdom. + unfold qcells in Hx |- *. + destruct Hx as [C | [C | Hx]]; + [subst; apply in_eq | subst; apply in_cons, in_eq + | apply in_cons, in_cons; cbn; tauto]. } + assert (Hresnull: qres hdr a (hdf ns 0) h 0 = None). + { destruct (qres hdr a (hdf ns 0) h 0) eqn:E0; [| reflexivity]. + exfalso; apply (qwf_zero hdr ns Hwfns), Hres; congruence. } + split; [| intros x Hx; apply Hres; exact Hx]. + split; [exact Hwfns | split; [exact Hqshdr | split; [| split]]]. + + unfold tailok; destruct ns as [| b ns']; + [rewrite Hqhdr; exact Hhdrdom | rewrite Hqhdr; cbn in Htl |- *; exact Htl]. + + eapply chain_frame with (m := [a; S a; S hdr]) (h := h); [exact Hch | |]. + * intros x Hx; unfold qres. + assert (Hnb: nodeb a x = false). + { apply nodeb_false; split. + - intro C; subst; apply Hx; apply in_eq. + - intro C; subst; apply Hx; apply in_cons, in_eq. } + rewrite Hnb. + rewrite upd_neq by (intro C; subst; apply Hx; apply in_cons, in_cons, in_eq). + reflexivity. + * intros x Hx; cbn in Hx. + destruct Hx as [C | [C | [C | []]]]; subst; assumption. + + split; [exact Hresnull | intros x Hx; apply Hres; exact Hx]. + - (* the detached node, still owned *) + unfold nodeat, qnode; split; [| split]. + + rewrite Ea; exact Ha. + + rewrite Esa; exact Hsa. + + intro x; destruct (nodeb a x) eqn:E. + * apply nodeb_true in E as Ex; split; [intros _; exact Ex |]. + intros _; destruct Ex as [-> | ->]; [now rewrite Ha | now rewrite Hsa]. + * apply nodeb_false in E as (Exa & Exsa). + split; [congruence | intros [C | C]; congruence]. +Qed. + +(** The separating-conjunction reading of the same fact. *) +Corollary rot_detach_sep: forall hdr a ns v vs h, + qrep hdr (a :: ns) (v :: vs) h -> + qex hdr (a :: ns) h -> + exists hq hn, + hdisj hq hn + /\ heq (upd h (S hdr) (hdf ns 0)) (hunion hq hn) + /\ qrep hdr ns vs hq + /\ nodeat a v (hdf ns 0) hn. +Proof. + intros hdr a ns v vs h H Hex. + apply (rot_detach_split hdr a ns v vs h H) in Hex as (H1 & H2 & (H3 & _) & H4). + eauto 6. +Qed. + +Lemma hdf_ne: forall l f g, l <> [] -> hdf l f = hdf l g. +Proof. now intros [| a l] f g H. Qed. + +Lemma cells_mono_app: forall x l1 l2, In x (cells l1) -> In x (cells (l1 ++ l2)). +Proof. intros x l1 l2 H; rewrite cells_app, in_app_iff; now left. Qed. + +Lemma cells_mono_cons: forall x b l, In x (cells l) -> In x (cells (b :: l)). +Proof. intros x b l H; cbn; auto. Qed. + +(** ** The rotation theorem. + + One completed rotation turns the represented queue [a :: ns] / [v :: vs] + into [ns ++ [a]] / [vs ++ [v]] -- exactly the abstract pop-and-push -- and + touches no cell outside the queue's own footprint. *) +Theorem rot_heap_spec: forall hdr a ns v vs h, + qrep hdr (a :: ns) (v :: vs) h -> + qrep hdr (ns ++ [a]) (vs ++ [v]) (rot_heap hdr a (hdf ns 0) (zof hdr ns) h) + /\ (forall x, rot_heap hdr a (hdf ns 0) (zof hdr ns) h x <> None <-> h x <> None). +Proof. + intros hdr a ns v vs h Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + destruct Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). + pose proof (qwf_hdr_cells _ _ Hwf) as Hhnc. + pose proof (qwf_shdr_cells _ _ Hwf) as Hshnc. + assert (Hhdrdom: h hdr <> None) by (apply (proj2 Hdom); apply in_eq). + assert (Hshdrdom: h (S hdr) <> None) by (rewrite Hhd; discriminate). + assert (Hsadom: h (S a) <> None) by (rewrite Hsa; discriminate). + destruct (list_eq_dec Nat.eq_dec ns []) as [Hnil | Hne]. + - (* the queue had one element: detaching empties it, the append re-links + the header itself, and the structure comes back to where it started *) + subst ns. + destruct vs as [| v1 vs1]; [| cbn in Hch; contradiction]. + cbn in Hsa |- *. + assert (Hdom': forall x, rot_heap hdr a 0 hdr h x <> None <-> h x <> None) + by (apply rot_heap_dom; assumption). + split; [| exact Hdom']. + split; [exact Hwf | split; [| split; [| split]]]. + + rewrite (rot_heap_sz hdr a 0 hdr h); [reflexivity | congruence | congruence]. + + cbn; apply rot_heap_hdr. + + cbn; split; [| split; [| exact I]]. + * rewrite rot_heap_other by (first [congruence | lia]); exact Ha. + * apply rot_heap_sa; congruence. + + split. + * destruct (rot_heap hdr a 0 hdr h 0) eqn:E0; [| reflexivity]. + exfalso; assert (Hc: h 0 <> None) by (apply Hdom'; congruence). + apply Hc; exact (proj1 Hdom). + * intro x; rewrite Hdom'; apply (proj2 Hdom). + - (* the general case: the append re-links the old last node *) + destruct (exists_last Hne) as (ns0 & zz & Hns). + assert (Hzz: In zz ns) by (rewrite Hns, in_app_iff; right; apply in_eq). + pose proof (qwf_neqs_mem _ _ _ _ Hwf Hzz) + as (Hzh & Hza & Hzsh & Hzsa & Hszh & Hsza & Hszsh & Hszsa). + assert (Hz: zof hdr ns = zz) by (rewrite Hns; apply zof_snoc). + assert (Hvne: vs <> []). + { intro C; rewrite C in Hch; apply chain_len in Hch; + rewrite Hns, app_length in Hch; cbn in Hch; lia. } + destruct (exists_last Hvne) as (vs0 & vz & Hvs). + assert (Hlen: length ns0 = length vs0). + { apply chain_len in Hch; rewrite Hns, Hvs, !app_length in Hch; cbn in Hch; lia. } + rewrite Hns, Hvs in Hch. + apply chain_split in Hch as (Hch0 & Hchz); [| exact Hlen]. + cbn in Hch0, Hchz; destruct Hchz as (Hzv & Hszv & _). + assert (Hszdom: h (S zz) <> None) by (rewrite Hszv; discriminate). + assert (Hdom': forall x, rot_heap hdr a (hdf ns 0) zz h x <> None <-> h x <> None) + by (apply rot_heap_dom; assumption). + rewrite Hz. + split; [| exact Hdom']. + split; [| split; [| split; [| split]]]. + + eapply qwf_perm; [| exact Hwf]. + change (Permutation (a :: ns) (ns ++ [a])); apply (rotl_perm (a :: ns)). + + rewrite rot_heap_shdr by congruence. + rewrite hdf_app; cbn; f_equal; symmetry; now apply hdf_ne. + + unfold tailok; destruct (ns ++ [a]) eqn:E. + * exfalso; apply app_eq_nil in E as (_ & C); discriminate. + * rewrite <- E, last_last; apply rot_heap_hdr. + + apply chain_app. + * (* the remaining nodes, with the last link retargeted to [a] *) + cbn; rewrite Hns, Hvs; apply chain_app. + -- cbn; eapply chain_frame with (m := [hdr; S hdr; S a; S zz]) (h := h); + [exact Hch0 | |]. + ++ intros x Hx; apply rot_heap_other; + intro C; subst x; apply Hx; + [apply in_eq | apply in_cons, in_cons, in_eq + | apply in_cons, in_cons, in_cons, in_eq | apply in_cons, in_eq]. + ++ intros x Hx Hin; cbn in Hx. + assert (Hin': In x (cells (a :: ns))) + by (apply cells_mono_cons; rewrite Hns; now apply cells_mono_app). + destruct Hx as [C | [C | [C | [C | []]]]]; subst x. + ** now apply Hhnc. + ** now apply Hshnc. + ** apply Hsanc; rewrite Hns; now apply cells_mono_app. + ** (* [S zz] is the link the append rewrites; it is not a cell of + the nodes that stay in place *) + apply in_cells in Hin as (c & Hc & [C | C]). + --- assert (Hc': In c ns) by (rewrite Hns, in_app_iff; now left). + destruct Hwf as (_ & _ & Hov). + apply (Hov c zz); + [apply in_cons, in_cons; exact Hc' + | apply in_cons, in_cons; exact Hzz + | congruence]. + --- assert (Hcz: c = zz) by lia. + destruct Hwf as (Hnd & _ & _). + apply NoDup_cons_iff in Hnd as (_ & Hnd). + apply NoDup_cons_iff in Hnd as (_ & Hnd). + rewrite Hns in Hnd; apply NoDup_remove_2 in Hnd. + apply Hnd; rewrite app_nil_r; rewrite <- Hcz; exact Hc. + -- cbn; split; [| split; [| exact I]]. + ++ rewrite rot_heap_other by (first [congruence | lia]); exact Hzv. + ++ apply rot_heap_sz; congruence. + * cbn; split; [| split; [| exact I]]. + -- rewrite rot_heap_other by (first [congruence | lia]); exact Ha. + -- apply rot_heap_sa; congruence. + + split. + * destruct (rot_heap hdr a (hdf ns 0) zz h 0) eqn:E0; [| reflexivity]. + exfalso; assert (Hc: h 0 <> None) by (apply Hdom'; congruence). + apply Hc; exact (proj1 Hdom). + * intro x; rewrite Hdom'; intro Hx; apply (proj2 Hdom). + apply qcells_rot; exact Hx. +Qed. + +(** ** Two facts the language layer needs about the rotation's footprint. *) + +Lemma upd_mono: forall h a v x, h x <> None -> upd h a v x <> None. +Proof. intros h a v x H; unfold upd; destruct (Nat.eqb x a); [discriminate | exact H]. Qed. + +Lemma last_in: forall (l: list nat) d, l <> [] -> In (last l d) l. +Proof. + intros l d H; destruct (exists_last H) as (l' & x & ->). + rewrite last_last, in_app_iff; right; apply in_eq. +Qed. + +(** The cell the append phase writes is always already allocated: it is the + header's link cell when the detach empties the queue, and the last node's + link cell otherwise. *) +Lemma qrep_zof_dom: forall hdr a ns v vs h, + qrep hdr (a :: ns) (v :: vs) h -> h (S (zof hdr ns)) <> None. +Proof. + intros hdr a ns v vs h Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + destruct ns as [| b ns1]. + - cbn [zof]; rewrite Hhd; discriminate. + - apply (proj2 Hdom); unfold qcells; apply in_cons, in_cons. + apply in_cells; exists (last (b :: ns1) 0); split. + + apply in_cons, last_in; discriminate. + + right; reflexivity. +Qed. + +(** The address the program computes for the append is exactly [zof]. *) +Lemma zof_compute: forall hdr a ns, + qwf hdr (a :: ns) -> + (if Nat.eqb (hdf ns 0) 0 then hdr else last (a :: ns) 0) = zof hdr ns. +Proof. + intros hdr a ns (Hnd & H0 & Hov); destruct ns as [| b ns1]; [reflexivity |]. + cbn [hdf]. + destruct (Nat.eqb_spec b 0) as [-> | Hb]; [exfalso; apply H0; cbn; tauto |]. + reflexivity. +Qed. + +Lemma find_head: forall nl v vs, find nl (v :: vs) = Some 0 -> v = nl. +Proof. + intros nl v vs H; cbn in H. + destruct (Nat.eqb_spec v nl) as [-> | Hne]; [reflexivity |]. + destruct (find nl vs); cbn in H; discriminate. +Qed. + +Lemma rotl_cons: forall (v: nat) vs, rotl (v :: vs) = vs ++ [v]. +Proof. reflexivity. Qed. diff --git a/examples/CSL/HeapTests.v b/examples/CSL/HeapTests.v new file mode 100644 index 0000000..a09489c --- /dev/null +++ b/examples/CSL/HeapTests.v @@ -0,0 +1,126 @@ +From Stdlib Require Import Lia Arith.PeanoNat. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer + ICTree.Interp.State.Mod Lang.CSL.Heap. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +Lemma allocated_read_returns a h c v : + h a = Some v -> + runStateT (sh (SRd a)) (h,c) ≅ Ret (v,(h,c)). +Proof. apply sh_rd_some. Qed. + +Lemma empty_read_faults a c : + interp_state sh (srd a) (hemp,c) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. apply sinterp_srd_stuck; reflexivity. Qed. + +Lemma empty_write_faults a v c : + interp_state sh (swr a v) (hemp,c) ≅ + (stuck : ictreeW SObs (unit * SSig)). +Proof. apply sinterp_swr_stuck; reflexivity. Qed. + +Lemma allocated_write_updates a h c v old : + h a = Some old -> + runStateT (sh (SWr a v)) (h,c) ≅ Ret (tt,(upd h a v,c)). +Proof. apply sh_wr_some. Qed. + +Lemma emit_records_current_index q v h c : + runStateT (sh (SEmit q v)) (h,c) ≅ + (log (SPop q v c);; Ret (tt,(h,S c))). +Proof. apply sh_emit. Qed. + +Lemma alloc_empty_two : + runStateT (sh (SAlloc 2)) (hemp,5) ~ + Ret (1,(hunion (hblock 1 2) hemp,5)). +Proof. + apply sh_alloc_first; try lia. + - apply block_freeb_spec; reflexivity. +Qed. + +Lemma alloc_skips_partial_overlap : + runStateT (sh (SAlloc 2)) (Pcm.hsingle 2 99,5) ~ + Ret (3,(hunion (hblock 3 2) (Pcm.hsingle 2 99),5)). +Proof. + apply sh_alloc_first; try lia. + - apply block_freeb_spec; reflexivity. + - intros j J L F; assert (j = 1 \/ j = 2) by lia. + destruct H; subst j. + + specialize (F 1 ltac:(lia)); discriminate F. + + specialize (F 0 ltac:(lia)); discriminate F. +Qed. + +Lemma alloc_zero_stuck c : + interp_state sh (salloc 0) (hemp,c) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. apply sinterp_salloc_zero. Qed. + +Definition full_heap : Heap := fun _ : nat => Some 7. + +Lemma alloc_full_heap_stuck size c : + Nat.lt 0 size -> + runStateT (sh (SAlloc size)) (full_heap,c) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. + intro Pos; apply alloc_search_no_space; [exact Pos |]. + intros j J Free; specialize (Free 0 Pos); discriminate Free. +Qed. + +Example cas_replacement_preserves_frame frame c : + frame <> 2 -> + interp_state sh + (b <- scas 2 7 9 ;; + current <- srd 2 ;; + framed <- srd frame ;; + Ret (b,current,framed)) (full_heap,c) ~ + Ret ((true,9,7),(upd full_heap 2 9,c)). +Proof. + intro Frame. + etransitivity; [apply sinterp_cas_success; reflexivity |]. + etransitivity; [eapply sinterp_rd with (v := 9); reflexivity |]. + etransitivity. + - eapply sinterp_rd with (v := 7). + unfold upd; destruct (Nat.eqb_spec frame 2); [contradiction | reflexivity]. + - rewrite interp_state_ret; reflexivity. +Qed. + +Example cas_mismatch_preserves_entire_state frame c : + interp_state sh + (b <- scas 2 8 9 ;; + current <- srd 2 ;; + framed <- srd frame ;; + Ret (b,current,framed)) (full_heap,c) ~ + Ret ((false,7,7),(full_heap,c)). +Proof. + etransitivity. + - eapply sinterp_cas_failure with (current := 7); [reflexivity | discriminate]. + - etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. + etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. + rewrite interp_state_ret; reflexivity. +Qed. + +Example cas_same_value_still_succeeds frame c : + interp_state sh + (b <- scas 2 7 7 ;; + current <- srd 2 ;; + framed <- srd frame ;; + Ret (b,current,framed)) (full_heap,c) ~ + Ret ((true,7,7),(upd full_heap 2 7,c)). +Proof. + etransitivity; [apply sinterp_cas_success; reflexivity |]. + etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. + etransitivity. + - eapply sinterp_rd with (v := 7). + unfold upd; destruct (Nat.eqb frame 2); reflexivity. + - rewrite interp_state_ret; reflexivity. +Qed. + +Example cas_missing_faults_before_continuation c : + interp_state sh + (b <- scas 1 0 9 ;; + semit 10 (if b then 1 else 0) ;; + Ret b) (Pcm.hsingle 2 99,c) ~ + (stuck : ictreeW SObs (bool * SSig)). +Proof. apply sinterp_cas_missing; reflexivity. Qed. diff --git a/examples/CSL/InterpTests.v b/examples/CSL/InterpTests.v new file mode 100644 index 0000000..b006c93 --- /dev/null +++ b/examples/CSL/InterpTests.v @@ -0,0 +1,417 @@ +From Stdlib Require Import Arith.PeanoNat Fin Vector Lia. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod + ICTree.Interp.Yield.RoundRobin Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Local Ltac source_observe := + lazy [observe _observe Vector.nth Vector.replace Vector.caseS' + denote denote_flow ICtree.bind ICtree.subst' rr_pick + Nat.modulo Nat.divmod Fin.of_nat_lt]; reflexivity. + +Local Ltac pool_simpl := + cbv [Vector.replace Vector.caseS' rr_pick Nat.modulo Nat.divmod Fin.of_nat_lt]. + +Local Ltac finish_pool := + repeat first + [ progress pool_simpl + | rewrite vector_remove_head + | rewrite vector_remove_tail + | erewrite interp_schedule_rr_ret by source_observe + | rewrite interp_schedule_rr_select + | rewrite interp_schedule_rr_empty ]; + reflexivity. + +Local Ltac read_result value := + lazymatch goal with + | |- (interp_state sh (srd ?a) (?h,?c) >>= ?K) ~ ?rhs => + let Hp := fresh "Hread" in + assert (Hp : interp_state sh (srd a) (h,c) ≅ Guard (Ret (value,(h,c)))) by + (etransitivity; [unfold srd; apply interp_state_vis|]; + transitivity (Ret (value,(h,c)) >>= fun result : (nat * SSig)%type => + let '(x,σ') := result in Guard (interp_state sh (Ret x) σ')); + [ apply equ_clo_bind with (S := eq); + [ apply sh_rd_some; reflexivity | intros r r' <-; reflexivity ] + | etransitivity; [apply bind_ret_l|]; + step; constructor; apply interp_state_ret ]); + transitivity (Ret (value,(h,c)) >>= K); + [ apply sbisim_clo_bind_eq; + [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] + | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] + end. + +Local Ltac write_result old := + lazymatch goal with + | |- (interp_state sh (swr ?a ?v) (?h,?c) >>= ?K) ~ ?rhs => + let Hp := fresh "Hwrite" in + assert (Hp : interp_state sh (swr a v) (h,c) ≅ + Guard (Ret (tt,(upd h a v,c)))) by + (etransitivity; [unfold swr; apply interp_state_vis|]; + transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => + let '(_,σ') := result in Guard (interp_state sh (Ret tt) σ')); + [ apply equ_clo_bind with (S := eq); + [ apply (sh_wr_some a h c v old); reflexivity + | intros r r' <-; reflexivity ] + | etransitivity; [apply bind_ret_l|]; + step; constructor; apply interp_state_ret ]); + transitivity (Ret (tt,(upd h a v,c)) >>= K); + [ apply sbisim_clo_bind_eq; + [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] + | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] + end. + +Local Ltac emit_result := + lazymatch goal with + | |- (interp_state sh (semit ?q ?v) (?h,?c) >>= ?K) ~ ?rhs => + let Hp := fresh "Hemit" in + assert (Hp : interp_state sh (semit q v) (h,c) ≅ + (log (SPop q v c);; Guard (Ret (tt,(h,S c))))) by + (etransitivity; [unfold semit; apply interp_state_vis|]; + transitivity ((log (SPop q v c);; Ret (tt,(h,S c))) >>= + fun result : (unit * SSig)%type => + let '(_,σ') := result in Guard (interp_state sh (Ret tt) σ')); + [ apply equ_clo_bind with (S := eq); + [ apply sh_emit | intros r r' <-; reflexivity ] + | etransitivity; [apply bind_bind|]; + apply equ_clo_bind_eq; intros []; + etransitivity; [apply bind_ret_l|]; + step; constructor; apply interp_state_ret ]); + transitivity ((log (SPop q v c);; Ret (tt,(h,S c))) >>= K); + [ apply sbisim_clo_bind_eq; + [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|]; + apply sbisim_clo_bind_eq; [reflexivity|intros []; apply sb_guard] + | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_bind|reflexivity|]; + apply sbisim_clo_bind_eq; [reflexivity|intros []]; + eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] + end. + +Local Ltac alloc_result base Halloc := + lazymatch goal with + | |- (interp_state sh (salloc ?size) (?h,?c) >>= ?K) ~ ?rhs => + let Hp := fresh "Halloc_state" in + assert (Hp : interp_state sh (salloc size) (h,c) ~ + Ret (base,(hunion (hblock base size) h,c))) by + (eapply equ_clos_sbisim_goal; + [ unfold salloc; apply interp_state_vis | reflexivity | ]; + transitivity (Ret (base,(hunion (hblock base size) h,c)) >>= + fun result : (nat * SSig)%type => + let '(x,σ') := result in Guard (interp_state sh (Ret x) σ')); + [ apply sbisim_clo_bind_eq; + [ exact Halloc | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|]; + rewrite sb_guard, interp_state_ret; reflexivity ]); + transitivity (Ret (base,(hunion (hblock base size) h,c)) >>= K); + [ apply sbisim_clo_bind_eq; + [ exact Hp | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] + end. + +Local Ltac cas_result value next_heap Hcas := + lazymatch goal with + | |- (interp_state sh (scas ?a ?expected ?desired) (?h,?c) >>= ?K) ~ ?rhs => + let Hp := fresh "Hcas_state" in + assert (Hp : interp_state sh (scas a expected desired) (h,c) ≅ + Guard (Ret (value,(next_heap,c)))) by + (etransitivity; [unfold scas; apply interp_state_vis|]; + transitivity (Ret (value,(next_heap,c)) >>= fun result : (bool * SSig)%type => + let '(b,σ') := result in Guard (interp_state sh (Ret b) σ')); + [ apply equ_clo_bind with (S := eq); + [ exact Hcas | intros r r' <-; reflexivity ] + | etransitivity; [apply bind_ret_l|]; + step; constructor; apply interp_state_ret ]); + transitivity (Ret (value,(next_heap,c)) >>= K); + [ apply sbisim_clo_bind_eq; + [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] + | intro result; reflexivity ] + | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] + end. + +Definition shared_write_program : CProg unit := + CBind (CFork (CBind (CRead 4) (fun v => CEmit 2 v))) + (fun _ => CBind (CWrite 4 9) (fun _ => CYield)). + +Lemma shared_write_seen : + run_rr shared_write_program (Pcm.hsingle 4 0) 0 ~ + (log (SPop 2 9 0);; + Ret (tt, (upd (Pcm.hsingle 4 0) 4 9, 1))). +Proof. + unfold shared_write_program; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 + ([denote (CBind (CRead 4) (fun v => CEmit 2 v)); Ret tt]%vector + @ Fin.FS Fin.F1 := + (denote_flow (CBind (CWrite 4 9) (fun _ => CYield)) >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (Pcm.hsingle 4 0,0) ~ + (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). + rewrite interp_rr_bind, interp_rr_write. + write_result 0. + rewrite interp_rr_yield, interp_schedule_rr_select. + change (interp_schedule_rr sh 2 + ([Ret tt; Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CRead 4) (fun v => CEmit 2 v)) >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (upd (Pcm.hsingle 4 0) 4 9,0) ~ + (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). + rewrite interp_rr_bind, interp_rr_read. + read_result 9. + rewrite interp_rr_emit; emit_result. + finish_pool. +Qed. + +Definition scoped_child_program : CProg unit := + CBind + (CUntilNone + (CBind (CFork (CEmit 2 20)) + (fun _ => CBind (CEmit 1 10) + (fun _ => CRet (None : option unit))))) + (fun _ => CEmit 1 11). + +Lemma scoped_child_halts : + run_rr scoped_child_program hemp 0 ~ + (log (SPop 1 10 0);; + log (SPop 1 11 1);; + log (SPop 2 20 2);; + Ret (tt,(hemp,3))). +Proof. + set (body := CBind (CFork (CEmit 2 20)) + (fun _ => CBind (CEmit 1 10) (fun _ => CRet (None : option unit)))). + set (done := fun _ : option unit => (Ret tt : thread sE)). + set (after := fun r : option unit => + match r with None => done None | Some _ => denote_flow (CEmit 1 11) >>= done end). + set (next := fun r : option (option unit) => + match r with + | None => after None + | Some None => after (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= after) + end). + unfold run_rr, scoped_child_program. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CUntilNone body) (fun _ => CEmit 1 11)) >>= done)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). + rewrite interp_rr_bind, interp_rr_until_none. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := (denote_flow body >>= next)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). + unfold body at 1; rewrite interp_rr_bind, interp_rr_fork. + change (interp_schedule_rr sh 2 + ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CEmit 1 10) (fun _ => CRet (None : option unit))) >>= next)) + (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ + (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_ret. + change (interp_schedule_rr sh 2 + ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CEmit 1 11) >>= done)) + (Some (Fin.FS Fin.F1)) 0 (hemp,1) ~ + (log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). + rewrite interp_rr_emit; emit_result. + erewrite interp_schedule_rr_ret by source_observe. + pool_simpl; rewrite vector_remove_tail, vector_remove_head. + rewrite interp_schedule_rr_select. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 20) >>= done)) + (Some Fin.F1) 1 (hemp,2) ~ + (log (SPop 2 20 2);; Ret (tt,(hemp,3)))). + rewrite interp_rr_emit; emit_result. + unfold done; finish_pool. +Qed. + +Definition finite_tagged_program : CProg unit := + CBind + (CFork (CBind (CEmit 2 9) (fun _ => + CBind CYield (fun _ => CEmit 2 10)))) + (fun _ => CBind (CEmit 1 7) (fun _ => + CBind CYield (fun _ => CEmit 1 8))). + +Lemma finite_tagged_round_robin : + run_rr finite_tagged_program hemp 0 ~ + (log (SPop 1 7 0);; log (SPop 2 9 1);; + log (SPop 1 8 2);; log (SPop 2 10 3);; + Ret (tt,(hemp,4))). +Proof. + unfold finite_tagged_program; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 + ([denote (CBind (CEmit 2 9) (fun _ => CBind CYield (fun _ => CEmit 2 10))); Ret tt]%vector + @ Fin.FS Fin.F1 := + (denote_flow (CBind (CEmit 1 7) (fun _ => CBind CYield (fun _ => CEmit 1 8))) + >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ + (log (SPop 1 7 0);; log (SPop 2 9 1);; log (SPop 1 8 2);; + log (SPop 2 10 3);; Ret (tt,(hemp,4)))). + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. + change (interp_schedule_rr sh 2 + ([Ret tt; denote (CEmit 1 8)]%vector @ Fin.F1 := + (denote_flow (CBind (CEmit 2 9) (fun _ => CBind CYield (fun _ => CEmit 2 10))) + >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (hemp,1) ~ + (log (SPop 2 9 1);; log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. + change (interp_schedule_rr sh 2 + ([denote (CEmit 2 10); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CEmit 1 8) >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 2 (hemp,2) ~ + (log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). + rewrite interp_rr_emit; emit_result. + erewrite interp_schedule_rr_ret by source_observe. + pool_simpl; rewrite vector_remove_tail, vector_remove_head. + rewrite interp_schedule_rr_select. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 10) >>= fun _ => Ret tt)) + (Some Fin.F1) 3 (hemp,3) ~ + (log (SPop 2 10 3);; Ret (tt,(hemp,4)))). + rewrite interp_rr_emit; emit_result. + finish_pool. +Qed. + +Definition allocation_zero_read : CProg unit := + CBind (CAlloc 2) (fun base => + CBind (CRead (S base)) (fun value => CEmit 9 value)). + +Lemma allocation_zero_read_seen : + run_rr allocation_zero_read hemp 0 ~ + (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1))). +Proof. + assert (Halloc : runStateT (sh (SAlloc 2)) (hemp,0) ~ + Ret (1,(hunion (hblock 1 2) hemp,0))). + { apply sh_alloc_first; try lia. + apply block_freeb_spec; reflexivity. } + unfold run_rr, allocation_zero_read. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 2) (fun base => + CBind (CRead (S base)) (fun value => CEmit 9 value))) >>= + fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1)))). + rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Halloc. + rewrite interp_rr_bind, interp_rr_read; read_result 0. + rewrite interp_rr_emit; emit_result. + finish_pool. +Qed. + +Definition allocating_thread (tag : nat) : CProg unit := + CBind (CAlloc 2) (fun base => + CBind (CWrite base tag) (fun _ => + CBind (CEmit tag base) (fun _ => CYield))). + +Definition shared_alloc_program : CProg unit := + CBind (CFork (allocating_thread 2)) (fun _ => allocating_thread 1). + +Definition alloc_parent_heap := upd (hunion (hblock 1 2) hemp) 1 1. +Definition alloc_both_heap := upd (hunion (hblock 3 2) alloc_parent_heap) 3 2. + +Lemma shared_alloc_seen : + run_rr shared_alloc_program hemp 0 ~ + (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2))). +Proof. + assert (Hparent : runStateT (sh (SAlloc 2)) (hemp,0) ~ + Ret (1,(hunion (hblock 1 2) hemp,0))). + { apply sh_alloc_first; try lia. + apply block_freeb_spec; reflexivity. } + assert (Hchild : runStateT (sh (SAlloc 2)) (alloc_parent_heap,1) ~ + Ret (3,(hunion (hblock 3 2) alloc_parent_heap,1))). + { apply sh_alloc_first; try lia. + - apply block_freeb_spec; reflexivity. + - intros j J L F; assert (j = 1 \/ j = 2) as Cases by lia. + destruct Cases as [-> | ->]; + specialize (F 0 ltac:(lia)); discriminate F. } + unfold shared_alloc_program; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 + ([denote (allocating_thread 2); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CAlloc 2) (fun base => + CBind (CWrite base 1) (fun _ => + CBind (CEmit 1 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ + (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). + rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Hparent. + rewrite interp_rr_bind, interp_rr_write; write_result 0. + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_yield, interp_schedule_rr_select. + change (interp_schedule_rr sh 2 + ([Ret tt; Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 2) (fun base => + CBind (CWrite base 2) (fun _ => + CBind (CEmit 2 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (alloc_parent_heap,1) ~ + (log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). + rewrite interp_rr_bind, interp_rr_alloc; alloc_result 3 Hchild. + rewrite interp_rr_bind, interp_rr_write; write_result 0. + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_yield. + finish_pool. +Qed. + +Definition shared_cas_program : CProg unit := + CBind (CAlloc 1) (fun cell => + CBind (CFork (CBind (CCAS cell 0 20) (fun won => + CEmit 20 (if won then 1 else 0)))) + (fun _ => CBind (CCAS cell 0 10) (fun won => + CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield)))). + +Lemma shared_cas_seen : + run_rr shared_cas_program hemp 0 ~ + (log (SPop 10 1 0);; log (SPop 20 0 1);; + Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2))). +Proof. + assert (Halloc : runStateT (sh (SAlloc 1)) (hemp,0) ~ + Ret (1,(hunion (hblock 1 1) hemp,0))). + { apply sh_alloc_first; try lia. + apply block_freeb_spec; reflexivity. } + assert (Hparent : runStateT (sh (SCAS 1 0 10)) + (hunion (hblock 1 1) hemp,0) ≅ + Ret (true,(upd (hunion (hblock 1 1) hemp) 1 10,0))). + { apply sh_cas_success; reflexivity. } + assert (Hchild : runStateT (sh (SCAS 1 0 20)) + (upd (hunion (hblock 1 1) hemp) 1 10,1) ≅ + Ret (false,(upd (hunion (hblock 1 1) hemp) 1 10,1))). + { eapply sh_cas_failure; [reflexivity|discriminate]. } + unfold run_rr, shared_cas_program. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 1) (fun cell => + CBind (CFork (CBind (CCAS cell 0 20) (fun won => + CEmit 20 (if won then 1 else 0)))) + (fun _ => CBind (CCAS cell 0 10) (fun won => + CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))))) >>= + fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 10 1 0);; log (SPop 20 0 1);; + Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). + rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Halloc. + rewrite interp_rr_bind, interp_rr_fork. + change (interp_schedule_rr sh 2 + ([denote (CBind (CCAS 1 0 20) (fun won => + CEmit 20 (if won then 1 else 0))); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CCAS 1 0 10) (fun won => + CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))) >>= + fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (hunion (hblock 1 1) hemp,0) ~ + (log (SPop 10 1 0);; log (SPop 20 0 1);; + Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). + rewrite interp_rr_bind, interp_rr_cas. + cas_result true (upd (hunion (hblock 1 1) hemp) 1 10) Hparent. + rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_yield, interp_schedule_rr_select. + change (interp_schedule_rr sh 2 + ([Ret tt; Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CCAS 1 0 20) (fun won => + CEmit 20 (if won then 1 else 0))) >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (upd (hunion (hblock 1 1) hemp) 1 10,1) ~ + (log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). + rewrite interp_rr_bind, interp_rr_cas. + cas_result false (upd (hunion (hblock 1 1) hemp) 1 10) Hchild. + rewrite interp_rr_emit; emit_result. + finish_pool. +Qed. diff --git a/examples/CSL/Layout.v b/examples/CSL/Layout.v new file mode 100644 index 0000000..b161ea8 --- /dev/null +++ b/examples/CSL/Layout.v @@ -0,0 +1,501 @@ +(** * Layout: a generic queue constructor and the concrete rotating queue. + + SHARED between the two proof families. Everything here is a construction + or an elementary fact about it; no separation-logic notion appears. + + [qheap hdr ns vs] is the heap that IS the queue [ns]/[vs] headed at [hdr]. + Proving [qrep] and [qex] for it once means every per-variant file contains + an address layout and a payload list, and no heap reasoning at all. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From examples Require Import CSL.HeapQ. + +Import ListNotations. +Local Open Scope list_scope. + +(** ** A generic queue heap *) + +Fixpoint nodeval (ns vs: list nat) (x: nat) : option nat := + match ns, vs with + | a :: ns', v :: vs' => + if Nat.eqb x a then Some v + else if Nat.eqb x (S a) then Some (hdf ns' 0) + else nodeval ns' vs' x + | _, _ => None + end. + +Definition qheap (hdr: nat) (ns vs: list nat) : Heap := + fun x => if Nat.eqb x hdr then Some (last ns 0) + else if Nat.eqb x (S hdr) then Some (hdf ns 0) + else nodeval ns vs x. + +Lemma nodeval_dom: forall ns vs x, + nodeval ns vs x <> None -> In x (cells ns). +Proof. + induction ns as [| a ns IH]; intros vs x H. + - destruct vs; cbn in H; congruence. + - destruct vs as [| v vs]; [cbn in H; congruence |]. + apply in_cells; cbn [nodeval] in H. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; + [exists a; split; [apply in_eq | now left] |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; + [exists a; split; [apply in_eq | now right] |]. + apply IH in H; apply in_cells in H as (b & Hb & Hx). + exists b; split; [now apply in_cons | exact Hx]. +Qed. + +Lemma nodeval_in: forall ns vs x, + length ns = length vs -> In x (cells ns) -> nodeval ns vs x <> None. +Proof. + induction ns as [| a ns IH]; intros [| v vs] x Hlen Hx; + cbn in Hlen; try discriminate; [cbn in Hx; contradiction |]. + cbn [nodeval]. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; [discriminate |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; [discriminate |]. + apply (IH vs); [lia |]. + apply in_cells in Hx as (b & Hb & Hxb). + apply in_cells; destruct Hb as [Eb | Hb]; [| exists b; split; assumption]. + exfalso; destruct Hxb as [Ex | Ex]; [apply Hna | apply Hnsa]; congruence. +Qed. + +Lemma chain_mono: forall h h' ns vs fin, + chain h ns vs fin -> + (forall x, In x (cells ns) -> h' x = h x) -> + chain h' ns vs fin. +Proof. + intros h h'; induction ns as [| a ns IH]; intros [| v vs] fin Hc Hag; + cbn in *; try contradiction; auto. + destruct Hc as (Ha & Hsa & Hc). + split; [| split]. + - rewrite Hag; [exact Ha | auto]. + - rewrite Hag; [exact Hsa | auto]. + - apply (IH vs fin Hc); intros x Hx; apply Hag; auto. +Qed. + +Lemma nodeval_chain: forall hdr ns vs, + qwf hdr ns -> length ns = length vs -> chain (nodeval ns vs) ns vs 0. +Proof. + intros hdr; induction ns as [| a ns IH]; intros [| v vs] Hwf Hlen; + cbn in Hlen; try discriminate; [exact I |]. + destruct (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). + cbn [chain nodeval]. + rewrite Nat.eqb_refl. + split; [reflexivity |]. + destruct (Nat.eqb_spec (S a) a) as [C | _]; [lia |]. + rewrite Nat.eqb_refl. + split; [reflexivity |]. + eapply chain_mono; [apply (IH vs (qwf_tail _ _ _ Hwf)); lia |]. + intros x Hx; cbn [nodeval]. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; [rewrite Ex in Hx; contradiction |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; + [rewrite Ex in Hx; contradiction | reflexivity]. +Qed. + +Theorem qheap_qrep: forall hdr ns vs, + qwf hdr ns -> length ns = length vs -> ns <> [] -> + qrep hdr ns vs (qheap hdr ns vs). +Proof. + intros hdr ns vs Hwf Hlen Hne. + pose proof (qwf_hdr_cells _ _ Hwf) as Hhnc. + pose proof (qwf_shdr_cells _ _ Hwf) as Hshnc. + assert (Hhdr: qheap hdr ns vs hdr = Some (last ns 0)) + by (unfold qheap; now rewrite Nat.eqb_refl). + assert (Hshdr: qheap hdr ns vs (S hdr) = Some (hdf ns 0)). + { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [C | _]; [lia |]. + now rewrite Nat.eqb_refl. } + assert (Hcell: forall x, In x (cells ns) -> qheap hdr ns vs x = nodeval ns vs x). + { intros x Hx; unfold qheap. + destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex in Hx; contradiction |]. + destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; + [rewrite Ex in Hx; contradiction | reflexivity]. } + split; [exact Hwf | split; [exact Hshdr | split; [| split]]]. + - unfold tailok; destruct ns as [| a ns]; [contradiction | exact Hhdr]. + - eapply chain_mono; [apply (nodeval_chain hdr ns vs Hwf Hlen) |]. + intros x Hx; now apply Hcell. + - split. + + unfold qheap. + destruct (Nat.eqb_spec 0 hdr) as [C | _]; + [exfalso; apply (qwf_zero _ _ Hwf); rewrite C; apply in_eq |]. + destruct (Nat.eqb_spec 0 (S hdr)) as [C | _]; [lia |]. + destruct (nodeval ns vs 0) eqn:E; [| reflexivity]. + exfalso; apply (qwf_zero _ _ Hwf), in_cons, in_cons. + apply (nodeval_dom ns vs 0); congruence. + + intros x Hx; unfold qcells in Hx. + destruct Hx as [Ex | [Ex | Hx]]. + * rewrite <- Ex, Hhdr; discriminate. + * rewrite <- Ex, Hshdr; discriminate. + * rewrite (Hcell x Hx); revert Hx; now apply nodeval_in. +Qed. + +Theorem qheap_qex: forall hdr ns vs, qex hdr ns (qheap hdr ns vs). +Proof. + intros hdr ns vs x Hx; unfold qheap in Hx. + destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex; apply in_eq |]. + destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; + [rewrite Ex; apply in_cons, in_eq |]. + apply in_cons, in_cons, (nodeval_dom ns vs x), Hx. +Qed. + +(** ** Two elementary frame shapes *) + +Definition hsingle (a v: nat) : Heap := + fun x => if Nat.eqb x a then Some v else None. + +Lemma hsingle_dom: forall a v x, hsingle a v x <> None -> x = a. +Proof. + intros a v x H; unfold hsingle in H. + destruct (Nat.eqb_spec x a) as [Ex | Hne]; [exact Ex | congruence]. +Qed. + +Lemma hemp_dom: forall x, hemp x <> None -> False. +Proof. intros x H; apply H; reflexivity. Qed. + +(** ** The concrete rotating queue, frozen across every frame variant. + + Addresses are even and below 8; every frame variant below allocates only + addresses at least 8. That single numeric separation is what both proof + families use, and it is stated once, here. *) + +Definition hdr1 : nat := 2. +Definition ns1 : list nat := [4; 6]. +Definition vs1 : list nat := [7; 9]. +Definition nl : nat := 7. + +Definition h1 : Heap := qheap hdr1 ns1 vs1. + +Lemma qwf1: qwf hdr1 ns1. +Proof. + unfold hdr1, ns1; split; [| split]. + - repeat (apply NoDup_cons; [cbn; intuition congruence |]); apply NoDup_nil. + - cbn; intuition congruence. + - cbn; intros x y Hx Hy; intuition lia. +Qed. + +Lemma qrep1: qrep hdr1 ns1 vs1 h1. +Proof. apply qheap_qrep; [apply qwf1 | reflexivity | discriminate]. Qed. + +Lemma qex1: qex hdr1 ns1 h1. +Proof. apply qheap_qex. Qed. + +Lemma ns1_nonnil: ns1 <> []. +Proof. discriminate. Qed. + +Lemma find_nl_vs1: find nl vs1 = Some 0. +Proof. reflexivity. Qed. + +(** The queue's footprint is exactly the addresses below 8. *) +Lemma qcells1_low: forall x, In x (qcells hdr1 ns1) -> x < 8. +Proof. unfold hdr1, ns1, qcells; cbn; intros x H; intuition lia. Qed. + +Lemma h1_low: forall x, h1 x <> None -> x < 8. +Proof. intros x H; apply qcells1_low, qex1, H. Qed. + +(** [high] and [HighHeap] are the SHARED vocabulary in which every frame + variant describes itself: "I allocate only addresses at or above 8". + They are defined here, in a file that does not import the [Coinduction] + library, because inside TICL's scopes [<=] resolves to a lattice order + rather than to [Nat.le]. *) +Definition high (x: nat) : Prop := 8 <= x. + +Definition HighHeap (f: Heap) : Prop := forall x, f x <> None -> high x. + +Lemma high_not_low: forall x, high x -> x < 8 -> False. +Proof. unfold high; intros x H1 H2; lia. Qed. + +Lemma high_nonzero: forall x, high x -> x <> 0. +Proof. unfold high; intros x H; lia. Qed. + +(** The uniform vocabulary in which a frame's CONTENT is described: a list of + (address, value) pairs the frame holds. Both proof families state "the + frame is intact" as [cellsat Wcells h]. *) +Definition cellsat (W: list (nat * nat)) (h: Heap) : Prop := + Forall (fun p => h (fst p) = Some (snd p)) W. + +Lemma cellsat_heq: forall W h1 h2, heq h1 h2 -> cellsat W h1 -> cellsat W h2. +Proof. + intros W k1 k2 Heq H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite <- Heq; now apply H. +Qed. + +Lemma cellsat_agree: forall W h h', + (forall p, In p W -> h' (fst p) = h (fst p)) -> cellsat W h -> cellsat W h'. +Proof. + intros W h h' Hag H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite Hag by exact Hp; now apply H. +Qed. + +(** ** PCM facts about the disjoint-heap monoid. + + [hdisj]/[hunion] come from the frozen [HeapQ.v] resource model; these are + the four elementary consequences both proof families use. *) + +Lemma hunion_some: forall h f x v, h x = Some v -> hunion h f x = Some v. +Proof. intros h f x v H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_eq: forall h f x, h x <> None -> hunion h f x = h x. +Proof. + intros h f x H; destruct (h x) as [v |] eqn:E; [| congruence]. + now apply hunion_some. +Qed. + +Lemma hunion_none: forall h f x, h x = None -> hunion h f x = f x. +Proof. intros h f x H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_dom: forall h f x, h x <> None -> hunion h f x <> None. +Proof. intros h f x H; now rewrite hunion_eq. Qed. + +(** The two compatibility conditions, derived once from the address bound. + Every frame variant states only [HighHeap fv]; both proof families read + the conditions off from here. *) + +Lemma disj_of_high: forall f, HighHeap f -> hdisj h1 f. +Proof. + intros f Hhigh x; destruct (h1 x) eqn:E; [| now left]. + right; destruct (f x) eqn:F; [| reflexivity]. + exfalso; apply (high_not_low x); [apply Hhigh; congruence |]. + apply h1_low; congruence. +Qed. + +Lemma null_of_high: forall f, HighHeap f -> f 0 = None. +Proof. + intros f Hhigh; destruct (f 0) eqn:E; [| reflexivity]. + exfalso; apply (high_nonzero 0); [apply Hhigh; congruence | reflexivity]. +Qed. + +(** Rotation permutes the node list, so every node reachable from the initial + layout still lies below 8. Both families need this to know that the four + addresses a rotation writes are inside the queue. *) +Lemma ns1_low: forall x, In x ns1 -> x < 7. +Proof. unfold ns1; cbn; intros x H; intuition lia. Qed. + +(** ** Runtime-base contiguous queue layout *) + +Fixpoint node_addrs (first count : nat) : list nat := + match count with + | 0 => [] + | S rest => first :: node_addrs (first + 2) rest + end. + +Definition queue_nodes (hdr count : nat) : list nat := + node_addrs (hdr + 2) count. + +Fixpoint fill_nodes_heap (first : nat) (values : list nat) (h : Heap) : Heap := + match values with + | [] => h + | value :: rest => + fill_nodes_heap (first + 2) rest + (upd (upd h first value) (S first) + (match rest with [] => 0 | _ :: _ => first + 2 end)) + end. + +Definition init_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := + let ns := queue_nodes hdr (length values) in + fill_nodes_heap (hdr + 2) values + (upd (upd h hdr (last ns 0)) (S hdr) (hdf ns 0)). + +Definition new_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := + init_queue_heap hdr values + (hunion (hblock hdr (2 * S (length values))) h). + +Lemma node_addrs_in first count x : + In x (node_addrs first count) <-> + exists j, Nat.lt j count /\ x = first + 2*j. +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs]; split; [contradiction | intros (j & Hj & _); lia]. + - cbn [node_addrs In]; rewrite IH; split. + + intros [Hx | (j & Hj & Hx)]. + * exists 0; split; lia. + * exists (S j); split; lia. + + intros (j & Hj & Hx); destruct j as [| j]. + * left; lia. + * right; exists j; split; lia. +Qed. + +Lemma node_addrs_length first count : length (node_addrs first count) = count. +Proof. + revert first; induction count as [| count IH]; intro first; + cbn [node_addrs length]; [reflexivity | now rewrite IH]. +Qed. + +Lemma queue_nodes_length hdr count : length (queue_nodes hdr count) = count. +Proof. apply node_addrs_length. Qed. + +Lemma node_addrs_nodup first count : NoDup (node_addrs first count). +Proof. + revert first; induction count as [| count IH]; intro first; cbn [node_addrs]. + - constructor. + - constructor; [| apply IH]. + intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. +Qed. + +Lemma queue_nodes_qwf hdr count : Nat.lt 0 hdr -> qwf hdr (queue_nodes hdr count). +Proof. + intro Hhdr; unfold qwf, queue_nodes. + change (NoDup (node_addrs hdr (S count)) /\ + ~ In 0 (node_addrs hdr (S count)) /\ + (forall a b, In a (node_addrs hdr (S count)) -> + In b (node_addrs hdr (S count)) -> a <> S b)). + split; [apply node_addrs_nodup | split]. + - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. + - intros a b Ha Hb. + apply node_addrs_in in Ha as (j & Hj & Ha). + apply node_addrs_in in Hb as (k & Hk & Hb). + lia. +Qed. + +Lemma node_cells_range first count x : + In x (cells (node_addrs first count)) <-> + Nat.le first x /\ Nat.lt x (first + 2 * count). +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs cells]; split; [contradiction | lia]. + - change ((first = x \/ S first = x \/ + In x (cells (node_addrs (first + 2) count))) <-> + Nat.le first x /\ Nat.lt x (first + 2 * S count)). + rewrite IH; split. + + intros [Hx | [Hx | Hx]]; lia. + + intros [Hlo Hhi]. + destruct (Nat.eq_dec first x) as [Hx | Hx]; [now left |]. + destruct (Nat.eq_dec (S first) x) as [Hsx | Hsx]; [now right; left |]. + right; right; split; lia. +Qed. + +Lemma queue_cells_range hdr count x : + In x (qcells hdr (queue_nodes hdr count)) <-> + Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count). +Proof. + change (In x (cells (node_addrs hdr (S count))) <-> + Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count)). + apply node_cells_range. +Qed. + +Lemma qheap_queue_nodes_rep hdr values : + Nat.lt 0 hdr -> + qrep hdr (queue_nodes hdr (length values)) values + (qheap hdr (queue_nodes hdr (length values)) values). +Proof. + intro Hhdr; destruct values as [| value values]. + - change (qrep hdr [] [] (qheap hdr [] [])). + assert (Htail : qheap hdr [] [] hdr = Some 0). + { unfold qheap; now rewrite Nat.eqb_refl. } + assert (Hhead : qheap hdr [] [] (S hdr) = Some 0). + { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [Hbad | Hne]; [lia |]. + now rewrite Nat.eqb_refl. } + split; [exact (queue_nodes_qwf hdr 0 Hhdr) |]. + split; [exact Hhead |]. + split; [change (qheap hdr [] [] hdr <> None); rewrite Htail; discriminate |]. + split; [exact I | split]. + + unfold qheap; destruct (Nat.eqb_spec 0 hdr) as [Hbad | Hne]; [lia |]. + reflexivity. + + intros x [Hx | [Hx | []]]; subst x; + [rewrite Htail | rewrite Hhead]; discriminate. + - apply qheap_qrep. + + now apply queue_nodes_qwf. + + apply queue_nodes_length. + + discriminate. +Qed. + +Lemma nodeval_node_addrs_out first values x : + (Nat.lt x first \/ Nat.le (first + 2 * length values) x) -> + nodeval (node_addrs first (length values)) values x = None. +Proof. + intro Hout; destruct (nodeval (node_addrs first (length values)) values x) eqn:E; + [| reflexivity]. + exfalso. + assert (Hin : In x (cells (node_addrs first (length values)))). + { apply (nodeval_dom (node_addrs first (length values)) values x); rewrite E; discriminate. } + apply node_cells_range in Hin; lia. +Qed. + +(** Filling a strided list changes exactly its node cells. *) +Lemma fill_nodes_heap_lookup first values h x : + fill_nodes_heap first values h x = + match nodeval (node_addrs first (length values)) values x with + | Some value => Some value + | None => h x + end. +Proof. + revert first h x; induction values as [| value values IH]; intros first h x. + - reflexivity. + - cbn [fill_nodes_heap length node_addrs]; rewrite IH; cbn [nodeval]. + destruct (Nat.eqb_spec x first) as [Hx | Hfirst]. + + subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_neq by lia; apply upd_eq. + + destruct (Nat.eqb_spec x (S first)) as [Hx | Hsfirst]. + * subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_eq; destruct values; reflexivity. + * rewrite upd_neq by exact Hsfirst. + rewrite upd_neq by exact Hfirst; reflexivity. +Qed. + +Lemma init_queue_heap_agrees hdr values h : + heq (init_queue_heap hdr values h) + (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). +Proof. + intro x; unfold init_queue_heap; rewrite fill_nodes_heap_lookup. + unfold hunion, qheap, queue_nodes. + destruct (Nat.eqb_spec x hdr) as [Hx | Hhdr]. + - subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_neq by lia; apply upd_eq. + - destruct (Nat.eqb_spec x (S hdr)) as [Hx | Hshdr]. + + subst x; rewrite nodeval_node_addrs_out by (left; lia); apply upd_eq. + + rewrite upd_neq by exact Hshdr. + rewrite upd_neq by exact Hhdr; reflexivity. +Qed. + +Lemma new_queue_heap_agrees hdr values h : + Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> + heq (new_queue_heap hdr values h) + (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). +Proof. + intros Hhdr Hfree x; unfold new_queue_heap. + rewrite (init_queue_heap_agrees hdr values _ x); unfold hunion. + destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; + [reflexivity |]. + assert (Hout : hblock hdr (2 * S (length values)) x = None). + { apply hblock_out. + destruct (Nat.lt_ge_cases x hdr) as [Hlo | Hlo]; [now left | right]. + destruct (Nat.lt_ge_cases x (hdr + 2 * S (length values))) as [Hhi | Hhi]; + [| exact Hhi]. + exfalso. + pose proof (qheap_queue_nodes_rep hdr values Hhdr) as Hq. + apply (qrep_fp _ _ _ _ Hq x). + - apply queue_cells_range; split; assumption. + - exact E. } + now rewrite Hout. +Qed. + +Lemma new_queue_heap_disjoint hdr values h : + block_free h hdr (2 * S (length values)) -> + hdisj (qheap hdr (queue_nodes hdr (length values)) values) h. +Proof. + intros Hfree x. + destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; + [right | now left]. + assert (Hin : In x (qcells hdr (queue_nodes hdr (length values)))). + { apply (qheap_qex hdr (queue_nodes hdr (length values)) values x); rewrite E; discriminate. } + apply queue_cells_range in Hin as [Hlo Hhi]. + replace x with (hdr + (x - hdr)) by lia. + apply Hfree; lia. +Qed. + +Lemma fill_nodes_heap_finite first values h : + heap_finite h -> heap_finite (fill_nodes_heap first values h). +Proof. + revert first h; induction values as [| value values IH]; intros first h Hh. + - exact Hh. + - cbn [fill_nodes_heap]; apply IH, heap_finite_upd, heap_finite_upd, Hh. +Qed. + +Lemma new_queue_heap_finite hdr values h : + heap_finite h -> heap_finite (new_queue_heap hdr values h). +Proof. + intro Hh; unfold new_queue_heap, init_queue_heap. + apply fill_nodes_heap_finite, heap_finite_upd, heap_finite_upd. + apply heap_finite_hunion; [apply heap_finite_hblock | exact Hh]. +Qed. diff --git a/examples/CSL/Lex.v b/examples/CSL/Lex.v new file mode 100644 index 0000000..b387b9b --- /dev/null +++ b/examples/CSL/Lex.v @@ -0,0 +1,67 @@ +(** * Lex: the lexicographic variant used by the SCHEDULED composition. + + NEW in this experiment. The frozen [Recurrence.v] rank is [lexnat], a + lexicographic order on [nat * nat]: (occurrence bound still to outrun, + position of the observed element). A composed run needs a THIRD + component, and it is a genuinely new obligation rather than a bigger + number: + + - the first component (occurrence bound) falls on EVERY scheduler turn, + because every turn of either queue emits exactly one observation; + - the second component (position of the element in the FOCUSED queue) falls + only on the focused queue's own turns and is UNCHANGED by the foreign + queue's turns; + - the third component is the SCHEDULER PHASE, and it is what makes a + foreign turn count as progress at all: a turn of the other queue leaves + the focused queue's position alone, so without a phase component the + variant would not decrease and the composition proof would not close. + + So the third component is exactly the "scheduler-phase progress argument" + the composition needs on top of the reused position argument. Nothing + here is ordinal: the whole rank is [nat * (nat * nat)]. *) + +From Stdlib Require Import + Relations + Arith.Wf_nat + Arith.PeanoNat + Lia. + +(** One lexicographic layer over [nat]. *) +Definition lexn {A} (R: relation A) : relation (nat * A) := + fun p q => fst p < fst q \/ (fst p = fst q /\ R (snd p) (snd q)). + +Lemma lexn_wf {A} (R: relation A): well_founded R -> well_founded (lexn R). +Proof. + intros HR [a b]; revert b. + induction a as [a IHa] using (well_founded_induction lt_wf). + intro b. + induction b as [b IHb] using (well_founded_induction HR). + constructor; intros [c d] [Hlt | (Heq & Hlt)]; cbn in *. + - now apply IHa. + - subst c; now apply IHb. +Qed. + +(** The rank of the composed proof. *) +Definition rank3 : relation (nat * (nat * nat)) := lexn (lexn lt). + +Lemma rank3_wf: well_founded rank3. +Proof. apply lexn_wf, lexn_wf, lt_wf. Qed. + +(** The three ways the rank falls, stated as the composition proof uses them. + [rank3_bound] is the reused occurrence argument, [rank3_pos] the reused + position argument, [rank3_phase] the NEW scheduler-phase argument. *) + +Lemma rank3_bound: forall b b' p p' q q', + b' < b -> rank3 (b', (p', q')) (b, (p, q)). +Proof. intros; left; cbn; assumption. Qed. + +Lemma rank3_pos: forall b p p' q q', + p' < p -> rank3 (b, (p', q')) (b, (p, q)). +Proof. intros; right; cbn; split; [reflexivity | left; cbn; assumption]. Qed. + +Lemma rank3_phase: forall b p q q', + q' < q -> rank3 (b, (p, q')) (b, (p, q)). +Proof. + intros; right; cbn; split; [reflexivity |]. + right; cbn; split; [reflexivity | assumption]. +Qed. diff --git a/examples/CSL/NegativeTests.v b/examples/CSL/NegativeTests.v new file mode 100644 index 0000000..b4a08a8 --- /dev/null +++ b/examples/CSL/NegativeTests.v @@ -0,0 +1,107 @@ +From Stdlib Require Import List. +From TICL Require Import + Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer + ICTree.Interp.State.Mod ICTree.Interp.Yield.RoundRobin + ICTree.Logic.AG ICTree.Logic.Trans Logic.Core. +From examples Require Import + CSL.HeapQ CSL.Layout CSL.Overlap CSL.Recurrence CSL.SLang CSL.Program CSL.Queue. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +(* Ownership controls retain their original statements in CSL.Overlap: + overlap_rejected, overlap_frame_not_preserved, null_frame_disjoint_but_bad. + The sequential controls remain CSL.Recurrence.empty_queue_no_ag and + CSL.Recurrence.absent_never_observed; they do not quantify over concurrent pools. + CSL.SLang.sfresh_excludes_retained rules out reusing an old tagged observation. *) + +Lemma empty_heap_parallel_stuck : + run_rr (parallel_queues 2 10) hemp 0 ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + unfold parallel_queues; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 (queue_workers 2 10 false false) + (Some (queue_slot 0)) 0 (hemp,0) ~ + (stuck : ictreeW SObs (unit * SSig))). + etransitivity; [apply queue_pool_turn|]. + assert (Hfault : interp_state sh (turn 1 2) (hemp,0) ≅ + (stuck : ictreeW SObs (unit * SSig))). + { + unfold turn, turnk. + etransitivity; [apply interp_state_bind|]. + lazymatch goal with + | |- (interp_state sh (srd 3) (hemp,0) >>= ?next) ≅ _ => + etransitivity; + [ apply equ_clo_bind with (S := eq) (k2 := next); + [exact (sinterp_srd_stuck 3 hemp 0 eq_refl) | intros x y <-; reflexivity] + | apply bind_stuck_equ ] + end. + } + lazymatch goal with + | |- (interp_state sh ?p ?s >>= ?kont) ~ _ => + let Hwhole := fresh "Hwhole" in + assert (Hwhole : (interp_state sh p s >>= kont) ≅ + (stuck : ictreeW SObs (unit * SSig))) by + (etransitivity; + [apply equ_clo_bind with (S := eq) (k2 := kont); + [exact Hfault | intros x y <-; reflexivity] + | apply bind_stuck_equ]); + eapply equ_clos_sbisim_goal; [exact Hwhole | reflexivity | reflexivity] + end. +Qed. + +Local Typeclasses Transparent equ sbisim. + +Lemma empty_heap_parallel_no_recurrence : + ~ <( {run_rr (parallel_queues 2 10) hemp 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. + rewrite empty_heap_parallel_stuck. + apply ag_stuck. +Qed. + +Lemma allocated_empty_queue_stuck : + run_rr (allocated_parallel_queues [] [8]) hemp 0 ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + destruct (run_rr_allocated_parallel [] [8] 0) + as (u & v & h & Finite & Owned & Run). + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + destruct H1 as (_ & Hhead & _ & _ & Hnull & _). + change (h (S u) = Some 0) in Hhead. + rewrite Run; unfold parallel_queues; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 (queue_workers u v false false) + (Some (queue_slot 0)) 0 (h,0) ~ + (stuck : ictreeW SObs (unit * SSig))). + etransitivity; [apply queue_pool_turn |]. + assert (Hfault : interp_state sh (turn 1 u) (h,0) ~ + (stuck : ictreeW SObs (unit * SSig))). + { unfold turn, turnk. + etransitivity; [eapply sinterp_rd; exact Hhead |]. + eapply equ_clos_sbisim_goal; [apply interp_state_bind | reflexivity |]. + lazymatch goal with + | |- (interp_state sh (srd 0) (h,0) >>= ?next) ~ _ => + eapply equ_clos_sbisim_goal; + [ etransitivity; + [ apply equ_clo_bind with (S := eq) (k2 := next); + [exact (sinterp_srd_stuck 0 h 0 Hnull) | intros x y <-; reflexivity] + | apply bind_stuck_equ ] + | reflexivity | reflexivity ] + end. } + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hfault | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_stuck_equ | reflexivity | reflexivity]. +Qed. + +Lemma allocated_empty_queue_no_recurrence : + ~ <( {run_rr (allocated_parallel_queues [] [8]) hemp 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. + rewrite allocated_empty_queue_stuck; apply ag_stuck. +Qed. diff --git a/examples/CSL/Overlap.v b/examples/CSL/Overlap.v new file mode 100644 index 0000000..e29fa14 --- /dev/null +++ b/examples/CSL/Overlap.v @@ -0,0 +1,113 @@ +(** * Overlap: the compatibility preconditions are load-bearing. + + [Frame.qrepX_frame] asks for two things of a frame [f]: + + (C1) [hdisj h f] -- the frame owns no cell of the queue; + (C2) [f 0 = None] -- the frame does not allocate the null address. + + A precondition can fail to apply for two very different reasons: because + it is merely sufficient, or because dropping it makes the conclusion + false. These are the second kind. Each condition is refuted twice: once + showing that the compatibility check rejects the candidate frame, and once + showing that the conclusion the frame rule would license is actually + false. + + This file is frame-variant independent. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame. + +Import ListNotations. +Local Open Scope list_scope. + +(** ** C1: overlap *) + +(** The candidate frame claims address 3, which is the queue's HEAD POINTER + cell -- squarely inside [qcells hdr1 ns1]. *) +Definition fbad : Heap := Layout.hsingle 3 42. + +Lemma three_in_footprint: In 3 (qcells hdr1 ns1). +Proof. unfold hdr1, ns1, qcells; cbn; tauto. Qed. + +(** (a) The compatibility check rejects it. *) +Theorem overlap_rejected: ~ hdisj h1 fbad. +Proof. + intro Hd; destruct (Hd 3) as [H | H]. + - apply (qrep_fp hdr1 ns1 vs1 h1 qrep1 3 three_in_footprint); exact H. + - unfold fbad, Layout.hsingle in H; cbn in H; discriminate. +Qed. + +(** (b) ...and the conclusion it would license is FALSE. The cell the + candidate frame claims really does change value after one rotation, so no + assertion about it can be carried across the queue's execution. This is + what makes [hdisj] a genuine hypothesis rather than a convenience: the + failure is semantic, not a stuck proof. *) +Lemma rot_changes_head_pointer: qstep hdr1 ns1 h1 3 = Some 6 /\ h1 3 = Some 4. +Proof. split; reflexivity. Qed. + +Theorem overlap_frame_not_preserved: + cellsat [(3, 4)] h1 /\ ~ cellsat [(3, 4)] (qstep hdr1 ns1 h1). +Proof. + split. + - unfold cellsat; repeat constructor. + - intro H; unfold cellsat in H; rewrite Forall_forall in H. + specialize (H (3, 4) (in_eq _ _)); cbn in H; discriminate. +Qed. + +(** For contrast, the SAME shape of assertion about a cell outside the + footprint is preserved -- so the refutation above is about overlap and not + about [cellsat] being unpreservable in general. *) +Theorem disjoint_cell_is_preserved: forall n a v, + high a -> + cellsat [(a, v)] h1 -> cellsat [(a, v)] (qstepN hdr1 n ns1 h1). +Proof. + intros n a v Ha H; eapply cellsat_agree; [| exact H]. + intros p Hp; cbn in Hp; destruct Hp as [E | []]; rewrite <- E; cbn. + apply (qstepN_agree n hdr1 ns1 vs1 h1 qrep1 ns1_nonnil). + intro C; apply (high_not_low a); [exact Ha | now apply qcells1_low]. +Qed. + +(** ** C2: the null address *) + +(** The candidate frame allocates address 0, which the language's + representation uses as the end-of-list terminator. *) +Definition fnull : Heap := Layout.hsingle 0 1. + +(** (a) The compatibility check rejects it. *) +Theorem null_frame_rejected: fnull 0 <> None. +Proof. unfold fnull, Layout.hsingle; cbn; discriminate. Qed. + +(** (b) ...and the conclusion it would license is FALSE: the extended heap is + not a representation of the queue at all, so the frozen recurrence theorem + does not even apply to it. [hdisj h1 fnull] DOES hold, so this is a + condition that disjointness alone does not supply. *) +Theorem null_frame_disjoint_but_bad: + hdisj h1 fnull /\ ~ qrep hdr1 ns1 vs1 (hunion h1 fnull). +Proof. + split. + - intro x; destruct (h1 x) eqn:E; [| now left]. + right; unfold fnull, Layout.hsingle. + destruct (Nat.eqb_spec x 0) as [Ex | Hne]; [| reflexivity]. + exfalso; rewrite Ex in E. + pose proof (qrep_null hdr1 ns1 vs1 h1 qrep1) as H0; congruence. + - intro Hq; pose proof (qrep_null _ _ _ _ Hq) as H0. + unfold hunion, fnull, Layout.hsingle in H0; cbn in H0; discriminate. +Qed. + +(** ** The two conditions are independent + + [fbad] satisfies C2 and fails C1; [fnull] satisfies C1 and fails C2. So + neither condition subsumes the other, and the transport theorem's + precondition is not redundant. *) +Theorem conditions_independent: + (fbad 0 = None /\ ~ hdisj h1 fbad) + /\ (hdisj h1 fnull /\ fnull 0 <> None). +Proof. + split. + - split; [reflexivity | apply overlap_rejected]. + - split; [apply (proj1 null_frame_disjoint_but_bad) | apply null_frame_rejected]. +Qed. diff --git a/examples/CSL/PcmTests.v b/examples/CSL/PcmTests.v new file mode 100644 index 0000000..b3be599 --- /dev/null +++ b/examples/CSL/PcmTests.v @@ -0,0 +1,30 @@ +From Stdlib Require Import Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL.Pcm. + +Lemma same_cell_cannot_separate a v w h : + ~ asep (pto a v) (pto a w) h. +Proof. apply Pcm.pto_sep_same_false. Qed. + +Lemma distinct_cells_separate : + asep (pto 2 7) (pto 4 9) + (hunion (Pcm.hsingle 2 7) (Pcm.hsingle 4 9)). +Proof. apply Pcm.pto_sep_distinct; discriminate. Qed. + +Lemma block_overlap_rejected : + forall h, ~ asep (block_pto 1 2) (pto 2 9) h. +Proof. + intros h (b & p & D & E & B & P). + pose proof (B 2) as B2; change (b 2 = Some 0) in B2. + pose proof (pto_lookup 2 9 p P) as P2. + destruct (D 2); congruence. +Qed. + +Lemma allocated_block_frame : + asep (block_pto 3 2) (pto 2 9) + (hunion (hblock 3 2) (Pcm.hsingle 2 9)). +Proof. + apply allocated_block_sep. + - intros offset O; unfold Pcm.hsingle; destruct (Nat.eq_dec 2 (3 + offset)); + [lia | reflexivity]. + - apply heq_refl. +Qed. diff --git a/examples/CSL/Program.v b/examples/CSL/Program.v new file mode 100644 index 0000000..866d5c2 --- /dev/null +++ b/examples/CSL/Program.v @@ -0,0 +1,506 @@ +From Stdlib Require Import Arith.PeanoNat Fin Vector List Lia. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.Events.Yield Lang.CSL + ICTree.Events.Writer ICTree.SBisim ICTree.Interp.State.Mod + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.SBisim Utils.Vectors. +From examples Require Import CSL.SLang CSL.HeapQ CSL.Sep2 CSL.Layout CSL.Frame. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Definition rotate_once (q hdr : nat) : CProg unit := + CBind (CRead (S hdr)) (fun a => + CBind (CRead a) (fun v => + CBind (CEmit q v) (fun _ => + CBind (CRead (S a)) (fun n => + CBind (CWrite (S hdr) n) (fun _ => + CBind (CRead hdr) (fun z0 => + CBind (CWrite (S (if Nat.eqb n 0 then hdr else z0)) a) (fun _ => + CBind (CWrite (S a) 0) (fun _ => + CWrite hdr a)))))))). + +Definition worker (q hdr : nat) : CProg unit := + CUntilNone + (CBind (rotate_once q hdr) (fun _ => + CBind CYield (fun _ => CRet (Some tt)))). + +Definition parallel_queues (u v : nat) : CProg unit := + CBind (CFork (worker 2 v)) (fun _ => worker 1 u). + +Fixpoint fill_nodes (first : nat) (values : list nat) : CProg unit := + match values with + | []%list => CRet tt + | (value :: rest)%list => + CBind (CWrite first value) (fun _ => + CBind (CWrite (S first) + (match rest with []%list => 0 | (_ :: _)%list => first + 2 end)) (fun _ => + fill_nodes (first + 2) rest)) + end. + +Definition init_queue (hdr : nat) (values : list nat) : CProg unit := + let ns := queue_nodes hdr (length values) in + CBind (CWrite hdr (last ns 0)) (fun _ => + CBind (CWrite (S hdr) (hdf ns 0)) (fun _ => + fill_nodes (hdr + 2) values)). + +Definition new_queue (values : list nat) : CProg nat := + CBind (CAlloc (2 * S (length values))) (fun hdr => + CBind (init_queue hdr values) (fun _ => CRet hdr)). + +Definition allocated_parallel_queues (values1 values2 : list nat) : CProg unit := + CBind (new_queue values1) (fun u => + CBind (new_queue values2) (fun v => parallel_queues u v)). + +Lemma denote_rotate_once q hdr : + denote_flow (rotate_once q hdr) ≅ + (a <- heap_event (SRd (S hdr));; + v <- heap_event (SRd a);; + heap_event (SEmit q v);; + n <- heap_event (SRd (S a));; + heap_event (SWr (S hdr) n);; + z0 <- heap_event (SRd hdr);; + heap_event (SWr (S (if Nat.eqb n 0 then hdr else z0)) a);; + heap_event (SWr (S a) 0);; + heap_event (SWr hdr a);; + Ret (Some tt)). +Proof. + unfold rotate_once; cbn [denote_flow]. + do 8 (etransitivity; [apply bind_bind|]; + apply equ_clo_bind_eq; intro; + etransitivity; [apply bind_ret_l|]). + reflexivity. +Qed. + +Local Lemma denote_rotate_once_bind {X} q hdr + (K : option unit -> ictree CEff X) : + (denote_flow (rotate_once q hdr) >>= K) ≅ + (denote (rotate_once q hdr);; K (Some tt)). +Proof. + pose proof (denote_rotate_once q hdr) as Hr. + etransitivity. + - apply equ_clo_bind with (S := eq) (k2 := K); + [exact Hr | intros x y <-; reflexivity]. + - symmetry; unfold denote. + etransitivity; [apply bind_bind|]. + etransitivity. + + apply equ_clo_bind with (S := eq) + (k2 := fun _ : option unit => Ret tt;; K (Some tt)); + [exact Hr | intros x y <-; reflexivity]. + + do 9 (etransitivity; [apply bind_bind|]; + symmetry; etransitivity; [apply bind_bind|]; symmetry; + apply equ_clo_bind_eq; intro). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma denote_worker q hdr : + denote (worker q hdr) ≅ + (denote (rotate_once q hdr);; source_yield;; Guard (denote (worker q hdr))). +Proof. + unfold denote at 1; unfold worker at 1; cbn [denote_flow]. + etransitivity. + - apply equ_clo_bind with (S := eq) (k2 := fun _ : option unit => Ret tt); + [apply unfold_iter | intros x y <-; reflexivity]. + - do 3 (etransitivity; [apply bind_bind|]). + etransitivity; [apply denote_rotate_once_bind|]. + apply equ_clo_bind_eq; intro ignored. + do 2 (etransitivity; [apply bind_bind|]). + apply equ_clo_bind_eq; intro yielded. + do 3 (etransitivity; [apply bind_ret_l|]). + etransitivity; [apply bind_guard|]. + step; constructor; reflexivity. +Qed. + +Lemma denote_parallel_queues u v : + denote (parallel_queues u v) ≅ + Vis (inr (inl Fork)) + (fun child : bool => if child then denote (worker 2 v) else denote (worker 1 u)). +Proof. unfold parallel_queues; apply denote_fork_bind. Qed. + +Local Ltac rotate_state_bind := + lazymatch goal with + | |- _ ~ (interp_state ?handler (ICtree.bind ?t ?k) ?s >>= ?finish) => + let Hbind := fresh "Hbind" in + assert (Hbind : (interp_state handler (t >>= k) s >>= finish) ≅ + (interp_state handler t s >>= fun result => + (let '(x,s') := result in interp_state handler (k x) s') >>= finish)) by + (etransitivity; + [apply equ_clo_bind with (S := eq) (k2 := finish); + [apply interp_state_bind | intros x y <-; reflexivity] + | apply bind_bind]); + rewrite Hbind; clear Hbind + end. + +Local Ltac rotate_effect law := + try rewrite interp_rr_bind; + etransitivity; [apply law|]; + rotate_state_bind; + apply sbisim_clo_bind_eq; [reflexivity | intros [? [? ?]]]. + +Lemma interp_rr_rotate_once n (ts : pool sE (S n)) + (i : Fin.t (S n)) q hdr (K : option unit -> thread sE) m h c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (rotate_once q hdr) >>= K)) (Some i) m (h,c) ~ + (interp_state sh (turn q hdr) (h,c) >>= + fun '(_, (h',c')) => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h',c')). +Proof. + unfold rotate_once, turn, turnk. + rotate_effect interp_rr_read. + rotate_effect interp_rr_read. + rotate_effect interp_rr_emit. + rotate_effect interp_rr_read. + rotate_effect interp_rr_write. + rotate_effect interp_rr_read. + rotate_effect interp_rr_write. + rotate_effect interp_rr_write. + rotate_effect interp_rr_write. + lazymatch goal with + | |- _ ~ (interp_state ?handler (Ret ?x) ?s >>= ?finish) => + let Hret := fresh "Hret" in + assert (Hret : (interp_state handler (Ret x) s >>= finish) ≅ finish (x,s)) by + (transitivity (Ret (x,s) >>= finish); + [apply equ_clo_bind with (S := eq); + [apply interp_state_ret | intros a b <-; reflexivity] + | exact (bind_ret_l (x,s) finish)]); + eapply equ_clos_sbisim_goal; [reflexivity | exact Hret | reflexivity] + end. +Qed. + +Definition queue_slot (n : nat) : Fin.t 2 := + if Nat.even n then Fin.FS Fin.F1 else Fin.F1. + +Definition queue_workers (u v : nat) (g2 g1 : bool) : pool sE 2 := + [(if g2 then Guard (denote (worker 2 v)) else denote (worker 2 v)); + (if g1 then Guard (denote (worker 1 u)) else denote (worker 1 u))]%vector. + +Lemma queue_pick_next n : rr_pick 1 n = queue_slot (S n). +Proof. + unfold queue_slot; rewrite even_flip. + destruct (Nat.even n) eqn:Hn; cbn [negb]. + - now apply rr_pick_even. + - now apply rr_pick_odd. +Qed. + +Local Lemma interp_rr_worker n (ts : pool sE (S n)) + (i : Fin.t (S n)) q hdr m h c : + interp_schedule_rr sh (S n) (ts @ i := denote (worker q hdr)) (Some i) m (h,c) ~ + (interp_state sh (turn q hdr) (h,c) >>= fun '(_, (h',c')) => + interp_schedule_rr sh (S n) (ts @ i := Guard (denote (worker q hdr))) None m (h',c')). +Proof. + set (again := fun r : option (option unit) => + match r with + | None => (Ret tt : thread sE) + | Some None => Ret tt + | Some (Some _) => Guard (denote (worker q hdr)) + end). + unfold denote at 1; unfold worker at 1. + rewrite interp_rr_until_none. + lazymatch goal with + | |- _ ~ ?rhs => + change (interp_schedule_rr sh (S n) + (ts @ i := (denote_flow + (CBind (rotate_once q hdr) (fun _ => + CBind CYield (fun _ => CRet (Some tt)))) >>= again)) + (Some i) m (h,c) ~ rhs) + end. + rewrite interp_rr_bind. + etransitivity; [apply interp_rr_rotate_once|]. + apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + rewrite interp_rr_bind, interp_rr_yield. + assert (Hpark : pool_equ + (ts @ i := (denote_flow (CRet (Some tt)) >>= again)) + (ts @ i := Guard (denote (worker q hdr)))). + { + apply replace_pool_equ; [apply pool_equ_refl|]. + cbn [denote_flow]. + etransitivity; [exact (bind_ret_l (Some (Some tt)) again)|]. + reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) _ _ None m (h',c') Hpark) as Hdone. + eapply equ_clos_sbisim_goal; [exact Hdone | reflexivity | reflexivity]. +Qed. + +Lemma queue_pool_turn u v n g2 g1 h c : + interp_schedule_rr sh 2 (queue_workers u v g2 g1) + (Some (queue_slot n)) n (h,c) ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) (h,c) >>= + fun '(_, (h',c')) => + interp_schedule_rr sh 2 + (queue_workers u v (if Nat.even n then g2 else true) + (if Nat.even n then true else g1)) + (Some (queue_slot (S n))) (S n) (h',c')). +Proof. + unfold queue_slot at 1; unfold tagof, hdrof. + destruct (Nat.even n) eqn:Hphase. + - destruct g1; + [etransitivity; [eapply interp_schedule_rr_guard; reflexivity|] |]. + all: lazymatch goal with + | |- _ ~ ?rhs => + change (interp_schedule_rr sh 2 + (queue_workers u v g2 false @ Fin.FS Fin.F1 := denote (worker 1 u)) + (Some (Fin.FS Fin.F1)) n (h,c) ~ rhs) + end. + all: etransitivity; [apply interp_rr_worker|]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + all: etransitivity; [apply interp_schedule_rr_select|]. + all: rewrite queue_pick_next; reflexivity. + - destruct g2; + [etransitivity; [eapply interp_schedule_rr_guard; reflexivity|] |]. + all: lazymatch goal with + | |- _ ~ ?rhs => + change (interp_schedule_rr sh 2 + (queue_workers u v false g1 @ Fin.F1 := denote (worker 2 v)) + (Some Fin.F1) n (h,c) ~ rhs) + end. + all: etransitivity; [apply interp_rr_worker|]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + all: etransitivity; [apply interp_schedule_rr_select|]. + all: rewrite queue_pick_next; reflexivity. +Qed. + + +Local Ltac queue_prefix R law := + cbv beta; + lazymatch goal with + | |- _ (ICtree.bind ?prefix ?left) (ICtree.bind ?other_prefix ?right) => + etransitivity; + [ apply (coinduction.gfp_bt (sb eq) R); + apply sbisim_clo_bind_eq with (k2 := left); + [law | intro result; reflexivity] + | ]; + etransitivity; + [ | apply (coinduction.gfp_bt (sb eq) R); symmetry; + apply sbisim_clo_bind_eq with (k2 := right); + [law | intro result; reflexivity] ] + end. + +Local Ltac queue_fault Hnone := + cbv beta; + lazymatch goal with + | |- interp_state sh (ICtree.bind (srd ?a) ?next) (?h,?c) ~ _ => + let Hfault := fresh "Hfault" in + assert (Hfault : interp_state sh (srd a >>= next) (h,c) ≅ stuck) by + (etransitivity; [apply interp_state_bind|]; + etransitivity; + [ apply equ_clo_bind with (S := eq) + (k2 := fun '(x,s') => interp_state sh (next x) s'); + [exact (sinterp_srd_stuck a h c Hnone) | intros x y <-; reflexivity] + | apply bind_stuck_equ ]); + eapply equ_clos_sbisim_goal; [exact Hfault | reflexivity | reflexivity] + end. + +Lemma queue_pool_bisim : forall u v n g2 g1 h c, + interp_schedule_rr sh 2 (queue_workers u v g2 g1) + (Some (queue_slot n)) n (h,c) ~ srun u v n h c. +Proof. + coinduction R CIH; intros u v n g2 g1 h c. + etransitivity; + [apply (coinduction.gfp_bt (sb eq) R), queue_pool_turn|]. + etransitivity; + [|apply (coinduction.gfp_bt (sb eq) R); symmetry; apply srun_turn]. + unfold turn, turnk. + destruct (h (S (hdrof u v n))) as [a|] eqn:Hhead. + - queue_prefix R ltac:(eapply sinterp_rd; exact Hhead). + destruct (h a) as [payload|] eqn:Hpayload. + + queue_prefix R ltac:(eapply sinterp_rd; exact Hpayload). + queue_prefix R ltac:(apply sinterp_emit). + eapply equ_sbt_closed_goal; [apply bind_bind | apply bind_bind |]. + unfold log, ICtree.trigger. + eapply equ_sbt_closed_goal; [apply bind_vis | apply bind_vis |]. + apply step_sb_vis. + * intros []; exists tt; split; [|reflexivity]. + eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. + apply st_clo_bind_eq; [reflexivity | intros [ignored [h' c']]; apply CIH]. + * intros []; exists tt; split; [|reflexivity]. + eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. + apply st_clo_bind_eq; [reflexivity | intros [ignored [h' c']]; apply CIH]. + + queue_prefix R ltac:(queue_fault Hpayload). + eapply equ_sbt_closed_goal; + [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. + - queue_prefix R ltac:(queue_fault Hhead). + eapply equ_sbt_closed_goal; + [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. +Qed. + +Theorem run_rr_parallel_bisim : + forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + run_rr (parallel_queues u v) h c ~ srun u v 0 h c. +Proof. + intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 _ _ _ _ _. + unfold parallel_queues; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 (queue_workers u v false false) + (Some (queue_slot 0)) 0 (h,c) ~ srun u v 0 h c). + apply queue_pool_bisim. +Qed. + +(** Silent initialization in the real shared source scheduler. *) + +Local Lemma interp_rr_write_present n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c : + h a <> None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (upd h a v,c). +Proof. + intro Present; destruct (h a) as [old|] eqn:E; [|contradiction]. + rewrite interp_rr_write. + assert (Hwrite : interp_state sh (swr a v) (h,c) ≅ + Guard (Ret (tt,(upd h a v,c)))). + { etransitivity; [unfold swr; apply interp_state_vis |]. + transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => + let '(_,sigma') := result in Guard (interp_state sh (Ret tt) sigma')). + - apply equ_clo_bind with (S := eq); + [exact (sh_wr_some a h c v old E) | intros x y <-; reflexivity]. + - etransitivity; [apply bind_ret_l |]. + step; constructor; apply interp_state_ret. } + transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => + let '(_,sigma') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m sigma'). + - apply sbisim_clo_bind_eq. + + eapply equ_clos_sbisim_goal; [exact Hwrite | reflexivity | apply sb_guard]. + + intro result; reflexivity. + - rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_fill_nodes n (ts : pool sE (S n)) (i : Fin.t (S n)) + first values (K : option unit -> thread sE) m h c : + (forall offset, Nat.lt offset (2 * length values) -> + h (first + offset)%nat <> None) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (fill_nodes_heap first values h,c). +Proof. + revert first h; induction values as [|value values IH]; intros first h Allocated. + - cbn [fill_nodes fill_nodes_heap]; rewrite interp_rr_ret; reflexivity. + - cbn [fill_nodes fill_nodes_heap]; rewrite interp_rr_bind. + etransitivity. + + apply interp_rr_write_present. + specialize (Allocated 0 ltac:(cbn; lia)); now rewrite Nat.add_0_r in Allocated. + + rewrite interp_rr_bind; etransitivity. + * apply interp_rr_write_present, upd_mono. + specialize (Allocated 1 ltac:(cbn; lia)). + replace (first + 1)%nat with (S first) in Allocated by lia; exact Allocated. + * apply IH; intros offset O; apply upd_mono, upd_mono. + replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. + apply Allocated; cbn; lia. +Qed. + +Lemma interp_rr_init_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) + hdr values (K : option unit -> thread sE) m h c : + (forall offset, Nat.lt offset (2 * S (length values)) -> + h (hdr + offset)%nat <> None) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (init_queue_heap hdr values h,c). +Proof. + intro Allocated; unfold init_queue, init_queue_heap; rewrite interp_rr_bind. + etransitivity. + - apply interp_rr_write_present. + specialize (Allocated 0 ltac:(lia)); now rewrite Nat.add_0_r in Allocated. + - rewrite interp_rr_bind; etransitivity. + + apply interp_rr_write_present, upd_mono. + specialize (Allocated 1 ltac:(lia)). + replace (hdr + 1)%nat with (S hdr) in Allocated by lia; exact Allocated. + + apply interp_rr_fill_nodes; intros offset O; apply upd_mono, upd_mono. + replace (hdr + 2 + offset)%nat with (hdr + (2 + offset))%nat by lia. + apply Allocated; lia. +Qed. + +Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) + values (K : option nat -> thread sE) m h c : + heap_finite h -> + exists hdr, + Nat.lt 0 hdr /\ block_free h hdr (2 * S (length values)) /\ + heap_finite (new_queue_heap hdr values h) /\ + asep (qrepX hdr (queue_nodes hdr (length values)) values) + (fun frame => heq frame h) (new_queue_heap hdr values h) /\ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) + (Some i) m (new_queue_heap hdr values h,c). +Proof. + intro Finite. + destruct (sh_alloc_finite h (2 * S (length values)) c Finite ltac:(lia)) + as (hdr & Positive & Free & First & Alloc). + exists hdr; split; [exact Positive |]; split; [exact Free |]; split. + - now apply new_queue_heap_finite. + - split; [now apply new_queue_heap_owned |]. + pose proof (sinterp_alloc_first h (2 * S (length values)) hdr c + (fun a : nat => (Ret a : ictree sE nat)) ltac:(lia) Positive Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + unfold new_queue; rewrite interp_rr_bind, interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + rewrite interp_rr_bind; etransitivity. + + apply interp_rr_init_queue; intros offset O. + unfold hunion; rewrite (hblock_in hdr (2 * S (length values)) offset O). + discriminate. + + rewrite interp_rr_ret; reflexivity. +Qed. + +Theorem run_rr_allocated_parallel : forall values1 values2 c, + exists u v h, + heap_finite h /\ + asep (qrepX u (queue_nodes u (length values1)) values1) + (qrepX v (queue_nodes v (length values2)) values2) h /\ + run_rr (allocated_parallel_queues values1 values2) hemp c ~ + run_rr (parallel_queues u v) h c. +Proof. + intros values1 values2 c. + set (done := fun _ : option unit => (Ret tt : thread sE)). + set (after1 := fun r : option nat => + match r with + | None => done None + | Some u => denote_flow + (CBind (new_queue values2) (fun v => parallel_queues u v)) >>= done + end). + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values1 after1 0 hemp c + heap_finite_hemp) as (u & Upos & Ufree & Finite1 & Own1 & Run1). + set (h1 := new_queue_heap u values1 hemp). + set (after2 := fun r : option nat => + match r with + | None => done None + | Some v => denote_flow (parallel_queues u v) >>= done + end). + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values2 after2 0 h1 c + Finite1) as (v & Vpos & Vfree & Finite2 & Own2 & Run2). + exists u, v, (new_queue_heap v values2 h1); split; [exact Finite2 |]; split. + - set (q1 := qheap u (queue_nodes u (length values1)) values1). + set (q2 := qheap v (queue_nodes v (length values2)) values2). + assert (E1 : heq h1 q1). + { intro x; unfold h1. + rewrite (new_queue_heap_agrees u values1 hemp Upos Ufree x). + change (hunion q1 hemp x = q1 x). + unfold hunion, hemp; destruct (q1 x); reflexivity. } + assert (D21 : hdisj q2 q1). + { eapply hdisj_resp; [apply heq_refl | exact E1 |]. + apply new_queue_heap_disjoint; exact Vfree. } + exists q1, q2; split; [apply hdisj_sym; exact D21 |]; split. + + eapply heq_trans; [apply new_queue_heap_agrees; eassumption |]. + eapply heq_trans. + * apply hunion_resp; [apply heq_refl | exact E1]. + * apply hunion_comm; exact D21. + + split; split; try apply qheap_qex; apply qheap_queue_nodes_rep; assumption. + - unfold allocated_parallel_queues, run_rr at 1; unfold denote at 1. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (new_queue values1) (fun u => + CBind (new_queue values2) (fun v => parallel_queues u v))) >>= done)) + (Some Fin.F1) 0 (hemp,c) ~ + run_rr (parallel_queues u v) (new_queue_heap v values2 h1) c). + rewrite interp_rr_bind. + etransitivity; [exact Run1 |]. + cbn [after1]; rewrite interp_rr_bind. + etransitivity; [exact Run2 |]. + reflexivity. +Qed. diff --git a/examples/CSL/QLang.v b/examples/CSL/QLang.v new file mode 100644 index 0000000..e3a7741 --- /dev/null +++ b/examples/CSL/QLang.v @@ -0,0 +1,265 @@ +(** * QLang: a small heap language with a SAFE handler, and the rotation body. + + Three deliberate departures from the reference language [Lang.HeapImp], + each of which is a research decision rather than a convenience: + + 1. **The handler is safe.** A read or a write outside the current heap's + domain produces [ICtree.stuck]. [HeapImp]'s [Put] never checks, and its + [Get] on an unmapped address is also stuck; here BOTH are checked, so an + out-of-footprint access invalidates every [AG] specification rather than + silently corrupting an unrelated cell. The footprint discipline is + therefore forced by the temporal proof, not assumed alongside it. + + 2. **The observation is heap-free.** [HeapImp] logs the WHOLE memory on + every write, which puts numeric addresses into the world and makes any + world-literal specification frame-unstable. Here the only logged event + is the popped payload together with an occurrence index, so the world + never mentions an address. + + 3. **The observation is occurrence-tagged.** [Pop v k] carries the number + of pops that preceded it. A retained [Obs (Log (Pop v k)) tt] world + cannot satisfy an occurrence-indexed formula for a later index, which is + what makes "the same element is popped AGAIN" a checkable statement + rather than a re-reading of a stale world. + + The projection back to the reference alphabet is [qval]: the reference + [examples/Queue.v] logs the popped payload [h : T] and specifies + [visW {fun h => h = nl}]; here the corresponding formula is + [visW {fun o => qval o = nl}]. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From examples Require Import CSL.HeapQ. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +(** Needed so that [equ] rewrites go through inside [sbisim] goals; the + reference files [Lang/MeQ.v] and [examples/Queue.v] do the same. *) +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** The observation alphabet and its projection *) + +Record QObs : Type := Pop { qval: nat ; qidx: nat }. + +(** ** Events *) + +Variant heapE : Type := + | Rd (a: nat) + | Wr (a: nat) (v: nat) + | Emit (v: nat). + +Global Instance encode_heapE: Encode heapE := + fun e => match e with Rd _ => nat | Wr _ _ => unit | Emit _ => unit end. + +(** The three instructions. They are written as raw [Vis] nodes rather than + [ICtree.trigger]: [trigger e] unfolds to exactly this shape through the + identity [ReSum]/[ReSumRet] instances, and keeping the [Vis] explicit lets + every equation below go through [interp_state_vis] without any [resum] + bookkeeping. *) +Definition rd (a: nat) : ictree heapE nat := Vis (Rd a) (fun x: nat => Ret x). +Definition wr (a v: nat) : ictree heapE unit := Vis (Wr a v) (fun _: unit => Ret tt). +Definition emit (v: nat) : ictree heapE unit := Vis (Emit v) (fun _: unit => Ret tt). + +(** The interpretation state: the OWNED heap and the PRIVATE occurrence + counter. The counter is not part of the heap and no heap operation reads + it; it exists to index the observations. *) +Notation Sig := (Heap * nat)%type. + +(** ** The safe handler *) +Definition h_heapE: heapE ~> stateT Sig (ictreeW QObs) := + fun e => + mkStateT (fun s => + match e return ictreeW QObs (encode e * Sig) with + | Rd a => match fst s a with + | Some v => Ret (v, s) + | None => ICtree.stuck + end + | Wr a v => match fst s a with + | Some _ => Ret (tt, (upd (fst s) a v, snd s)) + | None => ICtree.stuck + end + | Emit v => log (Pop v (snd s)) ;; Ret (tt, (fst s, S (snd s))) + end). + +(** *** Handler equations. These are pure computation on the handler; no + [interp_state] appears, so they are safe to reduce. *) + +Lemma h_rd_some: forall a h c v, + h a = Some v -> runStateT (h_heapE (Rd a)) (h, c) ≅ Ret (v, (h, c)). +Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. + +Lemma h_rd_none: forall a h c, + h a = None -> runStateT (h_heapE (Rd a)) (h, c) ≅ ICtree.stuck. +Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. + +Lemma h_wr_some: forall a h c v w, + h a = Some w -> runStateT (h_heapE (Wr a v)) (h, c) ≅ Ret (tt, (upd h a v, c)). +Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. + +Lemma h_emit: forall v h c, + runStateT (h_heapE (Emit v)) (h, c) ≅ (log (Pop v c) ;; Ret (tt, (h, S c))). +Proof. intros; cbn; reflexivity. Qed. + +(** *** Lifting the handler equations through [interp_state]. *) + +Lemma interp_rd {X}: forall a h c v (k: nat -> ictree heapE X), + h a = Some v -> + interp_state h_heapE (x <- rd a ;; k x) (h, c) ~ interp_state h_heapE (k v) (h, c). +Proof. + intros a h c v k H. + unfold rd; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis. + rewrite (h_rd_some a h c v H), bind_ret_l. + apply sb_guard. +Qed. + +Lemma interp_wr {X}: forall a h c v w (k: unit -> ictree heapE X), + h a = Some w -> + interp_state h_heapE (x <- wr a v ;; k x) (h, c) + ~ interp_state h_heapE (k tt) (upd h a v, c). +Proof. + intros a h c v w k H. + unfold wr; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis. + rewrite (h_wr_some a h c v w H), bind_ret_l. + apply sb_guard. +Qed. + +Lemma interp_emit {X}: forall v h c (k: unit -> ictree heapE X), + interp_state h_heapE (x <- emit v ;; k x) (h, c) + ~ (log (Pop v c) ;; interp_state h_heapE (k tt) (h, S c)). +Proof. + intros v h c k. + unfold emit; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, h_emit, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; apply sb_guard. +Qed. + +(** A read outside the footprint cannot step: this is the whole content of + "the handler is safe", and it is what makes an out-of-footprint access + invalidate every [AG] specification instead of corrupting a cell. *) +Lemma interp_rd_nostep {X}: forall a h c (k: nat -> ictree heapE X) w, + h a = None -> + ~ can_step (interp_state h_heapE (x <- rd a ;; k x) (h, c)) w. +Proof. + intros a h c k w H. + unfold rd; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, (h_rd_none a h c H). + intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; + revert TR; apply ktrans_stuck. +Qed. + +(** ** The rotating queue program. + + One iteration: read the head pointer, read and EMIT the head payload, read + the head's link, detach, find the node to append after, and re-link. No + allocation and no free: the same four cells are rewritten forever. *) + +Definition rot_body (hdr: nat) : ictree heapE (unit + unit) := + a <- rd (S hdr) ;; + v <- rd a ;; + _ <- emit v ;; + n <- rd (S a) ;; + _ <- wr (S hdr) n ;; + z0 <- rd hdr ;; + _ <- wr (S (if Nat.eqb n 0 then hdr else z0)) a ;; + _ <- wr (S a) 0 ;; + _ <- wr hdr a ;; + Ret (inl tt). + +Definition rotate (hdr: nat) : ictree heapE unit := + ICtree.iter (fun _: unit => rot_body hdr) tt. + +Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW QObs (unit * Sig) := + interp_state h_heapE (rotate hdr) (h, c). + +Lemma interp_wr' {X}: forall a h c v (k: unit -> ictree heapE X), + h a <> None -> + interp_state h_heapE (x <- wr a v ;; k x) (h, c) + ~ interp_state h_heapE (k tt) (upd h a v, c). +Proof. + intros a h c v k H; destruct (h a) as [w |] eqn:E; [| contradiction]. + eapply interp_wr; eauto. +Qed. + +(** ** The body correspondence. + + ONE completed rotation is strongly bisimilar to a SINGLE logged step + followed by a return. Three things are packed into this one statement: + + - **hidden-segment termination.** Every read and write in the body is + silent and finite, so the whole heap segment collapses; there is no + stuttering to reason about, and in particular no next-sensitive + stuttering theorem is needed. This holds ONLY because every access is + inside the footprint: an out-of-footprint access would leave [ICtree.stuck] + in place of a [Ret] and the collapse would fail ([interp_rd_nostep]). + + - **operation correctness.** The resulting heap is [rot_heap], which + [HeapQ.rot_heap_spec] proves implements the abstract pop-and-push. + + - **the observation.** The single event is [Pop v c] where [v] is the + payload READ OUT OF the head node's cell and [c] is the occurrence + counter before the pop. *) +Theorem rot_body_spec: forall hdr a ns v vs h c, + qrep hdr (a :: ns) (v :: vs) h -> + interp_state h_heapE (rot_body hdr) (h, c) + ~ (log (Pop v c) ;; + Ret (@inl unit unit tt, (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))). +Proof. + intros hdr a ns v vs h c Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + cbn in Hhd, Htl. + destruct Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. + assert (Hhdrdom: h hdr <> None) by (rewrite Htl; discriminate). + assert (Hsadom: h (S a) <> None) by (rewrite Hsa; discriminate). + assert (Hshdrdom: h (S hdr) <> None) by (rewrite Hhd; discriminate). + assert (Hread_hdr: upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) + by (rewrite upd_neq by congruence; exact Htl). + unfold rot_body. + rewrite (interp_rd (S hdr) h c a _ Hhd). + rewrite (interp_rd a h c v _ Ha). + rewrite interp_emit. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite (interp_rd (S a) h (S c) (hdf ns 0) _ Hsa). + rewrite (interp_wr' (S hdr) h (S c) (hdf ns 0) _ Hshdrdom). + rewrite (interp_rd hdr (upd h (S hdr) (hdf ns 0)) (S c) (last (a :: ns) 0) _ Hread_hdr). + rewrite (zof_compute hdr a ns Hwf). + rewrite (interp_wr' (S (zof hdr ns)) _ (S c) a _ (upd_mono _ _ _ _ Hzdom)). + rewrite (interp_wr' (S a) _ (S c) 0 _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom))). + rewrite (interp_wr' hdr _ (S c) a _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom)))). + rewrite interp_state_ret. + reflexivity. +Qed. diff --git a/examples/CSL/Queue.v b/examples/CSL/Queue.v new file mode 100644 index 0000000..72d26c1 --- /dev/null +++ b/examples/CSL/Queue.v @@ -0,0 +1,165 @@ +From TICL Require Import + Lang.CSL ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim + ICTree.Logic.Trans Logic.Core. +From examples Require Import + CSL.HeapQ CSL.Layout CSL.Frame CSL.Sep2 CSL.SLang CSL.Compose CSL.Program. + +Import ICtree ICTreeNotations TiclNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Typeclasses Transparent equ sbisim. + +Theorem rotate_agaf_pop_rr : + forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {run_rr (parallel_queues u v) h c}, Pure + |= AG (AF visW {spopped 1 nl1}) )>. +Proof. + intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 + H1 H2 Hd F1 F2). + exact (Compose.sched_agaf_q1 u v nl1 nl2 0 h c + ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). +Qed. + +Theorem rotate_agaf_pop_rr_q2 : + forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {run_rr (parallel_queues u v) h c}, Pure + |= AG (AF visW {spopped 2 nl2}) )>. +Proof. + intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 + H1 H2 Hd F1 F2). + exact (Compose.sched_agaf_q2 u v nl1 nl2 0 h c + ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). +Qed. + +Theorem rotate_agaf_pop_rr_fresh : + forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {run_rr (parallel_queues u v) h c}, Pure + |= AG (AF visW {spopped_after 1 nl1 k}) )>. +Proof. + intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 + H1 H2 Hd F1 F2). + exact (Compose.sched_agaf_q1_fresh u v nl1 nl2 k 0 h c + ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). +Qed. + +Theorem rotate_agaf_pop_rr_q2_fresh : + forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, + qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {run_rr (parallel_queues u v) h c}, Pure + |= AG (AF visW {spopped_after 2 nl2 k}) )>. +Proof. + intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 + H1 H2 Hd F1 F2). + exact (Compose.sched_agaf_q2_fresh u v nl1 nl2 k 0 h c + ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). +Qed. + +Definition owned_queues u ns1 vs1 v ns2 vs2 : Heap -> Prop := + asep (qrepX u ns1 vs1) (qrepX v ns2 vs2). + +Lemma owned_queues_sound u ns1 vs1 v ns2 vs2 h : + owned_queues u ns1 vs1 v ns2 vs2 h -> + qrep u ns1 vs1 h /\ qrep v ns2 vs2 h /\ Disj u ns1 v ns2. +Proof. + intros (h1 & h2 & Hd & Heq & H1 & H2). + change (hdisj h1 h2) in Hd. + change (heq h (hunion h1 h2)) in Heq. + assert (H1e : hdisj h1 hemp) by (intro x; right; reflexivity). + assert (H2e : hdisj h2 hemp) by (intro x; right; reflexivity). + destruct (compose3 u ns1 vs1 h1 v ns2 vs2 h2 hemp + H1 H2 Hd H1e H2e eq_refl) as (Q1 & Q2 & Hdisj). + assert (Hagree : forall x, hunion h1 (hunion h2 hemp) x = h x). + { intro x; rewrite Heq; unfold hunion, hemp. + destruct (h1 x); [reflexivity | destruct (h2 x); reflexivity]. } + split; [| split]. + - eapply qrep_agree_fp; [exact Q1 | |]. + + intros x _; symmetry; apply Hagree. + + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q1). + - eapply qrep_agree_fp; [exact Q2 | |]. + + intros x _; symmetry; apply Hagree. + + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q2). + - exact Hdisj. +Qed. + +Theorem rotate_agaf_pop_rr_owned : + forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + owned_queues u ns1 vs1 v ns2 vs2 h -> + find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + <( {run_rr (parallel_queues u v) h c}, Pure + |= AG (AF visW {spopped 1 nl1}) )>. +Proof. + intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. + destruct (owned_queues_sound u ns1 vs1 v ns2 vs2 h Hown) as (H1 & H2 & Hd). + eapply rotate_agaf_pop_rr; eassumption. +Qed. + +Theorem rotate_agaf_pop_alloc : + forall values1 values2 nl1 nl2 c d1 d2, + find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + |= AG (AF visW {spopped 1 nl1}) )>. +Proof. + intros values1 values2 nl1 nl2 c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 c) + as (u & v & h & Finite & Owned & Run). + change (owned_queues u (queue_nodes u (List.length values1)) values1 + v (queue_nodes v (List.length values2)) values2 h) in Owned. + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + rewrite Run; eapply rotate_agaf_pop_rr; eassumption. +Qed. + +Theorem rotate_agaf_pop_alloc_q2 : + forall values1 values2 nl1 nl2 c d1 d2, + find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + |= AG (AF visW {spopped 2 nl2}) )>. +Proof. + intros values1 values2 nl1 nl2 c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 c) + as (u & v & h & Finite & Owned & Run). + change (owned_queues u (queue_nodes u (List.length values1)) values1 + v (queue_nodes v (List.length values2)) values2 h) in Owned. + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + rewrite Run; eapply rotate_agaf_pop_rr_q2; eassumption. +Qed. + +Theorem rotate_agaf_pop_alloc_fresh : + forall values1 values2 nl1 nl2 k c d1 d2, + find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + |= AG (AF visW {spopped_after 1 nl1 k}) )>. +Proof. + intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 c) + as (u & v & h & Finite & Owned & Run). + change (owned_queues u (queue_nodes u (List.length values1)) values1 + v (queue_nodes v (List.length values2)) values2 h) in Owned. + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + rewrite Run; eapply rotate_agaf_pop_rr_fresh; eassumption. +Qed. + +Theorem rotate_agaf_pop_alloc_q2_fresh : + forall values1 values2 nl1 nl2 k c d1 d2, + find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + |= AG (AF visW {spopped_after 2 nl2 k}) )>. +Proof. + intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 c) + as (u & v & h & Finite & Owned & Run). + change (owned_queues u (queue_nodes u (List.length values1)) values1 + v (queue_nodes v (List.length values2)) values2 h) in Owned. + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + rewrite Run; eapply rotate_agaf_pop_rr_q2_fresh; eassumption. +Qed. diff --git a/examples/CSL/QueueTests.v b/examples/CSL/QueueTests.v new file mode 100644 index 0000000..8d7cd82 --- /dev/null +++ b/examples/CSL/QueueTests.v @@ -0,0 +1,403 @@ +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. +From TICL Require Import + Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer + ICTree.Interp.State.Mod ICTree.Logic.Trans Logic.Core + ICTree.Events.Yield ICTree.Interp.Yield.RoundRobin Utils.Vectors. +From examples Require Import + CSL.HeapQ CSL.Layout CSL.Frame CSL.Sep2 CSL.SLang CSL.Trace CSL.Program CSL.Queue. + +Import ICtree ICTreeNotations TiclNotations VectorNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. +Local Open Scope fin_vector_scope. +Local Typeclasses Opaque equ sbisim. + +Definition demo_h1 := qheap 2 [4;6] [7;9]. +Definition demo_h2 := qheap 10 [12] [8]. +Definition demo_heap := hunion demo_h1 demo_h2. +Definition duplicate_heap := + hunion (qheap 2 [4;6] [7;7]) (qheap 10 [12] [7]). + +Lemma demo_queue2_aligned : qwf 10 [12]. +Proof. + apply qwf_aligned. + - repeat (apply NoDup_cons; [cbn; intuition congruence |]); apply NoDup_nil. + - cbn; intuition congruence. + - repeat constructor; [exists 5 | exists 6]; reflexivity. +Qed. + +Lemma demo_h1_owned : qrepX 2 [4;6] [7;9] demo_h1. +Proof. exact Frame.qrepX1. Qed. + +Lemma demo_h2_owned : qrepX 10 [12] [8] demo_h2. +Proof. + split; [apply qheap_qrep; [apply demo_queue2_aligned | reflexivity | discriminate] + | apply qheap_qex]. +Qed. + +Lemma demo_disjoint xs ys : hdisj (qheap 2 [4;6] xs) (qheap 10 [12] ys). +Proof. + intro x. + destruct (qheap 2 [4;6] xs x) eqn:H1; [| now left]. + destruct (qheap 10 [12] ys x) eqn:H2; [| now right]. + exfalso. + pose proof (qheap_qex 2 [4;6] xs x ltac:(congruence)) as F1. + pose proof (qheap_qex 10 [12] ys x ltac:(congruence)) as F2. + cbn in F1, F2; intuition congruence. +Qed. + +Lemma demo_owned : owned_queues 2 [4;6] [7;9] 10 [12] [8] demo_heap. +Proof. + exists demo_h1, demo_h2. + split; [apply demo_disjoint |]. + split; [intro x; reflexivity |]. + split; [apply demo_h1_owned | apply demo_h2_owned]. +Qed. + +Lemma duplicate_owned : + owned_queues 2 [4;6] [7;7] 10 [12] [7] duplicate_heap. +Proof. + exists (qheap 2 [4;6] [7;7]), (qheap 10 [12] [7]). + split; [apply demo_disjoint |]. + split; [intro x; reflexivity |]. + split; split; try apply qheap_qex. + - apply qheap_qrep; [exact Layout.qwf1 | reflexivity | discriminate]. + - apply qheap_qrep; [apply demo_queue2_aligned | reflexivity | discriminate]. +Qed. + +Local Ltac reference_turn Hq := + lazymatch type of Hq with + | qrep ?hdr (?a :: ?ns) (?pv :: ?vs) ?h => + lazymatch goal with + | |- srun ?u ?v ?n h ?c ~ ?rhs => + let Hbody := constr:(sbody_spec u v n a ns pv vs h c Hq) in + unfold srun, sched at 1; + rewrite interp_state_unfold_iter; + cbv beta; + match goal with + | |- sbisim _ (ICtree.bind _ ?k) _ => + eapply Transitive_sbisim; + [ eapply sbisim_clo_bind_eq with (k2 := k); + [ exact Hbody | intros ?; reflexivity ] + | ] + end; + rewrite bind_bind; + apply sbisim_clo_bind_eq; [reflexivity | intros []]; + rewrite bind_ret_l, sb_guard; + lazymatch goal with + | |- _ ~ ?tail => + change (srun u v (S n) (qstep hdr (a :: ns) h) (S c) ~ tail) + end + end + end. + +Local Lemma fixed_layout_four_pop u a b v d h x y z : + qrep u [a;b] [x;y] h -> qrep v [d] [z] h -> Disj u [a;b] v [d] -> + exists rest : ictreeW SObs (unit * SSig), + run_rr (parallel_queues u v) h 0 ~ + (log (SPop 1 x 0);; log (SPop 2 z 1);; + log (SPop 1 y 2);; log (SPop 2 z 3);; rest). +Proof. + intros H1 H2 Hd. + assert (F1 : find x [x;y] = Some 0) by (cbn [find]; now rewrite Nat.eqb_refl). + assert (F2 : find z [z] = Some 0) by (cbn [find]; now rewrite Nat.eqb_refl). + pose proof (qstep_qrep u [a;b] [x;y] h H1 ltac:(discriminate)) as H1a. + change (qrep u [b;a] [y;x] (qstep u [a;b] h)) in H1a. + pose proof (foreign_pres u [a;b] [x;y] v [d] [z] h + H1 ltac:(discriminate) H2 Hd) as H2a. + pose proof (Disj_rotl_l u [a;b] v [d] ltac:(discriminate) Hd) as Hda. + change (Disj u [b;a] v [d]) in Hda. + pose proof (foreign_pres v [d] [z] u [b;a] [y;x] + (qstep u [a;b] h) H2a ltac:(discriminate) H1a + (Disj_sym u [b;a] v [d] Hda)) as H1b. + pose proof (qstep_qrep v [d] [z] (qstep u [a;b] h) + H2a ltac:(discriminate)) as H2b. + change (qrep v [d] [z] (qstep v [d] (qstep u [a;b] h))) in H2b. + pose proof (foreign_pres u [b;a] [y;x] v [d] [z] + (qstep v [d] (qstep u [a;b] h)) H1b ltac:(discriminate) H2b Hda) as H2c. + exists (srun u v 4 + (qstep v [d] (qstep u [b;a] + (qstep v [d] (qstep u [a;b] h)))) 4). + etransitivity. + - exact (run_rr_parallel_bisim u v x z h 0 [a;b] [x;y] [d] [z] 0 0 + H1 H2 Hd F1 F2). + - reference_turn H1. + reference_turn H2a. + reference_turn H1b. + reference_turn H2c. + reflexivity. +Qed. + +Lemma demo_four_pop_prefix : exists rest : ictreeW SObs (unit * SSig), + run_rr (parallel_queues 2 10) demo_heap 0 ~ + (log (SPop 1 7 0);; log (SPop 2 8 1);; + log (SPop 1 9 2);; log (SPop 2 8 3);; rest). +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). + apply (fixed_layout_four_pop 2 4 6 10 12); assumption. +Qed. + +Lemma duplicate_four_pop_prefix : exists rest : ictreeW SObs (unit * SSig), + run_rr (parallel_queues 2 10) duplicate_heap 0 ~ + (log (SPop 1 7 0);; log (SPop 2 7 1);; + log (SPop 1 7 2);; log (SPop 2 7 3);; rest). +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). + apply (fixed_layout_four_pop 2 4 6 10 12); assumption. +Qed. + +Lemma demo_queue1_recurs : + <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr 2 10 7 8 demo_heap 0 + [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma demo_queue2_recurs : + <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure + |= AG (AF visW {spopped 2 8}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_q2 2 10 7 8 demo_heap 0 + [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma demo_queue1_fresh k : + <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure + |= AG (AF visW {spopped_after 1 7 k}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_fresh 2 10 7 8 k demo_heap 0 + [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma demo_queue2_fresh k : + <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure + |= AG (AF visW {spopped_after 2 8 k}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_q2_fresh 2 10 7 8 k demo_heap 0 + [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma duplicate_queue1_recurs : + <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr 2 10 7 7 duplicate_heap 0 + [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma duplicate_queue2_recurs : + <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure + |= AG (AF visW {spopped 2 7}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_q2 2 10 7 7 duplicate_heap 0 + [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma duplicate_queue1_fresh k : + <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure + |= AG (AF visW {spopped_after 1 7 k}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_fresh 2 10 7 7 k duplicate_heap 0 + [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma duplicate_queue2_fresh k : + <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure + |= AG (AF visW {spopped_after 2 7 k}) )>. +Proof. + destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). + exact (rotate_agaf_pop_rr_q2_fresh 2 10 7 7 k duplicate_heap 0 + [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). +Qed. + +Lemma allocated_demo_four_pop_prefix : + exists rest : ictreeW SObs (unit * SSig), + run_rr (allocated_parallel_queues [7;9] [8]) hemp 0 ~ + (log (SPop 1 7 0);; log (SPop 2 8 1);; + log (SPop 1 9 2);; log (SPop 2 8 3);; rest). +Proof. + destruct (run_rr_allocated_parallel [7;9] [8] 0) + as (u & v & h & Finite & Owned & Run). + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + destruct (fixed_layout_four_pop _ _ _ _ _ _ _ _ _ H1 H2 Hd) as (rest & Prefix). + exists rest; etransitivity; [exact Run | exact Prefix]. +Qed. + +Lemma allocated_duplicate_four_pop_prefix : + exists rest : ictreeW SObs (unit * SSig), + run_rr (allocated_parallel_queues [7;7] [7]) hemp 0 ~ + (log (SPop 1 7 0);; log (SPop 2 7 1);; + log (SPop 1 7 2);; log (SPop 2 7 3);; rest). +Proof. + destruct (run_rr_allocated_parallel [7;7] [7] 0) + as (u & v & h & Finite & Owned & Run). + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). + destruct (fixed_layout_four_pop _ _ _ _ _ _ _ _ _ H1 H2 Hd) as (rest & Prefix). + exists rest; etransitivity; [exact Run | exact Prefix]. +Qed. + +Lemma allocated_demo_queue1_recurs : + <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. exact (rotate_agaf_pop_alloc [7;9] [8] 7 8 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_demo_queue2_recurs : + <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure + |= AG (AF visW {spopped 2 8}) )>. +Proof. exact (rotate_agaf_pop_alloc_q2 [7;9] [8] 7 8 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_demo_queue1_fresh k : + <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure + |= AG (AF visW {spopped_after 1 7 k}) )>. +Proof. exact (rotate_agaf_pop_alloc_fresh [7;9] [8] 7 8 k 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_demo_queue2_fresh k : + <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure + |= AG (AF visW {spopped_after 2 8 k}) )>. +Proof. exact (rotate_agaf_pop_alloc_q2_fresh [7;9] [8] 7 8 k 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_duplicate_queue1_recurs : + <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure + |= AG (AF visW {spopped 1 7}) )>. +Proof. exact (rotate_agaf_pop_alloc [7;7] [7] 7 7 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_duplicate_queue2_recurs : + <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure + |= AG (AF visW {spopped 2 7}) )>. +Proof. exact (rotate_agaf_pop_alloc_q2 [7;7] [7] 7 7 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_duplicate_queue1_fresh k : + <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure + |= AG (AF visW {spopped_after 1 7 k}) )>. +Proof. exact (rotate_agaf_pop_alloc_fresh [7;7] [7] 7 7 k 0 0 0 eq_refl eq_refl). Qed. + +Lemma allocated_duplicate_queue2_fresh k : + <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure + |= AG (AF visW {spopped_after 2 7 k}) )>. +Proof. exact (rotate_agaf_pop_alloc_q2_fresh [7;7] [7] 7 7 k 0 0 0 eq_refl eq_refl). Qed. + +Local Lemma interp_rr_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) + values (K : option nat -> thread sE) m c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) + (Some i) m (new_queue_heap 1 values hemp,c). +Proof. + assert (Free : block_free hemp 1 (2 * S (length values))) + by (intros offset O; reflexivity). + assert (First : forall j, Nat.lt 0 j -> Nat.lt j 1 -> + ~ block_free hemp j (2 * S (length values))) by (intros; lia). + pose proof (sinterp_alloc_first hemp (2 * S (length values)) 1 c + (fun a : nat => (Ret a : ictree sE nat)) ltac:(lia) ltac:(lia) Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + unfold new_queue; rewrite interp_rr_bind, interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + rewrite interp_rr_bind; etransitivity. + - apply interp_rr_init_queue; intros offset O. + unfold hunion; rewrite (hblock_in 1 (2 * S (length values)) offset O). + discriminate. + - rewrite interp_rr_ret; reflexivity. +Qed. + +Local Ltac probe_read value := + lazymatch goal with + | |- (interp_state sh (srd ?a) (?h,?c) >>= ?next) ~ _ => + let Hr := fresh "Hread" in + pose proof (sinterp_rd a h c value + (fun x : nat => (Ret x : ictree sE nat)) eq_refl) as Hr; + rewrite bind_ret_r, interp_state_ret in Hr; + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hr | intro result; reflexivity] |]; + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |] + end. + +Local Ltac probe_emit := + lazymatch goal with + | |- (interp_state sh (semit ?q ?v) (?h,?c) >>= ?next) ~ _ => + let He := fresh "Hemit" in + assert (He : interp_state sh (semit q v) (h,c) ~ + (log (SPop q v c);; Ret (tt,(h,S c)))) by + (let Hraw := fresh "Hraw" in + pose proof (sinterp_emit q v h c + (fun x : unit => (Ret x : ictree sE unit))) as Hraw; + rewrite bind_ret_r in Hraw; + etransitivity; [exact Hraw |]; + apply sbisim_clo_bind_eq; [reflexivity | intros []]; + rewrite interp_state_ret; reflexivity); + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact He | intro result; reflexivity] |]; + eapply equ_clos_sbisim_goal; [apply bind_bind | reflexivity |]; + apply sbisim_clo_bind_eq; [reflexivity | intros []]; + eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |] + end. + +Local Ltac probe_finish := + cbv [Vector.replace Vector.caseS']; + erewrite interp_schedule_rr_ret by reflexivity; + rewrite vector_remove_head, interp_schedule_rr_empty; reflexivity. + +Definition initialized_queue_probe : CProg unit := + CBind (new_queue [7;9]) (fun hdr => + CBind (CRead (S hdr)) (fun head => + CBind (CRead head) (fun value => CEmit hdr value))). + +Lemma initialized_queue_probe_seen : + run_rr initialized_queue_probe hemp 0 ~ + (log (SPop 1 7 0);; Ret (tt,(new_queue_heap 1 [7;9] hemp,1))). +Proof. + unfold run_rr, initialized_queue_probe. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (new_queue [7;9]) (fun hdr => + CBind (CRead (S hdr)) (fun head => + CBind (CRead head) (fun value => CEmit hdr value)))) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 1 7 0);; Ret (tt,(new_queue_heap 1 [7;9] hemp,1)))). + rewrite interp_rr_bind, interp_rr_new_queue_empty. + rewrite interp_rr_bind, interp_rr_read; probe_read 3. + rewrite interp_rr_bind, interp_rr_read; probe_read 7. + rewrite interp_rr_emit; probe_emit. + probe_finish. +Qed. + +Definition empty_queue_probe : CProg unit := + CBind (new_queue []) (fun hdr => + CBind (CRead hdr) (fun tail => + CBind (CRead (S hdr)) (fun head => CEmit tail head))). + +Lemma empty_queue_probe_seen : + run_rr empty_queue_probe hemp 0 ~ + (log (SPop 0 0 0);; Ret (tt,(new_queue_heap 1 [] hemp,1))). +Proof. + unfold run_rr, empty_queue_probe. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (new_queue []) (fun hdr => + CBind (CRead hdr) (fun tail => + CBind (CRead (S hdr)) (fun head => CEmit tail head)))) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ + (log (SPop 0 0 0);; Ret (tt,(new_queue_heap 1 [] hemp,1)))). + rewrite interp_rr_bind, interp_rr_new_queue_empty. + rewrite interp_rr_bind, interp_rr_read; probe_read 0. + rewrite interp_rr_bind, interp_rr_read; probe_read 0. + rewrite interp_rr_emit; probe_emit. + probe_finish. +Qed. + diff --git a/examples/CSL/README.md b/examples/CSL/README.md new file mode 100644 index 0000000..742b62a --- /dev/null +++ b/examples/CSL/README.md @@ -0,0 +1,311 @@ +# Cooperative heap queues + +`TICL.Lang.CSL` is a typed cooperative fork/yield language over a disjoint heap +PCM. `Program.allocated_parallel_queues values1 values2` constructs two linked +queues by source execution on `hemp`, then starts their workers. The lower-level +`Program.parallel_queues u v` remains available for preallocated heaps. Both +workers own **different queues in one shared heap**; they do not concurrently +modify one queue, and the facade does not assert a general CSL parallel rule. + +## Actual execution and proof boundary + +The source execution is: + +```text +raw source denotations + -> existing Yield vector scheduler + -> modulo-cursor branch refinement + -> Spawn/Yield erasure + -> one shared checked heap handler +``` + +`ICTree.Interp.Refine` owns the stateful cursor API, erasing runner, observational +`BranchFree` predicate and closure proofs, and parity picker facts. +`ICTree.Interp.Yield.RoundRobin` owns the handler-parametric pool interpreter and +its eight execution equations. Neither module imports a language or example. +`Lang.CSL.Interp` instantiates that API with `sh`; it owns source-constructor +execution equations and scoped-fork startup. No example-local pool interpreter +or bridge module is used. + +Every encountered `Br` is refined, including source branches in a generic raw +pool. `Br 0` has one alternative and still advances the cursor. Guards, events, +and Spawn do not advance it. `denote_branchfree` proves that CSL source trees +have no branch nodes. This policy does not force a nonyielding worker to yield, +and no universal fairness theorem for arbitrary or changing pools is claimed. + +Fork prepends the child while retaining parent focus. Thus the initial queue +pool is `[queue2; queue1]`, slot 1 is focused, and cursor 0 has not yet been used +for selection. The parent runs first. `queue_pick_next`, parked iteration guards, +and `queue_pool_turn` establish the subsequent alternation explicitly. + +`rotate_once` executes nine source instructions: read head, read payload, emit, +read next, write head, read old tail, write the tail/header link, clear the moved +node's link, and write tail. Only the worker's final yield relinquishes focus. +The singleton case links through the header. There is no atomic-rotation +primitive and no output generated from ghost payload lists. + +`Program.interp_rr_rotate_once` composes the source constructor rules for those +instructions, preserving fault behavior and the entire post-emit heap suffix. +`queue_pool_bisim` matches both failed-read cases and takes its coinductive step +at a real `Log (SPop ...)` transition, not at an administrative guard. +`Program.run_rr_parallel_bisim` proves equivalence of the actual `run_rr` source +execution to the tagged cyclic reference. The reference alone is not the +implementation or evidence of source execution. + +`Program.run_rr_allocated_parallel` proves that actual silent allocation and +checked initialization from `hemp` reach a finite heap with two PCM-separated +queues and the original worker execution, at the same observation counter. +It also covers empty input lists. No initialized heap is assumed. + +`Queue.v` exposes recurrence directly for +`run_rr (allocated_parallel_queues values1 values2) hemp c`: + +- `rotate_agaf_pop_alloc`: queue 1 ordinary recurrence. +- `rotate_agaf_pop_alloc_q2`: queue 2 ordinary recurrence. +- `rotate_agaf_pop_alloc_fresh`: queue 1 recurrence at every inclusive index bound. +- `rotate_agaf_pop_alloc_q2_fresh`: queue 2 recurrence at every inclusive index bound. + +These four theorems require only one successful `find` premise for each payload +list, not representation, disjointness, or preallocated-heap premises. They +transport the existing worker recurrence through the proved initialization +bisimulation. The lower-level statements remain: + +- `rotate_agaf_pop_rr`: queue 1 ordinary recurrence. +- `rotate_agaf_pop_rr_q2`: queue 2 ordinary recurrence. +- `rotate_agaf_pop_rr_fresh`: queue 1 recurrence at every inclusive index bound. +- `rotate_agaf_pop_rr_q2_fresh`: queue 2 recurrence at every inclusive index bound. +- `rotate_agaf_pop_rr_owned`: queue 1 recurrence from actual PCM separation. + +Each lower-level conclusion is `AG (AF visW {...})` over `run_rr (parallel_queues u v) h c`. +Both membership premises remain: both workers must be nonempty and productive +for recurrence. The internal execution bisimulation also covers faulty heaps. +Freshness means `k <= sidx`; `sfresh_excludes_retained` prevents counting an old +observation at index `j` toward the bound `S j`. + +## Heap and ownership contract + +The canonical heap is `nat -> option nat`, with pointwise `heq`, pointwise +`hdisj`, and left-biased `hunion`. This representation does **not** impose finite +support. `heap_finite` is an existential proof bound, not a new carrier or runtime +field. `SSig` remains `(Heap * nat)%type`; results remain `(result, SSig)`. + +`CAlloc size` uses `SAlloc` and a guarded, constructive search inside the shared +handler. It returns the least positive base whose entire interval is free and +initializes exactly `size` cells to zero, preserving every old allocated value +and address zero. It neither emits nor yields, and advances neither the +observation counter nor the scheduler cursor. There is no runtime fuel, +caller-selected base, heap-wide maximum, classical choice, or allocation log. +Size zero is `stuck`. Positive requests terminate on every finite heap; an +infinite heap with no suitable interval silently diverges, as proved by +`alloc_search_no_space`. This is not a finite-memory exhaustion policy. + +Reads and writes remain checked; writes never allocate implicitly. Emit records +`SPop tag value c`, preserves the heap, and increments the global observation +counter. The scheduler cursor is separate. There is no variable store, CAS, +lock, or implicit read/write yield. + +`qrep` reserves address zero through `h 0 = None`; the handler itself has no +special address-zero check. Header `hdr` stores tail and `S hdr` stores head; +node `a` stores payload and `S a` stores its next pointer. `qrep` permits +unrelated allocated cells, and an empty queue may retain a stale allocated tail. +`qrepX := qrep /\ qex` expresses exact ownership. Framing requires both heap +disjointness and a frame that leaves address zero unallocated. + +`owned_queues` is precisely `asep (qrepX ...) (qrepX ...)`, using transparent +`HeapPCM`, not a conjunction standing in for separation. `owned_queues_sound` +uses `compose3` and pointwise footprint agreement; it does not equate heap +functions by Leibniz equality. + +## Runtime queue construction + +`new_queue values` allocates one block of `2 * S (length values)` cells, then +`init_queue` and `fill_nodes` execute ordinary checked writes. Header `hdr` +stores the last node and `S hdr` the first; `queue_nodes hdr count` starts at +`hdr + 2` with stride two. Both odd and even runtime bases are valid. Duplicate +payloads are permitted. `new_queue []` allocates two header cells and writes +zero to both, rather than requesting an invalid zero-size block. + +`interp_rr_fill_nodes`, `interp_rr_init_queue`, and `interp_rr_new_queue` prove +execution with arbitrary raw continuation, pool, focus, cursor, and observation +index. `new_queue_heap` describes the exact result of those writes, not a second +interpreter. `new_queue_heap_owned` separates the exact `qheap` resource from +the unchanged old heap; it does not claim exact queue ownership of unrelated +cells. Allocation addresses need not remain the same under framing. + +Both blocks are initialized before fork. Initialization emits and yields +nothing; the existing parent-first startup and rotation loop are unchanged. +The infinite workers do not allocate or free further storage. + +## Donor provenance + +These directories were **copy sources only**, not build or runtime dependencies: + +```text +P = /home/eioannidis/ticl-sl/spark_submission/experiments/prove-scoped-pcm-transport-and-owned-structural-rules/proofs +Q = /home/eioannidis/ticl-sl/spark_submission/experiments/heap-backed-rotating-queue-and-unused-frame-transport/proofs +S = /home/eioannidis/ticl-sl/spark_submission/experiments/separate-active-composition-from-unused-framing/proofs +``` + +| Source | Destination | +| --- | --- | +| `P/Pcm.v`, complete | `theories/Lang/CSL/Pcm.v` | +| `S/SLang.v`, heap prefix | `theories/Lang/CSL/Heap.v` | +| `Q/HeapQ.v` | `examples/CSL/HeapQ.v` | +| `Q/QLang.v` | `examples/CSL/QLang.v` | +| `Q/Recurrence.v` | `examples/CSL/Recurrence.v` | +| `Q/Trace.v` | `examples/CSL/Trace.v` | +| `Q/Layout.v` | `examples/CSL/Layout.v` | +| `Q/Frame.v` | `examples/CSL/Frame.v` | +| `S/Sep2.v` | `examples/CSL/Sep2.v` | +| `S/SLang.v`, imports/scopes and turn/scheduler suffix | `examples/CSL/SLang.v` | +| `S/Lex.v` | `examples/CSL/Lex.v` | +| `S/Compose.v` | `examples/CSL/Compose.v` | +| `Q/Overlap.v` | `examples/CSL/Overlap.v` | + +The transformations were: + +- Preserve all of `Pcm.v`, including proofs and transparent `HeapPCM`. +- Extract `Heap.v` from `From Stdlib Require Import` up to, excluding, + `(** ** A turn:`. Replace its `HQ.HeapQ` import with an export of canonical + `Pcm` and the boolean `upd` definition; add no `hdom` alias. Only Pcm is + exported. Add write-none, continuation-free fault, and pointwise update + agreement proofs in this owning heap layer. +- In `HeapQ.v`, replace the span from `Definition Heap :=` up to `Lemma upd_eq:` + with `From TICL Require Export Lang.CSL.Heap.`. This removes the duplicate + foundation and unused local points-to definition, retaining all queue proofs, + including `rot_detach_split` and both `rot_heap_spec` conjuncts. +- Rewrite old `ICTree.Interp.State` imports to `.State.Mod`, and `From HQ Require + Import/Export ...` to `From examples Require Import/Export CSL....`, preserving + the import/export distinction. +- For the example `SLang.v`, retain donor imports/scopes before the observation + alphabet and the suffix beginning `(** ** A turn:`. Export canonical Heap and + import CSL.HeapQ rather than duplicating events or handlers. Append its own + `turnk_bind` and `srun_turn` proofs; it imports neither the source program nor + the round-robin policy. +- Keep `Layout.hsingle` private to that layout and qualify Overlap's definitions + and unfolds with `Layout.hsingle`. PCM tests use `Pcm.hsingle`. + +No `Layout2.v`, frozen donor TICL installation, or older exact-domain heap donor +was used. `QLang` remains the distinct untagged sequential reference required by +the inherited proof chain. `SLang.sbody` alternates `turnk 1 u` and `turnk 2 v` +according to parity and increments its iteration index; `srun` interprets that +cyclic reference with the tagged handler. + +The new refiner's modulo-counter mechanism follows the read-only provenance +`git show 161d1eadedb7479b162fcde688e750b3a45ae37e:theories/Interp/Refine.v`. +Its old CTree API, arity-zero fault case, and state-first pairs were not copied. +In that original extraction, the only modified pre-existing proof file was +`ICTree/Eq/Bind.v`, which gained the generic `bind_stuck_equ` immediately after +`bind_guard`. Existing State/Yield work and Dune configuration were preserved. +The dynamic-allocation extension uses only the current repository: it adds no +donor dependency and changes no generic scheduler or refiner API. + +## Behavioral verification + +The six retained regression modules compile: + +- `PcmTests`: same-cell and overlapping-block ownership exclusion, distinct-cell + separation, and the actual fresh-block split beside an unchanged points-to frame. +- `HeapTests`: checked access/fault behavior, exact emit observation/counter, + zero-initialized allocation, whole-block first-fit rejection of partial overlap, + zero-size faults, and silent divergence on a saturated infinite heap. +- `RoundRobinTests`: modulo choices, returned cursors, singleton-branch cursor + advance, actual scheduler selection, and a language-independent shared state + counter with complete trace `1,11,12,22` and final state 22. +- `InterpTests`: a child sees the parent's write, a scoped child skips both + remaining loop body and post-loop continuation, and the finite alternating + tagged trace. Allocation tests read a fresh zero cell and allocate across two + active threads: parent base 1, child base 3, emit indices 0 and 1. All contracts + include the final returned shared state. +- `QueueTests`: both literal preallocated fixtures and dynamically initialized + programs on `hemp`, with both tags' ordinary/fresh recurrence and four-pop + prefixes. The demo prefix is `(1,7,0),(2,8,1),(1,9,2),(2,8,3)`. Duplicate + payloads still produce tags `1,2,1,2` at indices `0,1,2,3`. Source probes read + the newly initialized `[7;9]` queue and both zero pointers of an empty queue. +- `NegativeTests`: retains the ownership/sequential/freshness controls. The + low-level `parallel_queues` still faults on `hemp`. Dynamically initializing + `[]` and `[8]` succeeds, but the first worker then faults on its null payload + read; that execution is `stuck` and fails queue-1 recurrence. Sequential + controls are not claims about arbitrary concurrent pools. + +The initial baseline, every dependency gate, and the final `make build` passed. +The allocation extension rejected both requested temporary mutations with +nonzero proof compilation status: + +1. Replacing `block_freeb`'s recursive `None` branch with `true` failed in + `Heap.block_freeb_spec`, before the heap/source regression modules. +2. Replacing only `new_queue`'s `CAlloc` prefix with `CRet 1` failed in + `Program.interp_rr_new_queue` at the source allocation equation, before + `QueueTests`. + +Both correct bodies were restored immediately. Afterwards: + +```sh +dune build examples/CSL/PcmTests.vo examples/CSL/HeapTests.vo \ + examples/CSL/RoundRobinTests.vo examples/CSL/InterpTests.vo \ + examples/CSL/QueueTests.vo examples/CSL/NegativeTests.vo +make build +``` + +Both commands exited zero. No commit or index modification was performed. + +The earlier scheduler migration separately recorded rejection of `rr_pick` +returning `Fin.F1` in `rr_pick_even`, and per-thread `run_rr` interpretation in +`run_rr_unfold`. Those generic mechanisms were not mutated for this extension. + +## Trust-base audit + +`coqtop -quiet -Q _build/default/theories TICL -Q _build/default/examples examples` +ran the post-build `Print Assumptions` audit for `sh_alloc_finite`, +`interp_rr_alloc`, `interp_rr_new_queue`, `run_rr_allocated_parallel`, +`run_rr_parallel_bisim`, and all four new dynamic recurrence theorems. +The changed `.v` files contain no `Admitted`, `admit`, `Axiom`, `Parameter`, +`Classical`, or choice declaration. Imports were checked for obsolete State +paths, HQ dependencies, donor runtime paths, and layer violations. + +The previously recorded baseline `examples.Queue.Queue.rotate_agaf_pop` prints: + +```text +Axioms: +Eqdep.Eq_rect_eq.eq_rect_eq : + forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p), + x = eq_rect p Q x p h +MeQ.ME.T : Type +MeQ.ME.HDec : RelDec.RelDec eq +MeQ.ME.HCor : RelDec.RelDec_Correct MeQ.ME.HDec +``` + +`interp_schedule_rr_user` and `denote_branchfree` print only the same inherited +`Eqdep.Eq_rect_eq.eq_rect_eq` axiom. `run_rr_fork_bind`, +`run_rr_parallel_bisim`, and the five lower-level source recurrence theorems print: + +```text +Axioms: +FunctionalExtensionality.functional_extensionality_dep : + forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g +Eqdep.Eq_rect_eq.eq_rect_eq : + forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p), + x = eq_rect p Q x p h +``` + +The dynamic audit found only the already accepted assumptions: + +| Audited theorem | Assumptions | +|---|---| +| `Heap.sh_alloc_finite` | `Eqdep.Eq_rect_eq.eq_rect_eq` (UIP) | +| `Interp.interp_rr_alloc` | UIP and dependent functional extensionality | +| `Program.interp_rr_new_queue` | UIP and dependent functional extensionality | +| `Program.run_rr_allocated_parallel` | UIP and dependent functional extensionality | +| `Program.run_rr_parallel_bisim` | UIP and dependent functional extensionality | +| All four `Queue.rotate_agaf_pop_alloc*` theorems | UIP and dependent functional extensionality | + +The functional-extensionality dependency is inherited from the **pre-existing** +`ICTree.Interp.Yield.SBisim.schedule_pool_proper`, whose `Print Assumptions` +reports those same two axioms. That scheduler proof was not changed. +`interp_schedule_rr_equ` consumes it as required by the pool-congruence API. +This is not an added heap-extensionality axiom: `Heap.upd_pcm` and +`Queue.owned_queues_sound` each print `Closed under the global context`. +There is no new admitted constant, allocator-choice or finite-support oracle, +assumed initialization correctness, fairness or recurrence axiom, or assumed +program bisimulation. diff --git a/examples/CSL/Recurrence.v b/examples/CSL/Recurrence.v new file mode 100644 index 0000000..8d18e71 --- /dev/null +++ b/examples/CSL/Recurrence.v @@ -0,0 +1,417 @@ +(** * Recurrence: the heap-backed [AG AF] theorem and its freshness companion. + + The reference theorem is [examples/Queue.v], [rotate_agaf_pop]: + + find nl q = Some i -> + <( instr_prog rotate q, Pure |= AG AF visW {fun h => h = nl} )> + + over an ABSTRACT queue held in the interpretation state as a [list T]. + Here the queue is a preallocated linked structure in a heap, the pops are + real heap reads, and the rotation is four real heap writes. + + What is reused unchanged, and what had to change, is recorded in + FINDINGS.md; the two structural facts are: + + - the outer [AG] needs NO adaptation. [ICTree.Logic.State.ag_state_iter] + takes an invariant [R i sigma w], and the abstract queue can be + existentially quantified inside it. There is no variant, so nothing + has to be a function of the state. + + - the inner [AF] DOES need an adaptation. [aul_state_iter_nat] and + [aul_state_iter] require the rank to be a function of + [(i, sigma, w)]. A heap representation has no such function without + first proving that [qrep] determines the abstract queue. The rank here + is a function of GHOST data (the abstract queue and the position of [nl] + in it), tied to the state by the invariant, so the loop rule is + re-derived over ghost data from [aul_state_iter_next_eq]. That + re-derivation is [owned_aul_iter_ghost] below, and it is the one place + the baseline's client-facing loop interface was not enough. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat + Arith.Wf_nat + Relations. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From examples Require Import CSL.HeapQ CSL.QLang. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** The lexicographic control. + + Reused verbatim from the companion experiment's [proofs/Owned.v] + ([owned_aur_iter_lex]); the reference queue proof needs only a [nat] rank, + and so does the plain recurrence theorem below. The SECOND component is + what the freshness companion needs: it must first outrun a given occurrence + bound and only then reach the element. *) +Definition lexnat : relation (nat * nat) := + fun p q => fst p < fst q \/ (fst p = fst q /\ snd p < snd q). + +Lemma lexnat_wf: well_founded lexnat. +Proof. + intros [a b]; revert b. + induction a as [a IHa] using (well_founded_induction lt_wf). + intro b. + induction b as [b IHb] using (well_founded_induction lt_wf). + constructor; intros [c d] [Hlt | (Heq & Hlt)]; cbn in *. + - now apply IHa. + - subst c; now apply IHb. +Qed. + +(** ** The observation projection. + + [qval] is the documented projection from the queue-tagged observation to + the reference alphabet: the reference logs the popped payload, this + language logs the popped payload PLUS its occurrence index. Erasing + [qidx] recovers the reference formula exactly. *) +Definition popped (nl: nat) : QObs -> Prop := fun o => qval o = nl. +Definition popped_after (nl kb: nat) : QObs -> Prop := + fun o => qval o = nl /\ Nat.le kb (qidx o). + +(** A retained observation cannot masquerade as a later one. This is what + makes the freshness companion say something the plain theorem does not: + the world [Obs (Log (Pop v j)) tt] does NOT satisfy [popped_after nl (S j)], + so an [AF] of that formula cannot be discharged by the world already in + hand. *) +Lemma fresh_excludes_retained {X}: forall (t: ictreeW QObs X) nl v j, + ~ <( t, {Obs (Log (Pop v j)) tt} |= visW {popped_after nl (S j)} )>. +Proof. + intros t nl v j H. + apply ticll_vis in H. + inversion H as [e0 v0 Hphi Heq]; subst. + destruct v0; destruct Hphi as (_ & Hle); cbn in Hle; lia. +Qed. + +(** ** The owned loop rule over GHOST data. + + [ICTree.Logic.State.aul_state_iter] and [aul_state_iter_nat] require the + variant to be a relation on [(i, sigma, w)] -- the private control, the + WHOLE interpretation state, and the world. For a heap-backed + representation there is no function from the state to the abstract queue + without first proving that [qrep] determines it, and the world must not + enter a variant at all. + + This rule moves both the invariant and the variant onto client-chosen + ghost data [G], tied to the state only by the invariant. It is derived + from the baseline's [aul_state_iter_next_eq] and [ticll_bind_l]; the + well-founded induction is in the ambient logic, so no TICL fixed-point + definition is unfolded here or at any call site. *) +Theorem owned_aul_iter_ghost {E Sg W} {HE: Encode E} + (hh: E ~> stateT Sg (ictreeW W)) {X I G} + (Rv: relation G) (Inv: G -> I -> Sg -> Prop) + (bd: I -> ictree E (I + X)) (phi psi: ticllW W): + well_founded Rv -> + forall (g: G) (i: I) (s: Sg) (w: WorldW W), + not_done w -> + Inv g i s -> + (forall g i s w, + not_done w -> + Inv g i s -> + <( {interp_state hh (bd i) s}, w |= phi AU psi )> + \/ (exists g' i' s' w', + not_done w' + /\ <[ {interp_state hh (bd i) s}, w + |= phi AU AX done= {(inl i', s')} w' ]> + /\ Inv g' i' s' + /\ Rv g' g)) -> + <( {interp_state hh (ICtree.iter bd i) s}, w |= phi AU psi )>. +Proof. + intros Hwf g. + induction g as [g IH] using (well_founded_induction Hwf). + intros i s w Hd Hinv Hbody. + destruct (Hbody g i s w Hd Hinv) + as [Hnow | (g' & i' & s' & w' & Hd' & Hstep & Hinv' & Hlt)]. + - rewrite interp_state_unfold_iter; now apply ticll_bind_l. + - eapply aul_state_iter_next_eq; [exact Hstep | exact Hd' |]. + eapply (IH g'); eauto. +Qed. + +Section Recurrence. + (** [hdr] is the queue header, [nl] the observed element, [kb] the occurrence + bound, and [P] any observation predicate satisfied by every pop of [nl] + at or after [kb]. Instantiating [kb := 0] gives the plain recurrence + theorem; leaving [kb] free gives the freshness companion. *) + Context (hdr nl kb: nat) (P: QObs -> Prop) + (HP: forall j, Nat.le kb j -> P (Pop nl j)). + + (** The [AG] invariant: the state is a valid representation of SOME queue + that still contains [nl]. The abstract queue is existentially + quantified -- no extraction function from heaps to lists is needed. *) + Definition Rq (_: unit) (s: Sig) (_: WorldW QObs) : Prop := + exists ns vs d, qrep hdr ns vs (fst s) /\ find nl vs = Some d. + + (** *** One iteration, as a deterministic suffix formula. + + This is the only place the body is opened, and it is opened through + [rot_body_spec] -- a bisimulation -- not by unfolding [auc]. *) + Lemma body_det: forall ns vs a v h c w, + qrep hdr (a :: ns) (v :: vs) h -> + not_done w -> + <[ {interp_state h_heapE (rot_body hdr) (h, c)}, w + |= ⊤ AU AX done= {(@inl unit unit tt, + (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))} + {Obs (Log (Pop v c)) tt} ]>. + Proof. + intros ns vs a v h c w Hq Hd. + rewrite (rot_body_spec hdr a ns v vs h c Hq). + apply aur_log. + - cleft; apply axr_ret; [constructor | split; reflexivity]. + - apply ticll_top; assumption. + Qed. + + (** *** The inner eventuality. + + The ghost data is the rank [(kb - c, d)]: [c] is the private occurrence + counter and [d] is the position of [nl] in the abstract queue. Neither + the heap nor the world appears in it. The whole proof is ONE + application of [owned_aul_iter_ghost] plus a body case analysis. *) + Definition InvQ (m: nat * nat) (_: unit) (s: Sig) : Prop := + exists ns vs d, qrep hdr ns vs (fst s) + /\ find nl vs = Some d + /\ m = (kb - snd s, d). + + Lemma inner_af: forall h c ns vs d w, + not_done w -> + qrep hdr ns vs h -> + find nl vs = Some d -> + <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AF visW {P} )>. + Proof. + intros h c ns vs d w Hd Hq Hf. + unfold rotate. + apply (owned_aul_iter_ghost h_heapE lexnat InvQ (fun _: unit => rot_body hdr) + _ _ lexnat_wf (kb - c, d) tt (h, c) w Hd). + - exists ns, vs, d; split; [exact Hq | split; [exact Hf | reflexivity]]. + - clear h c ns vs d w Hd Hq Hf. + intros m [] s w Hd (ns & vs & d & Hq & Hf & Hm). + destruct s as (h, c); cbn in Hq, Hm. + destruct vs as [| v vs']; [cbn in Hf; discriminate |]. + destruct ns as [| a ns']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. + (* the shared "rotate once" step *) + assert (Hstep: forall d', find nl (vs' ++ [v]) = Some d' -> + lexnat (kb - S c, d') m -> + (exists g' i' s' w', + not_done w' + /\ <[ {interp_state h_heapE + ((fun _: unit => rot_body hdr) tt) (h, c)}, w + |= ⊤ AU AX done= {(@inl unit unit i', s')} w' ]> + /\ InvQ g' i' s' + /\ lexnat g' m)). + { intros d' Hd' Hlex. + exists (kb - S c, d'), tt, + (rot_heap hdr a (hdf ns' 0) (zof hdr ns') h, S c), + (Obs (Log (Pop v c)) tt). + split; [constructor |]. + split; [eapply body_det; eassumption |]. + split; [| exact Hlex]. + exists (ns' ++ [a]), (vs' ++ [v]), d'; cbn; split; + [apply (rot_heap_spec hdr a ns' v vs' h Hq) + | split; [exact Hd' | reflexivity]]. } + destruct d as [| d0]. + + (* the element is at the head *) + pose proof (find_head _ _ _ Hf) as Hv; subst v. + destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. + * (* and the occurrence bound is already met: observe it now *) + left. + rewrite (rot_body_spec hdr a ns' nl vs' h c Hq). + apply afl_log; [assumption |]. + cleft; apply ticll_vis; constructor; now apply HP. + * (* the bound is not met yet: rotate, the bound gets closer *) + right. + destruct (find_last_ex nl vs') as (d' & Hd'). + apply (Hstep d'); [exact Hd' | rewrite Hm; left; cbn; lia]. + + (* the element is deeper in the queue: rotate, it gets closer *) + right. + apply (Hstep d0). + * rewrite <- rotl_cons; eapply find_rotl; exact Hf. + * rewrite Hm; destruct (Nat.le_gt_cases kb c); + [right; cbn; split; lia | left; cbn; lia]. + Qed. + + (** *** The recurrence theorem. *) + Theorem rotate_agaf_core: forall h c ns vs d w, + not_done w -> + qrep hdr ns vs h -> + find nl vs = Some d -> + <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AG (AF visW {P}) )>. + Proof. + intros h c ns vs d w Hd Hq Hf. + unfold rotate. + apply (ag_state_iter h_heapE (h, c) Rq tt w); [assumption | |]. + - exists ns, vs, d; split; assumption. + - intros [] s w' Hd' (ns1 & vs1 & d1 & Hq1 & Hf1). + destruct s as (h1, c1); cbn in Hq1. + destruct vs1 as [| v1 vs1']; [cbn in Hf1; discriminate |]. + destruct ns1 as [| a1 ns1']; + [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. + split. + + eapply inner_af; [exact Hd' | exact Hq1 | exact Hf1]. + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 c1 Hq1). + apply anr_log; [| apply ticll_top; assumption]. + cleft; apply axr_ret; [constructor |]. + exists tt; split; [reflexivity | split; [constructor |]]. + destruct (find_rotl_pres _ _ _ _ Hf1) as (d' & Hd''). + exists (ns1' ++ [a1]), (vs1' ++ [v1]), d'; split. + * apply (rot_heap_spec hdr a1 ns1' v1 vs1' h1 Hq1). + * rewrite <- rotl_cons; exact Hd''. + Qed. +End Recurrence. + +(** ** The two headline theorems. + + [rotate_agaf_pop_heap] is the heap-backed counterpart of the reference + [rotate_agaf_pop]: same modal shape, same natural position argument, same + pure [find] lemmas, but over owned heap nodes. + + [rotate_agaf_pop_fresh] is what the reference formula does NOT give: for + every occurrence bound [k], every reachable state still eventually + produces a pop of [nl] whose index is at least [k]. Since indices are + strictly increasing and each observation carries its own, this cannot be + discharged by a retained world ([fresh_excludes_retained]). *) + +Theorem rotate_agaf_pop_heap: forall hdr nl h c ns vs d, + qrep hdr ns vs h -> + find nl vs = Some d -> + <( {run hdr h c}, Pure |= AG (AF visW {popped nl}) )>. +Proof. + intros hdr nl h c ns vs d Hq Hf. + unfold run. + eapply (rotate_agaf_core hdr nl 0 (popped nl)); + [ intros j _; reflexivity | constructor | exact Hq | exact Hf ]. +Qed. + +Theorem rotate_agaf_pop_fresh: forall hdr nl h c ns vs d k, + qrep hdr ns vs h -> + find nl vs = Some d -> + <( {run hdr h c}, Pure |= AG (AF visW {popped_after nl k}) )>. +Proof. + intros hdr nl h c ns vs d k Hq Hf. + unfold run. + eapply (rotate_agaf_core hdr nl k (popped_after nl k)); + [ intros j Hj; split; [reflexivity | exact Hj] | constructor | exact Hq | exact Hf ]. +Qed. + +(** ** Precondition controls. + + The recurrence theorem's hypotheses are not decoration. Both controls are + about the SAFE handler: an out-of-footprint dereference is stuck, and a + stuck state satisfies no [AG] formula. *) + +Lemma nostep_bind {X Y}: forall (t: ictreeW QObs Y) (k: Y -> ictreeW QObs X) w, + ~ can_step t w -> ~ can_step (x <- t ;; k x) w. +Proof. + intros t k w Hns Hs. + apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]. + - apply Hns; exists t', w'; exact TR. + - apply Hns; exists ICtree.stuck, w'; exact TR. +Qed. + +(** *** Control 1: the EMPTY queue. + + The head pointer is null, the null address is not allocated, so the first + dereference of the body is out of footprint. The run cannot step at all, + hence NO [AG] formula holds of it -- in particular not the recurrence + formula. This is what the hypothesis [find nl vs = Some d] (which forces + a non-empty queue) buys. *) +Theorem empty_queue_no_ag: forall hdr h c vs w phi, + qrep hdr [] vs h -> ~ <( {run hdr h c}, w |= AG phi )>. +Proof. + intros hdr h c vs w phi Hq H. + pose proof Hq as (Hwf & Hhd & _ & _ & _); cbn in Hhd. + pose proof (qrep_null _ _ _ _ Hq) as H0. + assert (Hns: ~ can_step (run hdr h c) w). + { unfold run, rotate; rewrite interp_state_unfold_iter. + apply nostep_bind. + unfold rot_body. + rewrite (interp_rd (S hdr) h c 0 _ Hhd). + now apply interp_rd_nostep. } + cdestruct H; now apply Hns. +Qed. + +(** *** Control 2: an ABSENT element is never observed. + + Rotation permutes the queue, so every logged payload is a member of the + INITIAL payload list. Consequently, if [nl] does not occur initially, the + atom of the recurrence formula is false at every reachable state. The + statement below is the [AG] invariance; deriving [~ AF] from [AG ~] is the + standard duality and is NOT mechanised here. *) + +Definition obs_sat (Q: nat -> Prop) : WorldW QObs -> Prop := + fun w => forall o, w = Obs (Log o) tt -> Q (qval o). + +Theorem rotate_ag_obs: forall hdr h c ns vs w (Q: nat -> Prop), + (forall x, In x vs -> Q x) -> + not_done w -> + qrep hdr ns vs h -> + ns <> [] -> + obs_sat Q w -> + <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AG (now {obs_sat Q}) )>. +Proof. + intros hdr h c ns vs w Q HQ Hd Hq Hne Hw. + unfold rotate. + apply (ag_state_iter h_heapE (h, c) + (fun (_: unit) (s: Sig) (w: WorldW QObs) => + (exists ns' vs', qrep hdr ns' vs' (fst s) /\ ns' <> [] + /\ (forall x, In x vs' -> Q x)) + /\ obs_sat Q w) + tt w); [assumption | |]. + - split; [exists ns, vs; split; [exact Hq | split; [exact Hne | exact HQ]] + | exact Hw]. + - intros [] s w' Hd' ((ns1 & vs1 & Hq1 & Hne1 & Hin1) & Hw'). + destruct s as (h1, c1); cbn in Hq1. + destruct ns1 as [| a1 ns1']; [contradiction |]. + destruct vs1 as [| v1 vs1']; [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. + assert (Hv1: Q v1) by (apply Hin1, in_eq). + split. + + apply ticll_now; split; assumption. + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 c1 Hq1). + apply anr_log; [| apply ticll_top; assumption]. + cleft; apply axr_ret; [constructor |]. + exists tt; split; [reflexivity | split; [constructor |]]. + split. + * exists (ns1' ++ [a1]), (vs1' ++ [v1]); split; + [apply (rot_heap_spec hdr a1 ns1' v1 vs1' h1 Hq1) | split]. + -- intro C; apply app_eq_nil in C as (_ & C); discriminate. + -- intros x Hx; apply in_app_iff in Hx as [Hx | [Hx | []]]; + [apply Hin1, in_cons; exact Hx | subst; exact Hv1]. + * intros o Ho; inversion Ho; subst; cbn; exact Hv1. +Qed. + +(** The control itself: an element outside the initial queue is never the + payload of any observation. *) +Corollary absent_never_observed: forall hdr h c ns vs nl, + qrep hdr ns vs h -> + ns <> [] -> + ~ In nl vs -> + <( {run hdr h c}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. +Proof. + intros hdr h c ns vs nl Hq Hne Hnin. + unfold run. + apply (rotate_ag_obs hdr h c ns vs Pure (fun x => x <> nl)); + [ intros x Hx C; subst; contradiction + | constructor | exact Hq | exact Hne + | intros o Ho; discriminate ]. +Qed. diff --git a/examples/CSL/RoundRobinTests.v b/examples/CSL/RoundRobinTests.v new file mode 100644 index 0000000..84a773b --- /dev/null +++ b/examples/CSL/RoundRobinTests.v @@ -0,0 +1,104 @@ +From Stdlib Require Import Fin Vector. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Yield ICTree.Events.State ICTree.Events.Writer + ICTree.Interp.Refine ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.RoundRobin Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Lemma modulo_picks : + rr_pick 1 0 = Fin.F1 /\ + rr_pick 1 1 = Fin.FS Fin.F1 /\ + rr_pick 1 2 = Fin.F1 /\ + rr_pick 0 3 = Fin.F1. +Proof. repeat split; reflexivity. Qed. + +Lemma guard_retains_cursor : + runStateT (round_robin (Guard (Ret tt) : ictreeW nat unit)) 4 ≅ + Guard (Ret (tt,4)). +Proof. + change (refine_rr (Guard (Ret tt) : ictreeW nat unit) 4 ≅ Guard (Ret (tt,4))). + rewrite unfold_refine_rr; cbn [observe]. + apply guard_equ_node; rewrite unfold_refine_rr; reflexivity. +Qed. + +Lemma event_retains_cursor : + runStateT (round_robin (Vis (Log 7) (fun _ => Ret tt))) 4 ≅ + Vis (Log 7) (fun _ => Ret (tt,4)). +Proof. + change (refine_rr (Vis (Log 7) (fun _ => Ret tt)) 4 ≅ + Vis (Log 7) (fun _ => Ret (tt,4))). + rewrite unfold_refine_rr; cbn [observe]. + apply vis_equ_node; intros []; rewrite unfold_refine_rr; reflexivity. +Qed. + +Lemma singleton_branch_advances_cursor : + runStateT (round_robin (Br 0 (fun _ => Ret tt) : ictreeW nat unit)) 4 ≅ + Guard (Ret (tt,5)). +Proof. + change (refine_rr (Br 0 (fun _ => Ret tt) : ictreeW nat unit) 4 ≅ + Guard (Ret (tt,5))). + rewrite unfold_refine_rr; cbn [observe]. + apply guard_equ_node; rewrite unfold_refine_rr; reflexivity. +Qed. + +Lemma scheduled_two_selects {E : Type} {HE : Encode E} (ts : pool E 2) m : + refine_rr (schedule 2 ts None) m ≅ + Vis (inl Yield) (fun _ => + Guard (refine_rr (schedule 2 ts (Some (rr_pick 1 m))) (S m))). +Proof. + rewrite unfold_refine_rr, schedule_no_focus_nonempty. + apply vis_equ_node; intros []; rewrite unfold_refine_rr; reflexivity. +Qed. + +Definition raw_add (delta : nat) : thread (stateE nat) := + Vis (inr (inr Get)) (fun x => + Vis (inr (inr (Put ((x + delta)%nat)))) (fun _ => Ret tt)). +Definition counter_thread (delta : nat) : thread (stateE nat) := + raw_add delta;; Vis (inl Yield) (fun _ => raw_add delta). +Definition counter_fork : thread (stateE nat) := + Vis (inr (inl Fork)) + (fun child : bool => counter_thread (if child then 10 else 1)). + +Local Ltac counter_observe := + lazy [observe _observe Vector.nth Vector.replace Vector.caseS' raw_add + counter_thread ICtree.bind ICtree.subst' rr_pick]; reflexivity. + +Local Ltac counter_get := + erewrite interp_schedule_rr_user with (e := Get) by counter_observe; + cbn [h_stateW runStateT]; rewrite bind_ret_l. + +Local Ltac counter_put := + erewrite interp_schedule_rr_user by counter_observe; + cbn [h_stateW runStateT]; rewrite bind_bind; + apply sbisim_clo_bind_eq; [reflexivity|]; + intros []; rewrite bind_ret_l. + +Lemma shared_counter_round_robin : + interp_schedule_rr h_stateW 1 [counter_fork]%vector (Some Fin.F1) 0 0 ~ + (log 1;; log 11;; log 12;; log 22;; Ret (tt,22)). +Proof. + erewrite interp_schedule_rr_fork by reflexivity. + counter_get; counter_put. + erewrite interp_schedule_rr_yield by counter_observe. + rewrite interp_schedule_rr_select. + counter_get; counter_put. + erewrite interp_schedule_rr_yield by counter_observe. + rewrite interp_schedule_rr_select. + counter_get; counter_put. + erewrite interp_schedule_rr_ret by counter_observe. + change (interp_schedule_rr h_stateW 1 + ([raw_add 10; Ret tt]%vector -- Fin.FS Fin.F1) None 2 12 ~ + (log 22;; Ret (tt,22))). + rewrite vector_remove_tail, vector_remove_head. + rewrite interp_schedule_rr_select. + counter_get; counter_put. + erewrite interp_schedule_rr_ret by counter_observe. + change (interp_schedule_rr h_stateW 0 + ([Ret tt]%vector -- Fin.F1) None 3 22 ~ Ret (tt,22)). + rewrite vector_remove_head, interp_schedule_rr_empty; reflexivity. +Qed. diff --git a/examples/CSL/SLang.v b/examples/CSL/SLang.v new file mode 100644 index 0000000..a513aa4 --- /dev/null +++ b/examples/CSL/SLang.v @@ -0,0 +1,201 @@ +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From TICL Require Export Lang.CSL.Heap. +From examples Require Import CSL.HeapQ. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** A turn: one complete rotation of the queue at [hdr], tagged [q]. + + The tail [kt] is a parameter so that the same nine instructions serve both + the standalone turn and the scheduler body without any + bind-associativity reasoning. *) +Definition turnk {X} (q hdr: nat) (kt: ictree sE X) : ictree sE X := + a <- srd (S hdr) ;; + v <- srd a ;; + _ <- semit q v ;; + n <- srd (S a) ;; + _ <- swr (S hdr) n ;; + z0 <- srd hdr ;; + _ <- swr (S (if Nat.eqb n 0 then hdr else z0)) a ;; + _ <- swr (S a) 0 ;; + _ <- swr hdr a ;; + kt. + +Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). + +(** *** The turn correspondence. + + Same three-in-one content as the frozen [QLang.rot_body_spec]: hidden + segment termination, operation correctness ([HeapQ.rot_heap_spec]) and the + observation, now queue-tagged. The proof script is the frozen one with + the final [interp_state_ret] dropped, because the tail is a parameter. *) +Theorem turnk_spec {X}: forall q hdr a ns pv vs h c (kt: ictree sE X), + qrep hdr (a :: ns) (pv :: vs) h -> + interp_state sh (turnk q hdr kt) (h, c) + ~ (log (SPop q pv c) ;; + interp_state sh kt (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c)). +Proof. + intros q hdr a ns pv vs h c kt Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + cbn in Hhd, Htl. + destruct Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. + assert (Hhdrdom: h hdr <> None) by (rewrite Htl; discriminate). + assert (Hsadom: h (S a) <> None) by (rewrite Hsa; discriminate). + assert (Hshdrdom: h (S hdr) <> None) by (rewrite Hhd; discriminate). + assert (Hread_hdr: upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) + by (rewrite upd_neq by congruence; exact Htl). + unfold turnk. + rewrite (sinterp_rd (S hdr) h c a _ Hhd). + rewrite (sinterp_rd a h c pv _ Ha). + rewrite sinterp_emit. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite (sinterp_rd (S a) h (S c) (hdf ns 0) _ Hsa). + rewrite (sinterp_wr' (S hdr) h (S c) (hdf ns 0) _ Hshdrdom). + rewrite (sinterp_rd hdr (upd h (S hdr) (hdf ns 0)) (S c) (last (a :: ns) 0) _ + Hread_hdr). + rewrite (zof_compute hdr a ns Hwf). + rewrite (sinterp_wr' (S (zof hdr ns)) _ (S c) a _ (upd_mono _ _ _ _ Hzdom)). + rewrite (sinterp_wr' (S a) _ (S c) 0 _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom))). + rewrite (sinterp_wr' hdr _ (S c) a _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom)))). + reflexivity. +Qed. + +(** ** The nonpreemptive cyclic scheduler. + + [n] is the turn counter and the loop index. A turn is a whole rotation; + the counter advances only after it completes. *) + +Definition hdrof (u v n: nat) : nat := if Nat.even n then u else v. +Definition tagof (n: nat) : nat := if Nat.even n then 1 else 2. + +Definition sbody (u v: nat) (n: nat) : ictree sE (nat + unit) := + if Nat.even n + then turnk 1 u (Ret (inl (S n))) + else turnk 2 v (Ret (inl (S n))). + +Definition sched (u v n: nat) : ictree sE unit := ICtree.iter (sbody u v) n. + +Definition srun (u v n: nat) (h: Heap) (c: nat) : ictreeW SObs (unit * SSig) := + interp_state sh (sched u v n) (h, c). + +(** One scheduler turn, for EITHER phase, in one statement. [hdrof]/[tagof] + are what let the phase case analysis happen once, in the temporal proof, + rather than twice in the language layer. *) +Theorem sbody_spec: forall u v n a ns pv vs h c, + qrep (hdrof u v n) (a :: ns) (pv :: vs) h -> + interp_state sh (sbody u v n) (h, c) + ~ (log (SPop (tagof n) pv c) ;; + Ret (@inl nat unit (S n), + (rot_heap (hdrof u v n) a (hdf ns 0) (zof (hdrof u v n) ns) h, S c))). +Proof. + intros u v n a ns pv vs h c Hq. + unfold sbody, hdrof, tagof in *. + destruct (Nat.even n). + - rewrite (turnk_spec 1 u a ns pv vs h c + (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite interp_state_ret; reflexivity. + - rewrite (turnk_spec 2 v a ns pv vs h c + (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite interp_state_ret; reflexivity. +Qed. + +(** The parity flip: one turn of the scheduler changes whose turn it is. + This is the entire scheduling discipline, and the composition proof uses + exactly this. *) +Lemma even_flip: forall n, Nat.even (S n) = negb (Nat.even n). +Proof. + intro n; rewrite Nat.even_succ, <- Nat.negb_even; reflexivity. +Qed. + +Lemma hdrof_even: forall u v n, Nat.even n = true -> hdrof u v n = u. +Proof. intros u v n H; unfold hdrof; now rewrite H. Qed. + +Lemma hdrof_odd: forall u v n, Nat.even n = false -> hdrof u v n = v. +Proof. intros u v n H; unfold hdrof; now rewrite H. Qed. + +Lemma tagof_even: forall n, Nat.even n = true -> tagof n = 1. +Proof. intros n H; unfold tagof; now rewrite H. Qed. + +Lemma tagof_odd: forall n, Nat.even n = false -> tagof n = 2. +Proof. intros n H; unfold tagof; now rewrite H. Qed. + +(** ** Observation predicates *) + +Definition spopped (q nl: nat) : SObs -> Prop := + fun o => stag o = q /\ sval o = nl. + +Definition spopped_after (q nl kb: nat) : SObs -> Prop := + fun o => stag o = q /\ sval o = nl /\ Nat.le kb (sidx o). + +(** A retained observation cannot masquerade as a later one: the frozen + freshness argument, restated at the tagged alphabet. *) +Lemma sfresh_excludes_retained {X}: forall (t: ictreeW SObs X) q nl p pv j, + ~ <( t, {Obs (Log (SPop p pv j)) tt} |= visW {spopped_after q nl (S j)} )>. +Proof. + intros t q nl p pv j H. + apply ticll_vis in H. + inversion H as [e0 v0 Hphi Heq]; subst. + destruct v0; destruct Hphi as (_ & _ & Hle); cbn in Hle; lia. +Qed. + + +Lemma turnk_bind {X} q hdr (kt : ictree sE X) : + turnk q hdr kt ≅ (turn q hdr;; kt). +Proof. + unfold turn, turnk. + do 9 (rewrite bind_bind; apply equ_clo_bind_eq; intro). + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma srun_turn u v n h c : + srun u v n h c ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) (h,c) >>= + fun '(_, (h',c')) => srun u v (S n) h' c'). +Proof. + unfold srun, sched. + rewrite interp_state_unfold_iter. + cbv beta. + unfold sbody, tagof, hdrof. + destruct (Nat.even n). + all: rewrite turnk_bind, interp_state_bind, bind_bind. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [x [h' c']]]. + all: rewrite interp_state_ret, bind_ret_l. + all: apply sb_guard. +Qed. diff --git a/examples/CSL/Sep2.v b/examples/CSL/Sep2.v new file mode 100644 index 0000000..d98d998 --- /dev/null +++ b/examples/CSL/Sep2.v @@ -0,0 +1,156 @@ +(** * Sep2: the separation layer for TWO ACTIVE queues. + + NEW in this experiment. The dependency experiment + ("measure reuse under an unused second queue") proved a TRANSPORT theorem: + a queue's [AG AF] specification survives disjoint extension of the heap by + an arbitrary FIXED frame [f]. Nothing in that development says what + happens when the other region is itself running. + + This file is the resource-level content of that difference. It contains + exactly two kinds of statement: + + 1. [foreign_pres] -- a step of ONE queue preserves the OTHER queue's + representation. This is NOT an instance of the frame rule: the frame + rule says an untouched region stays untouched, whereas here the region + that stays intact is one that will itself take steps later, and the + region taking the step is one that the other's specification must also + be stated about. The proof is nevertheless CHEAP, and that is the + measurable finding: it is two applications of frozen lemmas + ([Frame.qstep_agree] and [Frame.qrep_agree_fp]). + + 2. [compose3] -- the three-way composition (queue 1 * queue 2 * outer + frame) that instantiates the disjointness premises from precise + ownership. Here the frame rule IS reused, unchanged + ([Frame.qrepX_frame]). + + Everything in this file is a statement about heaps. No temporal formula + and no ICTree appears. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame. + +Import ListNotations. +Local Open Scope list_scope. + +(** ** Footprint disjointness of two queues *) + +Definition Disj (u: nat) (n1: list nat) (v: nat) (n2: list nat) : Prop := + forall x, In x (qcells u n1) -> ~ In x (qcells v n2). + +Lemma Disj_sym: forall u n1 v n2, Disj u n1 v n2 -> Disj v n2 u n1. +Proof. intros u n1 v n2 H x Hx Hy; exact (H x Hy Hx). Qed. + +(** The footprint is stable as a SET under rotation ([Frame.qcells_rotl]), so + disjointness needs no re-establishing: it is transported, not re-proved. + This is one of the reused locality facts. *) +Lemma Disj_rotl_l: forall u n1 v n2, + n1 <> [] -> Disj u n1 v n2 -> Disj u (rotl n1) v n2. +Proof. + intros u n1 v n2 Hne H x Hx; apply H, (qcells_rotl u n1 x Hne), Hx. +Qed. + +Lemma Disj_rotl_r: forall u n1 v n2, + n2 <> [] -> Disj u n1 v n2 -> Disj u n1 v (rotl n2). +Proof. + intros u n1 v n2 Hne H x Hx Hy. + apply (H x Hx), (qcells_rotl v n2 x Hne), Hy. +Qed. + +(** ** The foreign step preserves the other queue + + This is the core new obligation of active composition. Read it as: the + OTHER component's representation predicate, at the SAME abstract queue + [n2]/[vs2], survives an arbitrary step of THIS component. *) + +Lemma qstep_null: forall u n1 vs1 h, + qrep u n1 vs1 h -> n1 <> [] -> qstep u n1 h 0 = None. +Proof. + intros u n1 vs1 h Hq Hne. + pose proof Hq as (Hwf & _ & _ & _ & Hnull & _). + rewrite (qstep_agree u n1 vs1 h Hq Hne 0) by (apply qwf_zero, Hwf). + exact Hnull. +Qed. + +Theorem foreign_pres: forall u n1 vs1 v n2 vs2 h, + qrep u n1 vs1 h -> n1 <> [] -> + qrep v n2 vs2 h -> + Disj u n1 v n2 -> + qrep v n2 vs2 (qstep u n1 h). +Proof. + intros u n1 vs1 v n2 vs2 h Hq1 Hne1 Hq2 Hd. + eapply qrep_agree_fp; [exact Hq2 | | ]. + - intros x Hx. + apply (qstep_agree u n1 vs1 h Hq1 Hne1). + intro C; exact (Hd x C Hx). + - eapply qstep_null; eassumption. +Qed. + +(** The same statement in the [rot_heap] form the language layer produces. + [qstep u (a :: n1) h] is [rot_heap u a (hdf n1 0) (zof u n1) h] by + definition, so this is a restatement, not a second proof. *) +Corollary foreign_pres_rot: forall u a n1 vs1 v n2 vs2 h, + qrep u (a :: n1) vs1 h -> + qrep v n2 vs2 h -> + Disj u (a :: n1) v n2 -> + qrep v n2 vs2 (rot_heap u a (hdf n1 0) (zof u n1) h). +Proof. + intros u a n1 vs1 v n2 vs2 h Hq1 Hq2 Hd. + exact (foreign_pres u (a :: n1) vs1 v n2 vs2 h Hq1 ltac:(discriminate) Hq2 Hd). +Qed. + +(** ** Three-way composition: queue 1 * queue 2 * outer frame + + The two queues are given as PRECISE resources ([qrepX], "this heap IS the + queue"), the outer frame [f] as an arbitrary null-avoiding heap. The + conclusion supplies the composed run's three preconditions. *) + +Lemma hdisj_union: forall h1 h2 f, + hdisj h1 h2 -> hdisj h1 f -> hdisj h1 (hunion h2 f). +Proof. + intros h1 h2 f H12 H1f x. + destruct (h1 x) eqn:E1; [| now left]. + right; unfold hunion. + destruct (H12 x) as [C | E2]; [congruence |]; rewrite E2. + destruct (H1f x) as [C | Ef]; [congruence | exact Ef]. +Qed. + +Lemma hunion_null: forall h f, h 0 = None -> f 0 = None -> hunion h f 0 = None. +Proof. intros h f Hh Hf; unfold hunion; now rewrite Hh. Qed. + +Theorem compose3: forall u n1 vs1 h1 v n2 vs2 h2 f, + qrepX u n1 vs1 h1 -> + qrepX v n2 vs2 h2 -> + hdisj h1 h2 -> hdisj h1 f -> hdisj h2 f -> + f 0 = None -> + qrep u n1 vs1 (hunion h1 (hunion h2 f)) + /\ qrep v n2 vs2 (hunion h1 (hunion h2 f)) + /\ Disj u n1 v n2. +Proof. + intros u n1 vs1 h1 v n2 vs2 h2 f Hx1 Hx2 H12 H1f H2f Hf0. + pose proof (qrepX_qrep _ _ _ _ Hx1) as Hq1. + pose proof (qrepX_qrep _ _ _ _ Hx2) as Hq2. + pose proof (qrep_null _ _ _ _ Hq2) as Hn2. + assert (Hun0: hunion h2 f 0 = None) by (apply hunion_null; assumption). + split; [| split]. + - (* the frame rule, REUSED unchanged *) + apply (qrepX_frame u n1 vs1 h1 (hunion h2 f) Hx1 + (hdisj_union h1 h2 f H12 H1f) Hun0). + - (* queue 2 sits under an allocated region on its left: agreement, not framing *) + eapply qrep_agree_fp; [exact Hq2 | |]. + + intros x Hx. + assert (Hd2: h2 x <> None) by (eapply qrep_fp; eassumption). + assert (H1n: h1 x = None) + by (destruct (H12 x) as [E | C]; [exact E | contradiction]). + unfold hunion; rewrite H1n. + destruct (h2 x) eqn:E2; [reflexivity | contradiction]. + + unfold hunion; rewrite (qrep_null _ _ _ _ Hq1); exact Hun0. + - (* disjoint ownership gives disjoint footprints *) + intros x Hx1' Hx2'. + assert (Hd1: h1 x <> None) by (eapply qrep_fp; eassumption). + assert (Hd2: h2 x <> None) by (eapply qrep_fp; eassumption). + destruct (H12 x); contradiction. +Qed. diff --git a/examples/CSL/Trace.v b/examples/CSL/Trace.v new file mode 100644 index 0000000..7e7b376 --- /dev/null +++ b/examples/CSL/Trace.v @@ -0,0 +1,130 @@ +(** * Trace: the state trajectory of the rotating queue. + + SHARED between the two proof families. Nothing here is a separation-logic + notion: [qstepN] is just "the heap after [n] rotations", and [run_stepN] + says that this is the same thing as "[n] observations into the run". Both + families need to talk about reachable states, so both import this file. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From examples Require Import CSL.HeapQ CSL.QLang. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** One completed rotation of the run: a single logged pop, then the run from + the rotated heap. This is [QLang.rot_body_spec] lifted through the + iteration; the [Guard] is discharged by [sb_guard], so no stuttering + theory is needed. *) +Lemma run_step: forall hdr a ns v vs h c, + qrep hdr (a :: ns) (v :: vs) h -> + run hdr h c + ~ (log (Pop v c) ;; run hdr (rot_heap hdr a (hdf ns 0) (zof hdr ns) h) (S c)). +Proof. + intros hdr a ns v vs h c Hq. + unfold run, rotate. + rewrite interp_state_unfold_iter. + cbv beta. + rewrite (rot_body_spec hdr a ns v vs h c Hq). + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l. + apply sb_guard. +Qed. + +(** The heap after one rotation, and after [n] of them. *) +Definition qstep (hdr: nat) (ns: list nat) (h: Heap) : Heap := + match ns with + | [] => h + | a :: ns' => rot_heap hdr a (hdf ns' 0) (zof hdr ns') h + end. + +Fixpoint qstepN (hdr: nat) (n: nat) (ns: list nat) (h: Heap) : Heap := + match n with + | 0 => h + | S k => qstepN hdr k (rotl ns) (qstep hdr ns h) + end. + +Fixpoint rotlN {A} (n: nat) (l: list A) : list A := + match n with 0 => l | S k => rotlN k (rotl l) end. + +(** The observation prefix of [n] rotations, with the continuation threaded so + that no [bind]-associativity reasoning is needed. *) +Fixpoint runN (hdr: nat) (n: nat) (ns vs: list nat) (h: Heap) (c: nat) + (k: ictreeW QObs (unit * Sig)) : ictreeW QObs (unit * Sig) := + match n with + | 0 => k + | S m => log (Pop (hd 0 vs) c) ;; + runN hdr m (rotl ns) (rotl vs) (qstep hdr ns h) (S c) k + end. + +Lemma rotl_nonnil: forall (l: list nat), l <> [] -> rotl l <> []. +Proof. + intros [| a l] H; [contradiction |]; cbn. + intro C; apply app_eq_nil in C as (_ & C); discriminate. +Qed. + +Lemma qstep_qrep: forall hdr ns vs h, + qrep hdr ns vs h -> ns <> [] -> + qrep hdr (rotl ns) (rotl vs) (qstep hdr ns h). +Proof. + intros hdr ns vs h Hq Hne. + destruct ns as [| a ns']; [contradiction |]. + destruct vs as [| v vs']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. + cbn [qstep rotl]. + apply (rot_heap_spec hdr a ns' v vs' h Hq). +Qed. + +Lemma qstepN_qrep: forall n hdr ns vs h, + qrep hdr ns vs h -> ns <> [] -> + qrep hdr (rotlN n ns) (rotlN n vs) (qstepN hdr n ns h) /\ rotlN n ns <> []. +Proof. + induction n as [| n IH]; intros hdr ns vs h Hq Hne; [split; assumption |]. + cbn [qstepN rotlN]. + apply (IH hdr (rotl ns) (rotl vs)); + [now apply qstep_qrep | now apply rotl_nonnil]. +Qed. + +(** [n] rotations of the run are [n] logged pops followed by the run from the + [n]-times-rotated heap. *) +Theorem run_stepN: forall n hdr ns vs h c, + qrep hdr ns vs h -> ns <> [] -> + run hdr h c ~ runN hdr n ns vs h c (run hdr (qstepN hdr n ns h) (c + n)). +Proof. + induction n as [| n IH]; intros hdr ns vs h c Hq Hne. + - cbn [runN qstepN]; rewrite Nat.add_0_r; reflexivity. + - destruct ns as [| a ns']; [contradiction |]. + destruct vs as [| v vs']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. + cbn [runN qstepN qstep hd]. + rewrite (run_step hdr a ns' v vs' h c Hq). + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite <- Nat.add_succ_comm. + apply (IH hdr (rotl (a :: ns')) (rotl (v :: vs'))). + + cbn [rotl]; apply (rot_heap_spec hdr a ns' v vs' h Hq). + + apply rotl_nonnil; discriminate. +Qed. diff --git a/examples/Election.v b/examples/Election.v index f55cf68..c555732 100644 --- a/examples/Election.v +++ b/examples/Election.v @@ -10,7 +10,7 @@ From TICL Require Import ICTree.Logic.State ICTree.Logic.Iter ICTree.Logic.Bind - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.Writer. From Stdlib Require Import diff --git a/examples/Queue.v b/examples/Queue.v index 3142c40..dd4312b 100644 --- a/examples/Queue.v +++ b/examples/Queue.v @@ -1,6 +1,5 @@ From TICL Require Import ICTree.Core - Events.Writer Logic.Core ICTree.Equ ICTree.SBisim @@ -10,7 +9,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer Lang.MeQ. diff --git a/examples/Sec.v b/examples/Sec.v index aa24dac..4be719e 100644 --- a/examples/Sec.v +++ b/examples/Sec.v @@ -15,7 +15,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Interp.Core - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State Lang.MeS. diff --git a/examples/Toy.v b/examples/Toy.v index f489871..198f1d6 100644 --- a/examples/Toy.v +++ b/examples/Toy.v @@ -1,7 +1,5 @@ From TICL Require Import ICTree.Core - Events.State - Events.Writer Logic.Core ICTree.Equ ICTree.SBisim @@ -14,7 +12,7 @@ From TICL Require Import ICTree.Logic.Iter ICTree.Logic.State ICTree.Logic.CanStep - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer Lang.Maps diff --git a/theories/Events/YieldE.v b/theories/Events/YieldE.v new file mode 100644 index 0000000..16d46b4 --- /dev/null +++ b/theories/Events/YieldE.v @@ -0,0 +1,24 @@ +From TICL Require Import Events.Core. + +Generalizable All Variables. + +(** * Cooperative concurrency events *) +(** These are plain event datatypes with their encodings. They are independent + of any source language and of the [ictree] structure itself. *) + +(** Cooperative scheduling point emitted by source-level [yield]. *) +Variant yieldE : Type := Yield. + +(** Thread-local fork choice. The scheduler interprets the resulting [bool] + to run both continuations. *) +Variant forkE : Type := Fork. + +(** Scheduler-level observation that a fork spawned another runnable thread. *) +Variant spawnE : Type := Spawn. + +#[global] Instance Encode_yieldE : Encode yieldE := + fun e => match e with Yield => unit end. +#[global] Instance Encode_forkE : Encode forkE := + fun e => match e with Fork => bool end. +#[global] Instance Encode_spawnE : Encode spawnE := + fun e => match e with Spawn => unit end. diff --git a/theories/ICTree/Eq/Bind.v b/theories/ICTree/Eq/Bind.v index 8e7f4f2..1a723bb 100644 --- a/theories/ICTree/Eq/Bind.v +++ b/theories/ICTree/Eq/Bind.v @@ -409,6 +409,15 @@ Lemma bind_guard {E X Y} {HE: Encode E} (t : ictree E X) (g : X -> ictree E Y): Guard t >>= g ≅ Guard (t >>= g). Proof. now rewrite unfold_bind. Qed. +Lemma bind_stuck_equ {E : Type} `{Encode E} {A B : Type} + (k : A -> ictree E B) : + ICtree.bind (@stuck E _ A) k ≅ @stuck E _ B. +Proof. + revert k; coinduction R CIH; intros k. + rewrite (unfold_stuck (R := A)), bind_guard, (unfold_stuck (R := B)). + constructor; apply CIH. +Qed. + Lemma vis_equ_bind {E X Y} {HE: Encode E}: forall (t : ictree E X) (e : E) k (k' : encode e -> ictree E Y), x <- t;; k' x ≅ Vis e k -> diff --git a/theories/Lang/Yield/Events.v b/theories/ICTree/Events/Yield.v similarity index 51% rename from theories/Lang/Yield/Events.v rename to theories/ICTree/Events/Yield.v index 2b6ddb1..1f7063a 100644 --- a/theories/Lang/Yield/Events.v +++ b/theories/ICTree/Events/Yield.v @@ -1,31 +1,26 @@ -From Stdlib Require Import Fin. -From TICL Require Import ICTree.Core Events.Core. +From TICL Require Import + ICTree.Core + Utils.Vectors. -Generalizable All Variables. - -(** Cooperative scheduling point emitted by source-level [yield]. *) -Variant yieldE : Type := Yield. - -(** Thread-local fork choice. The scheduler interprets the resulting [bool] - to run both continuations. *) -Variant forkE : Type := Fork. +From TICL Require Export + Events.Core + Events.YieldE. -(** Scheduler-level observation that a fork spawned another runnable thread. *) -Variant spawnE : Type := Spawn. +Generalizable All Variables. -#[global] Instance Encode_yieldE : Encode yieldE := - fun e => match e with Yield => unit end. -#[global] Instance Encode_forkE : Encode forkE := - fun e => match e with Fork => bool end. -#[global] Instance Encode_spawnE : Encode spawnE := - fun e => match e with Spawn => unit end. +(** * Cooperative concurrency triggers, threads and pools *) +(** Create a [Yield] event node, with subevents if needed *) Definition yield {E} `{HE : Encode E} `{RS : ReSum yieldE E} `{RR : @ReSumRet yieldE E Encode_yieldE HE RS} : ictree E unit := @ICtree.trigger yieldE E Encode_yieldE HE RS RR Yield. + +(** Create a [Fork] event node, with subevents if needed *) Definition fork {E} `{HE : Encode E} `{RS : ReSum forkE E} `{RR : @ReSumRet forkE E Encode_forkE HE RS} : ictree E bool := @ICtree.trigger forkE E Encode_forkE HE RS RR Fork. + +(** Create a [Spawn] event node, with subevents if needed *) Definition spawn {E} `{HE : Encode E} `{RS : ReSum spawnE E} `{RR : @ReSumRet spawnE E Encode_spawnE HE RS} : ictree E unit := @ICtree.trigger spawnE E Encode_spawnE HE RS RR Spawn. @@ -36,5 +31,5 @@ Definition thread (E : Type) `{Encode E} := ictree (yieldE + (forkE + E)) unit. (** A scheduled computation exposes yields and spawns, but no raw forks. *) Definition completed (E : Type) `{Encode E} := ictree (yieldE + (spawnE + E)) unit. -(** Finite thread pools are represented as functions from finite indices. *) -Definition pool (E : Type) `{Encode E} (n : nat) := Fin.t n -> thread E. +(** Finite thread pools are represented as vectors of threads. *) +Definition pool (E : Type) `{Encode E} (n : nat) := vec n (thread E). diff --git a/theories/ICTree/Interp/Core.v b/theories/ICTree/Interp/Core.v index cc64223..3f7a834 100644 --- a/theories/ICTree/Interp/Core.v +++ b/theories/ICTree/Interp/Core.v @@ -62,25 +62,69 @@ Proof. reflexivity. Qed. -(** Interpretation preserves equality [equ] *) -#[global] Instance interp_equ `{HE: Encode E} {X} {h: E ~> ictree E} : - Proper (equ eq ==> equ eq) (@interp E _ _ _ _ _ h X). +(** Interpretation preserves equality [equ]. The handler is heterogeneous: + events of [E] are interpreted into trees over an arbitrary [F]. *) +#[global] Instance interp_equ + {E F : Type} {HE : Encode E} {HF : Encode F} {X} + {h : E ~> ictree F} : + Proper (@equ E HE X X eq ==> @equ F HF X X eq) + (@interp E HE _ _ _ _ h X). Proof. unfold Proper, respectful. - coinduction R CH. - intros. setoid_rewrite unfold_iter. - step in H. inv H. + change (forall x y : ictree E X, + @equ E HE X X eq x y -> + @equ F HF X X eq (interp h x) (interp h y)). + __coinduction_equ RR IH; intros * EQ1. + setoid_rewrite unfold_iter. + step in EQ1; inv EQ1. - setoid_rewrite bind_ret_l; reflexivity. - setoid_rewrite bind_bind; setoid_rewrite bind_ret_l. - upto_bind_equ. + upto_bind_equ. constructor. intros. - apply CH. apply H2. + apply IH. apply H1. - setoid_rewrite bind_ret_l. constructor. - apply CH. apply H2. + apply IH. apply H1. - setoid_rewrite bind_bind. upto_bind_equ. setoid_rewrite bind_ret_l. - constructor. - apply CH. apply H2. + constructor. + apply IH. apply H1. +Qed. + +(** [interp] commutes with [bind], for a heterogeneous handler. *) +Lemma interp_bind_hetero + {E F : Type} `{Encode E} `{Encode F} {A B} + (h : E ~> ictree F) (t : ictree E A) (k : A -> ictree E B) : + interp h (x <- t;; k x) ≅ (x <- interp h t;; interp h (k x)). +Proof. + revert t. + __coinduction_equ RR IH; intros. + rewrite (ictree_eta t). + rewrite unfold_bind, unfold_interp. + destruct (observe t) eqn:Hobs; cbn. + - rewrite unfold_interp. + cbn. + rewrite bind_ret_l. + rewrite unfold_interp. + reflexivity. + - rewrite unfold_interp. + cbn. + rewrite bind_br. + setoid_rewrite bind_guard. + constructor; intro i. + step; econstructor; intros. + apply IH. + - rewrite (@unfold_interp _ _ _ _ _ h (Guard t0)). + cbn. + rewrite bind_guard. + constructor. + apply IH. + - rewrite unfold_interp. + cbn. + rewrite bind_bind. + upto_bind_equ. + rewrite bind_guard. + constructor. + apply IH. Qed. diff --git a/theories/ICTree/Interp/Refine.v b/theories/ICTree/Interp/Refine.v new file mode 100644 index 0000000..9a9ccbd --- /dev/null +++ b/theories/ICTree/Interp/Refine.v @@ -0,0 +1,242 @@ +From Stdlib Require Import Arith.PeanoNat Fin Morphisms Program.Equality. +From ExtLib Require Import Data.Monads.StateMonad. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import ICTree.Core ICTree.Equ. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. +Local Typeclasses Transparent equ. + +Definition rr_pick (n cursor : nat) : Fin.t (S n) := + @Fin.of_nat_lt (cursor mod S n) (S n) + (Nat.mod_upper_bound cursor (S n) (Nat.neq_succ_0 n)). + +CoFixpoint refine_rr {E : Type} `{Encode E} {A : Type} + (t : ictree E A) (cursor : nat) : ictree E (A * nat) := + match observe t with + | RetF x => Ret (x,cursor) + | GuardF t' => Guard (refine_rr t' cursor) + | BrF n k => Guard (refine_rr (k (rr_pick n cursor)) (S cursor)) + | VisF e k => Vis e (fun x => refine_rr (k x) cursor) + end. + +Definition round_robin {E : Type} `{Encode E} {A : Type} + (t : ictree E A) : stateT nat (ictree E) A := + mkStateT (fun cursor => refine_rr t cursor). + +Definition run_round_robin {E : Type} `{Encode E} {A : Type} + (t : ictree E A) (cursor : nat) : ictree E A := + result <- runStateT (round_robin t) cursor;; Ret (fst result). + +Lemma unfold_refine_rr {E : Type} `{Encode E} {A : Type} + (t : ictree E A) (cursor : nat) : + refine_rr t cursor ≅ + match observe t with + | RetF x => Ret (x,cursor) + | GuardF t' => Guard (refine_rr t' cursor) + | BrF n k => Guard (refine_rr (k (rr_pick n cursor)) (S cursor)) + | VisF e k => Vis e (fun x => refine_rr (k x) cursor) + end. +Proof. step; now cbn. Qed. + +Lemma unfold_run_round_robin {E : Type} `{Encode E} {A : Type} + (t : ictree E A) (m : nat) : + run_round_robin t m ≅ + match observe t with + | RetF x => Ret x + | GuardF t' => Guard (run_round_robin t' m) + | BrF n k => Guard (run_round_robin (k (rr_pick n m)) (S m)) + | VisF e k => Vis e (fun x => run_round_robin (k x) m) + end. +Proof. + unfold run_round_robin, round_robin; cbn [runStateT]. + rewrite unfold_refine_rr. + destruct (observe t); cbn; rewrite ?bind_ret_l, ?bind_guard, ?bind_vis; + reflexivity. +Qed. + +#[global] Instance refine_rr_equ {E : Type} {HE : Encode E} {A : Type} : + Proper (equ eq ==> eq ==> equ eq) (@refine_rr E HE A). +Proof. + unfold Proper, respectful. + coinduction R IH; intros t u Htu m m' <-. + rewrite !unfold_refine_rr. + step in Htu. + destruct Htu as [x y Hxy|e k1 k2 Hk|t1 t2 Ht|b k1 k2 Hk]; cbn. + - subst; reflexivity. + - constructor; intro x; apply IH; [exact (Hk x)|reflexivity]. + - constructor; apply IH; [exact Ht|reflexivity]. + - constructor; apply IH; [exact (Hk (rr_pick b m))|reflexivity]. +Qed. + +#[global] Instance run_round_robin_equ {E : Type} {HE : Encode E} {A : Type} : + Proper (equ eq ==> eq ==> equ eq) (@run_round_robin E HE A). +Proof. + intros t u Htu m m' <-. + unfold run_round_robin, round_robin; cbn [runStateT]. + now rewrite Htu. +Qed. + +Section BranchFreedom. + Context {E : Type} {HE : Encode E} {A : Type}. + + Variant branchfreeF (R : ictree E A -> Prop) : ictree' E A -> Prop := + | BfRetF x : branchfreeF R (RetF x) + | BfGuardF t : R t -> branchfreeF R (GuardF t) + | BfVisF e k : (forall x, R (k x)) -> branchfreeF R (VisF e k). + + Program Definition fbranchfree : mon (ictree E A -> Prop) := + {| body R t := branchfreeF R (observe t) |}. + Next Obligation. + unfold pointwise_relation, Basics.impl, Proper, respectful in *. + intros R S HRS t Ht; destruct Ht; constructor; auto. + Qed. + + Definition BranchFree : ictree E A -> Prop := gfp fbranchfree. + + Lemma branchfree_unfold t : + BranchFree t <-> branchfreeF BranchFree (observe t). + Proof. exact (gfp_fp fbranchfree t). Qed. +End BranchFreedom. + +Section BranchFreeLaws. + Context {E : Type} {HE : Encode E}. + + Lemma bf_ret {A} (x : A) : BranchFree (Ret x : ictree E A). + Proof. apply branchfree_unfold; constructor. Qed. + + Lemma bf_guard {A} (t : ictree E A) : + BranchFree t -> BranchFree (Guard t). + Proof. intro Ht; apply branchfree_unfold; now constructor. Qed. + + Lemma bf_vis {A} e (k : encode e -> ictree E A) : + (forall x, BranchFree (k x)) -> BranchFree (Vis e k). + Proof. intro Hk; apply branchfree_unfold; now constructor. Qed. + + Lemma branchfree_equ_impl {A} : forall (t u : ictree E A), + t ≅ u -> BranchFree t -> BranchFree u. + Proof. + change (forall (t u : ictree E A), + t ≅ u -> BranchFree t -> gfp fbranchfree u). + apply_coinduction; intros R IH t u Htu Ht. + change (branchfreeF (coinduction.t fbranchfree R) (observe u)). + apply branchfree_unfold in Ht. + step in Htu. + change (equF eq (equ eq) (observe t) (observe u)) in Htu. + remember (observe t) as ot in *. + remember (observe u) as ou in *. + destruct Htu; dependent destruction Ht; + constructor; intros; eapply IH; eauto. + Qed. + + #[global] Instance branchfree_equ {A} : + Proper (equ eq ==> iff) (@BranchFree E HE A). + Proof. + intros t u Htu; split; intro Hbf. + - eapply branchfree_equ_impl; [exact Htu|exact Hbf]. + - eapply branchfree_equ_impl; [symmetry; exact Htu|exact Hbf]. + Qed. + + Lemma branchfree_bind {A B} (t : ictree E A) (k : A -> ictree E B) : + BranchFree t -> (forall x, BranchFree (k x)) -> BranchFree (ICtree.bind t k). + Proof. + revert t k. + change (forall (t : ictree E A) (k : A -> ictree E B), + BranchFree t -> (forall x, BranchFree (k x)) -> + gfp fbranchfree (ICtree.bind t k)). + apply_coinduction; intros R IH t k Ht Hk. + change (branchfreeF (coinduction.t fbranchfree R) + (observe (match observe t with + | RetF x => k x + | BrF n ke => Br n (fun x => ICtree.bind (ke x) k) + | GuardF r => Guard (ICtree.bind r k) + | VisF e ke => Vis e (fun x => ICtree.bind (ke x) k) + end))). + apply branchfree_unfold in Ht. + remember (observe t) as ot in *. + destruct Ht as [x|r Hr|e ke Hke]; cbn. + - apply (gfp_bt fbranchfree R), Hk. + - constructor; apply IH; [exact Hr|exact Hk]. + - constructor; intro x; apply IH; [exact (Hke x)|exact Hk]. + Qed. + + Lemma branchfree_iter {I A} (body : I -> ictree E (I + A)) : + (forall i, BranchFree (body i)) -> forall i, BranchFree (ICtree.iter body i). + Proof. + intro Hbody. + set (next := fun lr : I + A => + match lr with + | inl i => Guard (ICtree.iter body i) + | inr a => Ret a + end). + assert (Hclosed : forall t : ictree E A, + ((exists i, t ≅ ICtree.iter body i) \/ + (exists r : ictree E (I + A), BranchFree r /\ t ≅ (r >>= next))) -> + BranchFree t). + { + change (forall t : ictree E A, + ((exists i, t ≅ ICtree.iter body i) \/ + (exists r : ictree E (I + A), BranchFree r /\ t ≅ (r >>= next))) -> + gfp fbranchfree t). + apply_coinduction; intros R IH t Ht. + change (branchfreeF (coinduction.t fbranchfree R) (observe t)). + assert (Hr : exists r : ictree E (I + A), + BranchFree r /\ t ≅ (r >>= next)). + { + destruct Ht as [[i Ht]|Ht]; auto. + exists (body i); split; auto. + rewrite Ht, unfold_iter; reflexivity. + } + destruct Hr as [r [Hr Htr]]. + apply branchfree_unfold in Hr. + rewrite (ictree_eta r) in Htr. + remember (observe r) as node in Htr, Hr. + destruct Hr as [lr|r' Hbf|e ke Hbf]; cbn in Htr. + - rewrite bind_ret_l in Htr. + destruct lr as [i|a]; unfold next in Htr; cbn in Htr. + + step in Htr. + change (equF eq (equ eq) (observe t) + (GuardF (ICtree.iter body i))) in Htr. + remember (observe t) as ot in *; clear Heqot. + inversion Htr; subst. + constructor; apply IH; left; eauto. + + step in Htr. + change (equF eq (equ eq) (observe t) (RetF a)) in Htr. + remember (observe t) as ot in *; clear Heqot. + inversion Htr; subst; constructor. + - rewrite bind_guard in Htr; step in Htr. + change (equF eq (equ eq) (observe t) + (GuardF (r' >>= next))) in Htr. + remember (observe t) as ot in *; clear Heqot. + inversion Htr; subst. + constructor; apply IH; right; eauto. + - rewrite bind_vis in Htr; step in Htr. + change (equF eq (equ eq) (observe t) + (VisF e (fun x => ke x >>= next))) in Htr. + remember (observe t) as ot in *; clear Heqot. + dependent destruction Htr. + constructor; intro x; apply IH; right; eauto. + } + intro i; apply Hclosed; left; exists i; reflexivity. + Qed. +End BranchFreeLaws. + +Lemma rr_pick_even n : Nat.even n = true -> rr_pick 1 n = Fin.F1. +Proof. + intro Hn; apply Nat.even_spec in Hn; destruct Hn as [k ->]. + apply Fin.to_nat_inj; unfold rr_pick; rewrite Fin.to_nat_of_nat. + change ((2 * k) mod 2 = 0). + rewrite Nat.mul_comm; apply Nat.mod_mul; discriminate. +Qed. + +Lemma rr_pick_odd n : Nat.even n = false -> rr_pick 1 n = Fin.FS Fin.F1. +Proof. + intro Hn. + assert (Ho : Nat.odd n = true) by (unfold Nat.odd; now rewrite Hn). + apply Nat.odd_spec in Ho; destruct Ho as [k ->]. + apply Fin.to_nat_inj; unfold rr_pick; rewrite Fin.to_nat_of_nat. + change ((2 * k + 1) mod 2 = 1). + rewrite Nat.add_mod by discriminate. + rewrite (Nat.mul_comm 2 k), Nat.mod_mul by discriminate. + reflexivity. +Qed. diff --git a/theories/ICTree/Interp/State.v b/theories/ICTree/Interp/State/Mod.v similarity index 100% rename from theories/ICTree/Interp/State.v rename to theories/ICTree/Interp/State/Mod.v diff --git a/theories/ICTree/Interp/Yield/Mod.v b/theories/ICTree/Interp/Yield/Mod.v new file mode 100644 index 0000000..63fdcfa --- /dev/null +++ b/theories/ICTree/Interp/Yield/Mod.v @@ -0,0 +1,591 @@ +From Stdlib Require Import + Fin + Vector + Morphisms. + +From TICL Require Import + Classes + Events.Core + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.Core + ICTree.Interp.State.Mod + ICTree.Events.Yield + ICTree.Events.State + ICTree.Events.Writer + Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Generalizable All Variables. + +(** * Cooperative scheduling over raw [ictree] pools *) +(** This module is language independent. It owns the cooperative scheduler, + the event-erasure handlers, and the instrumentation algebra that lifts a + raw thread or a raw scheduled pool into the writer-instrumented view. *) + +Section Scheduler. + Context {E : Type} `{Encode E}. + + (** Cooperative scheduler for a finite pool. + + [None] focus means the scheduler chooses a runnable thread after emitting + a scheduling [Yield]. [Some i] observes one step of thread [i], removing + finished threads, clearing focus on source yields, and turning source forks + into scheduler-visible [Spawn] events. *) + CoFixpoint schedule (n : nat) (v : pool E n) (focus : option (Fin.t n)) : completed E := + match focus with + | None => + match n return pool E n -> completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => Vis (inl Yield) (fun _ => Br n' (fun i => schedule (S n') v (Some i))) + end v + | Some i => + match n return pool E n -> Fin.t n -> completed E with + | 0 => fun _ i => match i with end + | S n' => fun v i => + match observe (v $ i) with + | RetF _ => Guard (schedule n' (v -- i) None) + | BrF b k => Br b (fun j => schedule (S n') (v @ i := (k j)) (Some i)) + | GuardF t => Guard (schedule (S n') (v @ i := t) (Some i)) + | VisF e k => + match e as e0 return (encode e0 -> thread E) -> completed E with + | inl Yield => fun k => Guard (schedule (S n') (v @ i := (k tt)) None) + | inr (inl Fork) => fun k => + @go (yieldE + (spawnE + E)) _ unit + (VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n')) + ((k true :: (v @ i := (k false)))%vector) + (Some (FS i)))) + | inr (inr e') => fun k => + @go (yieldE + (spawnE + E)) _ unit + (VisF ((inr (inr e')) : yieldE + (spawnE + E)) + (fun x => schedule (S n') (v @ i := (k x)) (Some i))) + end k + end + end v i + end. +End Scheduler. + +(** * Event erasure handlers *) + +(** Erase scheduler spawn observations while preserving yield and user events. *) +Definition handle_spawn {E} `{HE : Encode E} : + (yieldE + (spawnE + E)) ~> ictree (yieldE + E) := + fun event => + match event with + | inl y => ICtree.trigger y + | inr (inl Spawn) => Ret tt + | inr (inr m) => ICtree.trigger m + end. + +Definition interp_spawn {E} `{HE : Encode E} {X} + (t : ictree (yieldE + (spawnE + E)) X) : ictree (yieldE + E) X := + interp handle_spawn t. + +(** Erase cooperative yield observations, leaving only user events. *) +Definition handle_yield {E} `{HE : Encode E} : (yieldE + E) ~> ictree E := + fun event => + match event with + | inl Yield => Ret tt + | inr m => ICtree.trigger m + end. + +Definition interp_yield {E} `{HE : Encode E} {X} + (t : ictree (yieldE + E) X) : ictree E X := + interp handle_yield t. + +(** Interpret a raw thread without scheduling by resolving [Fork] to [false], + so a standalone thread behaves as the parent path and never starts the + fork body. *) +Definition handle_thread {E} `{HE : Encode E} : + (yieldE + (forkE + E)) ~> ictree (yieldE + E) := + fun event => + match event with + | inl y => ICtree.trigger y + | inr (inl Fork) => Ret false + | inr (inr m) => ICtree.trigger m + end. + +Definition interp_thread {E} `{HE : Encode E} {X} + (t : ictree (yieldE + (forkE + E)) X) : ictree E X := + interp_yield (interp handle_thread t). + +(** The erasure interpreters are [equ]-congruences; this lets structural + equations be rewritten underneath them. *) +#[global] Instance interp_spawn_equ {E} `{HE : Encode E} {X} : + Proper (equ eq ==> equ eq) (@interp_spawn E HE X). +Proof. intros t u Ht. unfold interp_spawn. now rewrite Ht. Qed. + +#[global] Instance interp_yield_equ {E} `{HE : Encode E} {X} : + Proper (equ eq ==> equ eq) (@interp_yield E HE X). +Proof. intros t u Ht. unfold interp_yield. now rewrite Ht. Qed. + +#[global] Instance interp_thread_equ_proper {E} `{HE : Encode E} {X} : + Proper (equ eq ==> equ eq) (@interp_thread E HE X). +Proof. intros t u Ht. unfold interp_thread, interp_yield. now rewrite Ht. Qed. + +(** Erasure handlers intentionally hide scheduler/thread observations. *) +Lemma handle_spawn_spawn_erased {E} {HE : Encode E} : + @handle_spawn E HE (inr (inl Spawn)) = Ret tt. +Proof. reflexivity. Qed. + +Lemma handle_yield_yield_erased {E} {HE : Encode E} : + @handle_yield E HE (inl Yield) = Ret tt. +Proof. reflexivity. Qed. + +(** * Scheduler one-step/case regression facts. *) +Section SchedulerFacts. + Context {E : Type} `{Encode E}. + + Local Ltac solve_focused_schedule H := + lazy [schedule observe _observe]; + match type of H with + | observe (Vector.nth ?v ?i) = _ => + change (@_observe _ _ unit (Vector.nth v i)) with (observe (Vector.nth v i)); + rewrite H; + reflexivity + end. + + Lemma schedule_empty_none (v : pool E 0) : + observe (schedule 0 v None) = RetF tt. + Proof. reflexivity. Qed. + + Lemma schedule_no_focus_nonempty n (v : pool E (S n)) : + observe (schedule (S n) v None) = + VisF (inl Yield) (fun _ => Br n (fun i => schedule (S n) v (Some i))). + Proof. reflexivity. Qed. + + Lemma schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule n (v -- i) None). + Proof. + intro Hret. + solve_focused_schedule Hret. + Qed. + + Lemma schedule_focused_br n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + observe (schedule (S n) v (Some i)) = + BrF b (fun j => schedule (S n) (v @ i := (k j)) (Some i)). + Proof. + intro Hbr. + solve_focused_schedule Hbr. + Qed. + + Lemma schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule (S n) (v @ i := t) (Some i)). + Proof. + intro Hg. + solve_focused_schedule Hg. + Qed. + + Lemma schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + observe (schedule (S n) v (Some i)) = + GuardF (schedule (S n) (v @ i := (k tt)) None). + Proof. + intro Hy. + solve_focused_schedule Hy. + Qed. + + Lemma schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + observe (schedule (S n) v (Some i)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n)) + ((k true :: (v @ i := (k false)))%vector) + (Some (Fin.FS i))). + Proof. + intro Hf. + solve_focused_schedule Hf. + Qed. + + Lemma schedule_focused_user_event n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + observe (schedule (S n) v (Some i)) = + VisF ((inr (inr e)) : yieldE + (spawnE + E)) + (fun x => schedule (S n) (v @ i := (k x)) (Some i)). + Proof. + intro Hu. + solve_focused_schedule Hu. + Qed. +End SchedulerFacts. + +(** * Non-degenerate finite-pool scheduler regressions. *) +Section SchedulerPoolRegressions. + Context {E : Type} `{Encode E}. + + Lemma schedule_yield_two_threads_one_step (next other : thread E) : + observe + (schedule 2 + [Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); + other]%vector + (Some Fin.F1)) = + GuardF + (schedule 2 + ([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); + other]%vector @ Fin.F1 := next) + None). + Proof. reflexivity. Qed. + + Lemma schedule_yield_two_threads_focused_slot (next other : thread E) : + (([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); + other]%vector @ Fin.F1 := next) $ Fin.F1) = next. + Proof. apply Vector.nth_replace_eq. Qed. + + Lemma schedule_yield_two_threads_other_slot (next other : thread E) : + (([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); + other]%vector @ Fin.F1 := next) $ (Fin.FS Fin.F1)) = other. + Proof. + rewrite Vector.nth_replace_neq by discriminate. + reflexivity. + Qed. + + Lemma schedule_fork_two_threads_one_step + (child parent other : thread E) : + observe + (schedule 2 + [Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector + (Some Fin.F1)) = + VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) + (fun _ => + schedule 3 + ((child :: + ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector @ Fin.F1 := parent))%vector) + (Some (Fin.FS Fin.F1))). + Proof. reflexivity. Qed. + + Lemma schedule_fork_two_threads_child_slot + (child parent other : thread E) : + (((child :: + ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector @ Fin.F1 := parent))%vector) $ Fin.F1) = child. + Proof. reflexivity. Qed. + + Lemma schedule_fork_two_threads_parent_slot + (child parent other : thread E) : + (((child :: + ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector @ Fin.F1 := parent))%vector) $ (Fin.FS Fin.F1)) = parent. + Proof. apply Vector.nth_replace_eq. Qed. + + Lemma schedule_fork_two_threads_other_slot + (child parent other : thread E) : + (((child :: + ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector @ Fin.F1 := parent))%vector) + $ (Fin.FS (Fin.FS Fin.F1))) = other. + Proof. + change ((([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) + (fun in_child : bool => if in_child then child else parent); + other]%vector @ Fin.F1 := parent) $ (Fin.FS Fin.F1)) = other). + rewrite Vector.nth_replace_neq by discriminate. + reflexivity. + Qed. +End SchedulerPoolRegressions. + +(** * Raw instrumentation entry points *) + +(** Instrument a standalone raw thread: erase [Fork] to the parent branch and + erase cooperative [Yield], then instrument the residual state effects. *) +Definition instr_thread {Σ X} + (t : ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) + : ictreeW Σ (X * Σ) := + instr_stateE (interp_thread t) σ. + +(** Instrument a scheduled pool: erase scheduler [Spawn] and cooperative + [Yield] observations, then instrument the residual state effects. *) +Definition instr_schedule {Σ} (n : nat) (v : pool (stateE Σ) n) + (focus : option (Fin.t n)) (σ : Σ) : ictreeW Σ (unit * Σ) := + instr_stateE (interp_yield (interp_spawn (schedule n v focus))) σ. + +(** ** Structural [interp] and [equ] equations used by the erasure algebra. *) +Lemma interp_ret_node `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) (x : X) : + interp h (Ret x) ≅ Ret x. +Proof. rewrite unfold_interp; reflexivity. Qed. + +Lemma interp_guard_node `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) (t : ictree E X) : + interp h (Guard t) ≅ Guard (interp h t). +Proof. rewrite unfold_interp; reflexivity. Qed. + +Lemma interp_br_node `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) n (k : fin' n -> ictree E X) : + interp h (Br n k) ≅ Br n (fun i => Guard (interp h (k i))). +Proof. rewrite unfold_interp; reflexivity. Qed. + +Lemma interp_vis_node `{Encode E} `{Encode F} {X} + (h : E ~> ictree F) (e : E) (k : encode e -> ictree E X) : + interp h (Vis e k) ≅ h e >>= (fun x => Guard (interp h (k x))). +Proof. rewrite unfold_interp; reflexivity. Qed. + +Lemma guard_equ_node `{Encode E} {X} (t u : ictree E X) : + t ≅ u -> Guard t ≅ Guard u. +Proof. intro Ht. step. constructor. exact Ht. Qed. + +Lemma vis_equ_node `{Encode E} {X} (e : E) (k1 k2 : encode e -> ictree E X) : + (forall x, k1 x ≅ k2 x) -> Vis e k1 ≅ Vis e k2. +Proof. intro Hk. step. constructor. exact Hk. Qed. + +Local Ltac erase_resum := + unfold resum, resum_ret, + ReSum_inl, ReSum_inr, ReSum_refl, + ReSumRet_inl, ReSumRet_inr, ReSumRet_refl. + +(** ** Composed erasure equations for a single raw thread node. *) + +Lemma interp_thread_yield_node {E} `{Encode E} {X} + (k : unit -> ictree (yieldE + (forkE + E)) X) : + interp_thread (Vis (inl Yield) k) ≅ Guard (Guard (interp_thread (k tt))). +Proof. + unfold interp_thread, interp_yield. + rewrite interp_vis_node. + cbn [handle_thread]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + rewrite interp_vis_node. + cbn [handle_yield]. + rewrite bind_ret_l. + apply guard_equ_node. + rewrite interp_guard_node. + reflexivity. +Qed. + +Lemma interp_thread_fork_node {E} `{Encode E} {X} + (k : bool -> ictree (yieldE + (forkE + E)) X) : + interp_thread (Vis (inr (inl Fork)) k) ≅ Guard (interp_thread (k false)). +Proof. + unfold interp_thread, interp_yield. + rewrite interp_vis_node. + cbn [handle_thread]. + rewrite bind_ret_l. + rewrite interp_guard_node. + reflexivity. +Qed. + +Lemma interp_thread_user_node {E} `{Encode E} {X} (m : E) + (k : encode m -> ictree (yieldE + (forkE + E)) X) : + interp_thread (Vis (inr (inr m)) k) + ≅ Vis m (fun x => Guard (Guard (interp_thread (k x)))). +Proof. + unfold interp_thread, interp_yield. + rewrite interp_vis_node. + cbn [handle_thread]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + rewrite interp_vis_node. + cbn [handle_yield]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + apply vis_equ_node; intro x. + apply guard_equ_node. + rewrite interp_guard_node. + reflexivity. +Qed. + +(** ** Instrumentation algebra for raw threads. *) + +#[global] Instance instr_thread_equ {Σ X} : + Proper (equ eq ==> eq ==> equ eq) (@instr_thread Σ X). +Proof. + intros t t' Ht σ σ' <-. + unfold instr_thread, interp_thread, interp_yield, instr_stateE. + now rewrite Ht. +Qed. + +Lemma instr_thread_ret {Σ X} (x : X) (σ : Σ) : + instr_thread (Ret x) σ ≅ Ret (x, σ). +Proof. + unfold instr_thread, interp_thread, interp_yield, instr_stateE. + rewrite interp_ret_node, interp_ret_node. + apply interp_state_ret. +Qed. + +Lemma instr_thread_bind {Σ A B} + (t : ictree (yieldE + (forkE + stateE Σ)) A) + (k : A -> ictree (yieldE + (forkE + stateE Σ)) B) (σ : Σ) : + instr_thread (t >>= k) σ + ≅ (instr_thread t σ >>= fun '(x, σ') => instr_thread (k x) σ'). +Proof. + unfold instr_thread, interp_thread, interp_yield, instr_stateE. + rewrite !interp_bind_hetero. + apply interp_state_bind. +Qed. + +Lemma instr_thread_yield {Σ X} + (k : unit -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : + instr_thread (Vis (inl Yield) k) σ ~ instr_thread (k tt) σ. +Proof. + unfold instr_thread, instr_stateE. + rewrite interp_thread_yield_node. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + reflexivity. +Qed. + +Lemma instr_thread_fork {Σ X} + (k : bool -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : + instr_thread (Vis (inr (inl Fork)) k) σ ~ instr_thread (k false) σ. +Proof. + unfold instr_thread, instr_stateE. + rewrite interp_thread_fork_node. + rewrite interp_state_tau, sb_guard. + reflexivity. +Qed. + +Lemma instr_thread_get {Σ X} + (k : Σ -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : + instr_thread (Vis (inr (inr Get)) k) σ ~ instr_thread (k σ) σ. +Proof. + unfold instr_thread, instr_stateE. + rewrite interp_thread_user_node. + rewrite interp_state_vis. + cbn [h_stateW runStateT]. + rewrite bind_ret_l, sb_guard. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + reflexivity. +Qed. + +Lemma instr_thread_put {Σ X} (σ' : Σ) + (k : unit -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : + instr_thread (Vis (inr (inr (Put σ'))) k) σ + ~ (log σ';; instr_thread (k tt) σ'). +Proof with eauto. + unfold instr_thread, instr_stateE. + rewrite interp_thread_user_node. + rewrite interp_state_vis. + cbn [h_stateW runStateT]. + rewrite bind_bind. + __upto_bind_sbisim... + intros []. + rewrite bind_ret_l, sb_guard. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + reflexivity. +Qed. + +(** ** Composed erasure equations for a single scheduled node. *) +(** [interp_yield (interp_spawn _)] is the erased view of a scheduled pool: + scheduler [Spawn] and cooperative [Yield] observations are removed, and the + residual user events are preserved. *) + +Lemma interp_erase_ret {E} `{Encode E} {X} (x : X) : + interp_yield (interp_spawn (Ret x : ictree (yieldE + (spawnE + E)) X)) ≅ Ret x. +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_ret_node, interp_ret_node. + reflexivity. +Qed. + +Lemma interp_erase_guard {E} `{Encode E} {X} + (t : ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Guard t)) ≅ Guard (interp_yield (interp_spawn t)). +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_guard_node, interp_guard_node. + reflexivity. +Qed. + +Lemma interp_erase_guard_ret {E} `{Encode E} {X} (x : X) : + interp_yield (interp_spawn (Guard (Ret x) : ictree (yieldE + (spawnE + E)) X)) + ≅ Guard (Ret x). +Proof. + rewrite interp_erase_guard. + apply guard_equ_node, interp_erase_ret. +Qed. + +Lemma interp_erase_br {E} `{Encode E} {X} n + (k : fin' n -> ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Br n k)) + ≅ Br n (fun i => Guard (Guard (interp_yield (interp_spawn (k i))))). +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_br_node, interp_br_node. + apply br_equ; intro i. + apply guard_equ_node, interp_guard_node. +Qed. + +Lemma interp_erase_yield {E} `{Encode E} {X} + (k : unit -> ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Vis (inl Yield) k)) + ≅ Guard (Guard (interp_yield (interp_spawn (k tt)))). +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_vis_node. + cbn [handle_spawn]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + rewrite interp_vis_node. + cbn [handle_yield]. + rewrite bind_ret_l. + apply guard_equ_node. + rewrite interp_guard_node. + reflexivity. +Qed. + +Lemma interp_erase_guard_yield {E} `{Encode E} {X} + (k : unit -> ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Guard (Vis (inl Yield) k))) + ≅ Guard (Guard (Guard (interp_yield (interp_spawn (k tt))))). +Proof. + rewrite interp_erase_guard. + apply guard_equ_node, interp_erase_yield. +Qed. + +Lemma interp_erase_spawn {E} `{Encode E} {X} + (k : unit -> ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Vis (inr (inl Spawn)) k)) + ≅ Guard (interp_yield (interp_spawn (k tt))). +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_vis_node. + cbn [handle_spawn]. + rewrite bind_ret_l. + rewrite interp_guard_node. + reflexivity. +Qed. + +Lemma interp_erase_user {E} `{Encode E} {X} (m : E) + (k : encode m -> ictree (yieldE + (spawnE + E)) X) : + interp_yield (interp_spawn (Vis (inr (inr m)) k)) + ≅ Vis m (fun x => Guard (Guard (interp_yield (interp_spawn (k x))))). +Proof. + unfold interp_yield, interp_spawn. + rewrite interp_vis_node. + cbn [handle_spawn]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + rewrite interp_vis_node. + cbn [handle_yield]. + unfold ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + erase_resum. + apply vis_equ_node; intro x. + apply guard_equ_node. + rewrite interp_guard_node. + reflexivity. +Qed. diff --git a/theories/ICTree/Interp/Yield/RoundRobin.v b/theories/ICTree/Interp/Yield/RoundRobin.v new file mode 100644 index 0000000..b7ffadd --- /dev/null +++ b/theories/ICTree/Interp/Yield/RoundRobin.v @@ -0,0 +1,141 @@ +From Stdlib Require Import Fin Vector. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Yield + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.State.Mod Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Section RoundRobinInterpretation. + Context {E F : Type} {HE : Encode E} {HF : Encode F} {Σ : Type}. + + Definition interp_schedule_rr + (handler : E ~> stateT Σ (ictree F)) + (n : nat) (ts : pool E n) (focus : option (Fin.t n)) + (cursor : nat) (σ : Σ) : ictree F (unit * Σ) := + interp_state handler + (interp_yield (interp_spawn + (run_round_robin (schedule n ts focus) cursor))) σ. + + Lemma interp_schedule_rr_equ + (handler : E ~> stateT Σ (ictree F)) n (ts ts' : pool E n) focus m σ : + pool_equ ts ts' -> + interp_schedule_rr handler n ts focus m σ ≅ + interp_schedule_rr handler n ts' focus m σ. + Proof. + intro Hts; unfold interp_schedule_rr. + apply equ_interp_state; [|reflexivity]. + apply interp_yield_equ, interp_spawn_equ. + apply run_round_robin_equ; [|reflexivity]. + now apply schedule_pool_proper. + Qed. + + Lemma interp_schedule_rr_empty + (handler : E ~> stateT Σ (ictree F)) m σ : + interp_schedule_rr handler 0 ([] : pool E 0) None m σ ~ Ret (tt,σ). + Proof. + unfold interp_schedule_rr. + rewrite unfold_run_round_robin, schedule_empty_none. + rewrite interp_erase_ret, interp_state_ret; reflexivity. + Qed. + + Lemma interp_schedule_rr_ret + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) m σ : + observe (ts $ i) = RetF tt -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + interp_schedule_rr handler n (ts -- i) None m σ. + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_ret n ts i Hobs). + rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_guard + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) t m σ : + observe (ts $ i) = GuardF t -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m σ. + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). + rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_yield + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) k m σ : + observe (ts $ i) = VisF (inl Yield) k -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + interp_schedule_rr handler (S n) (ts @ i := k tt) None m σ. + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). + rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_select + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) m σ : + interp_schedule_rr handler (S n) ts None m σ ~ + interp_schedule_rr handler (S n) ts (Some (rr_pick n m)) (S m) σ. + Proof. + unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, schedule_no_focus_nonempty. + rewrite interp_erase_yield, interp_state_tau, sb_guard, + interp_state_tau, sb_guard. + rewrite (unfold_run_round_robin + (Br n (fun i => schedule (S n) ts (Some i))) m). + change (interp_state handler + (interp_yield (interp_spawn + (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) σ ~ + interp_schedule_rr handler (S n) ts (Some (rr_pick n m)) (S m) σ). + rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_fork + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) k m σ : + observe (ts $ i) = VisF (inr (inl Fork)) k -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + interp_schedule_rr handler (S (S n)) + (k true :: (ts @ i := k false)) (Some (Fin.FS i)) m σ. + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_fork n ts i k Hobs). + rewrite interp_erase_spawn, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_user + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) e k m σ : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + (runStateT (handler e) σ >>= fun '(x,σ') => + interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m σ'). + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). + rewrite interp_erase_user, interp_state_vis. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x σ']; rewrite sb_guard, interp_state_tau, sb_guard, + interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_rr_branch + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) b k m σ : + observe (ts $ i) = BrF b k -> + interp_schedule_rr handler (S n) ts (Some i) m σ ~ + interp_schedule_rr handler (S n) (ts @ i := k (rr_pick b m)) + (Some i) (S m) σ. + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_br n ts i b k Hobs). + rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. +End RoundRobinInterpretation. + +Arguments interp_schedule_rr {E F HE HF Σ} handler n ts focus cursor σ. diff --git a/theories/ICTree/Interp/Yield/SBisim.v b/theories/ICTree/Interp/Yield/SBisim.v new file mode 100644 index 0000000..9a93d24 --- /dev/null +++ b/theories/ICTree/Interp/Yield/SBisim.v @@ -0,0 +1,938 @@ +From Stdlib Require Import Fin Vector Program.Equality. +From TICL Require Import + ICTree.Core + ICTree.Trans + ICTree.Equ + ICTree.Eq.Core + ICTree.Eq.Bind + ICTree.SBisim + ICTree.Interp.Core + ICTree.Interp.State.Mod + ICTree.Events.Yield + ICTree.Events.State + ICTree.Events.Writer + ICTree.Interp.Yield.Mod + Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Section PoolSBisim. + Context {E : Type} `{Encode E}. + + Definition pool_sbisim {n : nat} (v1 v2 : pool E n) : Prop := + forall i, (v1 $ i) ~ (v2 $ i). + + Lemma pool_sbisim_refl {n} (v : pool E n) : pool_sbisim v v. + Proof. intro i; reflexivity. Qed. + + Lemma pool_sbisim_sym {n} (v1 v2 : pool E n) : + pool_sbisim v1 v2 -> pool_sbisim v2 v1. + Proof. intros Hpool i; symmetry; apply Hpool. Qed. + + Lemma replace_pool_sbisim {n} (v1 v2 : pool E n) (i : Fin.t n) + (t1 t2 : thread E) : + pool_sbisim v1 v2 -> + t1 ~ t2 -> + pool_sbisim (v1 @ i := t1) (v2 @ i := t2). + Proof. + intros Hv Ht j. + destruct (Fin.eq_dec i j) as [Hij | Hij]. + - subst j. rewrite Vector.nth_replace_eq, Vector.nth_replace_eq. exact Ht. + - rewrite Vector.nth_replace_neq by congruence. + rewrite Vector.nth_replace_neq by congruence. + apply Hv. + Qed. + + Lemma remove_pool_sbisim {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : + pool_sbisim v1 v2 -> + pool_sbisim (v1 -- i) (v2 -- i). + Proof. + intros Hv. + exact (vector_remove_pointwise (fun a b : thread E => a ~ b) v1 v2 i + (fun j _ => Hv j)). + Qed. + + Lemma cons_pool_sbisim {n} (t1 t2 : thread E) (v1 v2 : pool E n) : + t1 ~ t2 -> + pool_sbisim v1 v2 -> + pool_sbisim ((t1 :: v1)%vector) ((t2 :: v2)%vector). + Proof. + intros Ht Hv i. + refine (Fin.caseS' i + (fun i => (((t1 :: v1)%vector) $ i) ~ (((t2 :: v2)%vector) $ i)) _ _). + - exact Ht. + - intro j. apply Hv. + Qed. + + (** ** [equ]-level pool congruences, used by [schedule_pool_proper]. *) + Definition pool_equ {n : nat} (v1 v2 : pool E n) : Prop := + forall i, (v1 $ i) ≅ (v2 $ i). + + Lemma replace_pool_equ {n} (v1 v2 : pool E n) (i : Fin.t n) + (t1 t2 : thread E) : + pool_equ v1 v2 -> + t1 ≅ t2 -> + pool_equ (v1 @ i := t1) (v2 @ i := t2). + Proof. + intros Hv Ht j. + destruct (Fin.eq_dec i j) as [Hij | Hij]. + - subst j. rewrite Vector.nth_replace_eq, Vector.nth_replace_eq. exact Ht. + - rewrite Vector.nth_replace_neq by congruence. + rewrite Vector.nth_replace_neq by congruence. + apply Hv. + Qed. + + Lemma remove_pool_equ {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : + pool_equ v1 v2 -> + pool_equ (v1 -- i) (v2 -- i). + Proof. + intros Hv. + exact (vector_remove_pointwise (fun a b : thread E => a ≅ b) v1 v2 i + (fun j _ => Hv j)). + Qed. + + Lemma cons_pool_equ {n} (t1 t2 : thread E) (v1 v2 : pool E n) : + t1 ≅ t2 -> + pool_equ v1 v2 -> + pool_equ ((t1 :: v1)%vector) ((t2 :: v2)%vector). + Proof. + intros Ht Hv i. + refine (Fin.caseS' i + (fun i => (((t1 :: v1)%vector) $ i) ≅ (((t2 :: v2)%vector) $ i)) _ _). + - exact Ht. + - intro j. apply Hv. + Qed. +End PoolSBisim. + +Section SchedulerTransitions. + Context {E : Type} `{Encode E}. + + Lemma trans_schedule_no_focus_nonempty n (v : pool E (S n)) : + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v None) + (Br n (fun i => schedule (S n) v (Some i))). + Proof. + unfold trans; cbn. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inl Yield) _ tt + (Br n (fun i => schedule (S n) v (Some i)))). + reflexivity. + Qed. + + Lemma trans_schedule_no_focus_choose n (v : pool E (S n)) (i : Fin.t (S n)) : + trans tau + (Br n (fun i => schedule (S n) v (Some i))) + (schedule (S n) v (Some i)). + Proof. + apply trans_br with (x := i). reflexivity. + Qed. + + Lemma trans_schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (Br n (fun j => schedule (S n) ((v @ i := (k tt))) (Some j))). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v $ i)) with (observe (v $ i)). + rewrite Hobs. + eapply Stepguard. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inl Yield) _ tt + (Br n (fun j => schedule (S n) ((v @ i := (k tt))) (Some j)))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v $ i)) with (observe (v $ i)). + rewrite Hobs. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inr (inl Spawn)) _ tt + (schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_user_event + n (v : pool E (S n)) (i : Fin.t (S n)) e k x : + observe (v $ i) = VisF (inr (inr e)) k -> + trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (schedule (S n) v (Some i)) + (schedule (S n) ((v @ i := (k x))) (Some i)). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v $ i)) with (observe (v $ i)). + rewrite Hobs. + eapply (@Stepobs + (yieldE + (spawnE + E)) _ unit + (inr (inr e)) _ x + (schedule (S n) ((v @ i := (k x))) (Some i))). + reflexivity. + Qed. + + Lemma trans_schedule_focused_br + n (v : pool E (S n)) (i : Fin.t (S n)) b k (j : Fin.t (S b)) : + observe (v $ i) = BrF b k -> + trans tau (schedule (S n) v (Some i)) + (schedule (S n) ((v @ i := (k j))) (Some i)). + Proof. + intro Hobs. + unfold trans; lazy [schedule observe _observe]. + change (@_observe _ _ unit (v $ i)) with (observe (v $ i)). + rewrite Hobs. + eapply (@Steptau + (yieldE + (spawnE + E)) _ unit b j _ + (schedule (S n) ((v @ i := (k j))) (Some i))). + reflexivity. + Qed. + + (** ** Phase 2: remaining transition / unfold constructors. *) + + Lemma trans_schedule_empty_ret (v : pool E 0) : + schedule 0 v None ≅ Ret tt. + Proof. + rewrite (ictree_eta (schedule 0 v None)). + rewrite schedule_empty_none. + reflexivity. + Qed. + + Lemma trans_schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + schedule (S n) v (Some i) ≅ Guard (schedule n ((v -- i)) None). + Proof. + intro Hobs. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_ret _ v i Hobs). + reflexivity. + Qed. + + Lemma trans_schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + schedule (S n) v (Some i) + ≅ Guard (schedule (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hobs. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_guard _ v i t Hobs). + reflexivity. + Qed. + + (** ** Phase 3: scheduler transition inversions. *) + + Lemma schedule_no_focus_equ n (v : pool E (S n)) : + schedule (S n) v None + ≅ Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ => Br n (fun i => schedule (S n) v (Some i))). + Proof. + rewrite (ictree_eta (schedule (S n) v None)). + rewrite schedule_no_focus_nonempty. + reflexivity. + Qed. + + Lemma trans_schedule_no_focus_inv n (v : pool E (S n)) l t' : + trans l (schedule (S n) v None) t' -> + l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ + t' ≅ Br n (fun i => schedule (S n) v (Some i)). + Proof. + intro TR. + rewrite schedule_no_focus_equ in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + Qed. + + Lemma trans_schedule_focused_inv n (v : pool E (S n)) (i : Fin.t (S n)) l t' : + trans l (schedule (S n) v (Some i)) t' -> + (** focused [Ret]: collapse the [Guard], step the residual pool *) + (observe (v $ i) = RetF tt /\ + trans l (schedule n ((v -- i)) None) t') + \/ + (** focused [Guard]: collapse, step the replaced-slot residual *) + (exists g, observe (v $ i) = GuardF g /\ + trans l (schedule (S n) ((v @ i := g)) (Some i)) t') + \/ + (** focused [Br b k]: [tau] to one of the branches *) + (exists b k (j : Fin.t (S b)), observe (v $ i) = BrF b k /\ + l = tau /\ + t' ≅ schedule (S n) ((v @ i := (k j))) (Some i)) + \/ + (** focused [Yield]: visible [Yield], [Br] back over the residual pool *) + (exists k, observe (v $ i) = VisF (inl Yield) k /\ + l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ + t' ≅ Br n (fun j => + schedule (S n) ((v @ i := (k tt))) (Some j))) + \/ + (** focused [Fork]: visible [Spawn], cons the child, focus it *) + (exists k, observe (v $ i) = VisF (inr (inl Fork)) k /\ + l = obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt /\ + t' ≅ schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))) + \/ + (** focused user event [e]: visible [e], step the focused thread *) + (exists e k x, observe (v $ i) = VisF (inr (inr e)) k /\ + l = obs (inr (inr e) : yieldE + (spawnE + E)) x /\ + t' ≅ schedule (S n) ((v @ i := (k x))) (Some i)). + Proof. + intro TR. + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hobs. + - (* RetF *) + destruct r. + left. + split; auto. + rewrite (trans_schedule_focused_ret _ v i Hobs) in TR. + now apply trans_guard_inv in TR. + - (* BrF b k *) + do 2 right; left. + assert (Hsch := schedule_focused_br _ v i b k Hobs). + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite Hsch in TR. + apply trans_br_inv in TR as (j & Heq & Hl). + exists b, k, j; auto. + - (* GuardF g *) + right; left. + exists g. + split; auto. + rewrite (trans_schedule_focused_guard _ v i g Hobs) in TR. + now apply trans_guard_inv in TR. + - (* VisF e k *) + destruct e as [yld | [frk | usr]]. + + (* Yield *) + destruct yld. + do 3 right; left. + exists k. + split; auto. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_yield _ v i k Hobs) in TR. + apply trans_guard_inv in TR. + rewrite schedule_no_focus_equ in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + + (* Fork *) + destruct frk. + do 4 right; left. + exists k. + split; auto. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_fork _ v i k Hobs) in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + destruct x. + split; auto. + + (* user event *) + do 5 right. + rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. + rewrite (schedule_focused_user_event _ v i usr k Hobs) in TR. + apply trans_vis_inv in TR as (x & Heq & Hl). + exists usr, k, x; auto. + Qed. + + (** ** [schedule] respects [equ]-equality of pools, in every focus. *) + Lemma schedule_pool_proper n (v w : pool E n) focus : + pool_equ v w -> + schedule n v focus ≅ schedule n w focus. + Proof. + revert n v w focus. + coinduction R CH. + intros n v w focus Hvw. + destruct focus as [i |]. + - destruct n as [| n']; [ inversion i |]. + pose proof (Hvw i) as Hi. + assert (Hgo : go (observe (v $ i)) ≅ go (observe (w $ i))). + { rewrite <- !ictree_eta. exact Hi. } + rewrite (ictree_eta (schedule (S n') v (Some i))). + rewrite (ictree_eta (schedule (S n') w (Some i))). + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hv; + destruct (observe (w $ i)) as [r2 | b2 k2 | g2 | e2 k2] eqn:Hw; + try (step in Hgo; inversion Hgo; fail). + + destruct r, r2. + rewrite (@schedule_focused_ret E _ n' v i Hv). + rewrite (@schedule_focused_ret E _ n' w i Hw). + cbn. constructor. apply CH. apply remove_pool_equ. exact Hvw. + + pose proof (equ_br_invT Hgo) as Hbeq; subst b2. + pose proof (equ_br_invE Hgo) as Hke. + rewrite (@schedule_focused_br E _ n' v i b k Hv). + rewrite (@schedule_focused_br E _ n' w i b k2 Hw). + cbn. constructor. intro j. apply CH. + apply replace_pool_equ. exact Hvw. apply Hke. + + pose proof (equ_guard_invE Hgo) as Hge. + rewrite (@schedule_focused_guard E _ n' v i g Hv). + rewrite (@schedule_focused_guard E _ n' w i g2 Hw). + cbn. constructor. apply CH. + apply replace_pool_equ. exact Hvw. exact Hge. + + pose proof (equ_vis_invT Hgo) as [_ Heeq]; subst e2. + pose proof (equ_vis_invE Hgo) as Hke. + destruct e as [yld | [frk | usr]]. + * destruct yld. + rewrite (@schedule_focused_yield E _ n' v i k Hv). + rewrite (@schedule_focused_yield E _ n' w i k2 Hw). + cbn. constructor. apply CH. + apply replace_pool_equ. exact Hvw. apply (Hke tt). + * destruct frk. + rewrite (@schedule_focused_fork E _ n' v i k Hv). + rewrite (@schedule_focused_fork E _ n' w i k2 Hw). + cbn. constructor. intros _. apply CH. + apply cons_pool_equ. + -- apply (Hke true). + -- apply replace_pool_equ. exact Hvw. apply (Hke false). + * rewrite (@schedule_focused_user_event E _ n' v i usr k Hv). + rewrite (@schedule_focused_user_event E _ n' w i usr k2 Hw). + cbn. constructor. intro x. apply CH. + apply replace_pool_equ. exact Hvw. apply (Hke x). + - destruct n as [| n']. + + rewrite (ictree_eta (schedule 0 v None)). + rewrite (ictree_eta (schedule 0 w None)). + rewrite schedule_empty_none, schedule_empty_none. + cbn. reflexivity. + + rewrite (ictree_eta (schedule (S n') v None)). + rewrite (ictree_eta (schedule (S n') w None)). + rewrite schedule_no_focus_nonempty, schedule_no_focus_nonempty. + cbn. constructor. intros _. cbn. step. + constructor. intro i. apply CH. exact Hvw. + Qed. + (** ** Phase 4: thread-step to scheduler-step lifts. *) + + Lemma pool_equ_refl {n} (v : pool E n) : pool_equ v v. + Proof. intro j; reflexivity. Qed. + + Lemma replace_pool_idem_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) + (a b : thread E) : + pool_equ (v @ i := b) ((v @ i := a) @ i := b). + Proof. rewrite Vector.replace_replace_eq. apply pool_equ_refl. Qed. + + Lemma br_schedule_pool_equ {n} (v w : pool E (S n)) : + pool_equ v w -> + Br n (fun j => schedule (S n) v (Some j)) + ≅ Br n (fun j => schedule (S n) w (Some j)). + Proof. + intro Hvw. step. constructor. intro j. + apply schedule_pool_proper. exact Hvw. + Qed. + + Lemma schedule_lift_yield n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans (obs (inl Yield : yieldE + (forkE + E)) tt) (v $ i) u -> + trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (Br n (fun j => schedule (S n) ((v @ i := u)) (Some j))). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v $ i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inl Yield : yieldE + (forkE + E)) tt) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard: observe (v $ i) = GuardF t *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (br_schedule_pool_equ ((v @ i := u0)) + ((((v @ i := t)) @ i := u0)) + (replace_pool_idem_equ v i t u0)). + apply (IHTR ((v @ i := t)) i u0). + + now rewrite Vector.nth_replace_eq. + + exact Hou. + + exact Hlbl. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + assert (Hu0 : u ≅ k tt). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (br_schedule_pool_equ ((v @ i := u)) + ((v @ i := (k tt))) + (replace_pool_equ v v i u (k tt) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_yield n v i k (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma schedule_some_pool_equ {m} (v w : pool E (S m)) (i : Fin.t (S m)) : + pool_equ v w -> + schedule (S m) v (Some i) ≅ schedule (S m) w (Some i). + Proof. intro Hvw. apply schedule_pool_proper. exact Hvw. Qed. + + Lemma schedule_lift_user n (v : pool E (S n)) (i : Fin.t (S n)) + (e : E) (x : encode e) (u : thread E) : + trans (obs (inr (inr e) : yieldE + (forkE + E)) x) (v $ i) u -> + trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (schedule (S n) v (Some i)) + (schedule (S n) ((v @ i := u)) (Some i)). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v $ i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inr (inr e) : yieldE + (forkE + E)) x) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_some_pool_equ ((v @ i := u0)) + ((((v @ i := t)) @ i := u0)) i + (replace_pool_idem_equ v i t u0)). + apply (IHTR ((v @ i := t)) i u0). + + now rewrite Vector.nth_replace_eq. + + exact Hou. + + exact Hlbl. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + assert (Hu0 : u ≅ k x). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (schedule_some_pool_equ ((v @ i := u)) + ((v @ i := (k x))) i + (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_user_event n v i e k x (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma schedule_lift_tau n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans tau (v $ i) u -> + trans tau + (schedule (S n) v (Some i)) + (schedule (S n) ((v @ i := u)) (Some i)). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v $ i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (tau : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_some_pool_equ ((v @ i := u0)) + ((((v @ i := t)) @ i := u0)) i + (replace_pool_idem_equ v i t u0)). + apply (IHTR ((v @ i := t)) i u0). + + now rewrite Vector.nth_replace_eq. + + exact Hou. + + exact Hlbl. + - (* Steptau *) + assert (Hu0 : u ≅ k x). + { transitivity t. + - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. + - symmetry; assumption. } + rewrite (schedule_some_pool_equ ((v @ i := u)) + ((v @ i := (k x))) i + (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). + apply (trans_schedule_focused_br n v i n0 k x (eq_sym Hot)). + - discriminate Hlbl. + - discriminate Hlbl. + Qed. + + Lemma schedule_lift_fork n (v : pool E (S n)) (i : Fin.t (S n)) + (b : bool) (u : thread E) : + trans (obs (inr (inl Fork) : yieldE + (forkE + E)) b) (v $ i) u -> + exists k2, + (forall c : bool, + trans (obs (inr (inl Fork) : yieldE + (forkE + E)) c) (v $ i) (k2 c)) /\ + trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (schedule (S n) v (Some i)) + (schedule (S (S n)) + (((k2 true) :: ((v @ i := (k2 false))))%vector) + (Some (Fin.FS i))). + Proof. + intro TR. + unfold trans in TR. + remember (observe (v $ i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (obs (inr (inl Fork) : yieldE + (forkE + E)) b) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + destruct (IHTR ((v @ i := t)) i u0 + ltac:(now rewrite Vector.nth_replace_eq) Hou Hlbl) + as (k2 & Hcont & Hstep). + exists k2. split. + + intro c. specialize (Hcont c). + rewrite Vector.nth_replace_eq in Hcont. + rewrite (ictree_eta (v $ i)), <- Hot. + now apply trans_guard. + + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + apply trans_guard. + rewrite (schedule_pool_proper (S (S n)) + (((k2 true) :: ((v @ i := (k2 false))))%vector) + (((k2 true) :: ((((v @ i := t)) @ i := (k2 false))))%vector) + (Some (Fin.FS i))). + * exact Hstep. + * apply cons_pool_equ; [reflexivity |]. + apply replace_pool_idem_equ. + - discriminate Hlbl. + - (* Stepobs *) + dependent destruction Hlbl. + exists k. split. + + intro c. + rewrite (ictree_eta (v $ i)), <- Hot. + apply trans_vis. + + apply (trans_schedule_focused_fork n v i k (eq_sym Hot)). + - discriminate Hlbl. + Qed. + + Lemma remove_pool_agree {n} : + forall (v w : pool E (S n)) (i : Fin.t (S n)), + (forall j, i <> j -> (v $ j) ≅ (w $ j)) -> + pool_equ (v -- i) (w -- i). + Proof. + intros v w i Hag. + exact (vector_remove_pointwise (fun a b : thread E => a ≅ b) v w i Hag). + Qed. + + Lemma remove_replace_pool_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) + (a : thread E) : + pool_equ ((v @ i := a) -- i) (v -- i). + Proof. + apply remove_pool_agree. intros j Hij. + rewrite Vector.nth_replace_neq by congruence. reflexivity. + Qed. + + Lemma schedule_lift_ret n (v : pool E (S n)) (i : Fin.t (S n)) + (u : thread E) : + trans (val tt : label (yieldE + (forkE + E))) (v $ i) u -> + schedule (S n) v (Some i) ~ schedule n ((v -- i)) None. + Proof. + intro TR. + unfold trans in TR. + remember (observe (v $ i)) as ot eqn:Hot. + remember (observe u) as ou eqn:Hou. + remember (val tt : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. + revert v i u Hot Hou Hlbl. + induction TR; intros. + - (* Stepguard *) + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). + rewrite sb_guard. + rewrite (IHTR ((v @ i := t)) i u0 + ltac:(now rewrite Vector.nth_replace_eq) Hou Hlbl). + now rewrite (schedule_pool_proper n ((((v @ i := t)) -- i)) + ((v -- i)) None (remove_replace_pool_equ v i t)). + - discriminate Hlbl. + - discriminate Hlbl. + - (* Stepval *) + dependent destruction Hlbl. + rewrite (trans_schedule_focused_ret n v i (eq_sym Hot)). + apply sb_guard. + Qed. + + (** ** Phase 5: [schedule] preserves pool strong bisimilarity. *) + + Notation completed' := (completed E). + Notation stR R := (lattice.body (coinduction.t (sb eq)) R). + + Lemma schedule_match (R : rel completed' completed') + (Hch : forall m (w1 w2 : pool E m) f, + pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)) : + forall l os ot', trans_ l os ot' -> + forall n (v1 v2 : pool E n) focus (t' : completed'), + os = observe (schedule n v1 focus) -> + ot' = observe t' -> + pool_sbisim v1 v2 -> + exists u', trans l (schedule n v2 focus) u' /\ stR R t' u'. + Proof. + intros l os ot' TR. + induction TR; intros nn v1 v2 focus t' Hos Hot' Hpool. + - (* Stepguard *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 $ i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. + * (* Ret: recurse on the smaller pool *) + destruct r0. + rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + dependent destruction Hos. + destruct (IHTR n' ((v1 -- i)) ((v2 -- i)) None t' + eq_refl Hot' (remove_pool_sbisim v1 v2 i Hpool)) + as (u' & Htru & Hresu). + assert (Hvr : (v1 $ i) ≅ Ret tt). + { rewrite (ictree_eta (v1 $ i)), Hvi. reflexivity. } + assert (Htrv : trans (val tt : label (yieldE + (forkE + E))) + (v1 $ i) stuck). + { rewrite Hvr. apply trans_ret. } + destruct (sbisim_trans (v1 $ i) (v2 $ i) stuck (val tt) eq + (Hpool i) Htrv) as (lv & uv & Htr2v & Hlv & Hsbv). + subst lv. + assert (Hlift : schedule (S n') v2 (Some i) + ~ schedule n' ((v2 -- i)) None). + { apply (schedule_lift_ret n' v2 i uv Htr2v). } + destruct (sbisim_trans (schedule n' ((v2 -- i)) None) + (schedule (S n') v2 (Some i)) u' l eq + ltac:(symmetry; exact Hlift) Htru) + as (lq & uq & Htrq & Hlq & Hsbq). + subst lq. + exists uq. split. + -- exact Htrq. + -- rewrite <- Hsbq. exact Hresu. + * (* Br: schedule head is a Br, not a Guard *) + rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + discriminate Hos. + * (* Guard: recurse on the same pool, focus unchanged *) + rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + dependent destruction Hos. + apply (IHTR (S n') ((v1 @ i := g)) v2 (Some i) t' + eq_refl Hot'). + intro j. destruct (Fin.eq_dec i j) as [Hij | Hij]. + -- subst j. + rewrite Vector.nth_replace_eq. + assert (Hvg : (v1 $ i) ≅ Guard g). + { rewrite (ictree_eta (v1 $ i)), Hvi. reflexivity. } + transitivity (v1 $ i); [| apply Hpool]. + rewrite Hvg. symmetry. apply sb_guard. + -- rewrite Vector.nth_replace_neq by congruence. apply Hpool. + * (* Vis: Yield (Guard head), or Fork / user (Vis head) *) + destruct e0 as [yld | [frk | usr]]. + -- (* Yield: invert the focused-yield residual directly *) + destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + dependent destruction Hos. + assert (TR0 : trans l + (schedule (S n') ((v1 @ i := (k0 tt))) None) t'). + { unfold trans. rewrite <- Hot'. exact TR. } + apply trans_schedule_no_focus_inv in TR0 as (Hl & Hbr). + subst l. + assert (Hvis : (v1 $ i) ≅ Vis (inl Yield) k0). + { rewrite (ictree_eta (v1 $ i)), Hvi. reflexivity. } + assert (Htry : trans + (obs (inl Yield : yieldE + (forkE + E)) tt) (v1 $ i) (k0 tt)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 $ i) (v2 $ i) (k0 tt) + (obs (inl Yield : yieldE + (forkE + E)) tt) eq + (Hpool i) Htry) as (ly & uy & Htr2y & Hly & Hsby). + subst ly. + exists (Br n' (fun j => + schedule (S n') ((v2 @ i := uy)) (Some j))). split. + ++ apply (schedule_lift_yield n' v2 i uy Htr2y). + ++ rewrite Hbr. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + apply replace_pool_sbisim; assumption. + -- (* Fork: Vis head, not a Guard *) + destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- (* user: Vis head, not a Guard *) + rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. + - (* Steptau *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 $ i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + dependent destruction Hos. + assert (Htr1 : trans tau (v1 $ i) (k0 x)). + { rewrite (ictree_eta (v1 $ i)), Hvi. + apply trans_br with (x := x). reflexivity. } + destruct (sbisim_trans (v1 $ i) (v2 $ i) (k0 x) tau eq (Hpool i) Htr1) + as (l' & u' & Htr2 & Hl' & Hsb). + subst l'. + exists (schedule (S n') ((v2 @ i := u')) (Some i)). split. + -- apply schedule_lift_tau. exact Htr2. + -- assert (Ht' : t' ≅ schedule (S n') ((v1 @ i := (k0 x))) (Some i)). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. apply Hch. + apply replace_pool_sbisim; assumption. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. + - (* Stepobs *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 $ i)) as [r0 | b0 k0 | g | e1 k0] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e1 as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. + discriminate Hos. + -- (* Fork *) + destruct frk. + rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. + dependent destruction Hos. + destruct x. + assert (Hvis : (v1 $ i) ≅ Vis (inr (inl Fork)) k0). + { rewrite (ictree_eta (v1 $ i)), Hvi. reflexivity. } + assert (Htrf : trans + (obs (inr (inl Fork) : yieldE + (forkE + E)) false) (v1 $ i) + (k0 false)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 $ i) (v2 $ i) (k0 false) + (obs (inr (inl Fork)) false) eq (Hpool i) Htrf) + as (lf & uf & Htr2 & Hlf & Hsbf). + subst lf. + destruct (schedule_lift_fork n' v2 i false uf Htr2) + as (kf & Hforall & Hstep). + exists (schedule (S (S n')) + (((kf true) :: ((v2 @ i := (kf false))))%vector) + (Some (Fin.FS i))). + split. + ++ exact Hstep. + ++ assert (Ht' : t' ≅ schedule (S (S n')) + (((k0 true) :: ((v1 @ i := (k0 false))))%vector) + (Some (Fin.FS i))). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. + assert (Hii : (v2 $ i) ~ (v1 $ i)) by (symmetry; apply Hpool). + assert (Hkf : forall c, k0 c ~ kf c). + { intro c. + destruct (sbisim_trans (v2 $ i) (v1 $ i) (kf c) + (obs (inr (inl Fork)) c) eq Hii (Hforall c)) + as (lc & wc & Htrc & Hlc & Hsbc). + subst lc. + rewrite Hvis in Htrc. + apply trans_vis_inv in Htrc as (y & Hwy & Hly). + dependent destruction Hly. + rewrite Hwy in Hsbc. symmetry; exact Hsbc. } + apply Hch. + apply cons_pool_sbisim. + ** apply Hkf. + ** apply replace_pool_sbisim; [exact Hpool | apply Hkf]. + -- (* user event *) + rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. + dependent destruction Hos. + assert (Hvis : (v1 $ i) ≅ Vis (inr (inr usr)) k0). + { rewrite (ictree_eta (v1 $ i)), Hvi. reflexivity. } + assert (Htru : trans + (obs (inr (inr usr) : yieldE + (forkE + E)) x) (v1 $ i) (k0 x)). + { rewrite Hvis. apply trans_vis. } + destruct (sbisim_trans (v1 $ i) (v2 $ i) (k0 x) + (obs (inr (inr usr) : yieldE + (forkE + E)) x) eq + (Hpool i) Htru) + as (lu & u' & Htr2 & Hlu & Hsbu). + subst lu. + exists (schedule (S n') ((v2 @ i := u')) (Some i)). split. + ++ apply (schedule_lift_user n' v2 i usr x u' Htr2). + ++ assert (Ht' : t' ≅ + schedule (S n') ((v1 @ i := (k0 x))) (Some i)). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. apply Hch. + apply replace_pool_sbisim; assumption. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. + * (* None nonempty Yield *) + rewrite (schedule_no_focus_nonempty n' v1) in Hos. + dependent destruction Hos. + destruct x. + exists (Br n' (fun j => schedule (S n') v2 (Some j))). split. + -- apply (trans_schedule_no_focus_nonempty n' v2). + -- assert (Ht' : t' ≅ Br n' (fun j => schedule (S n') v1 (Some j))). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. exact Hpool. + - (* Stepval *) + destruct focus as [i | ]. + + destruct nn as [| n']; [inversion i | ]. + destruct (observe (v1 $ i)) as [r0 | b k | g | e k] eqn:Hvi. + * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_br n' v1 i b k Hvi) in Hos. + discriminate Hos. + * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. + discriminate Hos. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + rewrite (schedule_focused_yield n' v1 i k Hvi) in Hos. + discriminate Hos. + -- destruct frk. + rewrite (schedule_focused_fork n' v1 i k Hvi) in Hos. + discriminate Hos. + -- rewrite (schedule_focused_user_event n' v1 i usr k Hvi) in Hos. + discriminate Hos. + + destruct nn as [| n']. + * rewrite (schedule_empty_none v1) in Hos. + inversion Hos; subst. + exists stuck. split. + -- rewrite (trans_schedule_empty_ret v2). apply trans_ret. + -- assert (Ht' : t' ≅ stuck). + { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). + symmetry; assumption. } + rewrite Ht'. reflexivity. + * rewrite (schedule_no_focus_nonempty n' v1) in Hos. + discriminate Hos. + Qed. + + Theorem sbisim_schedule n (v1 v2 : pool E n) focus : + pool_sbisim v1 v2 -> schedule n v1 focus ~ schedule n v2 focus. + Proof. + revert n v1 v2 focus. + coinduction R CH. + intros n v1 v2 focus Hpool. + assert (Hch : forall m (w1 w2 : pool E m) f, + pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)). + { intros m w1 w2 f Hw. apply CH. exact Hw. } + split. + - intros l t' TR. + destruct (schedule_match R Hch _ _ _ TR n v1 v2 focus t' + eq_refl eq_refl Hpool) as (u' & Htru & Hres). + exists l, u'. split; [exact Htru | split; [exact Hres | reflexivity]]. + - intros l t' TR. + destruct (schedule_match R Hch _ _ _ TR n v2 v1 focus t' + eq_refl eq_refl (pool_sbisim_sym v1 v2 Hpool)) + as (u' & Htru & Hres). + exists l, u'. split; [exact Htru | split]. + + unfold Basics.flip. symmetry. exact Hres. + + reflexivity. + Qed. + + +End SchedulerTransitions. + +(** ** Instrumented scheduling respects [equ]-equal pools. *) +(** This is the bridge used to normalize a source denotation before applying a + singleton scheduler rule: it transports [pool_equ] through both erasures + and through state instrumentation. *) +Lemma instr_schedule_pool_equ {Σ} n (v v' : pool (stateE Σ) n) focus σ : + pool_equ v v' -> + instr_schedule n v focus σ ≅ instr_schedule n v' focus σ. +Proof. + intro Hvv. + unfold instr_schedule, interp_yield, interp_spawn, instr_stateE. + rewrite (schedule_pool_proper n v v' focus Hvv). + reflexivity. +Qed. diff --git a/theories/ICTree/Logic/AF.v b/theories/ICTree/Logic/AF.v index 643f4f5..8b5995d 100644 --- a/theories/ICTree/Logic/AF.v +++ b/theories/ICTree/Logic/AF.v @@ -10,11 +10,11 @@ From TICL Require Import ICTree.Equ ICTree.SBisim ICTree.Interp.Core - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Logic.Trans ICTree.Logic.CanStep Logic.Core - Logic.AX + ICTree.Logic.AX Logic.Kripke Logic.Setoid. diff --git a/theories/ICTree/Logic/CanStep.v b/theories/ICTree/Logic/CanStep.v index a0ed70c..c284e8f 100644 --- a/theories/ICTree/Logic/CanStep.v +++ b/theories/ICTree/Logic/CanStep.v @@ -7,7 +7,7 @@ From TICL Require Import ICTree.Core Events.Core ICTree.Logic.Trans - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.Writer ICTree.Equ Logic.Core diff --git a/theories/ICTree/Logic/EF.v b/theories/ICTree/Logic/EF.v index 4994ea9..4beaa94 100644 --- a/theories/ICTree/Logic/EF.v +++ b/theories/ICTree/Logic/EF.v @@ -16,7 +16,7 @@ From TICL Require Import ICTree.Logic.Trans ICTree.Logic.CanStep Logic.Core - Logic.EX. + ICTree.Logic.EX. Set Implicit Arguments. Generalizable All Variables. diff --git a/theories/ICTree/Logic/SchedulerFairness.v b/theories/ICTree/Logic/SchedulerFairness.v new file mode 100644 index 0000000..a2c9d5b --- /dev/null +++ b/theories/ICTree/Logic/SchedulerFairness.v @@ -0,0 +1,2513 @@ +From Stdlib Require Import + Fin + Vector + Program.Equality. +From Coinduction Require Import lattice. +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.Interp.Core + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.CanStep + ICTree.Logic.Trans + ICTree.Trans + Events.Core + Logic.Core + Logic.Kripke + ICTree.Events.Yield + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim + Utils.Vectors + ICTree.SBisim. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. + +(** Proof-facing scheduler observations for local fairness reasoning. + + The core scheduler is left unchanged. This module mirrors [schedule] with + an additive observation tier that records no-focus scheduling points and + the finite set of slots offered at each such point. *) + +Definition LiveSlot (n : nat) : Type := Fin.t n. + +Record SlotRef : Type := { + slot_pool_size : nat; + slot_live_slot : LiveSlot slot_pool_size; +}. + +Definition live_slot_ref {n : nat} (i : LiveSlot n) : SlotRef := + {| slot_pool_size := n; slot_live_slot := i |}. + +Variant SchedulerObs : Type := +| ObsSchedulingPoint : nat -> SchedulerObs +| ObsOffered : SlotRef -> SchedulerObs. + +Definition schedulerObsE : Type := SchedulerObs. + +#[global] Instance Encode_schedulerObsE : Encode SchedulerObs := + fun _ => unit. + +Definition scheduler_observedE (E : Type) : Type := + schedulerObsE + (yieldE + (spawnE + E)). + +Definition observed_completed (E : Type) `{Encode E} : Type := + ictree (scheduler_observedE E) unit. + +Definition observed_scheduling_point (n : nat) (obs : schedulerObsE) : Prop := + obs = ObsSchedulingPoint n. + +Definition offer_live_slot_obs (n : nat) (i : LiveSlot n) + (obs : schedulerObsE) : Prop := + obs = ObsOffered (live_slot_ref i). + +Definition offer_live_slot {E : Type} `{Encode E} + (n : nat) (i : LiveSlot n) : ticll (scheduler_observedE E) := + CNow (fun w => w = Obs (inl (ObsOffered (live_slot_ref i))) tt). + +Definition recognize_live_slot {E : Type} `{Encode E} + (n : nat) (_ : pool E n) (_ : LiveSlot n) : Prop := + True. + +Lemma live_slot_one_eq (i j : LiveSlot 1) : i = j. +Proof. + refine (Fin.caseS' i (fun i => forall j, i = j) _ _ j). + - intro j'. + refine (Fin.caseS' j' (fun j => Fin.F1 = j) eq_refl _). + intro j0. + exact (Fin.case0 (fun j0 => Fin.F1 = Fin.FS j0) j0). + - intro i0. + exact (Fin.case0 (fun i0 => forall j, Fin.FS i0 = j) i0). +Qed. + +Section ObservedScheduler. + Context {E : Type} `{Encode E}. + + Definition emit_scheduler_obs (obs : schedulerObsE) : observed_completed E := + Vis (inl obs) (fun _ : unit => Ret tt). + + Fixpoint emit_live_slot_offers_into_then + (m n : nat) (embed : LiveSlot n -> LiveSlot m) + (k : observed_completed E) {struct n} : observed_completed E := + match n return (LiveSlot n -> LiveSlot m) -> observed_completed E with + | 0 => fun _ => k + | S n' => fun embed => + Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun i => embed (Fin.FS i)) k) + end embed. + + Definition emit_live_slot_offers_then + (n : nat) (k : observed_completed E) : observed_completed E := + emit_live_slot_offers_into_then n n (fun i => i) k. + + Definition emit_live_slot_offers (n : nat) : observed_completed E := + emit_live_slot_offers_then n (Ret tt). + + (** Observed scheduler. The only extra visible events are proof-facing + [schedulerObsE] events at nonempty no-focus scheduling points. *) + CoFixpoint schedule_with_offers + (n : nat) (v : pool E n) (focus : option (Fin.t n)) + : observed_completed E := + match focus with + | None => + match n return pool E n -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inl (ObsSchedulingPoint (S n'))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n') (S n') + (fun i => i) v) + end v + | Some i => + match n return pool E n -> Fin.t n -> observed_completed E with + | 0 => fun _ i => match i with end + | S n' => fun v i => + match observe (v $ i) with + | RetF _ => + Guard (schedule_with_offers n' ((v -- i)) None) + | BrF b k => + Br b (fun j => + schedule_with_offers (S n') + ((v @ i := (k j))) (Some i)) + | GuardF t => + Guard (schedule_with_offers (S n') + ((v @ i := t)) (Some i)) + | VisF e k => + match e as e0 return + (encode e0 -> thread E) -> observed_completed E with + | inl Yield => fun k => + Guard (schedule_with_offers (S n') + ((v @ i := (k tt))) None) + | inr (inl Fork) => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inl Spawn)) + : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))) + | inr (inr e') => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inr e')) + : scheduler_observedE E) + (fun x => schedule_with_offers (S n') + ((v @ i := (k x))) (Some i))) + end k + end + end v i + end + with schedule_with_offers_offer_prefix + (pool_size remaining : nat) + (embed : LiveSlot remaining -> LiveSlot pool_size) + (v : pool E pool_size) : observed_completed E := + match remaining return + (LiveSlot remaining -> LiveSlot pool_size) -> + pool E pool_size -> observed_completed E with + | 0 => fun _ v => + match pool_size return pool E pool_size -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inr (inl Yield) : scheduler_observedE E) + (fun _ : unit => + Br n' (fun i => + schedule_with_offers (S n') v (Some i))) + end v + | S n' => fun embed v => + Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix pool_size n' + (fun i => embed (Fin.FS i)) v) + end embed v. + + Definition observe_scheduler_offers + (n : nat) (v : pool E n) (focus : option (Fin.t n)) + : observed_completed E := + schedule_with_offers n v focus. + + Definition handle_scheduler_offers + : scheduler_observedE E ~> ictree (yieldE + (spawnE + E)) := + fun event => + match event with + | inl _ => Ret tt + | inr event' => ICtree.trigger event' + end. + + Definition forget_scheduler_offers {X} + (t : ictree (scheduler_observedE E) X) + : ictree (yieldE + (spawnE + E)) X := + interp handle_scheduler_offers t. + + Lemma handle_scheduler_offers_obs obs : + handle_scheduler_offers (inl obs) = Ret tt. + Proof. reflexivity. Qed. + + Lemma handle_scheduler_offers_visible event : + handle_scheduler_offers (inr event) = ICtree.trigger event. + Proof. reflexivity. Qed. + + Lemma forget_scheduler_offers_no_focus_nonempty_unfold n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ + Guard (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. reflexivity. + Qed. + + Theorem forget_scheduler_offers_preserves_schedule_exact_no_focus_impossible n + (v : pool E (S n)) : + ~ forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ + schedule (S n) v None. + Proof. + intro Heq. + step in Heq. + cbn in Heq. + inversion Heq. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_succ_stutter m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m (S n) embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_stutter m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m r embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m 0 + (fun i : LiveSlot 0 => match i with end) v). + Proof. + revert m embed v. + induction r as [| r IHr]; intros m embed v. + - destruct m as [| m']. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + apply sb_ret. reflexivity. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + reflexivity. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix m r + (fun i => embed (Fin.FS i)) v)). + + apply forget_scheduler_offers_offer_prefix_succ_stutter. + + apply IHr. + Qed. + + Lemma forget_scheduler_offers_no_focus_stutters_to_offer_prefix n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v). + Proof. + rewrite forget_scheduler_offers_no_focus_nonempty_unfold. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_zero_nonempty_unfold n + (embed : LiveSlot 0 -> LiveSlot (S n)) (v : pool E (S n)) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 embed v) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard_l. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_br_id. intro i. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_no_focus_projection_to_focused n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + - apply forget_scheduler_offers_no_focus_stutters_to_offer_prefix. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 + (fun i : LiveSlot 0 => match i with end) v)). + + apply forget_scheduler_offers_offer_prefix_stutter. + + apply forget_scheduler_offers_offer_prefix_zero_nonempty_unfold. + Qed. + + Lemma emit_live_slot_offers_into_then_zero m + (embed : LiveSlot 0 -> LiveSlot m) k : + emit_live_slot_offers_into_then m 0 embed k = k. + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_into_then_succ m n + (embed : LiveSlot (S n) -> LiveSlot m) k : + observe (emit_live_slot_offers_into_then m (S n) embed k) = + VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + emit_live_slot_offers_into_then m n + (fun i => embed (Fin.FS i)) k). + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_zero : + observe (emit_live_slot_offers 0) = RetF tt. + Proof. reflexivity. Qed. + + Lemma emit_live_slot_offers_succ n : + observe (emit_live_slot_offers (S n)) = + VisF (inl (ObsOffered (live_slot_ref (Fin.F1 : LiveSlot (S n))))) + (fun _ : unit => + emit_live_slot_offers_into_then (S n) n + (fun i => Fin.FS i) (Ret tt)). + Proof. reflexivity. Qed. + + Local Ltac solve_focused_schedule_with_offers H := + lazy [schedule_with_offers observe _observe]; + match type of H with + | observe (Vector.nth ?v ?i) = _ => + change (@_observe _ _ unit (Vector.nth v i)) with (observe (Vector.nth v i)); + rewrite H; + reflexivity + end. + + Lemma schedule_with_offers_empty_none (v : pool E 0) : + observe (schedule_with_offers 0 v None) = RetF tt. + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_no_focus_nonempty n + (v : pool E (S n)) : + observe (schedule_with_offers (S n) v None) = + VisF (inl (ObsSchedulingPoint (S n))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n) (S n) + (fun i => i) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_offer_prefix_zero m + (embed : LiveSlot 0 -> LiveSlot m) (v : pool E m) : + observe (schedule_with_offers_offer_prefix m 0 embed v) = + match m return pool E m -> ictree' (scheduler_observedE E) unit with + | 0 => fun _ => RetF tt + | S n => fun v => + VisF (inr (inl Yield) : scheduler_observedE E) + (fun _ : unit => + Br n (fun i => schedule_with_offers (S n) v (Some i))) + end v. + Proof. destruct m; reflexivity. Qed. + + Lemma schedule_with_offers_offer_prefix_succ m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + observe (schedule_with_offers_offer_prefix m (S n) embed v) = + VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_focused_ret n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers n ((v -- i)) None). + Proof. + intro Hret. + solve_focused_schedule_with_offers Hret. + Qed. + + Lemma schedule_with_offers_focused_br n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + observe (schedule_with_offers (S n) v (Some i)) = + BrF b (fun j => + schedule_with_offers (S n) ((v @ i := (k j))) (Some i)). + Proof. + intro Hbr. + solve_focused_schedule_with_offers Hbr. + Qed. + + Lemma schedule_with_offers_focused_guard n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hg. + solve_focused_schedule_with_offers Hg. + Qed. + + Lemma schedule_with_offers_focused_yield n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) + ((v @ i := (k tt))) None). + Proof. + intro Hy. + solve_focused_schedule_with_offers Hy. + Qed. + + Lemma schedule_with_offers_focused_fork n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inl Spawn)) : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + Proof. + intro Hf. + solve_focused_schedule_with_offers Hf. + Qed. + + Lemma schedule_with_offers_focused_user_event n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inr e)) : scheduler_observedE E) + (fun x => schedule_with_offers (S n) + ((v @ i := (k x))) (Some i)). + Proof. + intro Hu. + solve_focused_schedule_with_offers Hu. + Qed. + + Lemma focused_yield_returns_to_scheduling_point n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) + ((v @ i := (k tt))) None). + Proof. apply schedule_with_offers_focused_yield. Qed. + + Lemma forget_scheduler_offers_empty_no_focus_projection + (v : pool E 0) : + forget_scheduler_offers (schedule_with_offers 0 v None) ~ Ret tt. + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_ret. reflexivity. + Qed. + + Lemma forget_scheduler_offers_focused_ret_projection n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers (schedule_with_offers n ((v -- i)) None). + Proof. + intro Hret. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_ret n v i Hret). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_br_projection n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Br b (fun j => + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := (k j))) (Some i))). + Proof. + intro Hbr. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + cbn. + apply sb_br_id. intro j. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_guard_projection n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hguard. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_guard n v i t Hguard). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_yield_projection n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := (k tt))) None). + Proof. + intro Hyield. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_yield n v i k Hyield). + cbn. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_fork_projection n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => + forget_scheduler_offers (schedule_with_offers (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_user_event_projection n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := (k x))) (Some i))). + Proof. + intro Huser. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intro x. + apply sb_guard. + Qed. + + Local Notation completed' := (completed E). + Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). + + Local Definition erased_schedule (n : nat) (v : pool E n) + (focus : option (Fin.t n)) : completed E := + forget_scheduler_offers (schedule_with_offers n v focus). + + Local Lemma erased_focused_ret_equ n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule n ((v -- i)) None). + Proof. + intro Hret. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_ret n v i Hret). + reflexivity. + Qed. + + Local Lemma erased_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + erased_schedule (S n) v (Some i) ≅ + Br b (fun j => Guard (erased_schedule (S n) + ((v @ i := (k j))) (Some i))). + Proof. + intro Hbr. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma erased_focused_guard_equ n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hguard. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_guard n v i t Hguard). + reflexivity. + Qed. + + Local Lemma erased_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) ((v @ i := (k tt))) None). + Proof. + intro Hyield. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma erased_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma erased_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n) + ((v @ i := (k x))) (Some i))). + Proof. + intro Huser. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma schedule_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + schedule (S n) v (Some i) ≅ + Guard (schedule (S n) ((v @ i := (k tt))) None). + Proof. + intro Hyield. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma guard_residual_from_equ (actual target residual : completed') : + observe actual = GuardF residual -> + actual ≅ Guard target -> + residual ≅ target. + Proof. + intros Hobs Heq. + apply equ_guard_invE. + transitivity actual. + - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. + - exact Heq. + Qed. + + Local Ltac contradiction_from_shape_equ actual Hobs Heq := + exfalso; + rewrite (ictree_eta actual) in Heq; + rewrite <- Hobs in Heq; + step in Heq; inversion Heq. + + Local Lemma erased_schedule_match_left_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ erased_schedule 0 v None -> + trans l actual t' -> + exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + - rewrite (trans_schedule_empty_ret v). apply trans_ret. + - rewrite Hsb. rewrite Hmid. reflexivity. + Qed. + + Local Lemma erased_schedule_match_left_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ erased_schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n (fun i => + erased_schedule (S n) v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (Br n (fun i => schedule (S n) v (Some i))). split. + - apply trans_schedule_no_focus_nonempty. + - rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n) + ((v @ i := (k j))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + exists (schedule (S n) ((v @ i := (k j))) (Some i)). + split. + - apply trans_schedule_focused_br. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). split. + - apply trans_schedule_focused_fork. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n) + ((v @ i := (k x))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + exists (schedule (S n) ((v @ i := (k x))) (Some i)). + split. + - apply trans_schedule_focused_user_event. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma schedule_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + schedule (S n) v (Some i) ≅ + Br b (fun j => schedule (S n) ((v @ i := (k j))) (Some i)). + Proof. + intro Hbr. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma schedule_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + Proof. + intro Hfork. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_fork n v i k Hfork). + reflexivity. + Qed. + + Local Lemma schedule_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => schedule (S n) ((v @ i := (k x))) (Some i)). + Proof. + intro Huser. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_user_event n v i e k Huser). + reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ schedule 0 v None -> + trans l actual t' -> + exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + assert (Hret : actual ~ Ret tt). + { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hret TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + assert (Hproj : Ret tt ~ erased_schedule 0 v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as + [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + set (sres := Br n (fun i => schedule (S n) v (Some i))). + set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). + assert (Hshape : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) + lres). + { apply trans_vis. } + assert (Hproj : + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ + erased_schedule (S n) v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans _ _ lres + (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun j => + schedule (S n) ((v @ i := (k j))) (Some i)). + set (lres := fun j => + erased_schedule (S n) ((v @ i := (k j))) (Some i)). + assert (Hshape : actual ~ Br b sres). + { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans tau (Br b lres) (lres j)). + { apply trans_br with (x := j). reflexivity. } + assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_br_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) + as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + set (lres := erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + assert (Hshape : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres)) lres). + { apply trans_vis. } + assert (Hproj : + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres) ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } + destruct (sbisim_trans _ _ lres + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun x => + schedule (S n) ((v @ i := (k x))) (Some i)). + set (lres := fun x => + erased_schedule (S n) ((v @ i := (k x))) (Some i)). + assert (Hshape : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) sres). + { rewrite Hactual. + rewrite (schedule_focused_user_event_equ n v i e k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans + (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). + { apply trans_vis. } + assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres x) + (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ erased_schedule n v focus -> + exists u', trans l (schedule n v focus) u' /\ stR R t' u'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule n' ((v -- i)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' ((v -- i)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_ret n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n') + ((v @ i := (k j))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid ->]]. + exists (schedule (S n') ((v @ i := (k j))) (Some i)). + split. + -- apply trans_schedule_focused_br. exact Hvi. + -- rewrite Hsb. rewrite Hmid. apply Hch. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + assert (Ht : t ≅ + erased_schedule (S n') ((v @ i := g)) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_guard n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule (S n') + ((v @ i := (k tt))) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := (k tt))) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (schedule (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). split. + ++ apply trans_schedule_focused_fork. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + -- assert (Hproj : actual ~ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n') + ((v @ i := (k x))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + exists (schedule (S n') ((v @ i := (k x))) (Some i)). + split. + ++ apply trans_schedule_focused_user_event. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + + destruct nn as [| n']. + * assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + -- rewrite (trans_schedule_empty_ret v). apply trans_ret. + -- rewrite Hsb. rewrite Hmid. reflexivity. + * assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n' (fun i => + erased_schedule (S n') v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (Br n' (fun i => schedule (S n') v (Some i))). split. + -- apply trans_schedule_no_focus_nonempty. + -- rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_left_br; eauto. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (((k0 true) :: ((v @ i := (k0 false))))%vector) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + ((v @ i := (k0 x))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + ((v @ i := (k0 j))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_left_fork; eauto. + -- eapply erased_schedule_match_left_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + ((v @ i := (k0 j))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (((k0 true) :: ((v @ i := (k0 false))))%vector) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + ((v @ i := (k0 x))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + Qed. + + Local Lemma erased_schedule_match_right (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ schedule n v focus -> + exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + assert (Ht : t ≅ schedule n' ((v -- i)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' ((v -- i)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_ret_equ n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + assert (Ht : t ≅ + schedule (S n') ((v @ i := g)) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_guard_equ n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ schedule (S n') + ((v @ i := (k tt))) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := (k tt))) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (erased_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + Qed. + + Theorem forget_scheduler_offers_preserves_schedule + n (v : pool E n) focus : + forget_scheduler_offers (schedule_with_offers n v focus) ~ + schedule n v focus. + Proof. + change (erased_schedule n v focus ~ schedule n v focus). + revert n v focus. + coinduction R CH. + intros n v focus. + assert (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)). + { intros m w f. apply CH. } + split. + - intros l t' TR. + destruct (erased_schedule_match_left R Hch _ _ _ TR + (erased_schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + exact Hres. + + reflexivity. + - intros l t' TR. + destruct (erased_schedule_match_right R Hch _ _ _ TR + (schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + unfold Basics.flip. exact Hres. + + reflexivity. + Qed. + + Record ReturnSlotTransport {n : nat} + (v : pool E (S n)) (removed : LiveSlot (S n)) + (v' : pool E n) : Prop := { + return_new_slots_come_from_old_survivors : + forall j_new : LiveSlot n, + exists j_old : LiveSlot (S n), + j_old <> removed /\ (v' $ j_new) = (v $ j_old); + return_old_survivors_reappear : + forall j_old : LiveSlot (S n), + j_old <> removed -> + exists j_new : LiveSlot n, (v' $ j_new) = (v $ j_old) + }. + + Theorem return_removes_live_slot n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + ReturnSlotTransport v i (v -- i). + Proof. + intro Hret; clear Hret. + revert v i. + induction n as [| n IH]; intros v i. + - constructor. + + intro j_new. inversion j_new. + + intros j_old Hneq. + contradiction Hneq. apply live_slot_one_eq. + - refine (Vector.caseS' v + (fun v0 => ReturnSlotTransport v0 i (v0 -- i)) _). + clear v; intros h tl. + refine (Fin.caseS' i + (fun i0 => ReturnSlotTransport ((h :: tl)%vector) i0 + (((h :: tl)%vector) -- i0)) _ _); clear i. + + rewrite vector_remove_head. + constructor. + * intro j_new. + exists (Fin.FS j_new). split; [discriminate | reflexivity]. + * intros j_old Hneq. + refine (Fin.caseS' j_old + (fun j => j <> Fin.F1 -> + exists j_new : LiveSlot (S n), + (tl $ j_new) = (((h :: tl)%vector) $ j)) _ _ Hneq). + -- intro Hcontra. contradiction Hcontra; reflexivity. + -- intros j_new _. exists j_new. reflexivity. + + intro i_tail. + rewrite vector_remove_tail. + destruct (IH tl i_tail) as [IHnew IHold]. + constructor. + * intro j_new. + refine (Fin.caseS' j_new + (fun j => exists j_old : LiveSlot (S (S n)), + j_old <> Fin.FS i_tail /\ + (((h :: (tl -- i_tail))%vector) $ j) + = (((h :: tl)%vector) $ j_old)) _ _). + -- exists Fin.F1. split; [discriminate | reflexivity]. + -- intro j_new'. + destruct (IHnew j_new') as [j_old [Hneq Hv]]. + exists (Fin.FS j_old). split. + ++ intro Heq. apply Fin.FS_inj in Heq. + contradiction Hneq. + ++ exact Hv. + * intros j_old Hneq. + refine (Fin.caseS' j_old + (fun j => j <> Fin.FS i_tail -> + exists j_new : LiveSlot (S n), + (((h :: (tl -- i_tail))%vector) $ j_new) + = (((h :: tl)%vector) $ j)) _ _ Hneq). + -- intros _. exists Fin.F1. reflexivity. + -- intros j_old' Hneq'. + assert (Hsurv : j_old' <> i_tail) by + (intro Heq; subst; apply Hneq'; reflexivity). + destruct (IHold j_old' Hsurv) as [j_new Hv]. + exists (Fin.FS j_new). exact Hv. + Qed. + + Definition shift_live_slot_across_spawn {n : nat} + (i : LiveSlot n) : LiveSlot (S n) := + Fin.FS i. + + Lemma shift_live_slot_across_spawn_head {n} + (child : thread E) (v : pool E n) : + (((child :: v)%vector) $ Fin.F1) = child. + Proof. reflexivity. Qed. + + Lemma shift_live_slot_across_spawn_tail {n} + (child : thread E) (v : pool E n) (i : LiveSlot n) : + (((child :: v)%vector) $ (shift_live_slot_across_spawn i)) = (v $ i). + Proof. reflexivity. Qed. + + Lemma shift_live_slot_across_spawn_parent_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + ((((k true) :: (v @ i := (k false)))%vector) + $ (shift_live_slot_across_spawn i)) = k false. + Proof. + rewrite shift_live_slot_across_spawn_tail. + apply Vector.nth_replace_eq. + Qed. + + Lemma shift_live_slot_across_spawn_other_slot n + (v : pool E (S n)) (i j : LiveSlot (S n)) k : + i <> j -> + ((((k true) :: (v @ i := (k false)))%vector) + $ (shift_live_slot_across_spawn j)) = (v $ j). + Proof. + intro Hneq. + rewrite shift_live_slot_across_spawn_tail. + apply Vector.nth_replace_neq. congruence. + Qed. + + Lemma transport_live_slots_across_spawn_head {n} + (child : thread E) (v : pool E n) : + (((child :: v)%vector) $ Fin.F1) = child. + Proof. apply shift_live_slot_across_spawn_head. Qed. + + Lemma transport_live_slots_across_spawn_tail {n} + (child : thread E) (v : pool E n) (i : LiveSlot n) : + (((child :: v)%vector) $ (shift_live_slot_across_spawn i)) = (v $ i). + Proof. apply shift_live_slot_across_spawn_tail. Qed. + + Lemma transport_live_slots_across_spawn_parent_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + ((((k true) :: (v @ i := (k false)))%vector) + $ (shift_live_slot_across_spawn i)) = k false. + Proof. apply shift_live_slot_across_spawn_parent_slot. Qed. + + Lemma transport_live_slots_across_spawn_other_slot n + (v : pool E (S n)) (i j : LiveSlot (S n)) k : + i <> j -> + ((((k true) :: (v @ i := (k false)))%vector) + $ (shift_live_slot_across_spawn j)) = (v $ j). + Proof. apply shift_live_slot_across_spawn_other_slot. Qed. + + Record SpawnSlotTransport {n : nat} + (v : pool E (S n)) (parent : LiveSlot (S n)) + (k : bool -> thread E) (spawned : pool E (S (S n))) : Prop := { + spawn_child_at_head : (spawned $ Fin.F1) = k true; + spawn_parent_at_shifted_slot : (spawned $ (Fin.FS parent)) = k false; + spawn_other_old_slots_shifted : + forall j : LiveSlot (S n), + j <> parent -> (spawned $ (Fin.FS j)) = (v $ j) + }. + + Theorem transport_live_slots_across_spawn n + (v : pool E (S n)) (i : LiveSlot (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + SpawnSlotTransport v i k ((k true :: (v @ i := (k false)))%vector). + Proof. + intro Hfork; clear Hfork. + constructor. + - reflexivity. + - exact (Vector.nth_replace_eq _ _ i v (k false)). + - intros j Hneq. + exact (Vector.nth_replace_neq _ _ j i Hneq v (k false)). + Qed. + + Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) + : observed_completed E -> Prop := + | offered_prefix_here t k : + observe t = VisF (inl (ObsOffered (live_slot_ref i))) k -> + offered_in_scheduler_prefix n i t + | offered_prefix_later t obs k : + observe t = VisF (inl obs) k -> + offered_in_scheduler_prefix n i (k tt) -> + offered_in_scheduler_prefix n i t. + + Lemma emit_live_slot_offers_into_then_offers m : + forall n (embed : LiveSlot n -> LiveSlot m) k (i : LiveSlot n), + offered_in_scheduler_prefix m (embed i) + (emit_live_slot_offers_into_then m n embed k). + Proof. + intros n embed k i. + induction i as [n' | n' i IH]. + - apply offered_prefix_here with + (k := fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun i => embed (Fin.FS i)) k). + reflexivity. + - apply offered_prefix_later with + (obs := ObsOffered (live_slot_ref (embed Fin.F1))) + (k := fun _ : unit => + emit_live_slot_offers_into_then m n' + (fun j => embed (Fin.FS j)) k). + + reflexivity. + + apply (IH (fun j => embed (Fin.FS j))). + Qed. + + Lemma emit_live_slot_offers_then_offers n k (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers_then n k). + Proof. + unfold emit_live_slot_offers_then. + apply (emit_live_slot_offers_into_then_offers n n (fun i => i) k i). + Qed. + + Lemma emit_live_slot_offers_offers n (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers n). + Proof. + apply emit_live_slot_offers_then_offers. + Qed. + + Lemma emit_live_slot_offers_contains_every_slot n (i : LiveSlot n) : + offered_in_scheduler_prefix n i (emit_live_slot_offers n). + Proof. + apply emit_live_slot_offers_offers. + Qed. + + Lemma schedule_with_offers_offer_prefix_offers m : + forall n (embed : LiveSlot n -> LiveSlot m) (v : pool E m) + (i : LiveSlot n), + offered_in_scheduler_prefix m (embed i) + (schedule_with_offers_offer_prefix m n embed v). + Proof. + intros n embed v i. + induction i as [n' | n' i IH]. + - apply offered_prefix_here with + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun i => embed (Fin.FS i)) v). + apply schedule_with_offers_offer_prefix_succ. + - apply offered_prefix_later with + (obs := ObsOffered (live_slot_ref (embed Fin.F1))) + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun j => embed (Fin.FS j)) v). + + apply schedule_with_offers_offer_prefix_succ. + + apply (IH (fun j => embed (Fin.FS j))). + Qed. + + Lemma offer_live_slot_now n (i : LiveSlot n) + (t : observed_completed E) : + <( {t}, {Obs (inl (ObsOffered (live_slot_ref i))) tt} |= + {offer_live_slot n i} )>. + Proof. + unfold offer_live_slot. + split; [reflexivity | constructor]. + Qed. + + Lemma observed_equ_refl_no_eqdep (t : observed_completed E) : t ≅ t. + Proof. + unfold equ. + apply (leq_gfp (@fequ _ _ unit unit eq) + (fun u v : observed_completed E => u = v)). + - intros u v <-. cbn. destruct (observe u); constructor; auto. + - reflexivity. + Qed. + + Lemma observed_equ_step_no_eqdep (t u : observed_completed E) : + t ≅ u -> equF eq (equ eq) (observe t) (observe u). + Proof. + intro Htu. unfold equ in Htu. + exact (proj1 (gfp_fp (@fequ _ _ unit unit eq) t u) Htu). + Qed. + + Definition equF_scheduler_vis_result + (p q : ictree' (scheduler_observedE E) unit) : Prop := + match q with + | VisF (inl sched_obs) k_right => + exists k_left, + p = VisF (inl sched_obs) k_left /\ k_left tt ≅ k_right tt + | _ => True + end. + + Lemma equF_scheduler_vis_inv_no_eqdep p q : + equF eq (equ eq) p q -> equF_scheduler_vis_result p q. + Proof. + intro Hf. + destruct Hf as [x y Hxy | e k1 k2 Hk | t1 t2 Ht | + n k1 k2 Hk]; cbn; try exact I. + destruct e as [sched_obs | rest]; cbn; try exact I. + exists k1. split; [reflexivity | apply Hk]. + Qed. + + Lemma equ_scheduler_vis_inv_from_observe_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + t ≅ u -> + observe u = VisF (inl obs) k -> + exists k_t, observe t = VisF (inl obs) k_t /\ k_t tt ≅ k tt. + Proof. + intros Htu Hu. + pose proof (equF_scheduler_vis_inv_no_eqdep _ _ + (observed_equ_step_no_eqdep _ _ Htu)) as Hshape. + rewrite Hu in Hshape. + exact Hshape. + Qed. + + Lemma ktrans_vis_raw_inv_no_eqdep {X} (e : scheduler_observedE E) + (k : encode e -> ictree (scheduler_observedE E) X) + (w : World (scheduler_observedE E)) t' w' : + |Vis e k, w| ↦ |t', w'| -> + exists v (target : ictree (scheduler_observedE E) X), + w' = Obs e v /\ observe target = observe t' /\ + target ≅ k v /\ not_done w. + Proof. + intro Htr. + cbn in Htr. + refine (match Htr in ktrans_ ot w0 ot' w0' return + match ot with + | VisF e0 k0 => + exists v (target : ictree (scheduler_observedE E) X), + w0' = Obs e0 v /\ observe target = ot' /\ + target ≅ k0 v /\ not_done w0 + | _ => True + end with + | KtransObs e0 v k0 target w0 Hnd Heq => _ + | _ => I + end). + exists v, target. + split; [reflexivity | split; [reflexivity | split; assumption]]. + Qed. + + Lemma ktrans_scheduler_vis_inv_no_eqdep {X} (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + ictree (scheduler_observedE E) X) + (w : World (scheduler_observedE E)) t' w' : + |Vis (inl obs) k, w| ↦ |t', w'| -> + exists target : ictree (scheduler_observedE E) X, + w' = Obs (inl obs) tt /\ observe target = observe t' /\ + target ≅ k tt /\ not_done w. + Proof. + intro Htr. + destruct (ktrans_vis_raw_inv_no_eqdep _ _ _ _ _ Htr) as + [v [target [Hw [Ht [Heq Hnd]]]]]. + destruct v. + exists target. split; [exact Hw | split; [exact Ht | split; assumption]]. + Qed. + + Inductive SchedulerEquChain : + observed_completed E -> observed_completed E -> Prop := + | scheduler_equ_chain_refl t : SchedulerEquChain t t + | scheduler_equ_chain_cons t u v : + t ≅ u -> + SchedulerEquChain u v -> + SchedulerEquChain t v. + + Lemma scheduler_equ_chain_scheduler_vis_inv_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + SchedulerEquChain t u -> + observe u = VisF (inl obs) k -> + exists k_t, + observe t = VisF (inl obs) k_t /\ + SchedulerEquChain (k_t tt) (k tt). + Proof. + intros Hchain Hobs. + induction Hchain as [u | t mid u Htm _ IH]. + - exists k. split; [exact Hobs | constructor]. + - destruct (IH Hobs) as [k_mid [Hmid Hcont]]. + destruct (equ_scheduler_vis_inv_from_observe_no_eqdep obs k_mid + t mid Htm Hmid) as [k_t [Ht Hstep]]. + exists k_t. split; [exact Ht |]. + econstructor; [exact Hstep | exact Hcont]. + Qed. + + Lemma offered_in_scheduler_prefix_chain_implies_AF n + (i : LiveSlot n) (u actual bridge : observed_completed E) w : + observe bridge = observe actual -> + SchedulerEquChain bridge u -> + not_done w -> + offered_in_scheduler_prefix n i u -> + <( {actual}, w |= AF {offer_live_slot n i} )>. + Proof. + intros Hbridge Hchain Hnd Hprefix. + revert actual bridge w Hbridge Hchain Hnd. + induction Hprefix as [u k Hobs | u obs k Hobs _ IH]; + intros actual bridge w Hbridge Hchain Hnd. + - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep + (ObsOffered (live_slot_ref i)) k bridge u Hchain Hobs) as + [k_actual [Hactual Hcont]]. + rewrite unfold_entailsL. + apply StepA. + split. + + split; [exact I | exact Hnd]. + + split. + * exists (k_actual tt), + (Obs (inl (ObsOffered (live_slot_ref i))) tt). + cbn. rewrite <- Hbridge, Hactual. + constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. + * intros t' w' Htr. + cbn in Htr. + rewrite <- Hbridge, Hactual in Htr. + destruct (ktrans_scheduler_vis_inv_no_eqdep + (ObsOffered (live_slot_ref i)) k_actual w t' w' Htr) as + [target [Hw' [Htarget [Heqtarget Hsource]]]]. + subst w'. + apply MatchA. + unfold offer_live_slot. + split; [reflexivity | constructor]. + - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep + obs k bridge u Hchain Hobs) as [k_actual [Hactual Hcont]]. + rewrite unfold_entailsL. + apply StepA. + split. + + split; [exact I | exact Hnd]. + + split. + * exists (k_actual tt), (Obs (inl obs) tt). + cbn. rewrite <- Hbridge, Hactual. + constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. + * intros t' w' Htr. + cbn in Htr. + rewrite <- Hbridge, Hactual in Htr. + destruct (ktrans_scheduler_vis_inv_no_eqdep obs + k_actual w t' w' Htr) as + [target [Hw' [Htarget [Heqtarget Hsource]]]]. + subst w'. + specialize (IH t' target (Obs (inl obs) tt) Htarget + (scheduler_equ_chain_cons target (k_actual tt) (k tt) + Heqtarget Hcont) (NotDoneObs (inl obs) tt)). + rewrite unfold_entailsL in IH. + exact IH. + Qed. + + Theorem offered_in_scheduler_prefix_implies_AF n + (i : LiveSlot n) (t : observed_completed E) w : + not_done w -> + offered_in_scheduler_prefix n i t -> + <( {t}, w |= AF {offer_live_slot n i} )>. + Proof. + intros Hnd Hprefix. + eapply offered_in_scheduler_prefix_chain_implies_AF. + - reflexivity. + - constructor. + - exact Hnd. + - exact Hprefix. + Qed. + + Lemma show_no_focus_offers_every_live_slot_prefix n + (v : pool E (S n)) (i : LiveSlot (S n)) : + offered_in_scheduler_prefix (S n) i + (schedule_with_offers (S n) v None). + Proof. + eapply offered_prefix_later. + - apply schedule_with_offers_no_focus_nonempty. + - apply (schedule_with_offers_offer_prefix_offers (S n) (S n) + (fun i => i) v i). + Qed. + + Lemma no_focus_offers_every_live_slot_prefix n + (v : pool E (S n)) (i : LiveSlot (S n)) : + offered_in_scheduler_prefix (S n) i + (schedule_with_offers (S n) v None). + Proof. + apply show_no_focus_offers_every_live_slot_prefix. + Qed. + + Theorem show_no_focus_offers_every_live_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) : + <( {schedule_with_offers (S n) v None}, Pure |= + AF {offer_live_slot (S n) i} )>. + Proof. + apply offered_in_scheduler_prefix_implies_AF. + - constructor. + - apply show_no_focus_offers_every_live_slot_prefix. + Qed. + + Theorem no_focus_offers_every_live_slot n + (v : pool E (S n)) (i : LiveSlot (S n)) : + <( {schedule_with_offers (S n) v None}, Pure |= + AF {offer_live_slot (S n) i} )>. + Proof. + apply show_no_focus_offers_every_live_slot. + Qed. + + Definition scheduling_point_offer_obligation + (t : observed_completed E) (w : World (scheduler_observedE E)) + : Prop := + forall n, + w = Obs (inl (ObsSchedulingPoint (S n))) tt -> + forall i : LiveSlot (S n), + <( {t}, w |= AF {offer_live_slot (S n) i} )>. + + Local Definition non_scheduling_point_world + (w : World (scheduler_observedE E)) : Prop := + forall n, + w = Obs (inl (ObsSchedulingPoint (S n))) tt -> False. + + Local Lemma pure_non_scheduling_point : + non_scheduling_point_world Pure. + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Local Lemma obs_offered_non_scheduling_point ref : + non_scheduling_point_world + (Obs (inl (ObsOffered ref) : scheduler_observedE E) tt). + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Local Lemma obs_non_scheduler_non_scheduling_point + (event : yieldE + (spawnE + E)) + (value : encode (inr event : scheduler_observedE E)) : + non_scheduling_point_world (Obs (inr event) value). + Proof. intros n Hcontra. discriminate Hcontra. Qed. + + Private Inductive SchedulerOfferCanonical + : observed_completed E -> World (scheduler_observedE E) -> Prop := + | scheduler_offer_canonical_schedule : forall n + (v : pool E n) focus w, + non_scheduling_point_world w -> + SchedulerOfferCanonical (schedule_with_offers n v focus) w + | scheduler_offer_canonical_prefix_at_point : forall n + (v : pool E (S n)), + SchedulerOfferCanonical + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v) + (Obs (inl (ObsSchedulingPoint (S n))) tt) + | scheduler_offer_canonical_prefix_elsewhere : forall m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w, + non_scheduling_point_world w -> + SchedulerOfferCanonical + (schedule_with_offers_offer_prefix m r embed v) w + | scheduler_offer_canonical_choice : forall n + (v : pool E (S n)) w, + non_scheduling_point_world w -> + SchedulerOfferCanonical + (Br n (fun i : fin' n => + schedule_with_offers (S n) v (Some i))) w + | scheduler_offer_canonical_done : forall t (x : unit), + SchedulerOfferCanonical t (Done x) + | scheduler_offer_canonical_finish : forall t + (event : scheduler_observedE E) (value : encode event) (x : unit), + SchedulerOfferCanonical t (Finish event value x). + + Local Definition SchedulerOfferShape + (t : observed_completed E) (w : World (scheduler_observedE E)) + : Prop := + exists u : observed_completed E, t ≅ u /\ SchedulerOfferCanonical u w. + + Local Lemma scheduler_offer_shape_canonical t w : + SchedulerOfferCanonical t w -> SchedulerOfferShape t w. + Proof. + intro Hcanonical. + exists t. split; [apply observed_equ_refl_no_eqdep | exact Hcanonical]. + Qed. + + Local Lemma scheduler_offer_shape_equ t u w : + t ≅ u -> SchedulerOfferShape u w -> SchedulerOfferShape t w. + Proof. + intros Htu [v [Huv Hcanonical]]. + exists v. split. + - transitivity u; assumption. + - exact Hcanonical. + Qed. + + Local Lemma observed_equ_of_observe_eq (t u : observed_completed E) : + observe t = observe u -> t ≅ u. + Proof. + intro Hobserve. + transitivity (go (observe t)). + - apply ictree_eta. + - rewrite Hobserve. + symmetry. apply ictree_eta. + Qed. + + Local Lemma scheduler_offer_shape_schedule n + (v : pool E n) focus w : + non_scheduling_point_world w -> + SchedulerOfferShape (schedule_with_offers n v focus) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_prefix_at_point n + (v : pool E (S n)) : + SchedulerOfferShape + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v) + (Obs (inl (ObsSchedulingPoint (S n))) tt). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_shape_prefix_elsewhere m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w : + non_scheduling_point_world w -> + SchedulerOfferShape + (schedule_with_offers_offer_prefix m r embed v) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_choice n + (v : pool E (S n)) w : + non_scheduling_point_world w -> + SchedulerOfferShape + (Br n (fun i : fin' n => + schedule_with_offers (S n) v (Some i))) w. + Proof. + intro Hworld. + apply scheduler_offer_shape_canonical. + now constructor. + Qed. + + Local Lemma scheduler_offer_shape_done t (x : unit) : + SchedulerOfferShape t (Done x). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_shape_finish t + (event : scheduler_observedE E) (value : encode event) (x : unit) : + SchedulerOfferShape t (Finish event value x). + Proof. + apply scheduler_offer_shape_canonical. + constructor. + Qed. + + Local Lemma scheduler_offer_canonical_obligation t w : + SchedulerOfferCanonical t w -> scheduling_point_offer_obligation t w. + Proof. + intro Hcanonical. + destruct Hcanonical as + [n v focus w Hworld | n v | m r embed v w Hworld | + n v w Hworld | t x | t event value x]. + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. + inversion Hsched; subst. + apply offered_in_scheduler_prefix_implies_AF. + + constructor. + + apply (schedule_with_offers_offer_prefix_offers (S k) (S k) + (fun j : LiveSlot (S k) => j) v i). + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. + exfalso. exact (Hworld k Hsched). + - intros k Hsched i. discriminate Hsched. + - intros k Hsched i. discriminate Hsched. + Qed. + + Local Lemma scheduler_offer_shape_obligation t w : + SchedulerOfferShape t w -> scheduling_point_offer_obligation t w. + Proof. + intros [u [Htu Hcanonical]] k Hsched i. + rewrite Htu. + eapply scheduler_offer_canonical_obligation; eauto. + Qed. + + Local Lemma scheduler_offer_shape_ret_step + (w : World (scheduler_observedE E)) t' w' : + |Ret tt, w| ↦ |t', w'| -> SchedulerOfferShape t' w'. + Proof. + intro Htr. + destruct w as [| event value | x | event value x]. + - apply ktrans_done in Htr as [-> _]. + apply scheduler_offer_shape_done. + - apply ktrans_finish in Htr as [-> _]. + apply scheduler_offer_shape_finish. + - apply ktrans_not_done in Htr. inversion Htr. + - apply ktrans_not_done in Htr. inversion Htr. + Qed. + + Local Lemma scheduler_offer_canonical_step t w t' w' : + SchedulerOfferCanonical t w -> + |t, w| ↦ |t', w'| -> + SchedulerOfferShape t' w'. + Proof. + intros Hcanonical Htr. + revert t w t' w' Hcanonical Htr. + fix IH 6. + intros t w t' w' Hcanonical Htr. + destruct Hcanonical as + [n v focus w Hworld | n v | m r embed v w Hworld | + n v w Hworld | t x | t event value x]. + - destruct focus as [slot |]. + + dependent destruction slot. + * set (focused_slot := (Fin.F1 : Fin.t (S n))). + destruct (observe (v $ focused_slot)) eqn:Hthread; + fold focused_slot in Htr. + -- destruct x. + cbn in Htr. + rewrite (schedule_with_offers_focused_ret + n v focused_slot Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_br + n v focused_slot n0 k Hthread) in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + ++ exact Htarget. + ++ apply scheduler_offer_shape_schedule. exact Hworld. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_guard + n v focused_slot t Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- destruct e as [yield_event | [spawn_event | user_event]]. + ++ destruct yield_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_yield + n v focused_slot k Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ** apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ** eapply IH. + --- apply scheduler_offer_canonical_schedule. + exact Hworld. + --- exact Htr. + ++ destruct spawn_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_fork + n v focused_slot k Hthread) in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + ++ cbn in Htr. + rewrite (schedule_with_offers_focused_user_event + n v focused_slot user_event k Hthread) in Htr. + apply ktrans_vis in Htr as [value [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + * set (focused_slot := Fin.FS slot). + destruct (observe (v $ focused_slot)) eqn:Hthread; + fold focused_slot in Htr. + -- destruct x. + cbn in Htr. + rewrite (schedule_with_offers_focused_ret + n v focused_slot Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_br + n v focused_slot n0 k Hthread) in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + ++ exact Htarget. + ++ apply scheduler_offer_shape_schedule. exact Hworld. + -- cbn in Htr. + rewrite (schedule_with_offers_focused_guard + n v focused_slot t Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ++ apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ++ eapply IH. + ** apply scheduler_offer_canonical_schedule. + exact Hworld. + ** exact Htr. + -- destruct e as [yield_event | [spawn_event | user_event]]. + ++ destruct yield_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_yield + n v focused_slot k Hthread) in Htr. + dependent destruction Htr. + eapply scheduler_offer_shape_equ. + ** apply observed_equ_of_observe_eq. + match goal with + | Hobs : observe ?mid = observe t' |- _ => + symmetry; exact Hobs + end. + ** eapply IH. + --- apply scheduler_offer_canonical_schedule. + exact Hworld. + --- exact Htr. + ++ destruct spawn_event. + cbn in Htr. + rewrite (schedule_with_offers_focused_fork + n v focused_slot k Hthread) in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + ++ cbn in Htr. + rewrite (schedule_with_offers_focused_user_event + n v focused_slot user_event k Hthread) in Htr. + apply ktrans_vis in Htr as [value [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + ** symmetry. exact Htarget. + ** apply scheduler_offer_shape_schedule. + apply obs_non_scheduler_non_scheduling_point. + + destruct n as [| n']. + * cbn in Htr. + apply scheduler_offer_shape_ret_step with (w := w). + exact Htr. + * cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + -- symmetry. exact Htarget. + -- apply scheduler_offer_shape_prefix_at_point. + - cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + + symmetry. exact Htarget. + + apply scheduler_offer_shape_prefix_elsewhere. + apply obs_offered_non_scheduling_point. + - destruct r as [| r']. + + destruct m as [| m']. + * cbn in Htr. + apply scheduler_offer_shape_ret_step with (w := w). + exact Htr. + * cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + -- symmetry. exact Htarget. + -- apply scheduler_offer_shape_choice. + apply obs_non_scheduler_non_scheduling_point. + + cbn in Htr. + apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. + eapply scheduler_offer_shape_equ. + * symmetry. exact Htarget. + * apply scheduler_offer_shape_prefix_elsewhere. + apply obs_offered_non_scheduling_point. + - cbn in Htr. + apply ktrans_br in Htr as [choice [Htarget [-> _]]]. + eapply scheduler_offer_shape_equ. + + exact Htarget. + + apply scheduler_offer_shape_schedule. exact Hworld. + - apply ktrans_not_done in Htr. inversion Htr. + - apply ktrans_not_done in Htr. inversion Htr. + Qed. + + Local Lemma scheduler_offer_shape_step t w t' w' : + SchedulerOfferShape t w -> + |t, w| ↦ |t', w'| -> + SchedulerOfferShape t' w'. + Proof. + intros [u [Htu Hcanonical]] Htr. + rewrite Htu in Htr. + eapply scheduler_offer_canonical_step; eauto. + Qed. + + CoInductive SchedulerProgress + : observed_completed E -> World (scheduler_observedE E) -> Prop := + | scheduler_progress_intro : forall t w, + can_step t w -> + (forall t' w', + |t, w| ↦ |t', w'| -> SchedulerProgress t' w') -> + SchedulerProgress t w. + + Lemma scheduler_progress_shape_implies_AG t w : + SchedulerProgress t w -> + SchedulerOfferShape t w -> + agc scheduling_point_offer_obligation t w. + Proof. + intros Hprogress0 Hshape0. + pose proof (leq_gfp (agcF scheduling_point_offer_obligation) + (fun t w => SchedulerProgress t w /\ SchedulerOfferShape t w)) + as Hcoind. + apply Hcoind. + - clear t w Hprogress0 Hshape0. + intros t w [Hprogress Hshape]. + destruct Hprogress as [t w Hstep Hnext]. + split. + + apply scheduler_offer_shape_obligation. exact Hshape. + + split. + * exact Hstep. + * intros t' w' Htr. + split. + -- apply Hnext. exact Htr. + -- eapply scheduler_offer_shape_step; eauto. + - split; assumption. + Qed. + + Theorem every_live_slot_is_eventually_offered_at_scheduling_points + n (v : pool E n) focus : + SchedulerProgress (schedule_with_offers n v focus) Pure -> + agc scheduling_point_offer_obligation + (schedule_with_offers n v focus) Pure. + Proof. + intro Hprogress. + eapply scheduler_progress_shape_implies_AG. + - exact Hprogress. + - apply scheduler_offer_shape_schedule. + apply pure_non_scheduling_point. + Qed. + + Theorem show_every_live_slot_is_eventually_offered_at_scheduling_points + n (v : pool E n) focus : + SchedulerProgress (schedule_with_offers n v focus) Pure -> + agc scheduling_point_offer_obligation + (schedule_with_offers n v focus) Pure. + Proof. + apply every_live_slot_is_eventually_offered_at_scheduling_points. + Qed. +End ObservedScheduler. diff --git a/theories/ICTree/Logic/Soundness.v b/theories/ICTree/Logic/Soundness.v index 3f030c1..3caacbe 100644 --- a/theories/ICTree/Logic/Soundness.v +++ b/theories/ICTree/Logic/Soundness.v @@ -9,18 +9,18 @@ From TICL Require Import ICTree.Equ ICTree.SBisim ICTree.Interp.Core - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Logic.Trans ICTree.Logic.Bind ICTree.Logic.Iter ICTree.Logic.CanStep Logic.Core - Logic.AX - Logic.AF - Logic.EX - Logic.EF - Logic.AG - Logic.EG + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.EX + ICTree.Logic.EF + ICTree.Logic.AG + ICTree.Logic.EG Logic.Kripke Logic.Setoid. diff --git a/theories/ICTree/Logic/State.v b/theories/ICTree/Logic/State.v index 0ec01cd..1b1fbb0 100644 --- a/theories/ICTree/Logic/State.v +++ b/theories/ICTree/Logic/State.v @@ -14,7 +14,7 @@ From TICL Require Import ICTree.Logic.AG ICTree.Logic.EX Logic.Core - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State. diff --git a/theories/ICTree/Logic/Yield.v b/theories/ICTree/Logic/Yield.v new file mode 100644 index 0000000..d76c544 --- /dev/null +++ b/theories/ICTree/Logic/Yield.v @@ -0,0 +1,345 @@ +From Stdlib Require Import + Fin + Vector + Program.Equality. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Events.Yield + ICTree.Events.State + ICTree.Events.Writer + ICTree.Interp.Core + ICTree.Interp.State.Mod + ICTree.Interp.Yield.Mod + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.Bind + ICTree.Logic.CanStep + ICTree.Logic.State + Logic.Core + Utils.Vectors. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. + +(** * TICL rules for instrumented raw threads and scheduled pools *) +(** These rules are stated over raw [ictree] values built from [yieldE], + [forkE] and [stateE] events. They know nothing about source syntax; a + language lifts them by instantiating the raw trees with its denotations. *) + +(** ** Singleton scheduler reductions. *) +(** A source program starts as a one-slot pool focused on its only thread. + These local reductions normalize that pool one observable step at a time. *) + +Local Lemma schedule_singleton_empty {E} `{Encode E} (v : pool E 0) : + schedule 0 v None ≅ Ret tt. +Proof. + rewrite (ictree_eta (schedule 0 v None)), schedule_empty_none. + reflexivity. +Qed. + +Local Lemma schedule_singleton_ret {E} `{Encode E} (v : pool E 1) : + observe (v $ Fin.F1) = RetF tt -> + schedule 1 v (Some Fin.F1) ≅ Guard (Ret tt). +Proof. + intro Hobs. + rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), + (schedule_focused_ret 0 v Fin.F1 Hobs). + apply guard_equ_node, schedule_singleton_empty. +Qed. + +Local Lemma schedule_singleton_yield {E} `{Encode E} (v : pool E 1) k : + observe (v $ Fin.F1) = VisF (inl Yield) k -> + schedule 1 v (Some Fin.F1) + ≅ Guard (Vis ((inl Yield) : yieldE + (spawnE + E)) + (fun _ => Br 0 (fun i => + schedule 1 (v @ Fin.F1 := (k tt)) (Some i)))). +Proof. + intro Hobs. + rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), + (schedule_focused_yield 0 v Fin.F1 k Hobs). + apply guard_equ_node. + rewrite (ictree_eta (schedule 1 (v @ Fin.F1 := (k tt)) None)), + (schedule_no_focus_nonempty 0 (v @ Fin.F1 := (k tt))). + reflexivity. +Qed. + +Local Lemma schedule_singleton_user {E} `{Encode E} (v : pool E 1) (e : E) k : + observe (v $ Fin.F1) = VisF (inr (inr e)) k -> + schedule 1 v (Some Fin.F1) + ≅ Vis ((inr (inr e)) : yieldE + (spawnE + E)) + (fun x => schedule 1 (v @ Fin.F1 := (k x)) (Some Fin.F1)). +Proof. + intro Hobs. + rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), + (schedule_focused_user_event 0 v Fin.F1 e k Hobs). + reflexivity. +Qed. + +Local Lemma instr_schedule_singleton_ret {Σ} (v : pool (stateE Σ) 1) (σ : Σ) : + observe (v $ Fin.F1) = RetF tt -> + instr_schedule 1 v (Some Fin.F1) σ ~ Ret (tt, σ). +Proof. + intro Hobs. + unfold instr_schedule, instr_stateE. + rewrite (schedule_singleton_ret v Hobs), interp_erase_guard_ret. + rewrite interp_state_tau, sb_guard, interp_state_ret. + reflexivity. +Qed. + +(** The singleton update step: read the state, write [f] of it, and finish. + Exactly one [Log] of the new state is observable. *) +Local Lemma instr_schedule_singleton_update {Σ} (f : Σ -> Σ) + (v : pool (stateE Σ) 1) (σ : Σ) : + observe (v $ Fin.F1) = + VisF ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt)) -> + instr_schedule 1 v (Some Fin.F1) σ ~ (log (f σ);; Ret (tt, f σ)). +Proof with eauto. + intro Hobs. + assert (Hput : observe + ((v @ Fin.F1 := + (Vis ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))) $ Fin.F1) + = VisF ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt)) + by (now rewrite Vector.nth_replace_eq). + assert (Hend : observe + (((v @ Fin.F1 := + (Vis ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))) + @ Fin.F1 := (Ret tt)) $ Fin.F1) = RetF tt) + by (now rewrite Vector.nth_replace_eq). + unfold instr_schedule, instr_stateE. + rewrite (schedule_singleton_user v Get _ Hobs). + rewrite interp_erase_user, interp_state_vis. + cbn [h_stateW runStateT]. + rewrite bind_ret_l, sb_guard. + cbv beta. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + rewrite (schedule_singleton_user _ (Put (f σ)) _ Hput). + rewrite interp_erase_user, interp_state_vis. + cbn [h_stateW runStateT]. + rewrite bind_bind. + __upto_bind_sbisim... + intros []. + rewrite bind_ret_l, sb_guard. + cbv beta. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + rewrite (schedule_singleton_ret _ Hend). + rewrite interp_erase_guard_ret. + rewrite interp_state_tau, sb_guard, interp_state_ret. + reflexivity. +Qed. + +(** ** Raw thread rules. *) + +(** A finished raw thread terminates in one step with the unchanged state. *) +Lemma axr_thread_ret {Σ X} : forall (r : X) (σ : Σ) w R, + not_done w -> + R (r, σ) w -> + <[ {instr_thread (Ret r) σ}, w |= AX done R ]>. +Proof with eauto with ticl. + intros r σ w R Hnd HR. + rewrite instr_thread_ret. + apply axr_ret... +Qed. + +(** Sequential composition of raw threads, suffix [AN]. *) +Lemma anr_thread_bind_r_eq {Σ A B} : + forall (t : ictree (yieldE + (forkE + stateE Σ)) A) + (k : A -> ictree (yieldE + (forkE + stateE Σ)) B) + (σ σ' : Σ) (r : A) w w' φ ψ, + <[ {instr_thread t σ}, w |= φ AN done= {(r, σ')} w' ]> -> + <[ {instr_thread (k r) σ'}, w' |= φ AN ψ ]> -> + <[ {instr_thread (x <- t ;; k x) σ}, w |= φ AN ψ ]>. +Proof. + intros t k σ σ' r w w' φ ψ Ht Hk. + rewrite instr_thread_bind. + eapply anr_bind_r_eq; eauto. +Qed. + +(** Sequential composition of raw threads, suffix [AU]. *) +Lemma aur_thread_bind_r_eq {Σ A B} : + forall (t : ictree (yieldE + (forkE + stateE Σ)) A) + (k : A -> ictree (yieldE + (forkE + stateE Σ)) B) + (σ σ' : Σ) (r : A) w w' φ ψ, + <[ {instr_thread t σ}, w |= φ AU AX done= {(r, σ')} w' ]> -> + <[ {instr_thread (k r) σ'}, w' |= φ AU ψ ]> -> + <[ {instr_thread (x <- t ;; k x) σ}, w |= φ AU ψ ]>. +Proof. + intros t k σ σ' r w w' φ ψ Ht Hk. + rewrite instr_thread_bind. + eapply aur_bind_r_eq; eauto. +Qed. + +(** Sequential composition of raw threads, prefix [AU]. *) +Lemma aul_thread_bind_r_eq {Σ A B} : + forall (t : ictree (yieldE + (forkE + stateE Σ)) A) + (k : A -> ictree (yieldE + (forkE + stateE Σ)) B) + (σ σ' : Σ) (r : A) w w' φ ψ, + <[ {instr_thread t σ}, w |= φ AU AX done= {(r, σ')} w' ]> -> + <( {instr_thread (k r) σ'}, w' |= φ AU ψ )> -> + <( {instr_thread (x <- t ;; k x) σ}, w |= φ AU ψ )>. +Proof. + intros t k σ σ' r w w' φ ψ Ht Hk. + rewrite instr_thread_bind. + eapply aul_bind_r_eq; eauto. +Qed. + +(** A raw state update [σ ↦ f σ] leaves exactly one [Log] observation and then + returns [r]; suffix [AU] version. *) +Lemma aur_thread_update {Σ X} : + forall (f : Σ -> Σ) (r : X) (σ : Σ) w ψ R, + <( {log (f σ)}, w |= ψ )> -> + R (r, f σ) (Obs (Log (f σ)) tt) -> + <[ {instr_thread + (Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret r))) σ}, + w |= ψ AU AX done R ]>. +Proof with eauto with ticl. + intros f r σ w ψ R Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + rewrite instr_thread_get; cbv beta. + setoid_rewrite instr_thread_put; cbv beta. + eapply aur_log. + - cleft; apply axr_thread_ret... + - now apply ticll_bind_l. +Qed. + +(** A raw state update [σ ↦ f σ]; prefix [AU] version. *) +Lemma aul_thread_update {Σ X} : + forall (f : Σ -> Σ) (r : X) (σ : Σ) w ψ φ, + <( {log (f σ)}, w |= ψ )> -> + <( {Ret (r, f σ)}, {Obs (Log (f σ)) tt} |= φ )> -> + <( {instr_thread + (Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret r))) σ}, + w |= ψ AU φ )>. +Proof with eauto with ticl. + intros f r σ w ψ φ Hlog Hret. + rewrite instr_thread_get; cbv beta. + setoid_rewrite instr_thread_put; cbv beta. + cright. + apply anl_log. + - cleft. + rewrite instr_thread_ret. + exact Hret. + - now apply ticll_bind_l. +Qed. + +(** ** Raw singleton scheduler rules. *) + +(** A finished singleton pool terminates in one step. *) +Lemma axr_schedule_ret {Σ} : forall (σ : Σ) w R, + not_done w -> + R (tt, σ) w -> + <[ {instr_schedule 1 + [(Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)]%vector + (Some Fin.F1) σ}, w |= AX done R ]>. +Proof with eauto with ticl. + intros σ w R Hnd HR. + rewrite (instr_schedule_singleton_ret + [(Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)]%vector + σ eq_refl). + apply axr_ret... +Qed. + +(** A cooperative [Yield] in a singleton pool costs two steps: the scheduler + emits the scheduling point and then chooses the (single) runnable slot. *) +Lemma axax_schedule_yield {Σ} : forall (σ : Σ) w R, + not_done w -> + R (tt, σ) w -> + <[ {instr_schedule 1 + [Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt)]%vector + (Some Fin.F1) σ}, w |= AX AX done R ]>. +Proof with eauto with ticl. + intros σ w R Hnd HR. + assert (Hend : observe + (([Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt)]%vector + @ Fin.F1 := (Ret tt)) $ Fin.F1) = RetF tt) + by (now rewrite Vector.nth_replace_eq). + unfold instr_schedule, instr_stateE. + rewrite (schedule_singleton_yield + [Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt)]%vector + (fun _ : unit => (Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)) + eq_refl). + rewrite interp_erase_guard_yield. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard, + interp_state_tau, sb_guard. + rewrite interp_erase_br. + apply anr_state_br; split. + - csplit... + - intro i; dependent destruction i. + + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + rewrite (schedule_singleton_ret _ Hend). + rewrite interp_erase_guard_ret. + rewrite interp_state_tau, sb_guard, interp_state_ret. + apply axr_ret... + + inversion i. +Qed. + +(** A scheduled singleton state update leaves exactly one [Log]; suffix [AU]. *) +Lemma aur_schedule_update {Σ} : + forall (f : Σ -> Σ) (σ : Σ) w ψ R, + <( {log (f σ)}, w |= ψ )> -> + R (tt, f σ) (Obs (Log (f σ)) tt) -> + <[ {instr_schedule 1 + [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))]%vector + (Some Fin.F1) σ}, + w |= ψ AU AX done R ]>. +Proof with eauto with ticl. + intros f σ w ψ R Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + rewrite (instr_schedule_singleton_update f + [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))]%vector + σ eq_refl). + eapply aur_log. + - cleft; apply axr_ret... + - now apply ticll_bind_l. +Qed. + +(** A scheduled singleton state update; prefix [AU]. *) +Lemma aul_schedule_update {Σ} : + forall (f : Σ -> Σ) (σ : Σ) w ψ φ, + <( {log (f σ)}, w |= ψ )> -> + <( {Ret (tt, f σ)}, {Obs (Log (f σ)) tt} |= φ )> -> + <( {instr_schedule 1 + [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))]%vector + (Some Fin.F1) σ}, + w |= ψ AU φ )>. +Proof with eauto with ticl. + intros f σ w ψ φ Hlog Hret. + rewrite (instr_schedule_singleton_update f + [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) + (fun σ0 : Σ => + Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) + (fun _ : unit => Ret tt))]%vector + σ eq_refl). + cright. + apply anl_log. + - cleft... + - now apply ticll_bind_l. +Qed. diff --git a/theories/Lang/CSL.v b/theories/Lang/CSL.v new file mode 100644 index 0000000..3f742b4 --- /dev/null +++ b/theories/Lang/CSL.v @@ -0,0 +1,3 @@ +From TICL Require Export + Lang.CSL.Pcm Lang.CSL.Heap Lang.CSL.Syntax Lang.CSL.Denote + ICTree.Interp.Refine Lang.CSL.Interp. diff --git a/theories/Lang/CSL/Denote.v b/theories/Lang/CSL/Denote.v new file mode 100644 index 0000000..055c05c --- /dev/null +++ b/theories/Lang/CSL/Denote.v @@ -0,0 +1,100 @@ +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.Events.Yield ICTree.Interp.Refine + Lang.CSL.Heap Lang.CSL.Syntax. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +Definition CEff := (yieldE + (forkE + sE))%type. +Definition heap_event (e : sE) : ictree CEff (encode e) := + Vis (inr (inr e)) (fun x => Ret x). +Definition source_yield : ictree CEff unit := + Vis (inl Yield) (fun _ => Ret tt). +Definition source_fork : ictree CEff bool := + Vis (inr (inl Fork)) (fun b => Ret b). + +Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := + match p in CProg A return ictree CEff (option A) with + | CRead a => x <- heap_event (SRd a);; Ret (Some x) + | CWrite a v => heap_event (SWr a v);; Ret (Some tt) + | CEmit q v => heap_event (SEmit q v);; Ret (Some tt) + | CYield => source_yield;; Ret (Some tt) + | CFork body => + child <- source_fork;; + if child then denote_flow body;; Ret None else Ret (Some tt) + | CRet x => Ret (Some x) + | CBind body next => + flow <- denote_flow body;; + match flow with None => Ret None | Some x => denote_flow (next x) end + | CUntilNone body => + ICtree.iter + (fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr None) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end) tt + | CAlloc size => a <- heap_event (SAlloc size);; Ret (Some a) + | CCAS a expected desired => + b <- heap_event (SCAS a expected desired);; Ret (Some b) + end. + +Definition denote (p : CProg unit) : thread sE := + denote_flow p;; Ret tt. + +Lemma denote_flow_branchfree {A} (p : CProg A) : BranchFree (denote_flow p). +Proof. + induction p as [a|a v|q v| |body IH|A x|A B body IH next IHnext|A body IH|size|a expected desired]; + cbn [denote_flow]. + - apply branchfree_bind. + + unfold heap_event; apply bf_vis; intro x; apply bf_ret. + + intro x; apply bf_ret. + - apply branchfree_bind. + + unfold heap_event; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold heap_event; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold source_yield; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold source_fork; apply bf_vis; intro b; apply bf_ret. + + intros []; cbn. + * apply branchfree_bind; [exact IH|intro flow; apply bf_ret]. + * apply bf_ret. + - apply bf_ret. + - apply branchfree_bind; [exact IH|]. + intros [x|]; [apply IHnext|apply bf_ret]. + - apply branchfree_iter; intros []. + apply branchfree_bind; [exact IH|]. + intros [[x|]|]; apply bf_ret. + - apply branchfree_bind. + + unfold heap_event; apply bf_vis; intro a; apply bf_ret. + + intro a; apply bf_ret. + - apply branchfree_bind. + + unfold heap_event; apply bf_vis; intro b; apply bf_ret. + + intro b; apply bf_ret. +Qed. + +Lemma denote_branchfree (p : CProg unit) : BranchFree (denote p). +Proof. + unfold denote; apply branchfree_bind; + [apply denote_flow_branchfree|intro flow; apply bf_ret]. +Qed. + +Lemma denote_fork_bind (p : CProg unit) (next : unit -> CProg unit) : + denote (CBind (CFork p) next) ≅ + Vis (inr (inl Fork)) + (fun child : bool => if child then denote p else denote (next tt)). +Proof. + unfold denote; cbn [denote_flow]; unfold source_fork. + rewrite !bind_bind, bind_vis. + step; constructor; intro child. + rewrite bind_ret_l; destruct child; cbn. + - rewrite !bind_bind. + apply equ_clo_bind_eq; intro flow. + rewrite !bind_ret_l; reflexivity. + - rewrite !bind_ret_l; reflexivity. +Qed. diff --git a/theories/Lang/CSL/Heap.v b/theories/Lang/CSL/Heap.v new file mode 100644 index 0000000..41dd445 --- /dev/null +++ b/theories/Lang/CSL/Heap.v @@ -0,0 +1,414 @@ +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core. + +From TICL Require Export Lang.CSL.Pcm. + +Definition upd (h : Heap) (a v : nat) : Heap := + fun x => if Nat.eqb x a then Some v else h x. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** The queue-tagged observation alphabet *) + +Record SObs : Type := SPop { stag: nat ; sval: nat ; sidx: nat }. + +(** ** Events *) + +Variant sE : Type := + | SRd (a: nat) + | SWr (a: nat) (v: nat) + | SEmit (q: nat) (v: nat) + | SAlloc (size: nat) + | SCAS (a expected desired : nat). + +Global Instance encode_sE: Encode sE := + fun e => match e with + | SRd _ => nat | SWr _ _ => unit | SEmit _ _ => unit + | SAlloc _ => nat + | SCAS _ _ _ => bool + end. + +Definition srd (a: nat) : ictree sE nat := Vis (SRd a) (fun x: nat => Ret x). +Definition swr (a v: nat) : ictree sE unit := Vis (SWr a v) (fun _: unit => Ret tt). +Definition semit (q v: nat) : ictree sE unit := + Vis (SEmit q v) (fun _: unit => Ret tt). +Definition salloc (size : nat) : ictree sE nat := + Vis (SAlloc size) (fun a => Ret a). +Definition scas (a expected desired : nat) : ictree sE bool := + Vis (SCAS a expected desired) (fun b => Ret b). + +(** Interpretation state: the SHARED heap (which holds both queues and the + outer frame) and one GLOBAL occurrence counter. *) +Notation SSig := (Heap * nat)%type. + +(** The immutable snapshot is searched without fuel or heap instrumentation. + Every rejected candidate is silent; only success changes the shared heap. *) +Fixpoint block_freeb (h : Heap) (base size : nat) : bool := + match size with + | 0 => true + | S rest => + match h base with + | None => block_freeb h (S base) rest + | Some _ => false + end + end. + +CoFixpoint alloc_search (h : Heap) (size candidate c : nat) + : ictreeW SObs (nat * SSig) := + match size with + | 0 => stuck + | S _ => + if block_freeb h candidate size + then Ret (candidate, (hunion (hblock candidate size) h, c)) + else Guard (alloc_search h size (S candidate) c) + end. + +(** ** Checked accesses and constructive allocation in one shared handler. *) +Definition sh: sE ~> stateT SSig (ictreeW SObs) := + fun e => + mkStateT (fun s => + match e return ictreeW SObs (encode e * SSig) with + | SRd a => match fst s a with + | Some v => Ret (v, s) + | None => ICtree.stuck + end + | SWr a v => match fst s a with + | Some _ => Ret (tt, (upd (fst s) a v, snd s)) + | None => ICtree.stuck + end + | SEmit q v => log (SPop q v (snd s)) ;; Ret (tt, (fst s, S (snd s))) + | SAlloc size => alloc_search (fst s) size 1 (snd s) + | SCAS a expected desired => + match fst s a with + | None => stuck + | Some current => + if Nat.eqb current expected + then Ret (true, (upd (fst s) a desired, snd s)) + else Ret (false, s) + end + end). + +(** *** Handler equations *) + +Lemma sh_rd_some: forall a h c v, + h a = Some v -> runStateT (sh (SRd a)) (h, c) ≅ Ret (v, (h, c)). +Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. + +Lemma sh_rd_none: forall a h c, + h a = None -> runStateT (sh (SRd a)) (h, c) ≅ ICtree.stuck. +Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. + +Lemma sh_wr_some: forall a h c v w, + h a = Some w -> runStateT (sh (SWr a v)) (h, c) ≅ Ret (tt, (upd h a v, c)). +Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. + +Lemma sh_emit: forall q v h c, + runStateT (sh (SEmit q v)) (h, c) ≅ (log (SPop q v c) ;; Ret (tt, (h, S c))). +Proof. intros; cbn; reflexivity. Qed. + +Lemma sh_cas_success a expected desired h c : + h a = Some expected -> + runStateT (sh (SCAS a expected desired)) (h,c) ≅ + Ret (true,(upd h a desired,c)). +Proof. intro H; cbn; rewrite H, Nat.eqb_refl; reflexivity. Qed. + +Lemma sh_cas_failure a expected desired current h c : + h a = Some current -> current <> expected -> + runStateT (sh (SCAS a expected desired)) (h,c) ≅ Ret (false,(h,c)). +Proof. + intros H N; cbn; rewrite H. + apply Nat.eqb_neq in N; rewrite N; reflexivity. +Qed. + +Lemma sh_cas_missing a expected desired h c : + h a = None -> + runStateT (sh (SCAS a expected desired)) (h,c) ≅ + (stuck : ictreeW SObs (bool * SSig)). +Proof. intro H; cbn; rewrite H; reflexivity. Qed. + +(** *** Lifting through [interp_state] *) + +Lemma sinterp_rd {X}: forall a h c v (k: nat -> ictree sE X), + h a = Some v -> + interp_state sh (x <- srd a ;; k x) (h, c) ~ interp_state sh (k v) (h, c). +Proof. + intros a h c v k H. + unfold srd; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis. + rewrite (sh_rd_some a h c v H), bind_ret_l. + apply sb_guard. +Qed. + +Lemma sinterp_wr {X}: forall a h c v w (k: unit -> ictree sE X), + h a = Some w -> + interp_state sh (x <- swr a v ;; k x) (h, c) + ~ interp_state sh (k tt) (upd h a v, c). +Proof. + intros a h c v w k H. + unfold swr; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis. + rewrite (sh_wr_some a h c v w H), bind_ret_l. + apply sb_guard. +Qed. + +Lemma sinterp_wr' {X}: forall a h c v (k: unit -> ictree sE X), + h a <> None -> + interp_state sh (x <- swr a v ;; k x) (h, c) + ~ interp_state sh (k tt) (upd h a v, c). +Proof. + intros a h c v k H; destruct (h a) as [w |] eqn:E; [| contradiction]. + eapply sinterp_wr; eauto. +Qed. + +Lemma sinterp_emit {X}: forall q v h c (k: unit -> ictree sE X), + interp_state sh (x <- semit q v ;; k x) (h, c) + ~ (log (SPop q v c) ;; interp_state sh (k tt) (h, S c)). +Proof. + intros q v h c k. + unfold semit; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, sh_emit, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; apply sb_guard. +Qed. + +Lemma sinterp_cas_success {X} a expected desired h c + (k : bool -> ictree sE X) : + h a = Some expected -> + interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + interp_state sh (k true) (upd h a desired,c). +Proof. + intro H; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, (sh_cas_success a expected desired h c H), bind_ret_l. + apply sb_guard. +Qed. + +Lemma sinterp_cas_failure {X} a expected desired current h c + (k : bool -> ictree sE X) : + h a = Some current -> current <> expected -> + interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + interp_state sh (k false) (h,c). +Proof. + intros H N; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, + (sh_cas_failure a expected desired current h c H N), bind_ret_l. + apply sb_guard. +Qed. + +Lemma sinterp_cas_missing {X} a expected desired h c + (k : bool -> ictree sE X) : + h a = None -> + interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + (stuck : ictreeW SObs (X * SSig)). +Proof. + intro H; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, (sh_cas_missing a expected desired h c H). + rewrite bind_stuck_equ; reflexivity. +Qed. + +(** An out-of-footprint read cannot step. *) +Lemma sinterp_rd_nostep {X}: forall a h c (k: nat -> ictree sE X) w, + h a = None -> + ~ can_step (interp_state sh (x <- srd a ;; k x) (h, c)) w. +Proof. + intros a h c k w H. + unfold srd; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, (sh_rd_none a h c H). + intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; + revert TR; apply ktrans_stuck. +Qed. + +Lemma sh_wr_none : forall a h c v, + h a = None -> runStateT (sh (SWr a v)) (h,c) ≅ stuck. +Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. + +Lemma sinterp_srd_stuck a h c : + h a = None -> + interp_state sh (srd a) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). +Proof. + intro H; unfold srd. + rewrite interp_state_vis, (sh_rd_none a h c H). + apply bind_stuck_equ. +Qed. + +Lemma sinterp_swr_stuck a v h c : + h a = None -> + interp_state sh (swr a v) (h,c) ≅ (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro H; unfold swr. + rewrite interp_state_vis, (sh_wr_none a h c v H). + apply bind_stuck_equ. +Qed. + +Lemma upd_pcm h a v : heq (upd h a v) (Pcm.hupd a v h). +Proof. + intro x; unfold upd, Pcm.hupd. + destruct (Nat.eqb_spec x a); destruct (Nat.eq_dec a x); congruence. +Qed. + +(** ** Allocation laws *) + +Lemma block_freeb_spec h base size : + block_freeb h base size = true <-> block_free h base size. +Proof. + revert base; induction size as [|size IH]; intro base. + - split; [intros _ offset O; lia | reflexivity]. + - cbn [block_freeb]; destruct (h base) as [v|] eqn:E. + + split; [discriminate | intro F]. + specialize (F 0 ltac:(lia)); rewrite Nat.add_0_r, E in F; discriminate. + + rewrite IH; split. + * intros F [|offset] O. + -- now rewrite Nat.add_0_r. + -- replace (base + S offset)%nat with (S base + offset)%nat by lia; apply F; lia. + * intros F offset O. + replace (S base + offset)%nat with (base + S offset)%nat by lia; apply F; lia. +Qed. + +Lemma unfold_alloc_search h size candidate c : + alloc_search h size candidate c ≅ + match size with + | 0 => stuck + | S _ => if block_freeb h candidate size + then Ret (candidate, (hunion (hblock candidate size) h, c)) + else Guard (alloc_search h size (S candidate) c) + end. +Proof. + step; cbn; unfold observe; cbn; reflexivity. +Qed. + +Lemma alloc_search_first h size start base c : + Nat.lt 0 size -> Nat.le start base -> block_free h base size -> + (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size) -> + alloc_search h size start c ~ + Ret (base, (hunion (hblock base size) h, c)). +Proof. + intros Pos L Free First; destruct size as [|size]; [lia |]. + remember (base - start) as distance eqn:D. + revert start L First D. + induction distance as [|distance IH]; intros start L First D. + - assert (start = base) by lia; subst start. + rewrite unfold_alloc_search. + apply block_freeb_spec in Free; rewrite Free; reflexivity. + - assert (Test : block_freeb h start (S size) = false). + { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. + exfalso; apply (First start); try lia; apply block_freeb_spec; exact T. } + rewrite unfold_alloc_search, Test. + etransitivity; [apply sb_guard |]. + apply IH; [lia | |lia]. + intros j J B; apply First; lia. +Qed. + +Lemma sh_alloc_zero h c : + runStateT (sh (SAlloc 0)) (h,c) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. apply unfold_alloc_search. Qed. + +Lemma sh_alloc_first h size base c : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + runStateT (sh (SAlloc size)) (h,c) ~ + Ret (base, (hunion (hblock base size) h, c)). +Proof. + intros Pos B F First; apply alloc_search_first; try assumption; try lia. +Qed. + +Lemma sh_alloc_finite h size c : + heap_finite h -> Nat.lt 0 size -> + exists base, + Nat.lt 0 base /\ block_free h base size /\ + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) /\ + runStateT (sh (SAlloc size)) (h,c) ~ + Ret (base, (hunion (hblock base size) h, c)). +Proof. + intros [B Bound] Pos. + assert (Search : forall distance start, + Nat.max 1 B = (start + distance)%nat -> + exists base, Nat.le start base /\ block_free h base size /\ + (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size)). + { induction distance as [|distance IH]; intros start D. + - exists start; split; [lia |]; split. + + eapply heap_bounded_block_free; [exact Bound |lia]. + + intros j J L; lia. + - destruct (block_freeb h start size) eqn:T. + + exists start; split; [lia |]; split. + * apply block_freeb_spec; exact T. + * intros j J L; lia. + + destruct (IH (S start) ltac:(lia)) as (base & L & F & First). + exists base; split; [lia |]; split; [exact F |]. + intros j J Lt Free; destruct (Nat.eq_dec j start) as [E|E]. + * subst j; apply block_freeb_spec in Free; congruence. + * apply (First j); try lia; exact Free. } + destruct (Search (Nat.max 1 B - 1) 1 ltac:(lia)) + as (base & L & F & First). + exists base; split; [lia |]; split; [exact F |]; split. + - intros j J Lt; apply First; lia. + - apply sh_alloc_first; try assumption; try lia. +Qed. + +Lemma sinterp_salloc_zero h c : + interp_state sh (salloc 0) (h,c) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. + unfold salloc; rewrite interp_state_vis, sh_alloc_zero. + apply bind_stuck_equ. +Qed. + +Lemma sinterp_alloc_first {X} h size base c (k : nat -> ictree sE X) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_state sh (a <- salloc size;; k a) (h,c) ~ + interp_state sh (k base) (hunion (hblock base size) h,c). +Proof. + intros Pos B F First. + unfold salloc; rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, (sh_alloc_first h size base c Pos B F First), bind_ret_l. + apply sb_guard. +Qed. + +Lemma heap_finite_upd h a v : heap_finite h -> heap_finite (upd h a v). +Proof. + intros [B Bound]; exists (Nat.max B (S a)); intros x X. + unfold upd; destruct (Nat.eqb_spec x a); [lia | apply Bound; lia]. +Qed. + +Lemma alloc_search_no_space h size start c : + Nat.lt 0 size -> + (forall j, Nat.le start j -> ~ block_free h j size) -> + alloc_search h size start c ≅ (stuck : ictreeW SObs (nat * SSig)). +Proof. + intros Pos Full; destruct size as [|size]; [lia |]. + revert start Full; __coinduction_equ R CIH; intros start Full. + assert (Test : block_freeb h start (S size) = false). + { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. + exfalso; apply (Full start); [lia | apply block_freeb_spec; exact T]. } + rewrite unfold_alloc_search, Test, unfold_stuck. + constructor; apply CIH; intros j J; apply Full; lia. +Qed. diff --git a/theories/Lang/CSL/Interp.v b/theories/Lang/CSL/Interp.v new file mode 100644 index 0000000..b5b2177 --- /dev/null +++ b/theories/Lang/CSL/Interp.v @@ -0,0 +1,840 @@ +From Stdlib Require Import Fin Vector. +From TICL Require Import + Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote + ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Events.Yield + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Refine + ICTree.Interp.State.Mod Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Definition scheduled (p : CProg unit) : completed sE := + schedule 1 [denote p]%vector (Some Fin.F1). +Definition scheduled_rr (p : CProg unit) : completed sE := + run_round_robin (scheduled p) 0. +Definition run_rr (p : CProg unit) (h : Heap) (c : nat) + : ictreeW SObs (unit * SSig) := + interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (h,c). + +Definition interp_nd (n : nat) (ts : pool sE n) + (focus : option (Fin.t n)) (sigma : SSig) + : ictreeW SObs (unit * SSig) := + interp_state sh (interp_yield (interp_spawn (schedule n ts focus))) sigma. + +Definition run_nd (p : CProg unit) (h : Heap) (c : nat) + : ictreeW SObs (unit * SSig) := + interp_nd 1 [denote p]%vector (Some Fin.F1) (h,c). + +Lemma run_rr_unfold p h c : + run_rr p h c ≅ + interp_state sh (interp_yield (interp_spawn (scheduled_rr p))) (h,c). +Proof. reflexivity. Qed. + +Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + cbn [denote_flow]; apply bind_ret_l. +Qed. + +Lemma interp_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m σ ~ + (interp_state sh (srd a) σ >>= fun '(x,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). +Proof. + assert (Hnode : (denote_flow (CRead a) >>= K) ≅ + Vis (inr (inr (SRd a))) (fun x => K (Some x))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro x. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) + (ts @ i := Vis (inr (inr (SRd a))) (fun x => K (Some x))) + (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (nat * SSig)%type => + let '(x,σ') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). + assert (Hrhs : (interp_state sh (srd a) σ >>= resume) ≅ + ((runStateT (sh (SRd a)) σ >>= fun '(x,σ') => + Guard (interp_state sh (Ret x) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold srd; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret x) σ' >>= resume) ≅ resume (x,σ')). + { + transitivity (Ret (x,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m sigma ~ + (interp_state sh (salloc size) sigma >>= fun '(base,sigma') => + interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). +Proof. + assert (Hnode : (denote_flow (CAlloc size) >>= K) ≅ + Vis (inr (inr (SAlloc size))) (fun base => K (Some base))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro base. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) + (ts @ i := Vis (inr (inr (SAlloc size))) (fun base => K (Some base))) + (Some i) m sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (nat * SSig)%type => + let '(base,sigma') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). + assert (Hrhs : (interp_state sh (salloc size) sigma >>= resume) ≅ + ((runStateT (sh (SAlloc size)) sigma >>= fun '(base,sigma') => + Guard (interp_state sh (Ret base) sigma')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold salloc; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [base sigma']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret base) sigma' >>= resume) ≅ resume (base,sigma')). + { + transitivity (Ret (base,sigma') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (Some i) m sigma ~ + (interp_state sh (scas a expected desired) sigma >>= fun '(b,sigma') => + interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). +Proof. + assert (Hnode : (denote_flow (CCAS a expected desired) >>= K) ≅ + Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro b. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (ts @ i := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) + (Some i) m sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (bool * SSig)%type => + let '(b,sigma') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). + assert (Hrhs : (interp_state sh (scas a expected desired) sigma >>= resume) ≅ + ((runStateT (sh (SCAS a expected desired)) sigma >>= fun '(b,sigma') => + Guard (interp_state sh (Ret b) sigma')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold scas; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [b sigma']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret b) sigma' >>= resume) ≅ resume (b,sigma')). + { + transitivity (Ret (b,sigma') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m σ ~ + (interp_state sh (swr a v) σ >>= fun '(_,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). +Proof. + assert (Hnode : (denote_flow (CWrite a v) >>= K) ≅ + Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) + (ts @ i := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) + (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (unit * SSig)%type => + let '(_,σ') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). + assert (Hrhs : (interp_state sh (swr a v) σ >>= resume) ≅ + ((runStateT (sh (SWr a v)) σ >>= fun '(_,σ') => + Guard (interp_state sh (Ret tt) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold swr; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [[] σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). + { + transitivity (Ret (tt,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + q v (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) m σ ~ + (interp_state sh (semit q v) σ >>= fun '(_,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). +Proof. + assert (Hnode : (denote_flow (CEmit q v) >>= K) ≅ + Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CEmit q v) >>= K)) + (ts @ i := Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))) + (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (unit * SSig)%type => + let '(_,σ') := result in + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). + assert (Hrhs : (interp_state sh (semit q v) σ >>= resume) ≅ + ((runStateT (sh (SEmit q v)) σ >>= fun '(_,σ') => + Guard (interp_state sh (Ret tt) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold semit; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [[] σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). + { + transitivity (Ret (tt,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m σ : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun r => + match r with None => K None | Some x => denote_flow (next x) >>= K end)) + (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. +Qed. + +Lemma interp_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) m σ ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) None m σ. +Proof. + assert (Hnode : (denote_flow CYield >>= K) ≅ + Vis (inl Yield) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold source_yield. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow CYield >>= K)) + (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) + (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg unit) (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) m σ ~ + interp_schedule_rr sh (S (S n)) + ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) + (Some (Fin.FS i)) m σ. +Proof. + assert (Hnode : (denote_flow (CFork p) >>= K) ≅ + Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))). + { + cbn [denote_flow]; unfold source_fork. + rewrite bind_bind, bind_vis; step; constructor; intro child. + rewrite bind_ret_l; destruct child; cbn. + - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. + rewrite bind_ret_l; reflexivity. + - apply bind_ret_l. + } + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CFork p) >>= K)) + (ts @ i := Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))) + (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_fork by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end)) (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + set (loop_body := fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr (None : option unit)) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end). + change ((ICtree.iter loop_body tt >>= K) ≅ + (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) + end)). + transitivity ((loop_body tt >>= fun lr => + match lr with + | inl j => Guard (ICtree.iter loop_body j) + | inr result => Ret result + end) >>= K). + - apply equ_clo_bind with (S := eq). + + apply unfold_iter. + + intros r r' <-; reflexivity. + - etransitivity; [apply bind_bind|]. + unfold loop_body at 1. + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros [[x|]|]; cbn. + + etransitivity; [apply bind_ret_l|]. apply bind_guard. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. +Qed. + +Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) h c : + run_rr (CBind (CFork p) next) h c ~ + interp_schedule_rr sh 2 [denote p; denote (next tt)]%vector + (Some (Fin.FS Fin.F1)) 0 (h,c). +Proof. + unfold run_rr. + assert (Hpool : pool_equ [denote (CBind (CFork p) next)]%vector + [Vis (inr (inl Fork)) + (fun child : bool => if child then denote p else denote (next tt))]%vector). + { apply cons_pool_equ; [apply denote_fork_bind|apply pool_equ_refl]. } + rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 (h,c) Hpool). + erewrite interp_schedule_rr_fork by reflexivity. + reflexivity. +Qed. + +Lemma interp_nd_equ n (ts ts' : pool sE n) focus sigma : + pool_equ ts ts' -> + interp_nd n ts focus sigma ≅ interp_nd n ts' focus sigma. +Proof. + intro Hts; unfold interp_nd. + apply equ_interp_state; [|reflexivity]. + apply interp_yield_equ, interp_spawn_equ. + now apply schedule_pool_proper. +Qed. + +Lemma interp_nd_empty sigma : + interp_nd 0 ([] : pool sE 0) None sigma ~ Ret (tt,sigma). +Proof. + unfold interp_nd. + assert (Hempty : schedule 0 ([] : pool sE 0) None ≅ Ret tt). + { rewrite (ictree_eta (schedule 0 ([] : pool sE 0) None)), schedule_empty_none. + reflexivity. } + rewrite Hempty, interp_erase_ret, interp_state_ret; reflexivity. +Qed. + +Lemma interp_nd_ret n (ts : pool sE (S n)) (i : Fin.t (S n)) sigma : + observe (ts $ i) = RetF tt -> + interp_nd (S n) ts (Some i) sigma ~ interp_nd n (ts -- i) None sigma. +Proof. + intro Hobs; unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ Guard (schedule n (ts -- i) None)). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_ret n ts i Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. +Qed. + +Lemma interp_nd_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : + observe (ts $ i) = GuardF t -> + interp_nd (S n) ts (Some i) sigma ~ + interp_nd (S n) (ts @ i := t) (Some i) sigma. +Proof. + intro Hobs; unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Guard (schedule (S n) (ts @ i := t) (Some i))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_guard n ts i t Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. +Qed. + +Lemma interp_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) k sigma : + observe (ts $ i) = VisF (inl Yield) k -> + interp_nd (S n) ts (Some i) sigma ~ + interp_nd (S n) (ts @ i := k tt) None sigma. +Proof. + intro Hobs; unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Guard (schedule (S n) (ts @ i := k tt) None)). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_yield n ts i k Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. +Qed. + +Lemma interp_nd_select n (ts : pool sE (S n)) sigma : + interp_nd (S n) ts None sigma ~ + Br n (fun i => interp_nd (S n) ts (Some i) sigma). +Proof. + unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts None ≅ + Vis (inl Yield) (fun _ => Br n (fun i => schedule (S n) ts (Some i)))). + { rewrite (ictree_eta (schedule (S n) ts None)), schedule_no_focus_nonempty. + reflexivity. } + rewrite Hnode, interp_erase_yield, interp_state_tau, sb_guard, + interp_state_tau, sb_guard. + rewrite interp_erase_br, interp_state_br. + apply sb_br_id; intro i. + rewrite sb_guard, interp_state_tau, sb_guard, interp_state_tau, sb_guard; + reflexivity. +Qed. + +Lemma interp_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) k sigma : + observe (ts $ i) = VisF (inr (inl Fork)) k -> + interp_nd (S n) ts (Some i) sigma ~ + interp_nd (S (S n)) (k true :: (ts @ i := k false)) + (Some (Fin.FS i)) sigma. +Proof. + intro Hobs; unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Vis (inr (inl Spawn)) (fun _ => + schedule (S (S n)) (k true :: (ts @ i := k false)) (Some (Fin.FS i)))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_fork n ts i k Hobs); reflexivity. } + rewrite Hnode, interp_erase_spawn, interp_state_tau, sb_guard; reflexivity. +Qed. + +Lemma interp_nd_user n (ts : pool sE (S n)) (i : Fin.t (S n)) e k sigma : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_nd (S n) ts (Some i) sigma ~ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + interp_nd (S n) (ts @ i := k x) (Some i) sigma'). +Proof. + intro Hobs; unfold interp_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + sE)) + (fun x => schedule (S n) (ts @ i := k x) (Some i))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_user_event n ts i e k Hobs); reflexivity. } + rewrite Hnode, interp_erase_user, interp_state_vis. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite sb_guard, interp_state_tau, sb_guard, + interp_state_tau, sb_guard; reflexivity. +Qed. + +Lemma interp_nd_source_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ + interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ. +Proof. + apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + cbn [denote_flow]; apply bind_ret_l. +Qed. + +Lemma interp_nd_source_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ + (interp_state sh (srd a) σ >>= fun '(x,σ') => + interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ'). +Proof. + assert (Hnode : (denote_flow (CRead a) >>= K) ≅ + Vis (inr (inr (SRd a))) (fun x => K (Some x))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro x. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) + (ts @ i := Vis (inr (inr (SRd a))) (fun x => K (Some x))) + (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (nat * SSig)%type => + let '(x,σ') := result in + interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ'). + assert (Hrhs : (interp_state sh (srd a) σ >>= resume) ≅ + ((runStateT (sh (SRd a)) σ >>= fun '(x,σ') => + Guard (interp_state sh (Ret x) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold srd; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret x) σ' >>= resume) ≅ resume (x,σ')). + { + transitivity (Ret (x,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) sigma : + interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) sigma ~ + (interp_state sh (salloc size) sigma >>= fun '(base,sigma') => + interp_nd (S n) (ts @ i := K (Some base)) (Some i) sigma'). +Proof. + assert (Hnode : (denote_flow (CAlloc size) >>= K) ≅ + Vis (inr (inr (SAlloc size))) (fun base => K (Some base))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro base. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) + (ts @ i := Vis (inr (inr (SAlloc size))) (fun base => K (Some base))) + (Some i) sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (nat * SSig)%type => + let '(base,sigma') := result in + interp_nd (S n) (ts @ i := K (Some base)) (Some i) sigma'). + assert (Hrhs : (interp_state sh (salloc size) sigma >>= resume) ≅ + ((runStateT (sh (SAlloc size)) sigma >>= fun '(base,sigma') => + Guard (interp_state sh (Ret base) sigma')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold salloc; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [base sigma']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret base) sigma' >>= resume) ≅ resume (base,sigma')). + { + transitivity (Ret (base,sigma') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) sigma : + interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (Some i) sigma ~ + (interp_state sh (scas a expected desired) sigma >>= fun '(b,sigma') => + interp_nd (S n) (ts @ i := K (Some b)) (Some i) sigma'). +Proof. + assert (Hnode : (denote_flow (CCAS a expected desired) >>= K) ≅ + Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intro b. + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (ts @ i := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) + (Some i) sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (bool * SSig)%type => + let '(b,sigma') := result in + interp_nd (S n) (ts @ i := K (Some b)) (Some i) sigma'). + assert (Hrhs : (interp_state sh (scas a expected desired) sigma >>= resume) ≅ + ((runStateT (sh (SCAS a expected desired)) sigma >>= fun '(b,sigma') => + Guard (interp_state sh (Ret b) sigma')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold scas; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [b sigma']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret b) sigma' >>= resume) ≅ resume (b,sigma')). + { + transitivity (Ret (b,sigma') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ + (interp_state sh (swr a v) σ >>= fun '(_,σ') => + interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). +Proof. + assert (Hnode : (denote_flow (CWrite a v) >>= K) ≅ + Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) + (ts @ i := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) + (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (unit * SSig)%type => + let '(_,σ') := result in + interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). + assert (Hrhs : (interp_state sh (swr a v) σ >>= resume) ≅ + ((runStateT (sh (SWr a v)) σ >>= fun '(_,σ') => + Guard (interp_state sh (Ret tt) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold swr; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [[] σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). + { + transitivity (Ret (tt,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + q v (K : option unit -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) σ ~ + (interp_state sh (semit q v) σ >>= fun '(_,σ') => + interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). +Proof. + assert (Hnode : (denote_flow (CEmit q v) >>= K) ≅ + Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold heap_event. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CEmit q v) >>= K)) + (ts @ i := Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))) + (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + set (resume := fun result : (unit * SSig)%type => + let '(_,σ') := result in + interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). + assert (Hrhs : (interp_state sh (semit q v) σ >>= resume) ≅ + ((runStateT (sh (SEmit q v)) σ >>= fun '(_,σ') => + Guard (interp_state sh (Ret tt) σ')) >>= resume)). + { + apply equ_clo_bind with (S := eq). + - unfold semit; apply interp_state_vis. + - intros r r' <-; reflexivity. + } + rewrite Hrhs, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [[] σ']; rewrite bind_guard, sb_guard. + assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). + { + transitivity (Ret (tt,σ') >>= resume). + - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. + intros r r' <-; reflexivity. + - apply bind_ret_l. + } + rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) σ : + interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) σ ≅ + interp_nd (S n) + (ts @ i := (denote_flow p >>= fun r => + match r with None => K None | Some x => denote_flow (next x) >>= K end)) + (Some i) σ. +Proof. + apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. +Qed. + +Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ + interp_nd (S n) (ts @ i := K (Some tt)) None σ. +Proof. + assert (Hnode : (denote_flow CYield >>= K) ≅ + Vis (inl Yield) (fun _ => K (Some tt))). + { + cbn [denote_flow]; unfold source_yield. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow CYield >>= K)) + (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) + (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg unit) (K : option unit -> thread sE) σ : + interp_nd (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) σ ~ + interp_nd (S (S n)) + ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) + (Some (Fin.FS i)) σ. +Proof. + assert (Hnode : (denote_flow (CFork p) >>= K) ≅ + Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))). + { + cbn [denote_flow]; unfold source_fork. + rewrite bind_bind, bind_vis; step; constructor; intro child. + rewrite bind_ret_l; destruct child; cbn. + - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. + rewrite bind_ret_l; reflexivity. + - apply bind_ret_l. + } + pose proof (interp_nd_equ (S n) + (ts @ i := (denote_flow (CFork p) >>= K)) + (ts @ i := Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))) + (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_fork by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) σ : + interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) σ ≅ + interp_nd (S n) + (ts @ i := (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end)) (Some i) σ. +Proof. + apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + set (loop_body := fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr (None : option unit)) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end). + change ((ICtree.iter loop_body tt >>= K) ≅ + (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) + end)). + transitivity ((loop_body tt >>= fun lr => + match lr with + | inl j => Guard (ICtree.iter loop_body j) + | inr result => Ret result + end) >>= K). + - apply equ_clo_bind with (S := eq). + + apply unfold_iter. + + intros r r' <-; reflexivity. + - etransitivity; [apply bind_bind|]. + unfold loop_body at 1. + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros [[x|]|]; cbn. + + etransitivity; [apply bind_ret_l|]. apply bind_guard. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. +Qed. diff --git a/theories/Lang/CSL/Pcm.v b/theories/Lang/CSL/Pcm.v new file mode 100644 index 0000000..c4736a3 --- /dev/null +++ b/theories/Lang/CSL/Pcm.v @@ -0,0 +1,515 @@ +(** * A partial commutative monoid with explicit definedness, and a concrete + disjoint-heap model. + + Design notes, all of them forced by the evidence collected earlier in this + project: + + - The composition is *partial*. We present it, as separation algebras + usually are, by a total operation [pop] together with a definedness + predicate [pdef]. This keeps every law a first-order statement and + avoids reasoning about [option] equalities inside a setoid. + + - The carrier comes with its own equivalence [peq]. This is deliberate: + the intended heap model is a *map*, and list concatenation is not + commutative under list equality. We therefore fix a justified map + representation (total functions [nat -> option nat]) and a justified map + equivalence (pointwise equality), and prove commutativity for that + equivalence rather than assuming it for a representation that does not + have it. + + - Cancellativity is NOT a field of the class. It is defined separately, + below, so that a theorem can be checked to be independent of it simply by + being provable in a section that only assumes [PCM]. [BoolPCM] below is + a PCM in which cancellativity provably fails; the transport theorems of + [Transport.v] instantiate at it. *) + +From Stdlib Require Import + Basics + Arith.PeanoNat + Lia + Relations. + +Generalizable All Variables. + +(** ** The interface *) +Class PCM (A: Type) := { + (** the justified equivalence on the carrier *) + peq : A -> A -> Prop; + (** definedness / compatibility of a composition *) + pdef : A -> A -> Prop; + (** the composition, meaningful exactly when [pdef] holds *) + pop : A -> A -> A; + (** the unit *) + pemp : A; + + peq_refl : forall a, peq a a; + peq_sym : forall a b, peq a b -> peq b a; + peq_trans : forall a b c, peq a b -> peq b c -> peq a c; + + (** both [pdef] and [pop] respect the equivalence *) + pdef_resp : forall a a' b b', peq a a' -> peq b b' -> pdef a b -> pdef a' b'; + pop_resp : forall a a' b b', peq a a' -> peq b b' -> peq (pop a b) (pop a' b'); + + (** commutativity, in both components *) + pdef_comm : forall a b, pdef a b -> pdef b a; + pop_comm : forall a b, pdef a b -> peq (pop a b) (pop b a); + + (** unit laws *) + pdef_emp : forall a, pdef pemp a; + pop_emp : forall a, peq (pop pemp a) a; + + (** associativity, with the definedness bookkeeping made explicit *) + pdef_assocL : forall a b c, pdef b c -> pdef a (pop b c) -> pdef a b; + pdef_assocR : forall a b c, pdef b c -> pdef a (pop b c) -> pdef (pop a b) c; + pdef_assocI : forall a b c, pdef b c -> pdef a b -> pdef (pop a b) c -> pdef a (pop b c); + pop_assoc : forall a b c, + pdef b c -> pdef a (pop b c) -> peq (pop a (pop b c)) (pop (pop a b) c) +}. + +Declare Scope pcm_scope. +Delimit Scope pcm_scope with pcm. +Notation "a ⊎ b" := (pop a b) (at level 50, left associativity): pcm_scope. +Notation "a # b" := (pdef a b) (at level 70, no associativity): pcm_scope. +Notation "a ≈ b" := (peq a b) (at level 70, no associativity): pcm_scope. +Local Open Scope pcm_scope. + +(** Cancellativity is a *separate* property. Everything proved in a section + that assumes only [PCM] is, by construction, independent of it. *) +Definition Cancellative (A: Type) `{PCM A} : Prop := + forall a b c, a # b -> a # c -> a ⊎ b ≈ a ⊎ c -> b ≈ c. + +Section PcmFacts. + Context {A: Type} `{PCM A}. + + Lemma pop_emp_r: forall a, a # pemp -> a ⊎ pemp ≈ a. + Proof. + intros a Hd. + eapply peq_trans; [apply pop_comm; auto | apply pop_emp]. + Qed. + + Lemma pdef_emp_r: forall a, a # pemp. + Proof. intro a; apply pdef_comm, pdef_emp. Qed. + + (** The "other" associativity direction, derived. *) + Lemma pop_assoc': forall a b c, + b # c -> a # (b ⊎ c) -> (a ⊎ b) ⊎ c ≈ a ⊎ (b ⊎ c). + Proof. intros; apply peq_sym, pop_assoc; auto. Qed. +End PcmFacts. + +(** ** Spatial assertions over an arbitrary PCM *) +Definition assn (A: Type) := A -> Prop. + +Section Assertions. + Context {A: Type} `{PCM A}. + + (** An assertion is *well formed* when it does not distinguish equivalent + resources. Every assertion built below is well formed. *) + Definition AProper (P: assn A) : Prop := forall a b, a ≈ b -> P a -> P b. + + Definition aemp : assn A := fun a => a ≈ pemp. + + Definition asep (P Q: assn A) : assn A := + fun a => exists a1 a2, a1 # a2 /\ a ≈ a1 ⊎ a2 /\ P a1 /\ Q a2. + + Definition awand (P Q: assn A) : assn A := + fun a => forall b, a # b -> P b -> Q (a ⊎ b). + + Definition atrue : assn A := fun _ => True. + + Lemma aemp_proper: AProper aemp. + Proof. intros a b Hab Ha; unfold aemp in *; eauto using peq_sym, peq_trans. Qed. + + Lemma asep_proper: forall P Q, AProper (asep P Q). + Proof. + intros P Q a b Hab (a1 & a2 & Hd & Heq & HP & HQ). + exists a1, a2; repeat split; auto. + eauto using peq_sym, peq_trans. + Qed. + + (** [⋆] is commutative. *) + Lemma asep_comm: forall P Q a, asep P Q a -> asep Q P a. + Proof. + intros P Q a (a1 & a2 & Hd & Heq & HP & HQ). + exists a2, a1; repeat split; auto using pdef_comm. + eapply peq_trans; [exact Heq | apply pop_comm; auto]. + Qed. + + (** [emp] is a left unit, in both directions. *) + Lemma asep_emp_l: forall P a, AProper P -> P a -> asep aemp P a. + Proof. + intros P a HP Ha. + exists pemp, a; repeat split; auto using pdef_emp, peq_refl. + - apply peq_sym, pop_emp. + - unfold aemp; apply peq_refl. + Qed. + + Lemma asep_emp_l_inv: forall P a, AProper P -> asep aemp P a -> P a. + Proof. + intros P a HP (a1 & a2 & Hd & Heq & Hemp & HQ). + eapply HP; [| exact HQ]. + apply peq_sym. + eapply peq_trans; [exact Heq |]. + eapply peq_trans; [| apply pop_emp]. + apply pop_resp; auto using peq_refl. + Qed. + + (** [⋆] is associative, one direction shown (the other is symmetric). *) + Lemma asep_assoc: forall P Q R a, + asep P (asep Q R) a -> asep (asep P Q) R a. + Proof. + intros P Q R a (a1 & a23 & Hd1 & Heq1 & HP & (a2 & a3 & Hd2 & Heq2 & HQ & HR)). + assert (Hd1': a1 # (a2 ⊎ a3)) by (eapply pdef_resp; [apply peq_refl | exact Heq2 | exact Hd1]). + exists (a1 ⊎ a2), a3; repeat split. + - eapply pdef_assocR; eauto. + - eapply peq_trans; [exact Heq1 |]. + eapply peq_trans; [| eapply pop_assoc; eauto]. + apply pop_resp; auto using peq_refl. + - exists a1, a2; repeat split; auto using peq_refl. + eapply pdef_assocL; eauto. + - assumption. + Qed. + + (** Monotonicity: the frame rule of the *spatial* layer. *) + Lemma asep_mono: forall (P P' Q Q': assn A) a, + (forall x, P x -> P' x) -> (forall x, Q x -> Q' x) -> + asep P Q a -> asep P' Q' a. + Proof. + intros * HP HQ (a1 & a2 & Hd & Heq & H1 & H2). + exists a1, a2; auto. + Qed. + + (** The adjunction, both directions. [awand] is recorded because the brief + lists it as optional; nothing downstream depends on it. *) + Lemma awand_intro: forall (P Q R: assn A), + (forall a, asep P Q a -> R a) -> + forall a, P a -> awand Q R a. + Proof. + intros P Q R Hpq a Ha b Hd HQ. + apply Hpq; exists a, b; repeat split; auto using peq_refl. + Qed. + + Lemma awand_elim: forall (P Q: assn A) a, + asep (awand P Q) P a -> AProper Q -> Q a. + Proof. + intros P Q a (a1 & a2 & Hd & Heq & Hw & HP) HQ. + eapply HQ; [apply peq_sym; exact Heq |]. + now apply Hw. + Qed. +End Assertions. + +Arguments AProper {A _} P. +Arguments aemp {A _}. +Arguments asep {A _} P Q. +Arguments awand {A _} P Q. +Arguments atrue {A _}. + +Notation "P ⋆ Q" := (asep P Q) (at level 55, right associativity): pcm_scope. +Notation "P -⋆ Q" := (awand P Q) (at level 60, right associativity): pcm_scope. + +(** ** The concrete model: finite partial maps as total functions. + + Representation: [nat -> option nat]. Equivalence: pointwise equality. + Composition: union, defined exactly on disjoint pairs. This is the + "justified map representation / equivalence" the brief asks for; it is not + an association list under list equality, for which commutativity is false. *) +Definition Heap := nat -> option nat. + +Definition hemp : Heap := fun _ => None. +Definition heq (h1 h2: Heap) : Prop := forall a, h1 a = h2 a. +Definition hdisj (h1 h2: Heap) : Prop := forall a, h1 a = None \/ h2 a = None. +Definition hunion (h1 h2: Heap) : Heap := + fun a => match h1 a with Some v => Some v | None => h2 a end. + +Definition hsingle (a v: nat) : Heap := + fun b => if Nat.eq_dec a b then Some v else None. +Definition hupd (a v: nat) (h: Heap) : Heap := + fun b => if Nat.eq_dec a b then Some v else h b. +Definition hfree (a: nat) (h: Heap) : Heap := + fun b => if Nat.eq_dec a b then None else h b. + +Ltac hcase a := unfold hunion, hupd, hfree, hsingle, hemp in *; + intros; repeat (destruct (Nat.eq_dec _ _)); subst; auto. + +Lemma hdisj_none: forall h1 h2 a v, hdisj h1 h2 -> h1 a = Some v -> h2 a = None. +Proof. intros h1 h2 a v Hd Hs; destruct (Hd a) as [Hn | Hn]; congruence. Qed. + +(** Every law is proved as a standalone lemma first, so that the instance is a + list of [exact]s and its field order cannot silently drift. *) +Lemma heq_refl: forall a, heq a a. +Proof. intros a x; reflexivity. Qed. + +Lemma heq_sym: forall a b, heq a b -> heq b a. +Proof. intros a b Hab x; now rewrite Hab. Qed. + +Lemma heq_trans: forall a b c, heq a b -> heq b c -> heq a c. +Proof. intros a b c Hab Hbc x; now rewrite Hab, Hbc. Qed. + +Lemma hdisj_resp: forall a a' b b', heq a a' -> heq b b' -> hdisj a b -> hdisj a' b'. +Proof. intros a a' b b' Ha Hb Hd x; rewrite <- Ha, <- Hb; apply Hd. Qed. + +Lemma hunion_resp: forall a a' b b', heq a a' -> heq b b' -> heq (hunion a b) (hunion a' b'). +Proof. intros a a' b b' Ha Hb x; unfold hunion; rewrite Ha, Hb; reflexivity. Qed. + +Lemma hdisj_sym: forall a b, hdisj a b -> hdisj b a. +Proof. intros a b Hd x; destruct (Hd x); auto. Qed. + +Lemma hunion_comm: forall a b, hdisj a b -> heq (hunion a b) (hunion b a). +Proof. + intros a b Hd x; unfold hunion; destruct (Hd x) as [Hx | Hx]; rewrite Hx. + - destruct (b x); reflexivity. + - destruct (a x); reflexivity. +Qed. + +Lemma hdisj_hemp: forall a, hdisj hemp a. +Proof. intros a x; left; reflexivity. Qed. + +Lemma hunion_hemp: forall a, heq (hunion hemp a) a. +Proof. intros a x; reflexivity. Qed. + +Lemma hdisj_assocL: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj a b. +Proof. + intros a b c Hbc Ha x; specialize (Ha x); unfold hunion in Ha. + destruct (b x) eqn:Hb; auto. +Qed. + +Lemma hdisj_assocR: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj (hunion a b) c. +Proof. + intros a b c Hbc Ha x; specialize (Ha x); specialize (Hbc x); unfold hunion in *. + destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; + intuition (try discriminate); auto. +Qed. + +Lemma hdisj_assocI: forall a b c, + hdisj b c -> hdisj a b -> hdisj (hunion a b) c -> hdisj a (hunion b c). +Proof. + intros a b c Hbc Hab Habc x. + specialize (Hbc x); specialize (Hab x); specialize (Habc x); unfold hunion in *. + destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; + intuition (try discriminate); auto. +Qed. + +Lemma hunion_assoc: forall a b c, + hdisj b c -> hdisj a (hunion b c) -> heq (hunion a (hunion b c)) (hunion (hunion a b) c). +Proof. intros a b c _ _ x; unfold hunion; destruct (a x); reflexivity. Qed. + +#[global] Instance HeapPCM : PCM Heap. +Proof. + refine {| peq := heq; pdef := hdisj; pop := hunion; pemp := hemp |}. + - exact heq_refl. + - exact heq_sym. + - exact heq_trans. + - exact hdisj_resp. + - exact hunion_resp. + - exact hdisj_sym. + - exact hunion_comm. + - exact hdisj_hemp. + - exact hunion_hemp. + - exact hdisj_assocL. + - exact hdisj_assocR. + - exact hdisj_assocI. + - exact hunion_assoc. +Defined. + +(** Heaps are cancellative -- recorded to show the class is not weakened by + leaving cancellativity out; nothing in [Transport.v] uses this. *) +Lemma HeapCancellative: Cancellative Heap. +Proof. + intros a b c Hab Hac Heq x; cbn in *. + unfold heq, hunion, hdisj in *. + specialize (Heq x); specialize (Hab x); specialize (Hac x). + destruct (a x) eqn:Ha; auto. + destruct Hab as [? | Hb]; [congruence |]. + destruct Hac as [? | Hc]; [congruence |]. + congruence. +Qed. + +(** ** A PCM in which cancellativity fails. + + Carrier [bool], composition [orb], always defined, unit [false]. Every PCM + law holds; cancellativity does not. [Transport.v] instantiates its six + transport theorems at this PCM, which is the evidence that generic + transport does not need cancellativity. *) +#[global] Instance BoolPCM : PCM bool. +Proof. + refine {| peq := @eq bool; pdef := fun _ _ => True; pop := orb; pemp := false |}. + - reflexivity. + - intros a b; auto. + - intros a b c; apply eq_trans. + - intros a a' b b' Ha Hb _; exact I. + - intros a a' b b' Ha Hb; now subst. + - intros a b _; exact I. + - intros a b _; apply Bool.orb_comm. + - intros a; exact I. + - intros a; reflexivity. + - intros a b c _ _; exact I. + - intros a b c _ _; exact I. + - intros a b c _ _ _; exact I. + - intros a b c _ _; now rewrite Bool.orb_assoc. +Defined. + +Theorem bool_pcm_not_cancellative: ~ Cancellative bool. +Proof. + intro Hc. + assert (Hd: (true # true)%pcm) by exact I. + assert (Hd': (true # false)%pcm) by exact I. + assert (Heq: (true ⊎ true ≈ true ⊎ false)%pcm) by reflexivity. + specialize (Hc true true false Hd Hd' Heq). + cbn in Hc; discriminate. +Qed. + +(** ** Points-to, and the separation it buys. + + [pto a v] is an assertion about the *owned* resource. Note the evidence + from the companion experiment: [CNow] is tree-blind, so this can never be a + TICL base predicate on its own. It is a predicate on the resource, lifted + into the temporal layer only through the owned projection in + [Transport.v]. *) +Definition pto (a v: nat) : assn Heap := fun h => heq h (hsingle a v). + +Lemma pto_proper: forall a v, AProper (pto a v). +Proof. intros a v h1 h2 Heq Hp x; rewrite <- Heq; apply Hp. Qed. + +Lemma pto_lookup: forall a v h, pto a v h -> h a = Some v. +Proof. intros a v h Hp; rewrite Hp; hcase a; congruence. Qed. + +(** Two points-to on the same address cannot be separated: the hallmark + consequence of a disjointness-based PCM. *) +Theorem pto_sep_same_false: forall a v v' h, ~ (pto a v ⋆ pto a v')%pcm h. +Proof. + intros a v v' h (h1 & h2 & Hd & Heq & H1 & H2). + apply pto_lookup in H1; apply pto_lookup in H2. + destruct (Hd a); congruence. +Qed. + +(** Distinct addresses do separate. *) +Theorem pto_sep_distinct: forall a b v v', + a <> b -> (pto a v ⋆ pto b v')%pcm (hunion (hsingle a v) (hsingle b v')). +Proof. + intros a b v v' Hab. + exists (hsingle a v), (hsingle b v'). + split; [| split; [| split]]. + - intro x; unfold hsingle; destruct (Nat.eq_dec a x); destruct (Nat.eq_dec b x); + subst; auto. + exfalso; auto. + - intro x; reflexivity. + - intro x; reflexivity. + - intro x; reflexivity. +Qed. + +(** ** Safe-access locality on the concrete heap. + + Each of the three laws is stated with the footprint hypothesis it needs, + and [HeapLocal.v] refutes each of them once that hypothesis is dropped. *) + +(** A read inside the owned footprint returns the owned value, under every + compatible frame. *) +Theorem read_local: forall h f a v, + hdisj h f -> h a = Some v -> hunion h f a = Some v. +Proof. intros h f a v Hd Ha; unfold hunion; now rewrite Ha. Qed. + +(** A write inside the owned footprint keeps the frame disjoint ... *) +Theorem write_local_disj: forall h f a v v0, + hdisj h f -> h a = Some v0 -> hdisj (hupd a v h) f. +Proof. + intros h f a v v0 Hd Ha x; unfold hupd; destruct (Nat.eq_dec a x). + - subst; right; eapply hdisj_none; eauto. + - apply Hd. +Qed. + +(** ... and commutes with framing. *) +Theorem write_local_frame: forall h f a v, + heq (hupd a v (hunion h f)) (hunion (hupd a v h) f). +Proof. intros h f a v x; unfold hupd, hunion; destruct (Nat.eq_dec a x); auto. Qed. + +(** A free inside the owned footprint keeps the frame disjoint ... *) +Theorem free_local_disj: forall h f a, + hdisj h f -> hdisj (hfree a h) f. +Proof. intros h f a Hd x; unfold hfree; destruct (Nat.eq_dec a x); auto. Qed. + +(** ... and commutes with framing, provided the address is owned. *) +Theorem free_local_frame: forall h f a v0, + hdisj h f -> h a = Some v0 -> + heq (hfree a (hunion h f)) (hunion (hfree a h) f). +Proof. + intros h f a v0 Hd Ha x; unfold hfree, hunion; destruct (Nat.eq_dec a x); auto. + subst; erewrite hdisj_none; eauto. +Qed. + +(** ** Finite blocks over the unrestricted function heap. + Bounds are proof witnesses only; allocation searches in its handler. + Fresh ownership preserves the old resource, not literal frame-stable bases. *) + +Definition heap_bounded (bound : nat) (h : Heap) : Prop := + forall x, Nat.le bound x -> h x = None. +Definition heap_finite (h : Heap) : Prop := + exists bound, heap_bounded bound h. +Definition hblock (base size : nat) : Heap := + fun x => if andb (Nat.leb base x) (Nat.ltb x (base + size)) + then Some 0 else None. +Definition block_free (h : Heap) (base size : nat) : Prop := + forall offset, Nat.lt offset size -> h (base + offset) = None. +Definition block_pto (base size : nat) : Heap -> Prop := + fun h => heq h (hblock base size). + +Lemma hblock_in base size offset : + Nat.lt offset size -> hblock base size (base + offset) = Some 0. +Proof. + intro H; unfold hblock. + assert (L : Nat.leb base (base + offset) = true) + by (apply Nat.leb_le; lia). + assert (R : Nat.ltb (base + offset) (base + size) = true) + by (apply Nat.ltb_lt; lia). + now rewrite L, R. +Qed. + +Lemma hblock_out base size x : + (Nat.lt x base \/ Nat.le (base + size) x) -> + hblock base size x = None. +Proof. + intro H; unfold hblock. + destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); + cbn; try reflexivity; lia. +Qed. + +Lemma block_free_disjoint h base size : + block_free h base size <-> hdisj (hblock base size) h. +Proof. + split. + - intros H x. + destruct (Nat.le_gt_cases base x) as [L | L]; + [destruct (Nat.lt_ge_cases x (base + size)) as [R | R] |]. + + right; replace x with (base + (x - base)) by lia; apply H; lia. + + left; apply hblock_out; auto. + + left; apply hblock_out; auto. + - intros H offset O; specialize (H (base + offset)). + rewrite (hblock_in base size offset O) in H; destruct H; congruence. +Qed. + +Lemma heap_finite_hemp : heap_finite hemp. +Proof. exists 0; intros x H; reflexivity. Qed. + +Lemma heap_finite_hblock base size : heap_finite (hblock base size). +Proof. + exists (base + size); intros x H; apply hblock_out; auto. +Qed. + +Lemma heap_finite_hunion h f : + heap_finite h -> heap_finite f -> heap_finite (hunion h f). +Proof. + intros [B HB] [C HC]; exists (Nat.max B C); intros x H. + unfold hunion; rewrite HB, HC; try reflexivity; lia. +Qed. + +Lemma heap_bounded_block_free bound h base size : + heap_bounded bound h -> Nat.le bound base -> block_free h base size. +Proof. intros H B offset O; apply H; lia. Qed. + +Lemma allocated_block_sep base size h (P : Heap -> Prop) : + block_free h base size -> P h -> + asep (block_pto base size) P (hunion (hblock base size) h). +Proof. + intros F H; exists (hblock base size), h. + split; [apply block_free_disjoint; exact F |]. + split; [apply heq_refl |]. + split; [apply heq_refl | exact H]. +Qed. diff --git a/theories/Lang/CSL/Syntax.v b/theories/Lang/CSL/Syntax.v new file mode 100644 index 0000000..8d22ba0 --- /dev/null +++ b/theories/Lang/CSL/Syntax.v @@ -0,0 +1,14 @@ +Module CSLSyntax. + Inductive CProg : Type -> Type := + | CRead (a : nat) : CProg nat + | CWrite (a v : nat) : CProg unit + | CEmit (tag value : nat) : CProg unit + | CYield : CProg unit + | CFork (body : CProg unit) : CProg unit + | CRet {A : Type} (value : A) : CProg A + | CBind {A B : Type} (body : CProg A) (next : A -> CProg B) : CProg B + | CUntilNone {A : Type} (body : CProg (option A)) : CProg unit + | CAlloc (size : nat) : CProg nat + | CCAS (a expected desired : nat) : CProg bool. +End CSLSyntax. +Export CSLSyntax. diff --git a/theories/Lang/HeapImp.v b/theories/Lang/HeapImp.v index 0623cf5..a5b935a 100644 --- a/theories/Lang/HeapImp.v +++ b/theories/Lang/HeapImp.v @@ -13,10 +13,10 @@ From TICL Require Import ICTree.Core ICTree.SBisim ICTree.Equ - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Logic.Trans + ICTree.Logic.Trans Logic.Core ICTree.Logic.AX ICTree.Logic.AF diff --git a/theories/Lang/MeQ.v b/theories/Lang/MeQ.v index d551d29..f40e054 100644 --- a/theories/Lang/MeQ.v +++ b/theories/Lang/MeQ.v @@ -8,10 +8,10 @@ From TICL Require Import ICTree.Core ICTree.SBisim ICTree.Equ - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Logic.Trans + ICTree.Logic.Trans Logic.Core ICTree.Logic.AX ICTree.Logic.AF diff --git a/theories/Lang/MeS.v b/theories/Lang/MeS.v index 019cfea..8eca0ac 100644 --- a/theories/Lang/MeS.v +++ b/theories/Lang/MeS.v @@ -12,10 +12,10 @@ From TICL Require Import ICTree.Core ICTree.SBisim ICTree.Equ - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Logic.Trans + ICTree.Logic.Trans Logic.Core ICTree.Logic.AX ICTree.Logic.AF diff --git a/theories/Lang/StImp.v b/theories/Lang/StImp.v index 178e3b2..98b8505 100644 --- a/theories/Lang/StImp.v +++ b/theories/Lang/StImp.v @@ -11,10 +11,10 @@ From TICL Require Import ICTree.Core ICTree.SBisim ICTree.Equ - ICTree.Interp.State + ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Logic.Trans + ICTree.Logic.Trans Logic.Core ICTree.Logic.AX ICTree.Logic.AF diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v index adc1084..ec872c3 100644 --- a/theories/Lang/Yield.v +++ b/theories/Lang/Yield.v @@ -1,9 +1,16 @@ +(** Yield language façade. + + Both proof levels are exposed: first the reusable results over interpreted + [ictree] values, then the source-syntax layer that instantiates them. *) From TICL Require Export - Lang.Yield.Events + ICTree.Events.Yield + Utils.Vectors + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim + ICTree.Logic.Yield + ICTree.Logic.SchedulerFairness Lang.Yield.Syntax - Lang.Yield.Vec Lang.Yield.Denote - Lang.Yield.Scheduler Lang.Yield.Interp Lang.Yield.Ticl Lang.Yield.SBisim diff --git a/theories/Lang/Yield/Denote.v b/theories/Lang/Yield/Denote.v index 08a4108..a8fcd75 100644 --- a/theories/Lang/Yield/Denote.v +++ b/theories/Lang/Yield/Denote.v @@ -3,8 +3,8 @@ From ExtLib Require Import Data.Map.FMapAList Data.String Structures.Maps. From TICL Require Import ICTree.Core Events.StateE + ICTree.Events.Yield Lang.Maps - Lang.Yield.Events Lang.Yield.Syntax. Import ICtree ICTreeNotations. @@ -108,3 +108,107 @@ Fixpoint denote_stmt_flow (s : YStmt) : ictree YEff YStmtFlow := Definition denote_stmt (s : YStmt) : ictree YEff unit := _ <- denote_stmt_flow s;; Ret tt. + +(** * Constructor unfold facts *) + +(** Expression denotation constructor unfold facts. *) +Lemma denote_exp_yvar name : + denote_exp (YVar name) = + (ctx <- yget;; + match lookup name ctx with + | Some value => yyield;; Ret value + | None => stuck + end). +Proof. reflexivity. Qed. + +Lemma denote_exp_ylit n : denote_exp (YLit n) = Ret n. +Proof. reflexivity. Qed. + +Lemma denote_exp_yplus a b : + denote_exp (YPlus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_yminus a b : + denote_exp (YMinus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_ymult a b : + denote_exp (YMult a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). +Proof. reflexivity. Qed. + +(** Flow-sensitive statement denotation constructor unfold facts. *) +Lemma denote_stmt_unfold s : + denote_stmt s = (_ <- denote_stmt_flow s;; Ret tt). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yassign name expr : + denote_stmt_flow (YAssign name expr) = + (value <- denote_exp expr;; + ctx <- yget;; + yput (add name value ctx);; + Ret Fallthrough). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yseq a b : + denote_stmt_flow (YSeq a b) = + (flow <- denote_stmt_flow a;; + match flow with + | Fallthrough => denote_stmt_flow b + | HaltThread => Ret HaltThread + end). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yif test then_branch else_branch : + denote_stmt_flow (YIf test then_branch else_branch) = + (condition_value <- denote_exp test;; + if YieldSyntax.is_true condition_value then + denote_stmt_flow then_branch + else + denote_stmt_flow else_branch). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_ywhile test body : + denote_stmt_flow (YWhile test body) = + ICtree.iter + (fun _ => + condition_value <- denote_exp test;; + if YieldSyntax.is_true condition_value then + flow <- denote_stmt_flow body;; + match flow with + | Fallthrough => Ret (inl tt) + | HaltThread => Ret (inr HaltThread) + end + else + Ret (inr Fallthrough)) tt. +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yfork body : + denote_stmt_flow (YFork body) = + (in_child <- yfork;; + if in_child then + _ <- denote_stmt_flow body;; + Ret HaltThread + else + Ret Fallthrough). +Proof. reflexivity. Qed. + +Lemma denote_stmt_yfork body : + denote_stmt (YFork body) = + (_ <- (in_child <- yfork;; + if in_child then + _ <- denote_stmt_flow body;; + Ret HaltThread + else + Ret Fallthrough);; + Ret tt). +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yskip : denote_stmt_flow YSkip = Ret Fallthrough. +Proof. reflexivity. Qed. + +Lemma denote_stmt_flow_yyield : + denote_stmt_flow YYield = (yyield;; Ret Fallthrough). +Proof. reflexivity. Qed. diff --git a/theories/Lang/Yield/Interp.v b/theories/Lang/Yield/Interp.v index 14c4e9e..8020039 100644 --- a/theories/Lang/Yield/Interp.v +++ b/theories/Lang/Yield/Interp.v @@ -1,4 +1,4 @@ -From Stdlib Require Import Fin. +From Stdlib Require Import Fin Vector. From ExtLib Require Import Structures.Monad Data.Monads.StateMonad @@ -8,51 +8,35 @@ From ExtLib Require Import From TICL Require Import ICTree.Core ICTree.Interp.Core - ICTree.Interp.State + ICTree.Interp.State.Mod + ICTree.Interp.Yield.Mod + ICTree.Events.Yield ICTree.Events.State ICTree.Events.Writer Events.Core Events.StateE Lang.Maps - Lang.Yield.Events Lang.Yield.Syntax Lang.Yield.Denote - Lang.Yield.Scheduler. + Utils.Vectors. -Import ICtree ICTreeNotations. +Import ICtree ICTreeNotations VectorNotations. Local Open Scope ictree_scope. +(** * Source-level startup and instrumentation wrappers *) +(** Every definition below is a direct instantiation of the raw interpreter + layer in [ICTree.Interp.Yield.Mod] at the Yield source denotations. *) + (** Start a source statement as a singleton pool focused on its only thread. This is the scheduler-visible view: source [Fork] events have been scheduled into scheduler [Spawn] observations, and cooperative [Yield] observations remain visible alongside memory effects. *) Definition scheduled_visible (s : YStmt) : completed Mem := - schedule 1 (fun _ => denote_stmt s) (Some Fin.F1). + schedule 1 [denote_stmt s]%vector (Some Fin.F1). (** Backward-compatible name for the scheduler-visible scheduled computation. *) Definition scheduled : YStmt -> completed Mem := scheduled_visible. -(** Erase scheduler spawn observations while preserving yield and memory events. *) -Definition handle_spawn : (yieldE + (spawnE + Mem)) ~> ictree (yieldE + Mem) := - fun event => - match event with - | inl y => ICtree.trigger y - | inr (inl Spawn) => Ret tt - | inr (inr m) => ICtree.trigger m - end. -Definition interp_spawn {X} (t : ictree (yieldE + (spawnE + Mem)) X) : ictree (yieldE + Mem) X := - interp handle_spawn t. - -(** Erase cooperative yield observations, leaving only memory effects. *) -Definition handle_yield : (yieldE + Mem) ~> ictree Mem := - fun event => - match event with - | inl Yield => Ret tt - | inr m => ICtree.trigger m - end. -Definition interp_yield {X} (t : ictree (yieldE + Mem) X) : ictree Mem X := - interp handle_yield t. - (** Erased scheduled interpretation: both scheduler [Spawn] and cooperative [Yield] observations are intentionally erased, leaving only memory effects. *) Definition interp_scheduled_erased (s : YStmt) : ictree Mem unit := @@ -63,28 +47,22 @@ Definition interp_scheduled_erased (s : YStmt) : ictree Mem unit := [interp_scheduled_erased]. *) Definition interp_scheduled : YStmt -> ictree Mem unit := interp_scheduled_erased. -(** Interpret a raw thread without scheduling by resolving [Fork] to [false], - so a standalone thread behaves as the parent path and never starts the - fork body. *) -Definition handle_thread : YEff ~> ictree (yieldE + Mem) := - fun event => - match event with - | inl y => ICtree.trigger y - | inr (inl Fork) => Ret false - | inr (inr m) => ICtree.trigger m - end. -Definition interp_thread {X} (t : ictree YEff X) : ictree Mem X := - interp_yield (interp handle_thread t). - (** Erased expression instrumentation: raw thread-level [Yield] observations are erased before state instrumentation. *) Definition instr_exp_erased (e : YExp) (ctx : Ctx) : ictreeW Ctx (nat * Ctx) := - instr_stateE (interp_thread (denote_exp e)) ctx. + instr_thread (denote_exp e) ctx. + +(** Flow-preserving erased statement instrumentation for structural facts whose + contracts must expose [Fallthrough] versus [HaltThread]. The public + [instr_stmt_erased] remains the scheduled unit-returning view. *) +Definition instr_stmt_flow_erased + (s : YStmt) (ctx : Ctx) : ictreeW Ctx (YStmtFlow * Ctx) := + instr_thread (denote_stmt_flow s) ctx. (** Erased statement instrumentation: scheduler [Spawn] and cooperative [Yield] observations are erased before state instrumentation. *) Definition instr_stmt_erased (s : YStmt) (ctx : Ctx) : ictreeW Ctx (unit * Ctx) := - instr_stateE (interp_scheduled_erased s) ctx. + instr_schedule 1 [denote_stmt s]%vector (Some Fin.F1) ctx. (** Backward-compatible erased instrumentation aliases. These names preserve the iteration-1 API, where instrumentation observed only memory/state effects. *) diff --git a/theories/Lang/Yield/SBisim.v b/theories/Lang/Yield/SBisim.v index ee3f059..201a269 100644 --- a/theories/Lang/Yield/SBisim.v +++ b/theories/Lang/Yield/SBisim.v @@ -1,944 +1,22 @@ From Stdlib Require Import Fin Program.Equality. + +From TICL Require Export + ICTree.Interp.Yield.SBisim. + From TICL Require Import ICTree.Core - ICTree.Trans ICTree.Equ - ICTree.Eq.Core - ICTree.Eq.Bind ICTree.SBisim - Lang.Yield.Events - Lang.Yield.Vec - Lang.Yield.Scheduler + ICTree.Events.Yield + ICTree.Interp.Yield.Mod + Lang.Yield.Syntax Lang.Yield.Denote - Lang.Yield.Interp - Lang.Yield.Ticl. + Lang.Yield.Interp. Import ICtree ICTreeNotations. Local Open Scope ictree_scope. -Section PoolSBisim. - Context {E : Type} `{Encode E}. - - Definition pool_sbisim {n : nat} (v1 v2 : pool E n) : Prop := - forall i, v1 i ~ v2 i. - - Lemma pool_sbisim_refl {n} (v : pool E n) : pool_sbisim v v. - Proof. intro i; reflexivity. Qed. - - Lemma pool_sbisim_sym {n} (v1 v2 : pool E n) : - pool_sbisim v1 v2 -> pool_sbisim v2 v1. - Proof. intros Hpool i; symmetry; apply Hpool. Qed. - - Lemma replace_pool_sbisim {n} (v1 v2 : pool E n) (i : Fin.t n) - (t1 t2 : thread E) : - pool_sbisim v1 v2 -> - t1 ~ t2 -> - pool_sbisim (replace_pool v1 i t1) (replace_pool v2 i t2). - Proof. - intros Hv Ht j. - unfold replace_pool. - destruct (Fin.eq_dec i j); auto. - Qed. - - Lemma remove_pool_sbisim {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : - pool_sbisim v1 v2 -> - pool_sbisim (remove_pool v1 i) (remove_pool v2 i). - Proof. - intros Hv j. - revert v1 v2 i j Hv. - induction n as [| n IH]; intros v1 v2 i j Hv. - - dependent destruction j. - - cbn. - dependent destruction i. - + apply Hv. - + dependent destruction j. - * apply Hv. - * apply IH. intro k. apply Hv. - Qed. - - Lemma cons_pool_sbisim {n} (t1 t2 : thread E) (v1 v2 : pool E n) : - t1 ~ t2 -> - pool_sbisim v1 v2 -> - pool_sbisim (cons_pool t1 v1) (cons_pool t2 v2). - Proof. - intros Ht Hv i. - refine (Fin.caseS' i (fun i => cons_pool t1 v1 i ~ cons_pool t2 v2 i) _ _). - - exact Ht. - - intro j. apply Hv. - Qed. - - (** ** [equ]-level pool congruences, used by [schedule_pool_proper]. *) - Definition pool_equ {n : nat} (v1 v2 : pool E n) : Prop := - forall i, v1 i ≅ v2 i. - - Lemma replace_pool_equ {n} (v1 v2 : pool E n) (i : Fin.t n) - (t1 t2 : thread E) : - pool_equ v1 v2 -> - t1 ≅ t2 -> - pool_equ (replace_pool v1 i t1) (replace_pool v2 i t2). - Proof. - intros Hv Ht j. - unfold replace_pool. - destruct (Fin.eq_dec i j); auto. - Qed. - - Lemma remove_pool_equ {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : - pool_equ v1 v2 -> - pool_equ (remove_pool v1 i) (remove_pool v2 i). - Proof. - intros Hv j. - revert v1 v2 i j Hv. - induction n as [| n IH]; intros v1 v2 i j Hv. - - dependent destruction j. - - cbn. - dependent destruction i. - + apply Hv. - + dependent destruction j. - * apply Hv. - * apply IH. intro k. apply Hv. - Qed. - - Lemma cons_pool_equ {n} (t1 t2 : thread E) (v1 v2 : pool E n) : - t1 ≅ t2 -> - pool_equ v1 v2 -> - pool_equ (cons_pool t1 v1) (cons_pool t2 v2). - Proof. - intros Ht Hv i. - refine (Fin.caseS' i (fun i => cons_pool t1 v1 i ≅ cons_pool t2 v2 i) _ _). - - exact Ht. - - intro j. apply Hv. - Qed. -End PoolSBisim. - -Section SchedulerTransitions. - Context {E : Type} `{Encode E}. - - Lemma trans_schedule_no_focus_nonempty n (v : pool E (S n)) : - trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (schedule (S n) v None) - (Br n (fun i => schedule (S n) v (Some i))). - Proof. - unfold trans; cbn. - eapply (@Stepobs - (yieldE + (spawnE + E)) _ unit - (inl Yield) _ tt - (Br n (fun i => schedule (S n) v (Some i)))). - reflexivity. - Qed. - - Lemma trans_schedule_no_focus_choose n (v : pool E (S n)) (i : Fin.t (S n)) : - trans tau - (Br n (fun i => schedule (S n) v (Some i))) - (schedule (S n) v (Some i)). - Proof. - apply trans_br with (x := i). reflexivity. - Qed. - - Lemma trans_schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (schedule (S n) v (Some i)) - (Br n (fun j => schedule (S n) (replace_pool v i (k tt)) (Some j))). - Proof. - intro Hobs. - unfold trans; lazy [schedule observe _observe]. - change (@_observe _ _ unit (v i)) with (observe (v i)). - rewrite Hobs. - eapply Stepguard. - eapply (@Stepobs - (yieldE + (spawnE + E)) _ unit - (inl Yield) _ tt - (Br n (fun j => schedule (S n) (replace_pool v i (k tt)) (Some j)))). - reflexivity. - Qed. - - Lemma trans_schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) - (schedule (S n) v (Some i)) - (schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - Proof. - intro Hobs. - unfold trans; lazy [schedule observe _observe]. - change (@_observe _ _ unit (v i)) with (observe (v i)). - rewrite Hobs. - eapply (@Stepobs - (yieldE + (spawnE + E)) _ unit - (inr (inl Spawn)) _ tt - (schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i)))). - reflexivity. - Qed. - - Lemma trans_schedule_focused_user_event - n (v : pool E (S n)) (i : Fin.t (S n)) e k x : - observe (v i) = VisF (inr (inr e)) k -> - trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) - (schedule (S n) v (Some i)) - (schedule (S n) (replace_pool v i (k x)) (Some i)). - Proof. - intro Hobs. - unfold trans; lazy [schedule observe _observe]. - change (@_observe _ _ unit (v i)) with (observe (v i)). - rewrite Hobs. - eapply (@Stepobs - (yieldE + (spawnE + E)) _ unit - (inr (inr e)) _ x - (schedule (S n) (replace_pool v i (k x)) (Some i))). - reflexivity. - Qed. - - Lemma trans_schedule_focused_br - n (v : pool E (S n)) (i : Fin.t (S n)) b k (j : Fin.t (S b)) : - observe (v i) = BrF b k -> - trans tau (schedule (S n) v (Some i)) - (schedule (S n) (replace_pool v i (k j)) (Some i)). - Proof. - intro Hobs. - unfold trans; lazy [schedule observe _observe]. - change (@_observe _ _ unit (v i)) with (observe (v i)). - rewrite Hobs. - eapply (@Steptau - (yieldE + (spawnE + E)) _ unit b j _ - (schedule (S n) (replace_pool v i (k j)) (Some i))). - reflexivity. - Qed. - - (** ** Phase 2: remaining transition / unfold constructors. *) - - Lemma trans_schedule_empty_ret (v : pool E 0) : - schedule 0 v None ≅ Ret tt. - Proof. - rewrite (ictree_eta (schedule 0 v None)). - rewrite schedule_empty_none. - reflexivity. - Qed. - - Lemma trans_schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - schedule (S n) v (Some i) ≅ Guard (schedule n (remove_pool v i) None). - Proof. - intro Hobs. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_ret _ v i Hobs). - reflexivity. - Qed. - - Lemma trans_schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v i) = GuardF t -> - schedule (S n) v (Some i) - ≅ Guard (schedule (S n) (replace_pool v i t) (Some i)). - Proof. - intro Hobs. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_guard _ v i t Hobs). - reflexivity. - Qed. - - (** ** Phase 3: scheduler transition inversions. *) - - Lemma schedule_no_focus_equ n (v : pool E (S n)) : - schedule (S n) v None - ≅ Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ => Br n (fun i => schedule (S n) v (Some i))). - Proof. - rewrite (ictree_eta (schedule (S n) v None)). - rewrite schedule_no_focus_nonempty. - reflexivity. - Qed. - - Lemma trans_schedule_no_focus_inv n (v : pool E (S n)) l t' : - trans l (schedule (S n) v None) t' -> - l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ - t' ≅ Br n (fun i => schedule (S n) v (Some i)). - Proof. - intro TR. - rewrite schedule_no_focus_equ in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - destruct x. - split; auto. - Qed. - - Lemma trans_schedule_focused_inv n (v : pool E (S n)) (i : Fin.t (S n)) l t' : - trans l (schedule (S n) v (Some i)) t' -> - (** focused [Ret]: collapse the [Guard], step the residual pool *) - (observe (v i) = RetF tt /\ - trans l (schedule n (remove_pool v i) None) t') - \/ - (** focused [Guard]: collapse, step the [replace_pool] residual *) - (exists g, observe (v i) = GuardF g /\ - trans l (schedule (S n) (replace_pool v i g) (Some i)) t') - \/ - (** focused [Br b k]: [tau] to one of the branches *) - (exists b k (j : Fin.t (S b)), observe (v i) = BrF b k /\ - l = tau /\ - t' ≅ schedule (S n) (replace_pool v i (k j)) (Some i)) - \/ - (** focused [Yield]: visible [Yield], [Br] back over the residual pool *) - (exists k, observe (v i) = VisF (inl Yield) k /\ - l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ - t' ≅ Br n (fun j => - schedule (S n) (replace_pool v i (k tt)) (Some j))) - \/ - (** focused [Fork]: visible [Spawn], cons the child, focus it *) - (exists k, observe (v i) = VisF (inr (inl Fork)) k /\ - l = obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt /\ - t' ≅ schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))) - \/ - (** focused user event [e]: visible [e], step the focused thread *) - (exists e k x, observe (v i) = VisF (inr (inr e)) k /\ - l = obs (inr (inr e) : yieldE + (spawnE + E)) x /\ - t' ≅ schedule (S n) (replace_pool v i (k x)) (Some i)). - Proof. - intro TR. - destruct (observe (v i)) as [r | b k | g | e k] eqn:Hobs. - - (* RetF *) - destruct r. - left. - split; auto. - rewrite (trans_schedule_focused_ret _ v i Hobs) in TR. - now apply trans_guard_inv in TR. - - (* BrF b k *) - do 2 right; left. - assert (Hsch := schedule_focused_br _ v i b k Hobs). - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite Hsch in TR. - apply trans_br_inv in TR as (j & Heq & Hl). - exists b, k, j; auto. - - (* GuardF g *) - right; left. - exists g. - split; auto. - rewrite (trans_schedule_focused_guard _ v i g Hobs) in TR. - now apply trans_guard_inv in TR. - - (* VisF e k *) - destruct e as [yld | [frk | usr]]. - + (* Yield *) - destruct yld. - do 3 right; left. - exists k. - split; auto. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_yield _ v i k Hobs) in TR. - apply trans_guard_inv in TR. - rewrite schedule_no_focus_equ in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - destruct x. - split; auto. - + (* Fork *) - destruct frk. - do 4 right; left. - exists k. - split; auto. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_fork _ v i k Hobs) in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - destruct x. - split; auto. - + (* user event *) - do 5 right. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_user_event _ v i usr k Hobs) in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - exists usr, k, x; auto. - Qed. - - (** ** [schedule] respects [equ]-equality of pools, in every focus. *) - Lemma schedule_pool_proper n (v w : pool E n) focus : - pool_equ v w -> - schedule n v focus ≅ schedule n w focus. - Proof. - revert n v w focus. - coinduction R CH. - intros n v w focus Hvw. - destruct focus as [i |]. - - destruct n as [| n']; [ inversion i |]. - pose proof (Hvw i) as Hi. - assert (Hgo : go (observe (v i)) ≅ go (observe (w i))). - { rewrite <- !ictree_eta. exact Hi. } - rewrite (ictree_eta (schedule (S n') v (Some i))). - rewrite (ictree_eta (schedule (S n') w (Some i))). - destruct (observe (v i)) as [r | b k | g | e k] eqn:Hv; - destruct (observe (w i)) as [r2 | b2 k2 | g2 | e2 k2] eqn:Hw; - try (step in Hgo; inversion Hgo; fail). - + destruct r, r2. - rewrite (@schedule_focused_ret E _ n' v i Hv). - rewrite (@schedule_focused_ret E _ n' w i Hw). - cbn. constructor. apply CH. apply remove_pool_equ. exact Hvw. - + pose proof (equ_br_invT Hgo) as Hbeq; subst b2. - pose proof (equ_br_invE Hgo) as Hke. - rewrite (@schedule_focused_br E _ n' v i b k Hv). - rewrite (@schedule_focused_br E _ n' w i b k2 Hw). - cbn. constructor. intro j. apply CH. - apply replace_pool_equ. exact Hvw. apply Hke. - + pose proof (equ_guard_invE Hgo) as Hge. - rewrite (@schedule_focused_guard E _ n' v i g Hv). - rewrite (@schedule_focused_guard E _ n' w i g2 Hw). - cbn. constructor. apply CH. - apply replace_pool_equ. exact Hvw. exact Hge. - + pose proof (equ_vis_invT Hgo) as [_ Heeq]; subst e2. - pose proof (equ_vis_invE Hgo) as Hke. - destruct e as [yld | [frk | usr]]. - * destruct yld. - rewrite (@schedule_focused_yield E _ n' v i k Hv). - rewrite (@schedule_focused_yield E _ n' w i k2 Hw). - cbn. constructor. apply CH. - apply replace_pool_equ. exact Hvw. apply (Hke tt). - * destruct frk. - rewrite (@schedule_focused_fork E _ n' v i k Hv). - rewrite (@schedule_focused_fork E _ n' w i k2 Hw). - cbn. constructor. intros _. apply CH. - apply cons_pool_equ. - -- apply (Hke true). - -- apply replace_pool_equ. exact Hvw. apply (Hke false). - * rewrite (@schedule_focused_user_event E _ n' v i usr k Hv). - rewrite (@schedule_focused_user_event E _ n' w i usr k2 Hw). - cbn. constructor. intro x. apply CH. - apply replace_pool_equ. exact Hvw. apply (Hke x). - - destruct n as [| n']. - + rewrite (ictree_eta (schedule 0 v None)). - rewrite (ictree_eta (schedule 0 w None)). - rewrite schedule_empty_none, schedule_empty_none. - cbn. reflexivity. - + rewrite (ictree_eta (schedule (S n') v None)). - rewrite (ictree_eta (schedule (S n') w None)). - rewrite schedule_no_focus_nonempty, schedule_no_focus_nonempty. - cbn. constructor. intros _. cbn. step. - constructor. intro i. apply CH. exact Hvw. - Qed. - (** ** Phase 4: thread-step to scheduler-step lifts. *) - - Lemma pool_equ_refl {n} (v : pool E n) : pool_equ v v. - Proof. intro j; reflexivity. Qed. - - Lemma replace_pool_idem_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) - (a b : thread E) : - pool_equ (replace_pool v i b) (replace_pool (replace_pool v i a) i b). - Proof. intro j. unfold replace_pool. destruct (Fin.eq_dec i j); reflexivity. Qed. - - Lemma br_schedule_pool_equ {n} (v w : pool E (S n)) : - pool_equ v w -> - Br n (fun j => schedule (S n) v (Some j)) - ≅ Br n (fun j => schedule (S n) w (Some j)). - Proof. - intro Hvw. step. constructor. intro j. - apply schedule_pool_proper. exact Hvw. - Qed. - - Lemma schedule_lift_yield n (v : pool E (S n)) (i : Fin.t (S n)) - (u : thread E) : - trans (obs (inl Yield : yieldE + (forkE + E)) tt) (v i) u -> - trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (schedule (S n) v (Some i)) - (Br n (fun j => schedule (S n) (replace_pool v i u) (Some j))). - Proof. - intro TR. - unfold trans in TR. - remember (observe (v i)) as ot eqn:Hot. - remember (observe u) as ou eqn:Hou. - remember (obs (inl Yield : yieldE + (forkE + E)) tt) as lbl eqn:Hlbl. - revert v i u Hot Hou Hlbl. - induction TR; intros. - - (* Stepguard: observe (v i) = GuardF t *) - rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). - apply trans_guard. - rewrite (br_schedule_pool_equ (replace_pool v i u0) - (replace_pool (replace_pool v i t) i u0) - (replace_pool_idem_equ v i t u0)). - apply (IHTR (replace_pool v i t) i u0). - + now rewrite replace_pool_hit. - + exact Hou. - + exact Hlbl. - - discriminate Hlbl. - - (* Stepobs *) - dependent destruction Hlbl. - assert (Hu0 : u ≅ k tt). - { transitivity t. - - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. - - symmetry; assumption. } - rewrite (br_schedule_pool_equ (replace_pool v i u) - (replace_pool v i (k tt)) - (replace_pool_equ v v i u (k tt) (pool_equ_refl v) Hu0)). - apply (trans_schedule_focused_yield n v i k (eq_sym Hot)). - - discriminate Hlbl. - Qed. - - Lemma schedule_some_pool_equ {m} (v w : pool E (S m)) (i : Fin.t (S m)) : - pool_equ v w -> - schedule (S m) v (Some i) ≅ schedule (S m) w (Some i). - Proof. intro Hvw. apply schedule_pool_proper. exact Hvw. Qed. - - Lemma schedule_lift_user n (v : pool E (S n)) (i : Fin.t (S n)) - (e : E) (x : encode e) (u : thread E) : - trans (obs (inr (inr e) : yieldE + (forkE + E)) x) (v i) u -> - trans (obs (inr (inr e) : yieldE + (spawnE + E)) x) - (schedule (S n) v (Some i)) - (schedule (S n) (replace_pool v i u) (Some i)). - Proof. - intro TR. - unfold trans in TR. - remember (observe (v i)) as ot eqn:Hot. - remember (observe u) as ou eqn:Hou. - remember (obs (inr (inr e) : yieldE + (forkE + E)) x) as lbl eqn:Hlbl. - revert v i u Hot Hou Hlbl. - induction TR; intros. - - (* Stepguard *) - rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). - apply trans_guard. - rewrite (schedule_some_pool_equ (replace_pool v i u0) - (replace_pool (replace_pool v i t) i u0) i - (replace_pool_idem_equ v i t u0)). - apply (IHTR (replace_pool v i t) i u0). - + now rewrite replace_pool_hit. - + exact Hou. - + exact Hlbl. - - discriminate Hlbl. - - (* Stepobs *) - dependent destruction Hlbl. - assert (Hu0 : u ≅ k x). - { transitivity t. - - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. - - symmetry; assumption. } - rewrite (schedule_some_pool_equ (replace_pool v i u) - (replace_pool v i (k x)) i - (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). - apply (trans_schedule_focused_user_event n v i e k x (eq_sym Hot)). - - discriminate Hlbl. - Qed. - - Lemma schedule_lift_tau n (v : pool E (S n)) (i : Fin.t (S n)) - (u : thread E) : - trans tau (v i) u -> - trans tau - (schedule (S n) v (Some i)) - (schedule (S n) (replace_pool v i u) (Some i)). - Proof. - intro TR. - unfold trans in TR. - remember (observe (v i)) as ot eqn:Hot. - remember (observe u) as ou eqn:Hou. - remember (tau : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. - revert v i u Hot Hou Hlbl. - induction TR; intros. - - (* Stepguard *) - rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). - apply trans_guard. - rewrite (schedule_some_pool_equ (replace_pool v i u0) - (replace_pool (replace_pool v i t) i u0) i - (replace_pool_idem_equ v i t u0)). - apply (IHTR (replace_pool v i t) i u0). - + now rewrite replace_pool_hit. - + exact Hou. - + exact Hlbl. - - (* Steptau *) - assert (Hu0 : u ≅ k x). - { transitivity t. - - rewrite (ictree_eta u), (ictree_eta t), <- Hou; reflexivity. - - symmetry; assumption. } - rewrite (schedule_some_pool_equ (replace_pool v i u) - (replace_pool v i (k x)) i - (replace_pool_equ v v i u (k x) (pool_equ_refl v) Hu0)). - apply (trans_schedule_focused_br n v i n0 k x (eq_sym Hot)). - - discriminate Hlbl. - - discriminate Hlbl. - Qed. - - Lemma schedule_lift_fork n (v : pool E (S n)) (i : Fin.t (S n)) - (b : bool) (u : thread E) : - trans (obs (inr (inl Fork) : yieldE + (forkE + E)) b) (v i) u -> - exists k2, - (forall c : bool, - trans (obs (inr (inl Fork) : yieldE + (forkE + E)) c) (v i) (k2 c)) /\ - trans (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) - (schedule (S n) v (Some i)) - (schedule (S (S n)) - (cons_pool (k2 true) (replace_pool v i (k2 false))) - (Some (Fin.FS i))). - Proof. - intro TR. - unfold trans in TR. - remember (observe (v i)) as ot eqn:Hot. - remember (observe u) as ou eqn:Hou. - remember (obs (inr (inl Fork) : yieldE + (forkE + E)) b) as lbl eqn:Hlbl. - revert v i u Hot Hou Hlbl. - induction TR; intros. - - (* Stepguard *) - destruct (IHTR (replace_pool v i t) i u0 - ltac:(now rewrite replace_pool_hit) Hou Hlbl) - as (k2 & Hcont & Hstep). - exists k2. split. - + intro c. specialize (Hcont c). - rewrite replace_pool_hit in Hcont. - rewrite (ictree_eta (v i)), <- Hot. - now apply trans_guard. - + rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). - apply trans_guard. - rewrite (schedule_pool_proper (S (S n)) - (cons_pool (k2 true) (replace_pool v i (k2 false))) - (cons_pool (k2 true) - (replace_pool (replace_pool v i t) i (k2 false))) - (Some (Fin.FS i))). - * exact Hstep. - * apply cons_pool_equ; [reflexivity |]. - apply replace_pool_idem_equ. - - discriminate Hlbl. - - (* Stepobs *) - dependent destruction Hlbl. - exists k. split. - + intro c. - rewrite (ictree_eta (v i)), <- Hot. - apply trans_vis. - + apply (trans_schedule_focused_fork n v i k (eq_sym Hot)). - - discriminate Hlbl. - Qed. - - Lemma cast_refl m (i : Fin.t m) : Fin.cast i eq_refl = i. - Proof. induction i; cbn; [reflexivity | now rewrite IHi]. Qed. - - Lemma remove_pool_agree {n} : - forall (v w : pool E (S n)) (i : Fin.t (S n)), - (forall j, i <> j -> v j ≅ w j) -> - pool_equ (remove_pool v i) (remove_pool w i). - Proof. - induction n as [| n IH]; intros v w i Hag j. - - dependent destruction j. - - cbn. dependent destruction i. - + apply Hag. intro Hc; discriminate. - + dependent destruction j. - * apply Hag. intro Hc; discriminate. - * apply IH. intros k Hik. - rewrite (cast_refl _ i) in Hik. - apply Hag. intro Heq. apply Hik. - apply Fin.FS_inj. exact Heq. - Qed. - - Lemma remove_replace_pool_equ {n} (v : pool E (S n)) (i : Fin.t (S n)) - (a : thread E) : - pool_equ (remove_pool (replace_pool v i a) i) (remove_pool v i). - Proof. - apply remove_pool_agree. intros j Hij. - rewrite replace_pool_miss; [reflexivity | exact Hij]. - Qed. - - Lemma schedule_lift_ret n (v : pool E (S n)) (i : Fin.t (S n)) - (u : thread E) : - trans (val tt : label (yieldE + (forkE + E))) (v i) u -> - schedule (S n) v (Some i) ~ schedule n (remove_pool v i) None. - Proof. - intro TR. - unfold trans in TR. - remember (observe (v i)) as ot eqn:Hot. - remember (observe u) as ou eqn:Hou. - remember (val tt : label (yieldE + (forkE + E))) as lbl eqn:Hlbl. - revert v i u Hot Hou Hlbl. - induction TR; intros. - - (* Stepguard *) - rewrite (trans_schedule_focused_guard n v i t (eq_sym Hot)). - rewrite sb_guard. - rewrite (IHTR (replace_pool v i t) i u0 - ltac:(now rewrite replace_pool_hit) Hou Hlbl). - now rewrite (schedule_pool_proper n (remove_pool (replace_pool v i t) i) - (remove_pool v i) None (remove_replace_pool_equ v i t)). - - discriminate Hlbl. - - discriminate Hlbl. - - (* Stepval *) - dependent destruction Hlbl. - rewrite (trans_schedule_focused_ret n v i (eq_sym Hot)). - apply sb_guard. - Qed. - - (** ** Phase 5: [schedule] preserves pool strong bisimilarity. *) - - Notation completed' := (completed E). - Notation stR R := (lattice.body (coinduction.t (sb eq)) R). - - Lemma schedule_match (R : rel completed' completed') - (Hch : forall m (w1 w2 : pool E m) f, - pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)) : - forall l os ot', trans_ l os ot' -> - forall n (v1 v2 : pool E n) focus (t' : completed'), - os = observe (schedule n v1 focus) -> - ot' = observe t' -> - pool_sbisim v1 v2 -> - exists u', trans l (schedule n v2 focus) u' /\ stR R t' u'. - Proof. - intros l os ot' TR. - induction TR; intros nn v1 v2 focus t' Hos Hot' Hpool. - - (* Stepguard *) - destruct focus as [i | ]. - + destruct nn as [| n']; [inversion i | ]. - destruct (observe (v1 i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. - * (* Ret: recurse on the smaller pool *) - destruct r0. - rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. - dependent destruction Hos. - destruct (IHTR n' (remove_pool v1 i) (remove_pool v2 i) None t' - eq_refl Hot' (remove_pool_sbisim v1 v2 i Hpool)) - as (u' & Htru & Hresu). - assert (Hvr : v1 i ≅ Ret tt). - { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } - assert (Htrv : trans (val tt : label (yieldE + (forkE + E))) - (v1 i) stuck). - { rewrite Hvr. apply trans_ret. } - destruct (sbisim_trans (v1 i) (v2 i) stuck (val tt) eq - (Hpool i) Htrv) as (lv & uv & Htr2v & Hlv & Hsbv). - subst lv. - assert (Hlift : schedule (S n') v2 (Some i) - ~ schedule n' (remove_pool v2 i) None). - { apply (schedule_lift_ret n' v2 i uv Htr2v). } - destruct (sbisim_trans (schedule n' (remove_pool v2 i) None) - (schedule (S n') v2 (Some i)) u' l eq - ltac:(symmetry; exact Hlift) Htru) - as (lq & uq & Htrq & Hlq & Hsbq). - subst lq. - exists uq. split. - -- exact Htrq. - -- rewrite <- Hsbq. exact Hresu. - * (* Br: schedule head is a Br, not a Guard *) - rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. - discriminate Hos. - * (* Guard: recurse on the same pool, focus unchanged *) - rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. - dependent destruction Hos. - apply (IHTR (S n') (replace_pool v1 i g) v2 (Some i) t' - eq_refl Hot'). - intro j. unfold replace_pool. destruct (Fin.eq_dec i j) as [Hij | Hij]. - -- subst j. - assert (Hvg : v1 i ≅ Guard g). - { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } - transitivity (v1 i); [| apply Hpool]. - rewrite Hvg. symmetry. apply sb_guard. - -- apply Hpool. - * (* Vis: Yield (Guard head), or Fork / user (Vis head) *) - destruct e0 as [yld | [frk | usr]]. - -- (* Yield: invert the focused-yield residual directly *) - destruct yld. - rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. - dependent destruction Hos. - assert (TR0 : trans l - (schedule (S n') (replace_pool v1 i (k0 tt)) None) t'). - { unfold trans. rewrite <- Hot'. exact TR. } - apply trans_schedule_no_focus_inv in TR0 as (Hl & Hbr). - subst l. - assert (Hvis : v1 i ≅ Vis (inl Yield) k0). - { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } - assert (Htry : trans - (obs (inl Yield : yieldE + (forkE + E)) tt) (v1 i) (k0 tt)). - { rewrite Hvis. apply trans_vis. } - destruct (sbisim_trans (v1 i) (v2 i) (k0 tt) - (obs (inl Yield : yieldE + (forkE + E)) tt) eq - (Hpool i) Htry) as (ly & uy & Htr2y & Hly & Hsby). - subst ly. - exists (Br n' (fun j => - schedule (S n') (replace_pool v2 i uy) (Some j))). split. - ++ apply (schedule_lift_yield n' v2 i uy Htr2y). - ++ rewrite Hbr. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - apply replace_pool_sbisim; assumption. - -- (* Fork: Vis head, not a Guard *) - destruct frk. - rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. - discriminate Hos. - -- (* user: Vis head, not a Guard *) - rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. - discriminate Hos. - + destruct nn as [| n']. - * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. - * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. - - (* Steptau *) - destruct focus as [i | ]. - + destruct nn as [| n']; [inversion i | ]. - destruct (observe (v1 i)) as [r0 | b0 k0 | g | e0 k0] eqn:Hvi. - * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. - discriminate Hos. - * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. - dependent destruction Hos. - assert (Htr1 : trans tau (v1 i) (k0 x)). - { rewrite (ictree_eta (v1 i)), Hvi. - apply trans_br with (x := x). reflexivity. } - destruct (sbisim_trans (v1 i) (v2 i) (k0 x) tau eq (Hpool i) Htr1) - as (l' & u' & Htr2 & Hl' & Hsb). - subst l'. - exists (schedule (S n') (replace_pool v2 i u') (Some i)). split. - -- apply schedule_lift_tau. exact Htr2. - -- assert (Ht' : t' ≅ schedule (S n') (replace_pool v1 i (k0 x)) (Some i)). - { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). - symmetry; assumption. } - rewrite Ht'. apply Hch. - apply replace_pool_sbisim; assumption. - * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. - discriminate Hos. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. - discriminate Hos. - -- destruct frk. - rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. - discriminate Hos. - -- rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. - discriminate Hos. - + destruct nn as [| n']. - * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. - * rewrite (schedule_no_focus_nonempty n' v1) in Hos. discriminate Hos. - - (* Stepobs *) - destruct focus as [i | ]. - + destruct nn as [| n']; [inversion i | ]. - destruct (observe (v1 i)) as [r0 | b0 k0 | g | e1 k0] eqn:Hvi. - * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. - discriminate Hos. - * rewrite (schedule_focused_br n' v1 i b0 k0 Hvi) in Hos. - discriminate Hos. - * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. - discriminate Hos. - * destruct e1 as [yld | [frk | usr]]. - -- destruct yld. - rewrite (schedule_focused_yield n' v1 i k0 Hvi) in Hos. - discriminate Hos. - -- (* Fork *) - destruct frk. - rewrite (schedule_focused_fork n' v1 i k0 Hvi) in Hos. - dependent destruction Hos. - destruct x. - assert (Hvis : v1 i ≅ Vis (inr (inl Fork)) k0). - { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } - assert (Htrf : trans - (obs (inr (inl Fork) : yieldE + (forkE + E)) false) (v1 i) - (k0 false)). - { rewrite Hvis. apply trans_vis. } - destruct (sbisim_trans (v1 i) (v2 i) (k0 false) - (obs (inr (inl Fork)) false) eq (Hpool i) Htrf) - as (lf & uf & Htr2 & Hlf & Hsbf). - subst lf. - destruct (schedule_lift_fork n' v2 i false uf Htr2) - as (kf & Hforall & Hstep). - exists (schedule (S (S n')) - (cons_pool (kf true) (replace_pool v2 i (kf false))) - (Some (Fin.FS i))). - split. - ++ exact Hstep. - ++ assert (Ht' : t' ≅ schedule (S (S n')) - (cons_pool (k0 true) (replace_pool v1 i (k0 false))) - (Some (Fin.FS i))). - { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). - symmetry; assumption. } - rewrite Ht'. - assert (Hii : v2 i ~ v1 i) by (symmetry; apply Hpool). - assert (Hkf : forall c, k0 c ~ kf c). - { intro c. - destruct (sbisim_trans (v2 i) (v1 i) (kf c) - (obs (inr (inl Fork)) c) eq Hii (Hforall c)) - as (lc & wc & Htrc & Hlc & Hsbc). - subst lc. - rewrite Hvis in Htrc. - apply trans_vis_inv in Htrc as (y & Hwy & Hly). - dependent destruction Hly. - rewrite Hwy in Hsbc. symmetry; exact Hsbc. } - apply Hch. - apply cons_pool_sbisim. - ** apply Hkf. - ** apply replace_pool_sbisim; [exact Hpool | apply Hkf]. - -- (* user event *) - rewrite (schedule_focused_user_event n' v1 i usr k0 Hvi) in Hos. - dependent destruction Hos. - assert (Hvis : v1 i ≅ Vis (inr (inr usr)) k0). - { rewrite (ictree_eta (v1 i)), Hvi. reflexivity. } - assert (Htru : trans - (obs (inr (inr usr) : yieldE + (forkE + E)) x) (v1 i) (k0 x)). - { rewrite Hvis. apply trans_vis. } - destruct (sbisim_trans (v1 i) (v2 i) (k0 x) - (obs (inr (inr usr) : yieldE + (forkE + E)) x) eq - (Hpool i) Htru) - as (lu & u' & Htr2 & Hlu & Hsbu). - subst lu. - exists (schedule (S n') (replace_pool v2 i u') (Some i)). split. - ++ apply (schedule_lift_user n' v2 i usr x u' Htr2). - ++ assert (Ht' : t' ≅ - schedule (S n') (replace_pool v1 i (k0 x)) (Some i)). - { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). - symmetry; assumption. } - rewrite Ht'. apply Hch. - apply replace_pool_sbisim; assumption. - + destruct nn as [| n']. - * rewrite (schedule_empty_none v1) in Hos. discriminate Hos. - * (* None nonempty Yield *) - rewrite (schedule_no_focus_nonempty n' v1) in Hos. - dependent destruction Hos. - destruct x. - exists (Br n' (fun j => schedule (S n') v2 (Some j))). split. - -- apply (trans_schedule_no_focus_nonempty n' v2). - -- assert (Ht' : t' ≅ Br n' (fun j => schedule (S n') v1 (Some j))). - { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). - symmetry; assumption. } - rewrite Ht'. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. exact Hpool. - - (* Stepval *) - destruct focus as [i | ]. - + destruct nn as [| n']; [inversion i | ]. - destruct (observe (v1 i)) as [r0 | b k | g | e k] eqn:Hvi. - * destruct r0. rewrite (schedule_focused_ret n' v1 i Hvi) in Hos. - discriminate Hos. - * rewrite (schedule_focused_br n' v1 i b k Hvi) in Hos. - discriminate Hos. - * rewrite (schedule_focused_guard n' v1 i g Hvi) in Hos. - discriminate Hos. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - rewrite (schedule_focused_yield n' v1 i k Hvi) in Hos. - discriminate Hos. - -- destruct frk. - rewrite (schedule_focused_fork n' v1 i k Hvi) in Hos. - discriminate Hos. - -- rewrite (schedule_focused_user_event n' v1 i usr k Hvi) in Hos. - discriminate Hos. - + destruct nn as [| n']. - * rewrite (schedule_empty_none v1) in Hos. - inversion Hos; subst. - exists stuck. split. - -- rewrite (trans_schedule_empty_ret v2). apply trans_ret. - -- assert (Ht' : t' ≅ stuck). - { rewrite (ictree_eta t'), <- Hot', <- (ictree_eta t). - symmetry; assumption. } - rewrite Ht'. reflexivity. - * rewrite (schedule_no_focus_nonempty n' v1) in Hos. - discriminate Hos. - Qed. - - Theorem sbisim_schedule n (v1 v2 : pool E n) focus : - pool_sbisim v1 v2 -> schedule n v1 focus ~ schedule n v2 focus. - Proof. - revert n v1 v2 focus. - coinduction R CH. - intros n v1 v2 focus Hpool. - assert (Hch : forall m (w1 w2 : pool E m) f, - pool_sbisim w1 w2 -> stR R (schedule m w1 f) (schedule m w2 f)). - { intros m w1 w2 f Hw. apply CH. exact Hw. } - split. - - intros l t' TR. - destruct (schedule_match R Hch _ _ _ TR n v1 v2 focus t' - eq_refl eq_refl Hpool) as (u' & Htru & Hres). - exists l, u'. split; [exact Htru | split; [exact Hres | reflexivity]]. - - intros l t' TR. - destruct (schedule_match R Hch _ _ _ TR n v2 v1 focus t' - eq_refl eq_refl (pool_sbisim_sym v1 v2 Hpool)) - as (u' & Htru & Hres). - exists l, u'. split; [exact Htru | split]. - + unfold Basics.flip. symmetry. exact Hres. - + reflexivity. - Qed. - - -End SchedulerTransitions. - -(** ** Phase 6: scheduler-visible denotation respects thread bisimilarity. *) +(** * Scheduler-visible denotation respects thread bisimilarity *) (** Two source statements with strongly-bisimilar thread denotations yield strongly-bisimilar scheduler-visible computations. This is the singleton @@ -950,5 +28,8 @@ Proof. intro Hs. unfold scheduled_visible. apply sbisim_schedule. - intro i. exact Hs. + intro i. + dependent destruction i. + - exact Hs. + - inversion i. Qed. diff --git a/theories/Lang/Yield/Scheduler.v b/theories/Lang/Yield/Scheduler.v deleted file mode 100644 index e9e1782..0000000 --- a/theories/Lang/Yield/Scheduler.v +++ /dev/null @@ -1,48 +0,0 @@ -From Stdlib Require Import Fin. -From TICL Require Import ICTree.Core Events.Core Lang.Yield.Events Lang.Yield.Vec. - -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. - -Section Scheduler. - Context {E : Type} `{Encode E}. - - (** Cooperative scheduler for a finite pool. - - [None] focus means the scheduler chooses a runnable thread after emitting - a scheduling [Yield]. [Some i] observes one step of thread [i], removing - finished threads, clearing focus on source yields, and turning source forks - into scheduler-visible [Spawn] events. *) - CoFixpoint schedule (n : nat) (v : pool E n) (focus : option (Fin.t n)) : completed E := - match focus with - | None => - match n return pool E n -> completed E with - | 0 => fun _ => Ret tt - | S n' => fun v => Vis (inl Yield) (fun _ => Br n' (fun i => schedule (S n') v (Some i))) - end v - | Some i => - match n return pool E n -> Fin.t n -> completed E with - | 0 => fun _ i => match i with end - | S n' => fun v i => - match observe (v i) with - | RetF _ => Guard (schedule n' (remove_pool v i) None) - | BrF b k => Br b (fun j => schedule (S n') (replace_pool v i (k j)) (Some i)) - | GuardF t => Guard (schedule (S n') (replace_pool v i t) (Some i)) - | VisF e k => - match e as e0 return (encode e0 -> thread E) -> completed E with - | inl Yield => fun k => Guard (schedule (S n') (replace_pool v i (k tt)) None) - | inr (inl Fork) => fun k => - @go (yieldE + (spawnE + E)) _ unit - (VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) - (fun _ => schedule (S (S n')) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (FS i)))) - | inr (inr e') => fun k => - @go (yieldE + (spawnE + E)) _ unit - (VisF ((inr (inr e')) : yieldE + (spawnE + E)) - (fun x => schedule (S n') (replace_pool v i (k x)) (Some i))) - end k - end - end v i - end. -End Scheduler. diff --git a/theories/Lang/Yield/SchedulerFairness.v b/theories/Lang/Yield/SchedulerFairness.v index e7bd815..64c30ff 100644 --- a/theories/Lang/Yield/SchedulerFairness.v +++ b/theories/Lang/Yield/SchedulerFairness.v @@ -1,2519 +1,48 @@ From Stdlib Require Import Fin + Vector Program.Equality. -From Coinduction Require Import lattice. + +From TICL Require Export + ICTree.Logic.SchedulerFairness. + From TICL Require Import ICTree.Core ICTree.Equ - ICTree.Interp.Core - ICTree.Logic.AF - ICTree.Logic.AG - ICTree.Logic.CanStep - ICTree.Logic.Trans - ICTree.Trans - Events.Core + ICTree.SBisim + ICTree.Events.Yield + ICTree.Interp.Yield.Mod Logic.Core Logic.Kripke - Lang.Yield.Events - Lang.Yield.Scheduler - Lang.Yield.SBisim - Lang.Yield.Ticl - Lang.Yield.Vec - ICTree.SBisim. + Lang.Yield.Syntax + Lang.Yield.Denote + Lang.Yield.Interp + Utils.Vectors. -Import ICtree ICTreeNotations TiclNotations. +Import ICtree ICTreeNotations TiclNotations VectorNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. -(** Proof-facing scheduler observations for local fairness reasoning. - - The core scheduler is left unchanged. This module mirrors [schedule] with - an additive observation tier that records no-focus scheduling points and - the finite set of slots offered at each such point. *) - -Definition LiveSlot (n : nat) : Type := Fin.t n. - -Record SlotRef : Type := { - slot_pool_size : nat; - slot_live_slot : LiveSlot slot_pool_size; -}. - -Definition live_slot_ref {n : nat} (i : LiveSlot n) : SlotRef := - {| slot_pool_size := n; slot_live_slot := i |}. - -Variant SchedulerObs : Type := -| ObsSchedulingPoint : nat -> SchedulerObs -| ObsOffered : SlotRef -> SchedulerObs. - -Definition schedulerObsE : Type := SchedulerObs. - -#[global] Instance Encode_schedulerObsE : Encode SchedulerObs := - fun _ => unit. +(** * Source-level observed scheduler *) +(** The observation tier is entirely generic; a source program only supplies + the start-up pool. Nothing below discharges [SchedulerProgress]: the + fairness result stays conditional on scheduler progress, and it speaks + about scheduling-point offers, not about fair thread selection. *) -Definition scheduler_observedE (E : Type) : Type := - schedulerObsE + (yieldE + (spawnE + E)). +Definition scheduled_observed (s : YStmt) : observed_completed Mem := + schedule_with_offers 1 [denote_stmt s]%vector (Some Fin.F1). -Definition observed_completed (E : Type) `{Encode E} : Type := - ictree (scheduler_observedE E) unit. - -Definition observed_scheduling_point (n : nat) (obs : schedulerObsE) : Prop := - obs = ObsSchedulingPoint n. - -Definition offer_live_slot_obs (n : nat) (i : LiveSlot n) - (obs : schedulerObsE) : Prop := - obs = ObsOffered (live_slot_ref i). - -Definition offer_live_slot {E : Type} `{Encode E} - (n : nat) (i : LiveSlot n) : ticll (scheduler_observedE E) := - CNow (fun w => w = Obs (inl (ObsOffered (live_slot_ref i))) tt). - -Definition recognize_live_slot {E : Type} `{Encode E} - (n : nat) (_ : pool E n) (_ : LiveSlot n) : Prop := - True. - -Lemma fin_cast_refl {n : nat} (i : Fin.t n) : - Fin.cast i eq_refl = i. -Proof. induction i; cbn; congruence. Qed. - -Lemma live_slot_one_eq (i j : LiveSlot 1) : i = j. +Theorem forget_scheduled_observed_is_scheduled_visible (s : YStmt) : + forget_scheduler_offers (scheduled_observed s) ~ scheduled_visible s. Proof. - refine (Fin.caseS' i (fun i => forall j, i = j) _ _ j). - - intro j'. - refine (Fin.caseS' j' (fun j => Fin.F1 = j) eq_refl _). - intro j0. - exact (Fin.case0 (fun j0 => Fin.F1 = Fin.FS j0) j0). - - intro i0. - exact (Fin.case0 (fun i0 => forall j, Fin.FS i0 = j) i0). + unfold scheduled_observed, scheduled_visible. + apply forget_scheduler_offers_preserves_schedule. Qed. -Section ObservedScheduler. - Context {E : Type} `{Encode E}. - - Definition emit_scheduler_obs (obs : schedulerObsE) : observed_completed E := - Vis (inl obs) (fun _ : unit => Ret tt). - - Fixpoint emit_live_slot_offers_into_then - (m n : nat) (embed : LiveSlot n -> LiveSlot m) - (k : observed_completed E) {struct n} : observed_completed E := - match n return (LiveSlot n -> LiveSlot m) -> observed_completed E with - | 0 => fun _ => k - | S n' => fun embed => - Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun i => embed (Fin.FS i)) k) - end embed. - - Definition emit_live_slot_offers_then - (n : nat) (k : observed_completed E) : observed_completed E := - emit_live_slot_offers_into_then n n (fun i => i) k. - - Definition emit_live_slot_offers (n : nat) : observed_completed E := - emit_live_slot_offers_then n (Ret tt). - - (** Observed scheduler. The only extra visible events are proof-facing - [schedulerObsE] events at nonempty no-focus scheduling points. *) - CoFixpoint schedule_with_offers - (n : nat) (v : pool E n) (focus : option (Fin.t n)) - : observed_completed E := - match focus with - | None => - match n return pool E n -> observed_completed E with - | 0 => fun _ => Ret tt - | S n' => fun v => - Vis (inl (ObsSchedulingPoint (S n'))) - (fun _ : unit => - schedule_with_offers_offer_prefix (S n') (S n') - (fun i => i) v) - end v - | Some i => - match n return pool E n -> Fin.t n -> observed_completed E with - | 0 => fun _ i => match i with end - | S n' => fun v i => - match observe (v i) with - | RetF _ => - Guard (schedule_with_offers n' (remove_pool v i) None) - | BrF b k => - Br b (fun j => - schedule_with_offers (S n') - (replace_pool v i (k j)) (Some i)) - | GuardF t => - Guard (schedule_with_offers (S n') - (replace_pool v i t) (Some i)) - | VisF e k => - match e as e0 return - (encode e0 -> thread E) -> observed_completed E with - | inl Yield => fun k => - Guard (schedule_with_offers (S n') - (replace_pool v i (k tt)) None) - | inr (inl Fork) => fun k => - @go (scheduler_observedE E) _ unit - (VisF (inr (inr (inl Spawn)) - : scheduler_observedE E) - (fun _ => schedule_with_offers (S (S n')) - (cons_pool (k true) - (replace_pool v i (k false))) - (Some (Fin.FS i)))) - | inr (inr e') => fun k => - @go (scheduler_observedE E) _ unit - (VisF (inr (inr (inr e')) - : scheduler_observedE E) - (fun x => schedule_with_offers (S n') - (replace_pool v i (k x)) (Some i))) - end k - end - end v i - end - with schedule_with_offers_offer_prefix - (pool_size remaining : nat) - (embed : LiveSlot remaining -> LiveSlot pool_size) - (v : pool E pool_size) : observed_completed E := - match remaining return - (LiveSlot remaining -> LiveSlot pool_size) -> - pool E pool_size -> observed_completed E with - | 0 => fun _ v => - match pool_size return pool E pool_size -> observed_completed E with - | 0 => fun _ => Ret tt - | S n' => fun v => - Vis (inr (inl Yield) : scheduler_observedE E) - (fun _ : unit => - Br n' (fun i => - schedule_with_offers (S n') v (Some i))) - end v - | S n' => fun embed v => - Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - schedule_with_offers_offer_prefix pool_size n' - (fun i => embed (Fin.FS i)) v) - end embed v. - - Definition observe_scheduler_offers - (n : nat) (v : pool E n) (focus : option (Fin.t n)) - : observed_completed E := - schedule_with_offers n v focus. - - Definition handle_scheduler_offers - : scheduler_observedE E ~> ictree (yieldE + (spawnE + E)) := - fun event => - match event with - | inl _ => Ret tt - | inr event' => ICtree.trigger event' - end. - - Definition forget_scheduler_offers {X} - (t : ictree (scheduler_observedE E) X) - : ictree (yieldE + (spawnE + E)) X := - interp handle_scheduler_offers t. - - Lemma handle_scheduler_offers_obs obs : - handle_scheduler_offers (inl obs) = Ret tt. - Proof. reflexivity. Qed. - - Lemma handle_scheduler_offers_visible event : - handle_scheduler_offers (inr event) = ICtree.trigger event. - Proof. reflexivity. Qed. - - Lemma forget_scheduler_offers_no_focus_nonempty_unfold n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ - Guard (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v)). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. rewrite bind_ret_l. reflexivity. - Qed. - - Theorem forget_scheduler_offers_preserves_schedule_exact_no_focus_impossible n - (v : pool E (S n)) : - ~ forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ - schedule (S n) v None. - Proof. - intro Heq. - step in Heq. - cbn in Heq. - inversion Heq. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_succ_stutter m n - (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix m (S n) embed v) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix m n - (fun i => embed (Fin.FS i)) v). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. rewrite bind_ret_l. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_stutter m r - (embed : LiveSlot r -> LiveSlot m) (v : pool E m) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix m r embed v) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix m 0 - (fun i : LiveSlot 0 => match i with end) v). - Proof. - revert m embed v. - induction r as [| r IHr]; intros m embed v. - - destruct m as [| m']. - + unfold forget_scheduler_offers. - rewrite !unfold_interp. - cbn. - apply sb_ret. reflexivity. - + unfold forget_scheduler_offers. - rewrite !unfold_interp. - cbn. - reflexivity. - - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix m r - (fun i => embed (Fin.FS i)) v)). - + apply forget_scheduler_offers_offer_prefix_succ_stutter. - + apply IHr. - Qed. - - Lemma forget_scheduler_offers_no_focus_stutters_to_offer_prefix n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v). - Proof. - rewrite forget_scheduler_offers_no_focus_nonempty_unfold. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_zero_nonempty_unfold n - (embed : LiveSlot 0 -> LiveSlot (S n)) (v : pool E (S n)) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) 0 embed v) ~ - Vis (inl Yield) - (fun _ : unit => - Br n (fun i => - forget_scheduler_offers - (schedule_with_offers (S n) v (Some i)))). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intros []. - apply sb_guard_l. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - apply sb_br_id. intro i. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_no_focus_projection_to_focused n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ~ - Vis (inl Yield) - (fun _ : unit => - Br n (fun i => - forget_scheduler_offers - (schedule_with_offers (S n) v (Some i)))). - Proof. - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v)). - - apply forget_scheduler_offers_no_focus_stutters_to_offer_prefix. - - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) 0 - (fun i : LiveSlot 0 => match i with end) v)). - + apply forget_scheduler_offers_offer_prefix_stutter. - + apply forget_scheduler_offers_offer_prefix_zero_nonempty_unfold. - Qed. - - Lemma emit_live_slot_offers_into_then_zero m - (embed : LiveSlot 0 -> LiveSlot m) k : - emit_live_slot_offers_into_then m 0 embed k = k. - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_into_then_succ m n - (embed : LiveSlot (S n) -> LiveSlot m) k : - observe (emit_live_slot_offers_into_then m (S n) embed k) = - VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - emit_live_slot_offers_into_then m n - (fun i => embed (Fin.FS i)) k). - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_zero : - observe (emit_live_slot_offers 0) = RetF tt. - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_succ n : - observe (emit_live_slot_offers (S n)) = - VisF (inl (ObsOffered (live_slot_ref (Fin.F1 : LiveSlot (S n))))) - (fun _ : unit => - emit_live_slot_offers_into_then (S n) n - (fun i => Fin.FS i) (Ret tt)). - Proof. reflexivity. Qed. - - Local Ltac solve_focused_schedule_with_offers H := - lazy [schedule_with_offers observe _observe]; - match type of H with - | observe (?v ?i) = _ => - change (@_observe _ _ unit (v i)) with (observe (v i)); - rewrite H; - reflexivity - end. - - Lemma schedule_with_offers_empty_none (v : pool E 0) : - observe (schedule_with_offers 0 v None) = RetF tt. - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_no_focus_nonempty n - (v : pool E (S n)) : - observe (schedule_with_offers (S n) v None) = - VisF (inl (ObsSchedulingPoint (S n))) - (fun _ : unit => - schedule_with_offers_offer_prefix (S n) (S n) - (fun i => i) v). - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_offer_prefix_zero m - (embed : LiveSlot 0 -> LiveSlot m) (v : pool E m) : - observe (schedule_with_offers_offer_prefix m 0 embed v) = - match m return pool E m -> ictree' (scheduler_observedE E) unit with - | 0 => fun _ => RetF tt - | S n => fun v => - VisF (inr (inl Yield) : scheduler_observedE E) - (fun _ : unit => - Br n (fun i => schedule_with_offers (S n) v (Some i))) - end v. - Proof. destruct m; reflexivity. Qed. - - Lemma schedule_with_offers_offer_prefix_succ m n - (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : - observe (schedule_with_offers_offer_prefix m (S n) embed v) = - VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - schedule_with_offers_offer_prefix m n - (fun i => embed (Fin.FS i)) v). - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_focused_ret n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers n (remove_pool v i) None). - Proof. - intro Hret. - solve_focused_schedule_with_offers Hret. - Qed. - - Lemma schedule_with_offers_focused_br n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - observe (schedule_with_offers (S n) v (Some i)) = - BrF b (fun j => - schedule_with_offers (S n) (replace_pool v i (k j)) (Some i)). - Proof. - intro Hbr. - solve_focused_schedule_with_offers Hbr. - Qed. - - Lemma schedule_with_offers_focused_guard n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v i) = GuardF t -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) (replace_pool v i t) (Some i)). - Proof. - intro Hg. - solve_focused_schedule_with_offers Hg. - Qed. - - Lemma schedule_with_offers_focused_yield n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) - (replace_pool v i (k tt)) None). - Proof. - intro Hy. - solve_focused_schedule_with_offers Hy. - Qed. - - Lemma schedule_with_offers_focused_fork n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - observe (schedule_with_offers (S n) v (Some i)) = - VisF (inr (inr (inl Spawn)) : scheduler_observedE E) - (fun _ => schedule_with_offers (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - Proof. - intro Hf. - solve_focused_schedule_with_offers Hf. - Qed. - - Lemma schedule_with_offers_focused_user_event n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - observe (schedule_with_offers (S n) v (Some i)) = - VisF (inr (inr (inr e)) : scheduler_observedE E) - (fun x => schedule_with_offers (S n) - (replace_pool v i (k x)) (Some i)). - Proof. - intro Hu. - solve_focused_schedule_with_offers Hu. - Qed. - - Lemma focused_yield_returns_to_scheduling_point n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) - (replace_pool v i (k tt)) None). - Proof. apply schedule_with_offers_focused_yield. Qed. - - Lemma forget_scheduler_offers_empty_no_focus_projection - (v : pool E 0) : - forget_scheduler_offers (schedule_with_offers 0 v None) ~ Ret tt. - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - apply sb_ret. reflexivity. - Qed. - - Lemma forget_scheduler_offers_focused_ret_projection n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers (schedule_with_offers n (remove_pool v i) None). - Proof. - intro Hret. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_ret n v i Hret). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_br_projection n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Br b (fun j => - forget_scheduler_offers - (schedule_with_offers (S n) (replace_pool v i (k j)) (Some i))). - Proof. - intro Hbr. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_br n v i b k Hbr). - cbn. - apply sb_br_id. intro j. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_guard_projection n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v i) = GuardF t -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers - (schedule_with_offers (S n) (replace_pool v i t) (Some i)). - Proof. - intro Hguard. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_guard n v i t Hguard). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_yield_projection n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers - (schedule_with_offers (S n) (replace_pool v i (k tt)) None). - Proof. - intro Hyield. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_yield n v i k Hyield). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_fork_projection n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => - forget_scheduler_offers (schedule_with_offers (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i)))). - Proof. - intro Hfork. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_fork n v i k Hfork). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intros []. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_user_event_projection n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => - forget_scheduler_offers - (schedule_with_offers (S n) (replace_pool v i (k x)) (Some i))). - Proof. - intro Huser. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_user_event n v i e k Huser). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intro x. - apply sb_guard. - Qed. - - Local Notation completed' := (completed E). - Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). - - Local Definition erased_schedule (n : nat) (v : pool E n) - (focus : option (Fin.t n)) : completed E := - forget_scheduler_offers (schedule_with_offers n v focus). - - Local Lemma erased_focused_ret_equ n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule n (remove_pool v i) None). - Proof. - intro Hret. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_ret n v i Hret). - reflexivity. - Qed. - - Local Lemma erased_focused_br_equ n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - erased_schedule (S n) v (Some i) ≅ - Br b (fun j => Guard (erased_schedule (S n) - (replace_pool v i (k j)) (Some i))). - Proof. - intro Hbr. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_br n v i b k Hbr). - reflexivity. - Qed. - - Local Lemma erased_focused_guard_equ n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v i) = GuardF t -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule (S n) (replace_pool v i t) (Some i)). - Proof. - intro Hguard. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_guard n v i t Hguard). - reflexivity. - Qed. - - Local Lemma erased_focused_yield_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule (S n) (replace_pool v i (k tt)) None). - Proof. - intro Hyield. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_yield n v i k Hyield). - reflexivity. - Qed. - - Local Lemma erased_focused_fork_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - erased_schedule (S n) v (Some i) ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i)))). - Proof. - intro Hfork. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_fork n v i k Hfork). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - reflexivity. - Qed. - - Local Lemma erased_focused_user_event_equ n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - erased_schedule (S n) v (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n) - (replace_pool v i (k x)) (Some i))). - Proof. - intro Huser. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_user_event n v i e k Huser). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - reflexivity. - Qed. - - Local Lemma schedule_focused_yield_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - schedule (S n) v (Some i) ≅ - Guard (schedule (S n) (replace_pool v i (k tt)) None). - Proof. - intro Hyield. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_yield n v i k Hyield). - reflexivity. - Qed. - - Local Lemma guard_residual_from_equ (actual target residual : completed') : - observe actual = GuardF residual -> - actual ≅ Guard target -> - residual ≅ target. - Proof. - intros Hobs Heq. - apply equ_guard_invE. - transitivity actual. - - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. - - exact Heq. - Qed. - - Local Ltac contradiction_from_shape_equ actual Hobs Heq := - exfalso; - rewrite (ictree_eta actual) in Heq; - rewrite <- Hobs in Heq; - step in Heq; inversion Heq. - - Local Lemma erased_schedule_match_left_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ erased_schedule 0 v None -> - trans l actual t' -> - exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - - rewrite (trans_schedule_empty_ret v). apply trans_ret. - - rewrite Hsb. rewrite Hmid. reflexivity. - Qed. - - Local Lemma erased_schedule_match_left_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ erased_schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n (fun i => - erased_schedule (S n) v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (Br n (fun i => schedule (S n) v (Some i))). split. - - apply trans_schedule_no_focus_nonempty. - - rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n) - (replace_pool v i (k j)) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - exists (schedule (S n) (replace_pool v i (k j)) (Some i)). - split. - - apply trans_schedule_focused_br. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). split. - - apply trans_schedule_focused_fork. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n) - (replace_pool v i (k x)) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - exists (schedule (S n) (replace_pool v i (k x)) (Some i)). - split. - - apply trans_schedule_focused_user_event. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma schedule_focused_br_equ n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - schedule (S n) v (Some i) ≅ - Br b (fun j => schedule (S n) (replace_pool v i (k j)) (Some i)). - Proof. - intro Hbr. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_br n v i b k Hbr). - reflexivity. - Qed. - - Local Lemma schedule_focused_fork_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - Proof. - intro Hfork. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_fork n v i k Hfork). - reflexivity. - Qed. - - Local Lemma schedule_focused_user_event_equ n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => schedule (S n) (replace_pool v i (k x)) (Some i)). - Proof. - intro Huser. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_user_event n v i e k Huser). - reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ schedule 0 v None -> - trans l actual t' -> - exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - assert (Hret : actual ~ Ret tt). - { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hret TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - assert (Hproj : Ret tt ~ erased_schedule 0 v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as - [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - set (sres := Br n (fun i => schedule (S n) v (Some i))). - set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). - assert (Hshape : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) - lres). - { apply trans_vis. } - assert (Hproj : - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ - erased_schedule (S n) v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans _ _ lres - (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun j => - schedule (S n) (replace_pool v i (k j)) (Some i)). - set (lres := fun j => - erased_schedule (S n) (replace_pool v i (k j)) (Some i)). - assert (Hshape : actual ~ Br b sres). - { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans tau (Br b lres) (lres j)). - { apply trans_br with (x := j). reflexivity. } - assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_br_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) - as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - set (lres := erased_schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - assert (Hshape : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) - (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres)) lres). - { apply trans_vis. } - assert (Hproj : - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres) ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } - destruct (sbisim_trans _ _ lres - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun x => - schedule (S n) (replace_pool v i (k x)) (Some i)). - set (lres := fun x => - erased_schedule (S n) (replace_pool v i (k x)) (Some i)). - assert (Hshape : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) sres). - { rewrite Hactual. - rewrite (schedule_focused_user_event_equ n v i e k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans - (obs (inr (inr e) : yieldE + (spawnE + E)) x) - (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). - { apply trans_vis. } - assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres x) - (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ erased_schedule n v focus -> - exists u', trans l (schedule n v focus) u' /\ stR R t' u'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' (remove_pool v i) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule n' (remove_pool v i) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' (remove_pool v i) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_ret n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n') - (replace_pool v i (k j)) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid ->]]. - exists (schedule (S n') (replace_pool v i (k j)) (Some i)). - split. - -- apply trans_schedule_focused_br. exact Hvi. - -- rewrite Hsb. rewrite Hmid. apply Hch. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - assert (Ht : t ≅ - erased_schedule (S n') (replace_pool v i g) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') (replace_pool v i g) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_guard n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - (replace_pool v i (k tt)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule (S n') - (replace_pool v i (k tt)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') (replace_pool v i (k tt)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n')) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (schedule (S (S n')) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). split. - ++ apply trans_schedule_focused_fork. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - -- assert (Hproj : actual ~ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n') - (replace_pool v i (k x)) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - exists (schedule (S n') (replace_pool v i (k x)) (Some i)). - split. - ++ apply trans_schedule_focused_user_event. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - + destruct nn as [| n']. - * assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - -- rewrite (trans_schedule_empty_ret v). apply trans_ret. - -- rewrite Hsb. rewrite Hmid. reflexivity. - * assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n' (fun i => - erased_schedule (S n') v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (Br n' (fun i => schedule (S n') v (Some i))). split. - -- apply trans_schedule_no_focus_nonempty. - -- rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' (remove_pool v i) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_left_br; eauto. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (cons_pool (k0 true) (replace_pool v i (k0 false))) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - (replace_pool v i (k0 x)) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' (remove_pool v i) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - (replace_pool v i (k0 j)) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_left_fork; eauto. - -- eapply erased_schedule_match_left_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (erased_schedule n' (remove_pool v i) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - (replace_pool v i (k0 j)) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (cons_pool (k0 true) (replace_pool v i (k0 false))) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - (replace_pool v i (k0 x)) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - Qed. - - Local Lemma erased_schedule_match_right (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ schedule n v focus -> - exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' (remove_pool v i) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - assert (Ht : t ≅ schedule n' (remove_pool v i) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' (remove_pool v i) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_ret_equ n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - assert (Ht : t ≅ - schedule (S n') (replace_pool v i g) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') (replace_pool v i g) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_guard_equ n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - (replace_pool v i (k tt)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ schedule (S n') - (replace_pool v i (k tt)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') (replace_pool v i (k tt)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (erased_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' (remove_pool v i) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' (remove_pool v i) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (schedule n' (remove_pool v i) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') (replace_pool v i g) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - (replace_pool v i (k0 tt)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - Qed. - - Theorem forget_scheduler_offers_preserves_schedule - n (v : pool E n) focus : - forget_scheduler_offers (schedule_with_offers n v focus) ~ - schedule n v focus. - Proof. - change (erased_schedule n v focus ~ schedule n v focus). - revert n v focus. - coinduction R CH. - intros n v focus. - assert (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)). - { intros m w f. apply CH. } - split. - - intros l t' TR. - destruct (erased_schedule_match_left R Hch _ _ _ TR - (erased_schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + exact Hres. - + reflexivity. - - intros l t' TR. - destruct (erased_schedule_match_right R Hch _ _ _ TR - (schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + unfold Basics.flip. exact Hres. - + reflexivity. - Qed. - - Record ReturnSlotTransport {n : nat} - (v : pool E (S n)) (removed : LiveSlot (S n)) - (v' : pool E n) : Prop := { - return_new_slots_come_from_old_survivors : - forall j_new : LiveSlot n, - exists j_old : LiveSlot (S n), - j_old <> removed /\ v' j_new = v j_old; - return_old_survivors_reappear : - forall j_old : LiveSlot (S n), - j_old <> removed -> - exists j_new : LiveSlot n, v' j_new = v j_old - }. - - Theorem return_removes_live_slot n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - ReturnSlotTransport v i (remove_pool v i). - Proof. - intro Hret; clear Hret. - revert v i. - induction n as [| n IH]; intros v i. - - constructor. - + intro j_new. - exact (Fin.case0 (fun j_new => exists j_old : LiveSlot 1, - j_old <> i /\ remove_pool v i j_new = v j_old) j_new). - + intros j_old Hneq. - contradiction Hneq. apply live_slot_one_eq. - - refine (Fin.caseS' i - (fun i => ReturnSlotTransport v i (remove_pool v i)) _ _). - + constructor. - * intro j_new. - exists (Fin.FS j_new). split. - -- discriminate. - -- reflexivity. - * intros j_old Hneq. - refine (Fin.caseS' j_old - (fun j => j <> Fin.F1 -> - exists j_new : LiveSlot (S n), - remove_pool v Fin.F1 j_new = v j) _ _ Hneq). - -- intro Hcontra. contradiction Hcontra; reflexivity. - -- intros j_new _. exists j_new. reflexivity. - + intro i_tail. - pose proof (IH (fun k => v (Fin.FS k)) i_tail) as IHt. - destruct IHt as [IHnew IHold]. - constructor. - * intro j_new. - refine (Fin.caseS' j_new - (fun j => exists j_old : LiveSlot (S (S n)), - j_old <> Fin.FS i_tail /\ - remove_pool v (Fin.FS i_tail) j = v j_old) _ _). - -- exists Fin.F1. split. - ++ discriminate. - ++ reflexivity. - -- intros j_new'. - destruct (IHnew j_new') as [j_old [Hneq Hv]]. - exists (Fin.FS j_old). split. - ++ intro Heq. apply Fin.FS_inj in Heq. - contradiction Hneq. - ++ cbn. rewrite !fin_cast_refl. exact Hv. - * intros j_old Hneq. - refine (Fin.caseS' j_old - (fun j => j <> Fin.FS i_tail -> - exists j_new : LiveSlot (S n), - remove_pool v (Fin.FS i_tail) j_new = v j) _ _ Hneq). - -- intros _. exists Fin.F1. reflexivity. - -- intros j_old' Hneq'. - assert (Hsurv : j_old' <> i_tail) by - (intro Heq; subst; apply Hneq'; reflexivity). - destruct (IHold j_old' Hsurv) as [j_new Hv]. - exists (Fin.FS j_new). - cbn. rewrite !fin_cast_refl. exact Hv. - Qed. - - Definition shift_live_slot_across_spawn {n : nat} - (i : LiveSlot n) : LiveSlot (S n) := - Fin.FS i. - - Lemma shift_live_slot_across_spawn_head {n} - (child : thread E) (v : pool E n) : - cons_pool child v Fin.F1 = child. - Proof. apply cons_pool_head. Qed. - - Lemma shift_live_slot_across_spawn_tail {n} - (child : thread E) (v : pool E n) (i : LiveSlot n) : - cons_pool child v (shift_live_slot_across_spawn i) = v i. - Proof. apply cons_pool_tail. Qed. - - Lemma shift_live_slot_across_spawn_parent_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - cons_pool (k true) (replace_pool v i (k false)) - (shift_live_slot_across_spawn i) = k false. - Proof. - rewrite shift_live_slot_across_spawn_tail. - apply replace_pool_hit. - Qed. - - Lemma shift_live_slot_across_spawn_other_slot n - (v : pool E (S n)) (i j : LiveSlot (S n)) k : - i <> j -> - cons_pool (k true) (replace_pool v i (k false)) - (shift_live_slot_across_spawn j) = v j. - Proof. - intro Hneq. - rewrite shift_live_slot_across_spawn_tail. - now apply replace_pool_miss. - Qed. - - Lemma transport_live_slots_across_spawn_head {n} - (child : thread E) (v : pool E n) : - cons_pool child v Fin.F1 = child. - Proof. apply shift_live_slot_across_spawn_head. Qed. - - Lemma transport_live_slots_across_spawn_tail {n} - (child : thread E) (v : pool E n) (i : LiveSlot n) : - cons_pool child v (shift_live_slot_across_spawn i) = v i. - Proof. apply shift_live_slot_across_spawn_tail. Qed. - - Lemma transport_live_slots_across_spawn_parent_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - cons_pool (k true) (replace_pool v i (k false)) - (shift_live_slot_across_spawn i) = k false. - Proof. apply shift_live_slot_across_spawn_parent_slot. Qed. - - Lemma transport_live_slots_across_spawn_other_slot n - (v : pool E (S n)) (i j : LiveSlot (S n)) k : - i <> j -> - cons_pool (k true) (replace_pool v i (k false)) - (shift_live_slot_across_spawn j) = v j. - Proof. apply shift_live_slot_across_spawn_other_slot. Qed. - - Record SpawnSlotTransport {n : nat} - (v : pool E (S n)) (parent : LiveSlot (S n)) - (k : bool -> thread E) (spawned : pool E (S (S n))) : Prop := { - spawn_child_at_head : spawned Fin.F1 = k true; - spawn_parent_at_shifted_slot : spawned (Fin.FS parent) = k false; - spawn_other_old_slots_shifted : - forall j : LiveSlot (S n), - j <> parent -> spawned (Fin.FS j) = v j - }. - - Theorem transport_live_slots_across_spawn n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - SpawnSlotTransport v i k - (cons_pool (k true) (replace_pool v i (k false))). - Proof. - intro Hfork; clear Hfork. - constructor. - - apply cons_pool_head. - - rewrite cons_pool_tail. apply replace_pool_hit. - - intros j Hneq. - rewrite cons_pool_tail. - apply replace_pool_miss. congruence. - Qed. - - Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) - : observed_completed E -> Prop := - | offered_prefix_here t k : - observe t = VisF (inl (ObsOffered (live_slot_ref i))) k -> - offered_in_scheduler_prefix n i t - | offered_prefix_later t obs k : - observe t = VisF (inl obs) k -> - offered_in_scheduler_prefix n i (k tt) -> - offered_in_scheduler_prefix n i t. - - Lemma emit_live_slot_offers_into_then_offers m : - forall n (embed : LiveSlot n -> LiveSlot m) k (i : LiveSlot n), - offered_in_scheduler_prefix m (embed i) - (emit_live_slot_offers_into_then m n embed k). - Proof. - intros n embed k i. - induction i as [n' | n' i IH]. - - apply offered_prefix_here with - (k := fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun i => embed (Fin.FS i)) k). - reflexivity. - - apply offered_prefix_later with - (obs := ObsOffered (live_slot_ref (embed Fin.F1))) - (k := fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun j => embed (Fin.FS j)) k). - + reflexivity. - + apply (IH (fun j => embed (Fin.FS j))). - Qed. - - Lemma emit_live_slot_offers_then_offers n k (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers_then n k). - Proof. - unfold emit_live_slot_offers_then. - apply (emit_live_slot_offers_into_then_offers n n (fun i => i) k i). - Qed. - - Lemma emit_live_slot_offers_offers n (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers n). - Proof. - apply emit_live_slot_offers_then_offers. - Qed. - - Lemma emit_live_slot_offers_contains_every_slot n (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers n). - Proof. - apply emit_live_slot_offers_offers. - Qed. - - Lemma schedule_with_offers_offer_prefix_offers m : - forall n (embed : LiveSlot n -> LiveSlot m) (v : pool E m) - (i : LiveSlot n), - offered_in_scheduler_prefix m (embed i) - (schedule_with_offers_offer_prefix m n embed v). - Proof. - intros n embed v i. - induction i as [n' | n' i IH]. - - apply offered_prefix_here with - (k := fun _ : unit => - schedule_with_offers_offer_prefix m n' - (fun i => embed (Fin.FS i)) v). - apply schedule_with_offers_offer_prefix_succ. - - apply offered_prefix_later with - (obs := ObsOffered (live_slot_ref (embed Fin.F1))) - (k := fun _ : unit => - schedule_with_offers_offer_prefix m n' - (fun j => embed (Fin.FS j)) v). - + apply schedule_with_offers_offer_prefix_succ. - + apply (IH (fun j => embed (Fin.FS j))). - Qed. - - Lemma offer_live_slot_now n (i : LiveSlot n) - (t : observed_completed E) : - <( {t}, {Obs (inl (ObsOffered (live_slot_ref i))) tt} |= - {offer_live_slot n i} )>. - Proof. - unfold offer_live_slot. - split; [reflexivity | constructor]. - Qed. - - Lemma observed_equ_refl_no_eqdep (t : observed_completed E) : t ≅ t. - Proof. - unfold equ. - apply (leq_gfp (@fequ _ _ unit unit eq) - (fun u v : observed_completed E => u = v)). - - intros u v <-. cbn. destruct (observe u); constructor; auto. - - reflexivity. - Qed. - - Lemma observed_equ_step_no_eqdep (t u : observed_completed E) : - t ≅ u -> equF eq (equ eq) (observe t) (observe u). - Proof. - intro Htu. unfold equ in Htu. - exact (proj1 (gfp_fp (@fequ _ _ unit unit eq) t u) Htu). - Qed. - - Definition equF_scheduler_vis_result - (p q : ictree' (scheduler_observedE E) unit) : Prop := - match q with - | VisF (inl sched_obs) k_right => - exists k_left, - p = VisF (inl sched_obs) k_left /\ k_left tt ≅ k_right tt - | _ => True - end. - - Lemma equF_scheduler_vis_inv_no_eqdep p q : - equF eq (equ eq) p q -> equF_scheduler_vis_result p q. - Proof. - intro Hf. - destruct Hf as [x y Hxy | e k1 k2 Hk | t1 t2 Ht | - n k1 k2 Hk]; cbn; try exact I. - destruct e as [sched_obs | rest]; cbn; try exact I. - exists k1. split; [reflexivity | apply Hk]. - Qed. - - Lemma equ_scheduler_vis_inv_from_observe_no_eqdep - (obs : schedulerObsE) - (k : encode (inl obs : scheduler_observedE E) -> - observed_completed E) - (t u : observed_completed E) : - t ≅ u -> - observe u = VisF (inl obs) k -> - exists k_t, observe t = VisF (inl obs) k_t /\ k_t tt ≅ k tt. - Proof. - intros Htu Hu. - pose proof (equF_scheduler_vis_inv_no_eqdep _ _ - (observed_equ_step_no_eqdep _ _ Htu)) as Hshape. - rewrite Hu in Hshape. - exact Hshape. - Qed. - - Lemma ktrans_vis_raw_inv_no_eqdep {X} (e : scheduler_observedE E) - (k : encode e -> ictree (scheduler_observedE E) X) - (w : World (scheduler_observedE E)) t' w' : - |Vis e k, w| ↦ |t', w'| -> - exists v (target : ictree (scheduler_observedE E) X), - w' = Obs e v /\ observe target = observe t' /\ - target ≅ k v /\ not_done w. - Proof. - intro Htr. - cbn in Htr. - refine (match Htr in ktrans_ ot w0 ot' w0' return - match ot with - | VisF e0 k0 => - exists v (target : ictree (scheduler_observedE E) X), - w0' = Obs e0 v /\ observe target = ot' /\ - target ≅ k0 v /\ not_done w0 - | _ => True - end with - | KtransObs e0 v k0 target w0 Hnd Heq => _ - | _ => I - end). - exists v, target. - split; [reflexivity | split; [reflexivity | split; assumption]]. - Qed. - - Lemma ktrans_scheduler_vis_inv_no_eqdep {X} (obs : schedulerObsE) - (k : encode (inl obs : scheduler_observedE E) -> - ictree (scheduler_observedE E) X) - (w : World (scheduler_observedE E)) t' w' : - |Vis (inl obs) k, w| ↦ |t', w'| -> - exists target : ictree (scheduler_observedE E) X, - w' = Obs (inl obs) tt /\ observe target = observe t' /\ - target ≅ k tt /\ not_done w. - Proof. - intro Htr. - destruct (ktrans_vis_raw_inv_no_eqdep _ _ _ _ _ Htr) as - [v [target [Hw [Ht [Heq Hnd]]]]]. - destruct v. - exists target. split; [exact Hw | split; [exact Ht | split; assumption]]. - Qed. - - Inductive SchedulerEquChain : - observed_completed E -> observed_completed E -> Prop := - | scheduler_equ_chain_refl t : SchedulerEquChain t t - | scheduler_equ_chain_cons t u v : - t ≅ u -> - SchedulerEquChain u v -> - SchedulerEquChain t v. - - Lemma scheduler_equ_chain_scheduler_vis_inv_no_eqdep - (obs : schedulerObsE) - (k : encode (inl obs : scheduler_observedE E) -> - observed_completed E) - (t u : observed_completed E) : - SchedulerEquChain t u -> - observe u = VisF (inl obs) k -> - exists k_t, - observe t = VisF (inl obs) k_t /\ - SchedulerEquChain (k_t tt) (k tt). - Proof. - intros Hchain Hobs. - induction Hchain as [u | t mid u Htm _ IH]. - - exists k. split; [exact Hobs | constructor]. - - destruct (IH Hobs) as [k_mid [Hmid Hcont]]. - destruct (equ_scheduler_vis_inv_from_observe_no_eqdep obs k_mid - t mid Htm Hmid) as [k_t [Ht Hstep]]. - exists k_t. split; [exact Ht |]. - econstructor; [exact Hstep | exact Hcont]. - Qed. - - Lemma offered_in_scheduler_prefix_chain_implies_AF n - (i : LiveSlot n) (u actual bridge : observed_completed E) w : - observe bridge = observe actual -> - SchedulerEquChain bridge u -> - not_done w -> - offered_in_scheduler_prefix n i u -> - <( {actual}, w |= AF {offer_live_slot n i} )>. - Proof. - intros Hbridge Hchain Hnd Hprefix. - revert actual bridge w Hbridge Hchain Hnd. - induction Hprefix as [u k Hobs | u obs k Hobs _ IH]; - intros actual bridge w Hbridge Hchain Hnd. - - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep - (ObsOffered (live_slot_ref i)) k bridge u Hchain Hobs) as - [k_actual [Hactual Hcont]]. - rewrite unfold_entailsL. - apply StepA. - split. - + split; [exact I | exact Hnd]. - + split. - * exists (k_actual tt), - (Obs (inl (ObsOffered (live_slot_ref i))) tt). - cbn. rewrite <- Hbridge, Hactual. - constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. - * intros t' w' Htr. - cbn in Htr. - rewrite <- Hbridge, Hactual in Htr. - destruct (ktrans_scheduler_vis_inv_no_eqdep - (ObsOffered (live_slot_ref i)) k_actual w t' w' Htr) as - [target [Hw' [Htarget [Heqtarget Hsource]]]]. - subst w'. - apply MatchA. - unfold offer_live_slot. - split; [reflexivity | constructor]. - - destruct (scheduler_equ_chain_scheduler_vis_inv_no_eqdep - obs k bridge u Hchain Hobs) as [k_actual [Hactual Hcont]]. - rewrite unfold_entailsL. - apply StepA. - split. - + split; [exact I | exact Hnd]. - + split. - * exists (k_actual tt), (Obs (inl obs) tt). - cbn. rewrite <- Hbridge, Hactual. - constructor; [exact Hnd | apply observed_equ_refl_no_eqdep]. - * intros t' w' Htr. - cbn in Htr. - rewrite <- Hbridge, Hactual in Htr. - destruct (ktrans_scheduler_vis_inv_no_eqdep obs - k_actual w t' w' Htr) as - [target [Hw' [Htarget [Heqtarget Hsource]]]]. - subst w'. - specialize (IH t' target (Obs (inl obs) tt) Htarget - (scheduler_equ_chain_cons target (k_actual tt) (k tt) - Heqtarget Hcont) (NotDoneObs (inl obs) tt)). - rewrite unfold_entailsL in IH. - exact IH. - Qed. - - Theorem offered_in_scheduler_prefix_implies_AF n - (i : LiveSlot n) (t : observed_completed E) w : - not_done w -> - offered_in_scheduler_prefix n i t -> - <( {t}, w |= AF {offer_live_slot n i} )>. - Proof. - intros Hnd Hprefix. - eapply offered_in_scheduler_prefix_chain_implies_AF. - - reflexivity. - - constructor. - - exact Hnd. - - exact Hprefix. - Qed. - - Lemma show_no_focus_offers_every_live_slot_prefix n - (v : pool E (S n)) (i : LiveSlot (S n)) : - offered_in_scheduler_prefix (S n) i - (schedule_with_offers (S n) v None). - Proof. - eapply offered_prefix_later. - - apply schedule_with_offers_no_focus_nonempty. - - apply (schedule_with_offers_offer_prefix_offers (S n) (S n) - (fun i => i) v i). - Qed. - - Lemma no_focus_offers_every_live_slot_prefix n - (v : pool E (S n)) (i : LiveSlot (S n)) : - offered_in_scheduler_prefix (S n) i - (schedule_with_offers (S n) v None). - Proof. - apply show_no_focus_offers_every_live_slot_prefix. - Qed. - - Theorem show_no_focus_offers_every_live_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) : - <( {schedule_with_offers (S n) v None}, Pure |= - AF {offer_live_slot (S n) i} )>. - Proof. - apply offered_in_scheduler_prefix_implies_AF. - - constructor. - - apply show_no_focus_offers_every_live_slot_prefix. - Qed. - - Theorem no_focus_offers_every_live_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) : - <( {schedule_with_offers (S n) v None}, Pure |= - AF {offer_live_slot (S n) i} )>. - Proof. - apply show_no_focus_offers_every_live_slot. - Qed. - - Definition scheduling_point_offer_obligation - (t : observed_completed E) (w : World (scheduler_observedE E)) - : Prop := - forall n, - w = Obs (inl (ObsSchedulingPoint (S n))) tt -> - forall i : LiveSlot (S n), - <( {t}, w |= AF {offer_live_slot (S n) i} )>. - - Local Definition non_scheduling_point_world - (w : World (scheduler_observedE E)) : Prop := - forall n, - w = Obs (inl (ObsSchedulingPoint (S n))) tt -> False. - - Local Lemma pure_non_scheduling_point : - non_scheduling_point_world Pure. - Proof. intros n Hcontra. discriminate Hcontra. Qed. - - Local Lemma obs_offered_non_scheduling_point ref : - non_scheduling_point_world - (Obs (inl (ObsOffered ref) : scheduler_observedE E) tt). - Proof. intros n Hcontra. discriminate Hcontra. Qed. - - Local Lemma obs_non_scheduler_non_scheduling_point - (event : yieldE + (spawnE + E)) - (value : encode (inr event : scheduler_observedE E)) : - non_scheduling_point_world (Obs (inr event) value). - Proof. intros n Hcontra. discriminate Hcontra. Qed. - - Private Inductive SchedulerOfferCanonical - : observed_completed E -> World (scheduler_observedE E) -> Prop := - | scheduler_offer_canonical_schedule : forall n - (v : pool E n) focus w, - non_scheduling_point_world w -> - SchedulerOfferCanonical (schedule_with_offers n v focus) w - | scheduler_offer_canonical_prefix_at_point : forall n - (v : pool E (S n)), - SchedulerOfferCanonical - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v) - (Obs (inl (ObsSchedulingPoint (S n))) tt) - | scheduler_offer_canonical_prefix_elsewhere : forall m r - (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w, - non_scheduling_point_world w -> - SchedulerOfferCanonical - (schedule_with_offers_offer_prefix m r embed v) w - | scheduler_offer_canonical_choice : forall n - (v : pool E (S n)) w, - non_scheduling_point_world w -> - SchedulerOfferCanonical - (Br n (fun i : fin' n => - schedule_with_offers (S n) v (Some i))) w - | scheduler_offer_canonical_done : forall t (x : unit), - SchedulerOfferCanonical t (Done x) - | scheduler_offer_canonical_finish : forall t - (event : scheduler_observedE E) (value : encode event) (x : unit), - SchedulerOfferCanonical t (Finish event value x). - - Local Definition SchedulerOfferShape - (t : observed_completed E) (w : World (scheduler_observedE E)) - : Prop := - exists u : observed_completed E, t ≅ u /\ SchedulerOfferCanonical u w. - - Local Lemma scheduler_offer_shape_canonical t w : - SchedulerOfferCanonical t w -> SchedulerOfferShape t w. - Proof. - intro Hcanonical. - exists t. split; [apply observed_equ_refl_no_eqdep | exact Hcanonical]. - Qed. - - Local Lemma scheduler_offer_shape_equ t u w : - t ≅ u -> SchedulerOfferShape u w -> SchedulerOfferShape t w. - Proof. - intros Htu [v [Huv Hcanonical]]. - exists v. split. - - transitivity u; assumption. - - exact Hcanonical. - Qed. - - Local Lemma observed_equ_of_observe_eq (t u : observed_completed E) : - observe t = observe u -> t ≅ u. - Proof. - intro Hobserve. - transitivity (go (observe t)). - - apply ictree_eta. - - rewrite Hobserve. - symmetry. apply ictree_eta. - Qed. - - Local Lemma scheduler_offer_shape_schedule n - (v : pool E n) focus w : - non_scheduling_point_world w -> - SchedulerOfferShape (schedule_with_offers n v focus) w. - Proof. - intro Hworld. - apply scheduler_offer_shape_canonical. - now constructor. - Qed. - - Local Lemma scheduler_offer_shape_prefix_at_point n - (v : pool E (S n)) : - SchedulerOfferShape - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v) - (Obs (inl (ObsSchedulingPoint (S n))) tt). - Proof. - apply scheduler_offer_shape_canonical. - constructor. - Qed. - - Local Lemma scheduler_offer_shape_prefix_elsewhere m r - (embed : LiveSlot r -> LiveSlot m) (v : pool E m) w : - non_scheduling_point_world w -> - SchedulerOfferShape - (schedule_with_offers_offer_prefix m r embed v) w. - Proof. - intro Hworld. - apply scheduler_offer_shape_canonical. - now constructor. - Qed. - - Local Lemma scheduler_offer_shape_choice n - (v : pool E (S n)) w : - non_scheduling_point_world w -> - SchedulerOfferShape - (Br n (fun i : fin' n => - schedule_with_offers (S n) v (Some i))) w. - Proof. - intro Hworld. - apply scheduler_offer_shape_canonical. - now constructor. - Qed. - - Local Lemma scheduler_offer_shape_done t (x : unit) : - SchedulerOfferShape t (Done x). - Proof. - apply scheduler_offer_shape_canonical. - constructor. - Qed. - - Local Lemma scheduler_offer_shape_finish t - (event : scheduler_observedE E) (value : encode event) (x : unit) : - SchedulerOfferShape t (Finish event value x). - Proof. - apply scheduler_offer_shape_canonical. - constructor. - Qed. - - Local Lemma scheduler_offer_canonical_obligation t w : - SchedulerOfferCanonical t w -> scheduling_point_offer_obligation t w. - Proof. - intro Hcanonical. - destruct Hcanonical as - [n v focus w Hworld | n v | m r embed v w Hworld | - n v w Hworld | t x | t event value x]. - - intros k Hsched i. - exfalso. exact (Hworld k Hsched). - - intros k Hsched i. - inversion Hsched; subst. - apply offered_in_scheduler_prefix_implies_AF. - + constructor. - + apply (schedule_with_offers_offer_prefix_offers (S k) (S k) - (fun j : LiveSlot (S k) => j) v i). - - intros k Hsched i. - exfalso. exact (Hworld k Hsched). - - intros k Hsched i. - exfalso. exact (Hworld k Hsched). - - intros k Hsched i. discriminate Hsched. - - intros k Hsched i. discriminate Hsched. - Qed. - - Local Lemma scheduler_offer_shape_obligation t w : - SchedulerOfferShape t w -> scheduling_point_offer_obligation t w. - Proof. - intros [u [Htu Hcanonical]] k Hsched i. - rewrite Htu. - eapply scheduler_offer_canonical_obligation; eauto. - Qed. - - Local Lemma scheduler_offer_shape_ret_step - (w : World (scheduler_observedE E)) t' w' : - |Ret tt, w| ↦ |t', w'| -> SchedulerOfferShape t' w'. - Proof. - intro Htr. - destruct w as [| event value | x | event value x]. - - apply ktrans_done in Htr as [-> _]. - apply scheduler_offer_shape_done. - - apply ktrans_finish in Htr as [-> _]. - apply scheduler_offer_shape_finish. - - apply ktrans_not_done in Htr. inversion Htr. - - apply ktrans_not_done in Htr. inversion Htr. - Qed. - - Local Lemma scheduler_offer_canonical_step t w t' w' : - SchedulerOfferCanonical t w -> - |t, w| ↦ |t', w'| -> - SchedulerOfferShape t' w'. - Proof. - intros Hcanonical Htr. - revert t w t' w' Hcanonical Htr. - fix IH 6. - intros t w t' w' Hcanonical Htr. - destruct Hcanonical as - [n v focus w Hworld | n v | m r embed v w Hworld | - n v w Hworld | t x | t event value x]. - - destruct focus as [slot |]. - + dependent destruction slot. - * set (focused_slot := (Fin.F1 : Fin.t (S n))). - destruct (observe (v focused_slot)) eqn:Hthread; - fold focused_slot in Htr. - -- destruct x. - cbn in Htr. - rewrite (schedule_with_offers_focused_ret - n v focused_slot Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ++ eapply IH. - ** apply scheduler_offer_canonical_schedule. - exact Hworld. - ** exact Htr. - -- cbn in Htr. - rewrite (schedule_with_offers_focused_br - n v focused_slot n0 k Hthread) in Htr. - apply ktrans_br in Htr as [choice [Htarget [-> _]]]. - eapply scheduler_offer_shape_equ. - ++ exact Htarget. - ++ apply scheduler_offer_shape_schedule. exact Hworld. - -- cbn in Htr. - rewrite (schedule_with_offers_focused_guard - n v focused_slot t Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ++ eapply IH. - ** apply scheduler_offer_canonical_schedule. - exact Hworld. - ** exact Htr. - -- destruct e as [yield_event | [spawn_event | user_event]]. - ++ destruct yield_event. - cbn in Htr. - rewrite (schedule_with_offers_focused_yield - n v focused_slot k Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ** apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ** eapply IH. - --- apply scheduler_offer_canonical_schedule. - exact Hworld. - --- exact Htr. - ++ destruct spawn_event. - cbn in Htr. - rewrite (schedule_with_offers_focused_fork - n v focused_slot k Hthread) in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - ** symmetry. exact Htarget. - ** apply scheduler_offer_shape_schedule. - apply obs_non_scheduler_non_scheduling_point. - ++ cbn in Htr. - rewrite (schedule_with_offers_focused_user_event - n v focused_slot user_event k Hthread) in Htr. - apply ktrans_vis in Htr as [value [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - ** symmetry. exact Htarget. - ** apply scheduler_offer_shape_schedule. - apply obs_non_scheduler_non_scheduling_point. - * set (focused_slot := Fin.FS slot). - destruct (observe (v focused_slot)) eqn:Hthread; - fold focused_slot in Htr. - -- destruct x. - cbn in Htr. - rewrite (schedule_with_offers_focused_ret - n v focused_slot Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ++ eapply IH. - ** apply scheduler_offer_canonical_schedule. - exact Hworld. - ** exact Htr. - -- cbn in Htr. - rewrite (schedule_with_offers_focused_br - n v focused_slot n0 k Hthread) in Htr. - apply ktrans_br in Htr as [choice [Htarget [-> _]]]. - eapply scheduler_offer_shape_equ. - ++ exact Htarget. - ++ apply scheduler_offer_shape_schedule. exact Hworld. - -- cbn in Htr. - rewrite (schedule_with_offers_focused_guard - n v focused_slot t Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ++ eapply IH. - ** apply scheduler_offer_canonical_schedule. - exact Hworld. - ** exact Htr. - -- destruct e as [yield_event | [spawn_event | user_event]]. - ++ destruct yield_event. - cbn in Htr. - rewrite (schedule_with_offers_focused_yield - n v focused_slot k Hthread) in Htr. - dependent destruction Htr. - eapply scheduler_offer_shape_equ. - ** apply observed_equ_of_observe_eq. - match goal with - | Hobs : observe ?mid = observe t' |- _ => - symmetry; exact Hobs - end. - ** eapply IH. - --- apply scheduler_offer_canonical_schedule. - exact Hworld. - --- exact Htr. - ++ destruct spawn_event. - cbn in Htr. - rewrite (schedule_with_offers_focused_fork - n v focused_slot k Hthread) in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - ** symmetry. exact Htarget. - ** apply scheduler_offer_shape_schedule. - apply obs_non_scheduler_non_scheduling_point. - ++ cbn in Htr. - rewrite (schedule_with_offers_focused_user_event - n v focused_slot user_event k Hthread) in Htr. - apply ktrans_vis in Htr as [value [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - ** symmetry. exact Htarget. - ** apply scheduler_offer_shape_schedule. - apply obs_non_scheduler_non_scheduling_point. - + destruct n as [| n']. - * cbn in Htr. - apply scheduler_offer_shape_ret_step with (w := w). - exact Htr. - * cbn in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - -- symmetry. exact Htarget. - -- apply scheduler_offer_shape_prefix_at_point. - - cbn in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - + symmetry. exact Htarget. - + apply scheduler_offer_shape_prefix_elsewhere. - apply obs_offered_non_scheduling_point. - - destruct r as [| r']. - + destruct m as [| m']. - * cbn in Htr. - apply scheduler_offer_shape_ret_step with (w := w). - exact Htr. - * cbn in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - -- symmetry. exact Htarget. - -- apply scheduler_offer_shape_choice. - apply obs_non_scheduler_non_scheduling_point. - + cbn in Htr. - apply ktrans_vis in Htr as [[] [-> [Htarget _]]]. - eapply scheduler_offer_shape_equ. - * symmetry. exact Htarget. - * apply scheduler_offer_shape_prefix_elsewhere. - apply obs_offered_non_scheduling_point. - - cbn in Htr. - apply ktrans_br in Htr as [choice [Htarget [-> _]]]. - eapply scheduler_offer_shape_equ. - + exact Htarget. - + apply scheduler_offer_shape_schedule. exact Hworld. - - apply ktrans_not_done in Htr. inversion Htr. - - apply ktrans_not_done in Htr. inversion Htr. - Qed. - - Local Lemma scheduler_offer_shape_step t w t' w' : - SchedulerOfferShape t w -> - |t, w| ↦ |t', w'| -> - SchedulerOfferShape t' w'. - Proof. - intros [u [Htu Hcanonical]] Htr. - rewrite Htu in Htr. - eapply scheduler_offer_canonical_step; eauto. - Qed. - - CoInductive SchedulerProgress - : observed_completed E -> World (scheduler_observedE E) -> Prop := - | scheduler_progress_intro : forall t w, - can_step t w -> - (forall t' w', - |t, w| ↦ |t', w'| -> SchedulerProgress t' w') -> - SchedulerProgress t w. - - Lemma scheduler_progress_shape_implies_AG t w : - SchedulerProgress t w -> - SchedulerOfferShape t w -> - agc scheduling_point_offer_obligation t w. - Proof. - intros Hprogress0 Hshape0. - pose proof (leq_gfp (agcF scheduling_point_offer_obligation) - (fun t w => SchedulerProgress t w /\ SchedulerOfferShape t w)) - as Hcoind. - apply Hcoind. - - clear t w Hprogress0 Hshape0. - intros t w [Hprogress Hshape]. - destruct Hprogress as [t w Hstep Hnext]. - split. - + apply scheduler_offer_shape_obligation. exact Hshape. - + split. - * exact Hstep. - * intros t' w' Htr. - split. - -- apply Hnext. exact Htr. - -- eapply scheduler_offer_shape_step; eauto. - - split; assumption. - Qed. - - Theorem every_live_slot_is_eventually_offered_at_scheduling_points - n (v : pool E n) focus : - SchedulerProgress (schedule_with_offers n v focus) Pure -> - agc scheduling_point_offer_obligation - (schedule_with_offers n v focus) Pure. - Proof. - intro Hprogress. - eapply scheduler_progress_shape_implies_AG. - - exact Hprogress. - - apply scheduler_offer_shape_schedule. - apply pure_non_scheduling_point. - Qed. - - Theorem show_every_live_slot_is_eventually_offered_at_scheduling_points - n (v : pool E n) focus : - SchedulerProgress (schedule_with_offers n v focus) Pure -> - agc scheduling_point_offer_obligation - (schedule_with_offers n v focus) Pure. - Proof. - apply every_live_slot_is_eventually_offered_at_scheduling_points. - Qed. -End ObservedScheduler. +Theorem scheduled_observed_every_live_slot_eventually_offered (s : YStmt) : + SchedulerProgress (scheduled_observed s) Pure -> + agc scheduling_point_offer_obligation (scheduled_observed s) Pure. +Proof. + unfold scheduled_observed. + apply every_live_slot_is_eventually_offered_at_scheduling_points. +Qed. diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v index 477e819..b1a5145 100644 --- a/theories/Lang/Yield/Ticl.v +++ b/theories/Lang/Yield/Ticl.v @@ -2,9 +2,9 @@ Public tiers exported by this façade: - - [Lang.Yield.Events], [Lang.Yield.Syntax], and [Lang.Yield.Denote] expose + - [ICTree.Events.Yield], [Lang.Yield.Syntax], and [Lang.Yield.Denote] expose raw source-level threads with [Yield], [Fork], and memory effects. - - [Lang.Yield.Scheduler] exposes the scheduler, and [scheduled_visible] + - [ICTree.Interp.Yield.Mod] exposes the scheduler, and [scheduled_visible] exposes scheduled programs with scheduler [Spawn], cooperative [Yield], and memory effects visible. - [interp_scheduled_erased], [instr_exp_erased], and [instr_stmt_erased] @@ -13,16 +13,17 @@ - [interp_scheduled], [instr_exp], and [instr_stmt] are compatibility aliases for the erased tier. - This file also carries a small regression surface: constructor unfold facts, - one-step scheduler facts, finite-pool slot regressions, concrete visible - YYield/YFork examples, and alias facts documenting that the compatibility - APIs are erased. *) + Every temporal lemma below is an instantiation of a raw rule from + [ICTree.Logic.Yield] at the Yield denotations. This file also carries a + small regression surface: concrete visible YYield/YFork examples, and alias + facts documenting that the compatibility APIs are erased. *) From Stdlib Require Import Fin Morphisms Nat Program.Equality - Strings.String. + Strings.String + Vector. From ExtLib Require Import Data.Map.FMapAList @@ -30,20 +31,22 @@ From ExtLib Require Import Structures.Maps. From TICL Require Export - Lang.Yield.Events + ICTree.Logic.Yield Lang.Yield.Syntax Lang.Yield.Denote - Lang.Yield.Vec - Lang.Yield.Scheduler Lang.Yield.Interp. From TICL Require Import ICTree.Core ICTree.Equ ICTree.Eq.Bind + ICTree.Events.Yield + ICTree.Events.State ICTree.Events.Writer ICTree.Interp.Core - ICTree.Interp.State + ICTree.Interp.State.Mod + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.Bind @@ -51,225 +54,115 @@ From TICL Require Import ICTree.Logic.Iter ICTree.Logic.State ICTree.SBisim - Logic.Core. + Logic.Core + Utils.Vectors. -Import ICtree ICTreeNotations TiclNotations. +Import ICtree ICTreeNotations TiclNotations VectorNotations. Local Open Scope ticl_scope. Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. -Local Typeclasses Transparent equ. -Lemma interp_equ_hetero - {E F : Type} `{Encode E} `{Encode F} {X} - (h : E ~> ictree F) : - forall (x y : ictree E X), - x ≅ y -> @equ F _ X X eq (interp h x) (interp h y). +(** * Source trigger normalizations *) +(** These expose a source trigger followed by a continuation as the single + [Vis] node the raw rules expect. They unfold only source denotations and + triggers; no interpreter is unfolded here. *) + +Local Lemma yget_bind {X} (k : Ctx -> ictree YEff X) : + (x <- yget;; k x) ≅ Vis ((inr (inr Get)) : YEff) k. Proof. - change (forall x y : ictree E X, - @equ E _ X X eq x y -> - @equ F _ X X eq (interp h x) (interp h y)). - __coinduction_equ RR IH; intros * EQ1. - setoid_rewrite unfold_iter. - step in EQ1; inv EQ1. - - setoid_rewrite bind_ret_l; reflexivity. - - setoid_rewrite bind_bind; setoid_rewrite bind_ret_l. - upto_bind_equ. - constructor. intros. - apply IH. apply H3. - - setoid_rewrite bind_ret_l. - constructor. - apply IH. apply H3. - - setoid_rewrite bind_bind. - upto_bind_equ. - setoid_rewrite bind_ret_l. - constructor. - apply IH. apply H3. + unfold yget, ytrigger, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. + reflexivity. Qed. -#[local] Instance interp_equ_hetero_proper - {E F : Type} `{Encode E} `{Encode F} {X} - (h : E ~> ictree F) : - Proper (equ eq ==> equ eq) (@interp E _ _ _ _ _ h X). +Local Lemma yput_bind {X} (m : Ctx) (k : unit -> ictree YEff X) : + (x <- yput m;; k x) ≅ Vis ((inr (inr (Put m))) : YEff) k. Proof. - intros x y Hxy. - now apply interp_equ_hetero. + unfold yput, ytrigger, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. + reflexivity. Qed. -Lemma interp_bind_hetero - {E F : Type} `{Encode E} `{Encode F} {A B} - (h : E ~> ictree F) (t : ictree E A) (k : A -> ictree E B) : - interp h (x <- t;; k x) ≅ (x <- interp h t;; interp h (k x)). +Local Lemma yyield_bind {X} (k : unit -> ictree YEff X) : + (x <- yyield;; k x) ≅ Vis ((inl Yield) : YEff) k. Proof. - revert t. - __coinduction_equ RR IH; intros. - rewrite (ictree_eta t). - rewrite unfold_bind, unfold_interp. - destruct (observe t) eqn:Hobs; cbn. - - rewrite unfold_interp. - cbn. - rewrite bind_ret_l. - rewrite unfold_interp. - reflexivity. - - rewrite unfold_interp. - cbn. - rewrite bind_br. - setoid_rewrite bind_guard. - constructor; intro i. - step; econstructor; intros. - apply IH. - - rewrite (@unfold_interp _ _ _ _ _ h (Guard t0)). - cbn. - rewrite bind_guard. - constructor. - apply IH. - - rewrite unfold_interp. - cbn. - rewrite bind_bind. - upto_bind_equ. - rewrite bind_guard. - constructor. - apply IH. + unfold yyield, ytrigger, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. + reflexivity. Qed. -(** Expression denotation constructor unfold facts. *) -Lemma denote_exp_yvar name : - denote_exp (YVar name) = - (ctx <- yget;; - match lookup name ctx with - | Some value => yyield;; Ret value - | None => stuck - end). -Proof. reflexivity. Qed. - -Lemma denote_exp_ylit n : denote_exp (YLit n) = Ret n. -Proof. reflexivity. Qed. - -Lemma denote_exp_yplus a b : - denote_exp (YPlus a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat). -Proof. reflexivity. Qed. - -Lemma denote_exp_yminus a b : - denote_exp (YMinus a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat). -Proof. reflexivity. Qed. - -Lemma denote_exp_ymult a b : - denote_exp (YMult a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). -Proof. reflexivity. Qed. - -(** Flow-sensitive statement denotation constructor unfold facts. *) -Lemma denote_stmt_unfold s : - denote_stmt s = (_ <- denote_stmt_flow s;; Ret tt). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yassign name expr : - denote_stmt_flow (YAssign name expr) = - (value <- denote_exp expr;; - ctx <- yget;; - yput (add name value ctx);; - Ret Fallthrough). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yseq a b : - denote_stmt_flow (YSeq a b) = - (flow <- denote_stmt_flow a;; - match flow with - | Fallthrough => denote_stmt_flow b - | HaltThread => Ret HaltThread - end). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yif test then_branch else_branch : - denote_stmt_flow (YIf test then_branch else_branch) = - (condition_value <- denote_exp test;; - if YieldSyntax.is_true condition_value then - denote_stmt_flow then_branch - else - denote_stmt_flow else_branch). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_ywhile test body : - denote_stmt_flow (YWhile test body) = - ICtree.iter - (fun _ => - condition_value <- denote_exp test;; - if YieldSyntax.is_true condition_value then - flow <- denote_stmt_flow body;; - match flow with - | Fallthrough => Ret (inl tt) - | HaltThread => Ret (inr HaltThread) - end - else - Ret (inr Fallthrough)) tt. -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yfork body : - denote_stmt_flow (YFork body) = - (in_child <- yfork;; - if in_child then - _ <- denote_stmt_flow body;; - Ret HaltThread - else - Ret Fallthrough). -Proof. reflexivity. Qed. - -Lemma denote_stmt_yfork body : - denote_stmt (YFork body) = - (_ <- (in_child <- yfork;; - if in_child then - _ <- denote_stmt_flow body;; - Ret HaltThread - else - Ret Fallthrough);; - Ret tt). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yskip : denote_stmt_flow YSkip = Ret Fallthrough. -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yyield : - denote_stmt_flow YYield = (yyield;; Ret Fallthrough). -Proof. reflexivity. Qed. - -(** Erased source-structural facts for the state-only TICL tier. *) -Local Ltac unfold_erased_expression := - unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE; - cbn; - setoid_rewrite unfold_interp; - cbn. +(** The assignment tail is exactly the raw state-update node. *) +Local Lemma denote_yassign_tail name value : + (ctx <- yget;; yput (add name value ctx);; Ret Fallthrough) + ≅ Vis ((inr (inr Get)) : YEff) + (fun σ0 : Ctx => + Vis ((inr (inr (Put (add name value σ0)))) : YEff) + (fun _ : unit => Ret Fallthrough)). +Proof. + rewrite yget_bind. + apply vis_equ_node; intro σ0. + apply yput_bind. +Qed. -Local Ltac unfold_erased_statement := - unfold instr_stmt_erased, interp_scheduled_erased, interp_yield, - interp_spawn, scheduled_visible, instr_stateE; - cbn; - setoid_rewrite unfold_interp; - cbn. +(** Singleton startup denotations, normalized for the raw scheduler rules. *) +Local Lemma denote_stmt_yskip_ret : denote_stmt YSkip ≅ Ret tt. +Proof. + rewrite denote_stmt_unfold, denote_stmt_flow_yskip. + rewrite bind_ret_l. + reflexivity. +Qed. -Local Ltac step_erased_state := - rewrite interp_state_tau, sb_guard; - setoid_rewrite unfold_interp; - cbn. +Local Lemma denote_stmt_yyield_vis : + denote_stmt YYield ≅ Vis ((inl Yield) : YEff) (fun _ : unit => Ret tt). +Proof. + rewrite denote_stmt_unfold, denote_stmt_flow_yyield. + unfold yyield, ytrigger, ICtree.trigger, + resum, ReSum_refl, resum_ret, ReSumRet_refl. + rewrite bind_bind, bind_vis. + apply vis_equ_node; intro x. + cbv beta. + repeat (setoid_rewrite bind_ret_l; cbv beta). + reflexivity. +Qed. -Local Ltac expose_erased_get_result ctx := - rewrite interp_state_tau, sb_guard; - change (resum_ret (inr (inr StateE.Get)) (resum_ret StateE.Get ctx)) - with ctx; - setoid_rewrite unfold_interp; - cbn; - rewrite interp_state_tau, sb_guard; - setoid_rewrite unfold_interp; - cbn. +Local Lemma denote_stmt_yassign_ylit_update name n : + denote_stmt (YAssign name (YLit n)) + ≅ Vis ((inr (inr Get)) : YEff) + (fun σ0 : Ctx => + Vis ((inr (inr (Put (add name n σ0)))) : YEff) + (fun _ : unit => Ret tt)). +Proof. + rewrite denote_stmt_unfold, denote_stmt_flow_yassign, denote_exp_ylit. + unfold yget, yput, ytrigger, ICtree.trigger, + resum, ReSum_refl, resum_ret, ReSumRet_refl. + rewrite bind_bind, bind_ret_l; cbv beta. + rewrite bind_bind, bind_vis. + apply vis_equ_node; intro σ0. + cbv beta. + setoid_rewrite bind_ret_l; cbv beta. + rewrite bind_bind, bind_vis. + apply vis_equ_node; intro x. + cbv beta. + repeat (setoid_rewrite bind_ret_l; cbv beta). + reflexivity. +Qed. -Local Ltac step_erased_state3 := - step_erased_state; step_erased_state; step_erased_state. +Local Lemma pool_equ_singleton (t u : thread Mem) : + t ≅ u -> pool_equ [t]%vector [u]%vector. +Proof. + intros Ht i. + dependent destruction i. + - exact Ht. + - inversion i. +Qed. -(** Flow-preserving erased statement instrumentation for structural facts whose - contracts must expose [Fallthrough] versus [HaltThread]. The public - [instr_stmt_erased] remains the scheduled unit-returning view. *) -Definition instr_stmt_flow_erased - (s : YStmt) (ctx : Ctx) : ictreeW Ctx (YStmtFlow * Ctx) := - instr_stateE (interp_thread (denote_stmt_flow s)) ctx. +(** * Expression rules *) Lemma axr_yexp_ylit : forall n n' ctx ctx' w w', n = n' -> @@ -280,9 +173,9 @@ Lemma axr_yexp_ylit : forall n n' ctx ctx' w w', w |= AX done= {(n', ctx')} w' ]>. Proof. intros; subst. - unfold_erased_expression. - rewrite interp_state_ret. - now apply axr_ret. + unfold instr_exp_erased. + rewrite denote_exp_ylit. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma axr_yexp_yvar_some : forall name value ctx ctx' w w', @@ -293,42 +186,14 @@ Lemma axr_yexp_yvar_some : forall name value ctx ctx' w w', <[ {instr_exp_erased (YVar name) ctx}, w |= AX done= {(value, ctx')} w' ]>. Proof. - intros; subst. - unfold_erased_expression. - eapply anr_state_bind_r_eq. - - rewrite interp_state_get. - now apply axr_ret. - - cbn. - rewrite interp_state_tau, sb_guard. - change (resum_ret (inr (inr StateE.Get)) (resum_ret StateE.Get ctx')) - with ctx'. - setoid_rewrite subst_ret_l. - cbn. - setoid_rewrite unfold_interp. - cbn. - rewrite interp_state_tau, sb_guard. - setoid_rewrite subst_ret_l. - cbn. - setoid_rewrite unfold_interp. - cbn. - change (alist_find RelDec_string name ctx') with (lookup name ctx'). - destruct (lookup name ctx') eqn:Hlookup; try congruence. - inv H. - cbn. - rewrite bind_ret_l. - repeat (rewrite interp_state_tau, sb_guard). - change (resum_ret (inl Yield) (resum_ret Yield tt)) with tt. - rewrite subst_ret_l. - cbn. - setoid_rewrite unfold_interp. - cbn. - rewrite interp_state_tau, sb_guard. - rewrite subst_ret_l. - cbn. - setoid_rewrite unfold_interp. - cbn. - rewrite interp_state_ret. - now apply axr_ret. + intros name value ctx ctx' w w' Hlookup Hctx Hw Hnd; subst. + unfold instr_exp_erased. + rewrite denote_exp_yvar, yget_bind. + rewrite instr_thread_get; cbv beta. + rewrite Hlookup. + rewrite yyield_bind. + rewrite instr_thread_yield; cbv beta. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma axr_yexp_yplus : forall a b x y value ctx ctx' w w', @@ -341,24 +206,16 @@ Lemma axr_yexp_yplus : forall a b x y value ctx ctx' w w', <[ {instr_exp_erased (YPlus a b) ctx}, w |= AX done= {(value, ctx')} w' ]>. Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. - subst. - unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. + unfold instr_exp_erased in *. + rewrite denote_exp_yplus. + eapply anr_thread_bind_r_eq. - exact Ha. - - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + - cbv beta. + eapply anr_thread_bind_r_eq. + exact Hb. - + cbn. - rewrite !unfold_interp. - cbn. - rewrite interp_state_ret. - apply axr_ret; auto. + + cbv beta. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma axr_yexp_yminus : forall a b x y value ctx ctx' w w', @@ -371,24 +228,16 @@ Lemma axr_yexp_yminus : forall a b x y value ctx ctx' w w', <[ {instr_exp_erased (YMinus a b) ctx}, w |= AX done= {(value, ctx')} w' ]>. Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. - subst. - unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. + unfold instr_exp_erased in *. + rewrite denote_exp_yminus. + eapply anr_thread_bind_r_eq. - exact Ha. - - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + - cbv beta. + eapply anr_thread_bind_r_eq. + exact Hb. - + cbn. - rewrite !unfold_interp. - cbn. - rewrite interp_state_ret. - apply axr_ret; auto. + + cbv beta. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma axr_yexp_ymult : forall a b x y value ctx ctx' w w', @@ -401,24 +250,16 @@ Lemma axr_yexp_ymult : forall a b x y value ctx ctx' w w', <[ {instr_exp_erased (YMult a b) ctx}, w |= AX done= {(value, ctx')} w' ]>. Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd. - subst. - unfold instr_exp_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. + unfold instr_exp_erased in *. + rewrite denote_exp_ymult. + eapply anr_thread_bind_r_eq. - exact Ha. - - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq. + - cbv beta. + eapply anr_thread_bind_r_eq. + exact Hb. - + cbn. - rewrite !unfold_interp. - cbn. - rewrite interp_state_ret. - apply axr_ret; auto. + + cbv beta. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma axr_yexp_yplus_ylit_ylit : forall x y value ctx ctx' w w', @@ -430,11 +271,7 @@ Lemma axr_yexp_yplus_ylit_ylit : forall x y value ctx ctx' w w', w |= AX done= {(value, ctx')} w' ]>. Proof. intros; subst. - unfold_erased_expression. - repeat rewrite subst_ret_l. - cbn. - rewrite interp_state_ret. - now apply axr_ret. + eapply axr_yexp_yplus; eauto; apply axr_yexp_ylit; auto. Qed. Lemma axr_yexp_yminus_ylit_ylit : forall x y value ctx ctx' w w', @@ -446,11 +283,7 @@ Lemma axr_yexp_yminus_ylit_ylit : forall x y value ctx ctx' w w', w |= AX done= {(value, ctx')} w' ]>. Proof. intros; subst. - unfold_erased_expression. - repeat rewrite subst_ret_l. - cbn. - rewrite interp_state_ret. - now apply axr_ret. + eapply axr_yexp_yminus; eauto; apply axr_yexp_ylit; auto. Qed. Lemma axr_yexp_ymult_ylit_ylit : forall x y value ctx ctx' w w', @@ -462,13 +295,11 @@ Lemma axr_yexp_ymult_ylit_ylit : forall x y value ctx ctx' w w', w |= AX done= {(value, ctx')} w' ]>. Proof. intros; subst. - unfold_erased_expression. - repeat rewrite subst_ret_l. - cbn. - rewrite interp_state_ret. - now apply axr_ret. + eapply axr_yexp_ymult; eauto; apply axr_yexp_ylit; auto. Qed. +(** * Scheduled statement rules *) + Lemma axr_ystmt_yskip_erased : forall ctx ctx' w w', ctx = ctx' -> w = w' -> @@ -476,11 +307,11 @@ Lemma axr_ystmt_yskip_erased : forall ctx ctx' w w', <[ {instr_stmt_erased YSkip ctx}, w |= AX done= {(tt, ctx')} w' ]>. Proof. - intros; subst. - unfold_erased_statement. - step_erased_state. - rewrite interp_state_ret. - now apply axr_ret. + intros ctx ctx' w w' Hctx Hw Hnd; subst. + unfold instr_stmt_erased. + rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' + (pool_equ_singleton _ _ denote_stmt_yskip_ret)). + apply axr_schedule_ret; [ assumption | split; reflexivity ]. Qed. Lemma axax_ystmt_yyield_erased : forall ctx ctx' w w', @@ -490,20 +321,11 @@ Lemma axax_ystmt_yyield_erased : forall ctx ctx' w w', <[ {instr_stmt_erased YYield ctx}, w |= AX AX done= {(tt, ctx')} w' ]>. Proof. - intros; subst. - unfold_erased_statement. - step_erased_state. - rewrite bind_ret_l. - cbn. - step_erased_state. - step_erased_state. - apply anr_state_br; split. - - csplit; auto. - - intro i; dependent destruction i. - + step_erased_state3. - rewrite interp_state_ret. - apply axr_ret; auto. - + inversion i. + intros ctx ctx' w w' Hctx Hw Hnd; subst. + unfold instr_stmt_erased. + rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' + (pool_equ_singleton _ _ denote_stmt_yyield_vis)). + apply axax_schedule_yield; [ assumption | split; reflexivity ]. Qed. Lemma aur_ystmt_yyield_erased : forall ctx ctx' w w' ψ, @@ -518,64 +340,7 @@ Proof. now apply axax_ystmt_yyield_erased. Qed. -Local Definition yassign_after_value - (name : var) (value : nat) : ictree YEff YStmtFlow := - ctx <- yget;; yput (add name value ctx);; Ret Fallthrough. - -Local Lemma aur_yassign_after_value : forall name value ctx w ψ R, - <( {log (add name value ctx)}, w |= ψ )> -> - R (Fallthrough, add name value ctx) - (Obs (Log (add name value ctx)) tt) -> - <[ {instr_stateE (interp_thread (yassign_after_value name value)) ctx}, - w |= ψ AU AX done R ]>. -Proof. - intros name value ctx w ψ R Hlog HR. - pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. - unfold yassign_after_value, interp_thread, interp_yield, instr_stateE. - cbn. - setoid_rewrite unfold_interp. - cbn. - eapply aur_state_bind_r_eq. - - apply aur_get; auto; split; reflexivity. - - cbn. - expose_erased_get_result ctx. - eapply aur_state_bind_r_eq. - + apply aur_put; auto; split; reflexivity. - + cbn. - step_erased_state. - step_erased_state. - rewrite interp_state_ret. - cleft. - apply axr_ret; auto. - constructor. -Qed. - -Local Lemma aul_yassign_after_value : forall name value ctx w ψ φ, - <( {log (add name value ctx)}, w |= ψ )> -> - <( {Ret (Fallthrough, add name value ctx)}, - {Obs (Log (add name value ctx)) tt} |= φ )> -> - <( {instr_stateE (interp_thread (yassign_after_value name value)) ctx}, - w |= ψ AU φ )>. -Proof. - intros name value ctx w ψ φ Hlog Hret. - pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. - unfold yassign_after_value, interp_thread, interp_yield, instr_stateE. - cbn. - setoid_rewrite unfold_interp. - cbn. - eapply aul_state_bind_r_eq. - - apply aur_get; auto; split; reflexivity. - - cbn. - expose_erased_get_result ctx. - eapply aul_state_bind_r_eq. - + apply aur_put; auto; split; reflexivity. - + cbn. - step_erased_state. - step_erased_state. - rewrite interp_state_ret. - cleft. - exact Hret. -Qed. +(** * Flow-preserving statement rules *) Lemma aur_ystmt_yassign : forall name expr value ctx w ψ R, <[ {instr_exp_erased expr ctx}, w |= AX done= {(value, ctx)} w ]> -> @@ -586,22 +351,13 @@ Lemma aur_ystmt_yassign : forall name expr value ctx w ψ R, w |= ψ AU AX done R ]>. Proof. intros name expr value ctx w ψ R Hexp Hlog HR. - unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, - interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aur_bind_r_eq. - - cleft. - exact Hexp. - - cbn. - change (interp_state h_stateW - (interp handle_yield - (interp handle_thread - (ctx <- yget;; yput (add name value ctx);; - Ret Fallthrough))) ctx) - with (instr_stateE (interp_thread (yassign_after_value name value)) ctx). - now apply aur_yassign_after_value. + unfold instr_stmt_flow_erased, instr_exp_erased in *. + rewrite denote_stmt_flow_yassign. + eapply aur_thread_bind_r_eq. + - cleft. exact Hexp. + - cbv beta. + rewrite (denote_yassign_tail name value). + now apply (aur_thread_update (add name value) Fallthrough ctx). Qed. Lemma aul_ystmt_yassign : forall name expr value ctx w ψ φ, @@ -612,22 +368,13 @@ Lemma aul_ystmt_yassign : forall name expr value ctx w ψ φ, <( {instr_stmt_flow_erased (YAssign name expr) ctx}, w |= ψ AU φ )>. Proof. intros name expr value ctx w ψ φ Hexp Hlog Hret. - unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, - interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aul_bind_r_eq. - - cleft. - exact Hexp. - - cbn. - change (interp_state h_stateW - (interp handle_yield - (interp handle_thread - (ctx <- yget;; yput (add name value ctx);; - Ret Fallthrough))) ctx) - with (instr_stateE (interp_thread (yassign_after_value name value)) ctx). - now apply aul_yassign_after_value. + unfold instr_stmt_flow_erased, instr_exp_erased in *. + rewrite denote_stmt_flow_yassign. + eapply aul_thread_bind_r_eq. + - cleft. exact Hexp. + - cbv beta. + rewrite (denote_yassign_tail name value). + now apply (aul_thread_update (add name value) Fallthrough ctx). Qed. Lemma anr_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, @@ -637,11 +384,9 @@ Lemma anr_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AN ψ ]>. Proof. intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply anr_bind_r_eq; eauto. + unfold instr_stmt_flow_erased in *. + rewrite denote_stmt_flow_yseq. + eapply anr_thread_bind_r_eq; eauto. Qed. Lemma aur_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, @@ -651,11 +396,9 @@ Lemma aur_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ ]>. Proof. intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aur_bind_r_eq; eauto. + unfold instr_stmt_flow_erased in *. + rewrite denote_stmt_flow_yseq. + eapply aur_thread_bind_r_eq; eauto. Qed. Lemma aul_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, @@ -665,11 +408,9 @@ Lemma aul_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, <( {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ )>. Proof. intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aul_bind_r_eq; eauto. + unfold instr_stmt_flow_erased in *. + rewrite denote_stmt_flow_yseq. + eapply aul_thread_bind_r_eq; eauto. Qed. Lemma yseq_halt_propagates : forall a b ctx ctx' w w' φ, @@ -680,16 +421,13 @@ Lemma yseq_halt_propagates : forall a b ctx ctx' w w' φ, w |= φ AU AX done= {(HaltThread, ctx')} w' ]>. Proof. intros a b ctx ctx' w w' φ Ha Hnd. - unfold instr_stmt_flow_erased, interp_thread, interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aur_bind_r_eq. + unfold instr_stmt_flow_erased in *. + rewrite denote_stmt_flow_yseq. + eapply aur_thread_bind_r_eq. - exact Ha. - - cbn. - rewrite !unfold_interp. - cbn. - apply aur_state_ret; auto; split; reflexivity. + - cbv beta. + cleft. + apply axr_thread_ret; [ assumption | split; reflexivity ]. Qed. Lemma aul_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, @@ -702,14 +440,11 @@ Lemma aul_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, w |= φ AU ψ )>. Proof. intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. - unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, - interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aul_bind_r_eq. + unfold instr_stmt_flow_erased, instr_exp_erased in *. + rewrite denote_stmt_flow_yif. + eapply aul_thread_bind_r_eq. - cleft; exact Htest. - - cbn. + - cbv beta. destruct (YieldSyntax.is_true condition); exact Hbranch. Qed. @@ -723,20 +458,18 @@ Lemma aur_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, w |= φ AU ψ ]>. Proof. intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. - unfold instr_stmt_flow_erased, instr_exp_erased, interp_thread, - interp_yield, instr_stateE in *. - cbn. - rewrite !interp_bind_hetero. - rewrite !interp_state_bind. - eapply aur_bind_r_eq. + unfold instr_stmt_flow_erased, instr_exp_erased in *. + rewrite denote_stmt_flow_yif. + eapply aur_thread_bind_r_eq. - cleft; exact Htest. - - cbn. + - cbv beta. destruct (YieldSyntax.is_true condition); exact Hbranch. Qed. -(** Raw source-flow while unrolling facts. These expose [YStmtFlow] - directly, avoiding any claim that the scheduled erased unit layer can - distinguish loop fallthrough from child-thread halt. *) +(** * Raw source-flow while unrolling facts *) +(** These expose [YStmtFlow] directly, avoiding any claim that the scheduled + erased unit layer can distinguish loop fallthrough from child-thread + halt. *) Definition ywhile_iteration (test : YExp) (body : YStmt) : ictree YEff (unit + YStmtFlow) := condition_value <- denote_exp test;; @@ -897,6 +630,8 @@ Proof. exact Hnext. Qed. +(** * Scheduled assignment rules *) + Lemma aur_ystmt_yassign_ylit_erased : forall name n ctx w ψ R, <( {log (add name n ctx)}, w |= ψ )> -> R (tt, add name n ctx) (Obs (Log (add name n ctx)) tt) -> @@ -904,19 +639,10 @@ Lemma aur_ystmt_yassign_ylit_erased : forall name n ctx w ψ R, w |= ψ AU AX done R ]>. Proof. intros name n ctx w ψ R Hlog HR. - pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. - unfold_erased_statement. - eapply aur_state_bind_r_eq. - - apply aur_get; auto; split; reflexivity. - - cbn. - expose_erased_get_result ctx. - eapply aur_state_bind_r_eq. - + apply aur_put. - * exact Hlog. - * split; reflexivity. - + cbn. - step_erased_state3. - apply aur_state_ret; auto with ticl. + unfold instr_stmt_erased. + rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx + (pool_equ_singleton _ _ (denote_stmt_yassign_ylit_update name n))). + now apply (aur_schedule_update (add name n) ctx). Qed. Lemma aul_ystmt_yassign_ylit_erased : forall name n ctx w ψ φ, @@ -926,209 +652,13 @@ Lemma aul_ystmt_yassign_ylit_erased : forall name n ctx w ψ φ, <( {instr_stmt_erased (YAssign name (YLit n)) ctx}, w |= ψ AU φ )>. Proof. intros name n ctx w ψ φ Hlog Hret. - pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. - unfold_erased_statement. - eapply aul_state_bind_r_eq. - - apply aur_get; auto; split; reflexivity. - - cbn. - expose_erased_get_result ctx. - eapply aul_state_bind_r_eq. - + apply aur_put. - * exact Hlog. - * split; reflexivity. - + cbn. - step_erased_state3. - apply aul_state_ret; auto with ticl. + unfold instr_stmt_erased. + rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx + (pool_equ_singleton _ _ (denote_stmt_yassign_ylit_update name n))). + now apply (aul_schedule_update (add name n) ctx). Qed. -(** Scheduler one-step/case regression facts. *) -Section SchedulerFacts. - Context {E : Type} `{Encode E}. - - Local Ltac solve_focused_schedule H := - lazy [schedule observe _observe]; - match type of H with - | observe (?v ?i) = _ => - change (@_observe _ _ unit (v i)) with (observe (v i)); - rewrite H; - reflexivity - end. - - Lemma schedule_empty_none (v : pool E 0) : - observe (schedule 0 v None) = RetF tt. - Proof. reflexivity. Qed. - - Lemma schedule_no_focus_nonempty n (v : pool E (S n)) : - observe (schedule (S n) v None) = - VisF (inl Yield) (fun _ => Br n (fun i => schedule (S n) v (Some i))). - Proof. reflexivity. Qed. - - Lemma schedule_focused_ret n (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v i) = RetF tt -> - observe (schedule (S n) v (Some i)) = - GuardF (schedule n (remove_pool v i) None). - Proof. - intro Hret. - solve_focused_schedule Hret. - Qed. - - Lemma schedule_focused_br n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v i) = BrF b k -> - observe (schedule (S n) v (Some i)) = - BrF b (fun j => schedule (S n) (replace_pool v i (k j)) (Some i)). - Proof. - intro Hbr. - solve_focused_schedule Hbr. - Qed. - - Lemma schedule_focused_guard n (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v i) = GuardF t -> - observe (schedule (S n) v (Some i)) = - GuardF (schedule (S n) (replace_pool v i t) (Some i)). - Proof. - intro Hg. - solve_focused_schedule Hg. - Qed. - - Lemma schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inl Yield) k -> - observe (schedule (S n) v (Some i)) = - GuardF (schedule (S n) (replace_pool v i (k tt)) None). - Proof. - intro Hy. - solve_focused_schedule Hy. - Qed. - - Lemma schedule_focused_fork n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v i) = VisF (inr (inl Fork)) k -> - observe (schedule (S n) v (Some i)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) - (fun _ => schedule (S (S n)) - (cons_pool (k true) (replace_pool v i (k false))) - (Some (Fin.FS i))). - Proof. - intro Hf. - solve_focused_schedule Hf. - Qed. - - Lemma schedule_focused_user_event n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v i) = VisF (inr (inr e)) k -> - observe (schedule (S n) v (Some i)) = - VisF ((inr (inr e)) : yieldE + (spawnE + E)) - (fun x => schedule (S n) (replace_pool v i (k x)) (Some i)). - Proof. - intro Hu. - solve_focused_schedule Hu. - Qed. -End SchedulerFacts. - -(** Non-degenerate finite-pool scheduler regressions. *) -Section SchedulerPoolRegressions. - Context {E : Type} `{Encode E}. - - Lemma schedule_yield_two_threads_one_step (next other : thread E) : - observe - (schedule 2 - (cons_pool - (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) - (fun _ : Fin.t 1 => other)) - (Some Fin.F1)) = - GuardF - (schedule 2 - (replace_pool - (cons_pool - (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) - (fun _ : Fin.t 1 => other)) - Fin.F1 next) - None). - Proof. reflexivity. Qed. - - Lemma schedule_yield_two_threads_focused_slot (next other : thread E) : - replace_pool - (cons_pool - (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) - (fun _ : Fin.t 1 => other)) - Fin.F1 next Fin.F1 = next. - Proof. apply replace_pool_hit. Qed. - - Lemma schedule_yield_two_threads_other_slot (next other : thread E) : - replace_pool - (cons_pool - (Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next)) - (fun _ : Fin.t 1 => other)) - Fin.F1 next (Fin.FS Fin.F1) = other. - Proof. - rewrite replace_pool_miss by discriminate. - apply cons_pool_tail. - Qed. - - Lemma schedule_fork_two_threads_one_step - (child parent other : thread E) : - observe - (schedule 2 - (cons_pool - (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent)) - (fun _ : Fin.t 1 => other)) - (Some Fin.F1)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) - (fun _ => - schedule 3 - (cons_pool child - (replace_pool - (cons_pool - (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent)) - (fun _ : Fin.t 1 => other)) - Fin.F1 parent)) - (Some (Fin.FS Fin.F1))). - Proof. reflexivity. Qed. - - Lemma schedule_fork_two_threads_child_slot - (child parent other : thread E) : - cons_pool child - (replace_pool - (cons_pool - (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent)) - (fun _ : Fin.t 1 => other)) - Fin.F1 parent) - Fin.F1 = child. - Proof. apply cons_pool_head. Qed. - - Lemma schedule_fork_two_threads_parent_slot - (child parent other : thread E) : - cons_pool child - (replace_pool - (cons_pool - (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent)) - (fun _ : Fin.t 1 => other)) - Fin.F1 parent) - (Fin.FS Fin.F1) = parent. - Proof. - rewrite cons_pool_tail. - apply replace_pool_hit. - Qed. - - Lemma schedule_fork_two_threads_other_slot - (child parent other : thread E) : - cons_pool child - (replace_pool - (cons_pool - (Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent)) - (fun _ : Fin.t 1 => other)) - Fin.F1 parent) - (Fin.FS (Fin.FS Fin.F1)) = other. - Proof. - rewrite cons_pool_tail. - rewrite replace_pool_miss by discriminate. - apply cons_pool_tail. - Qed. -End SchedulerPoolRegressions. - -(** Concrete scheduler-visible examples. *) +(** * Concrete scheduler-visible examples *) Local Ltac solve_visible_regression := cbn; unfold resum, ReSum_refl, resum_ret, ReSumRet_refl; @@ -1138,14 +668,12 @@ Lemma scheduled_visible_yyield_one_step : observe (scheduled_visible YYield) = GuardF (schedule 1 - (replace_pool - (fun _ : Fin.t 1 => denote_stmt YYield) - Fin.F1 (denote_stmt YSkip)) + ([denote_stmt YYield]%vector @ Fin.F1 := (denote_stmt YSkip)) None). Proof. unfold scheduled_visible. apply (@schedule_focused_yield Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt YYield) + [denote_stmt YYield]%vector Fin.F1 (fun _ : unit => denote_stmt YSkip)). solve_visible_regression. @@ -1169,16 +697,15 @@ Lemma scheduled_visible_yfork_body_one_step : forall body, VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) (fun _ => schedule 2 - (cons_pool (yfork_body_fork_continuation body true) - (replace_pool - (fun _ : Fin.t 1 => denote_stmt (YFork body)) - Fin.F1 (yfork_body_fork_continuation body false))) + ((yfork_body_fork_continuation body true :: + ([denote_stmt (YFork body)]%vector + @ Fin.F1 := (yfork_body_fork_continuation body false)))%vector) (Some (Fin.FS Fin.F1))). Proof. intro body. unfold scheduled_visible. apply (@schedule_focused_fork Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt (YFork body)) + [denote_stmt (YFork body)]%vector Fin.F1 (yfork_body_fork_continuation body)). solve_visible_regression. @@ -1219,19 +746,16 @@ Lemma scheduled_visible_yseq_yfork_body_rest_one_step : forall body rest, VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) (fun _ => schedule 2 - (cons_pool - (yseq_yfork_body_rest_fork_continuation body rest true) - (replace_pool - (fun _ : Fin.t 1 => - denote_stmt (YSeq (YFork body) rest)) - Fin.F1 - (yseq_yfork_body_rest_fork_continuation body rest false))) + ((yseq_yfork_body_rest_fork_continuation body rest true :: + ([denote_stmt (YSeq (YFork body) rest)]%vector + @ Fin.F1 := + (yseq_yfork_body_rest_fork_continuation body rest false)))%vector) (Some (Fin.FS Fin.F1))). Proof. intros body rest. unfold scheduled_visible. apply (@schedule_focused_fork Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt (YSeq (YFork body) rest)) + [denote_stmt (YSeq (YFork body) rest)]%vector Fin.F1 (yseq_yfork_body_rest_fork_continuation body rest)). solve_visible_regression. @@ -1259,15 +783,14 @@ Lemma scheduled_visible_yfork_yield_one_step : VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) (fun _ => schedule 2 - (cons_pool (yfork_yield_fork_continuation true) - (replace_pool - (fun _ : Fin.t 1 => denote_stmt (YFork YYield)) - Fin.F1 (yfork_yield_fork_continuation false))) + ((yfork_yield_fork_continuation true :: + ([denote_stmt (YFork YYield)]%vector + @ Fin.F1 := (yfork_yield_fork_continuation false)))%vector) (Some (Fin.FS Fin.F1))). Proof. unfold scheduled_visible. apply (@schedule_focused_fork Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt (YFork YYield)) + [denote_stmt (YFork YYield)]%vector Fin.F1 yfork_yield_fork_continuation). solve_visible_regression. @@ -1307,33 +830,25 @@ Lemma scheduled_visible_yseq_yfork_skip_yield_one_step : VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) (fun _ => schedule 2 - (cons_pool (yseq_yfork_skip_yield_fork_continuation true) - (replace_pool - (fun _ : Fin.t 1 => - denote_stmt (YSeq (YFork YSkip) YYield)) - Fin.F1 (yseq_yfork_skip_yield_fork_continuation false))) + ((yseq_yfork_skip_yield_fork_continuation true :: + ([denote_stmt (YSeq (YFork YSkip) YYield)]%vector + @ Fin.F1 := + (yseq_yfork_skip_yield_fork_continuation false)))%vector) (Some (Fin.FS Fin.F1))). Proof. unfold scheduled_visible. apply (@schedule_focused_fork Mem _ 0 - (fun _ : Fin.t 1 => denote_stmt (YSeq (YFork YSkip) YYield)) + [denote_stmt (YSeq (YFork YSkip) YYield)]%vector Fin.F1 yseq_yfork_skip_yield_fork_continuation). solve_visible_regression. Qed. -(** Erasure handlers intentionally hide scheduler/thread observations. *) -Lemma handle_spawn_spawn_erased : handle_spawn (inr (inl Spawn)) = Ret tt. -Proof. reflexivity. Qed. - -Lemma handle_yield_yield_erased : handle_yield (inl Yield) = Ret tt. -Proof. reflexivity. Qed. - +(** * Compatibility aliases are erased APIs *) Lemma interp_scheduled_erased_unfold s : interp_scheduled_erased s = interp_yield (interp_spawn (scheduled_visible s)). Proof. reflexivity. Qed. -(** Compatibility aliases are erased APIs. *) Lemma scheduled_alias s : scheduled s = scheduled_visible s. Proof. reflexivity. Qed. diff --git a/theories/Lang/Yield/Vec.v b/theories/Lang/Yield/Vec.v deleted file mode 100644 index 5797dad..0000000 --- a/theories/Lang/Yield/Vec.v +++ /dev/null @@ -1,55 +0,0 @@ -From Stdlib Require Import Fin. - -(** Replace the value stored at one finite index. *) -Definition replace_pool {A n} (v : Fin.t n -> A) (i : Fin.t n) (a : A) : Fin.t n -> A := - fun j => - match Fin.eq_dec i j with - | left _ => a - | right _ => v j - end. - -Lemma replace_pool_hit {A n} (v : Fin.t n -> A) (i : Fin.t n) (a : A) : - replace_pool v i a i = a. -Proof. - unfold replace_pool. - destruct (Fin.eq_dec i i) as [_ | Hneq]. - - reflexivity. - - contradiction Hneq; reflexivity. -Qed. - -Lemma replace_pool_miss {A n} (v : Fin.t n -> A) (i j : Fin.t n) (a : A) : - i <> j -> replace_pool v i a j = v j. -Proof. - intro Hneq. - unfold replace_pool. - destruct (Fin.eq_dec i j) as [Heq | _]. - - contradiction Hneq; exact Heq. - - reflexivity. -Qed. - -(** Remove one index from a non-empty finite vector/function. *) -Fixpoint remove_pool {A} {n : nat} : (Fin.t (S n) -> A) -> Fin.t (S n) -> Fin.t n -> A := - match n return (Fin.t (S n) -> A) -> Fin.t (S n) -> Fin.t n -> A with - | 0 => fun _ _ j => match j with end - | S n' => fun v i j => - match i in Fin.t (S n0) return n0 = S n' -> Fin.t (S n') -> A with - | F1 => fun _ j => v (FS j) - | FS i' => fun e j => - match j in Fin.t (S n1) return n1 = n' -> A with - | F1 => fun _ => v F1 - | FS j' => fun e' => remove_pool (fun k => v (FS k)) (Fin.cast i' e) (Fin.cast j' e') - end eq_refl - end eq_refl j - end. - -(** Prepend a value at [F1] and shift the existing pool right. *) -Definition cons_pool {A n} (x : A) (v : Fin.t n -> A) : Fin.t (S n) -> A := - fun i => Fin.caseS' i (fun _ => A) x (fun j => v j). - -Lemma cons_pool_head {A n} (x : A) (v : Fin.t n -> A) : - cons_pool x v Fin.F1 = x. -Proof. reflexivity. Qed. - -Lemma cons_pool_tail {A n} (x : A) (v : Fin.t n -> A) (i : Fin.t n) : - cons_pool x v (Fin.FS i) = v i. -Proof. reflexivity. Qed. diff --git a/theories/Utils/Vectors.v b/theories/Utils/Vectors.v index 7c0ca81..f96ad49 100644 --- a/theories/Utils/Vectors.v +++ b/theories/Utils/Vectors.v @@ -53,6 +53,48 @@ Equations vector_remove{A n}(v: vec (S n) A)(i: fin (S n)) : vec n A by wf n lt vector_remove (h :: h' :: ts) F1 := h' :: ts; vector_remove (h::nil) F1 := @nil A. +(** Removing the head slot keeps the tail unchanged. *) +Lemma vector_remove_head {A n} (x : A) (v : vec n A) : + vector_remove (Vector.cons A x n v) Fin.F1 = v. +Proof. + destruct v; simp vector_remove; reflexivity. +Qed. + +(** Removing a non-head slot keeps the head and recurses on the tail. *) +Lemma vector_remove_tail {A n} (x : A) (v : vec (S n) A) + (i : Fin.t (S n)) : + vector_remove (Vector.cons A x (S n) v) (Fin.FS i) = + Vector.cons A x n (vector_remove v i). +Proof. + dependent destruction v. + dependent destruction i. + - rewrite vector_remove_head; simp vector_remove; reflexivity. + - simp vector_remove; reflexivity. +Qed. + +(** Pointwise agreement away from the removed slot survives the removal. *) +Lemma vector_remove_pointwise {A n} (R : A -> A -> Prop) + (v1 v2 : vec (S n) A) (i : Fin.t (S n)) : + (forall j, i <> j -> R (Vector.nth v1 j) (Vector.nth v2 j)) -> + forall j, R (Vector.nth (vector_remove v1 i) j) + (Vector.nth (vector_remove v2 i) j). +Proof. + revert v1 v2 i. + induction n as [| m IH]; intros v1 v2 i Hagree j. + - inversion j. + - dependent destruction v1. + dependent destruction v2. + dependent destruction i. + + rewrite !vector_remove_head. + exact (Hagree (Fin.FS j) ltac:(discriminate)). + + rewrite !vector_remove_tail. + dependent destruction j. + * exact (Hagree Fin.F1 ltac:(discriminate)). + * apply IH. + intros k Hk. + exact (Hagree (Fin.FS k) ltac:(intro Heq; apply Hk, (Fin.FS_inj _ _ Heq))). +Qed. + Equations nth_map{A n}(v: vec n A)(i: fin n)(f: A -> A): vec n A by wf n lt := nth_map [] _ _ := []; nth_map (h :: h' :: ts) (FS (FS j)) _ := h :: (nth_map (h' :: ts) (FS j) f); From 7d9697235b8d4ffcf3cb02381232f65ca13d8864 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Tue, 22 Sep 2026 23:19:43 +0000 Subject: [PATCH 07/14] feat(csl): share heap effects and reusable structural proofs Add shared heap events and 130 structural TICL rules for nondeterministic and round-robin CSL execution. Preserve backend allocation, fault, free, and observation policies. Promote queue, segment, trace, ghost-iteration, and ranking machinery into reusable libraries. Deduplicate heap and rotation proofs and migrate all consumers. Verified with dune build, all 130 public rule checks, cross-backend and temporal consumers, polymorphic trace smoke proofs, and assumption audits. --- examples/CSL/Allocator/Execution.v | 1571 +------------- examples/CSL/Allocator/Layout.v | 21 +- examples/CSL/Allocator/Liveness.v | 336 +-- examples/CSL/Allocator/Model.v | 20 +- examples/CSL/Allocator/NegativeTests.v | 1 + examples/CSL/HeapTests.v | 40 +- examples/CSL/InterpTests.v | 238 +-- examples/CSL/Layout.v | 416 +--- examples/CSL/Lex.v | 67 - examples/CSL/NegativeTests.v | 20 +- examples/CSL/Overlap.v | 20 +- examples/CSL/QLang.v | 265 --- examples/CSL/QueueTests.v | 94 +- examples/CSL/README.md | 193 +- examples/CSL/TiclTests.v | 784 +++++++ examples/HeapEventTests.v | 201 ++ theories/Events/HeapE.v | 15 + theories/ICTree/Events/Heap.v | 27 + theories/ICTree/Interp/State/Mod.v | 14 + theories/ICTree/Logic/Bind.v | 71 + theories/ICTree/Logic/State.v | 34 + theories/ICTree/Logic/Trace.v | 70 + theories/ICTree/SBisim.v | 16 + theories/ICTree/Trace.v | 365 ++++ theories/Lang/CSL.v | 2 +- theories/Lang/CSL/Denote.v | 32 +- theories/Lang/CSL/Heap.v | 326 +-- theories/Lang/CSL/Interp.v | 1295 +++++++----- theories/Lang/CSL/Pcm.v | 57 +- theories/Lang/CSL/Queue.v | 6 + .../Lang/CSL/Queue/Alternating.v | 54 +- .../Lang/CSL/Queue/Composition.v | 29 +- .../CSL => theories/Lang/CSL/Queue}/Frame.v | 33 +- theories/Lang/CSL/Queue/Layout.v | 344 ++++ theories/Lang/CSL/Queue/Operations.v | 89 + .../CSL => theories/Lang/CSL/Queue}/Program.v | 114 +- .../Lang/CSL/Queue}/Recurrence.v | 105 +- .../Lang/CSL/Queue/Representation.v | 41 +- .../Lang/CSL/Queue/Separation.v | 16 +- theories/Lang/CSL/Queue/Sequential.v | 164 ++ .../Queue.v => theories/Lang/CSL/Queue/Ticl.v | 25 +- .../CSL => theories/Lang/CSL/Queue}/Trace.v | 4 +- theories/Lang/CSL/Segments.v | 960 +++++++++ theories/Lang/CSL/Ticl.v | 1815 +++++++++++++++++ theories/Lang/HeapImp.v | 51 +- theories/Utils/Relations.v | 114 ++ 46 files changed, 6765 insertions(+), 3810 deletions(-) delete mode 100644 examples/CSL/Lex.v delete mode 100644 examples/CSL/QLang.v create mode 100644 examples/CSL/TiclTests.v create mode 100644 examples/HeapEventTests.v create mode 100644 theories/Events/HeapE.v create mode 100644 theories/ICTree/Events/Heap.v create mode 100644 theories/ICTree/Logic/Trace.v create mode 100644 theories/ICTree/Trace.v create mode 100644 theories/Lang/CSL/Queue.v rename examples/CSL/SLang.v => theories/Lang/CSL/Queue/Alternating.v (71%) rename examples/CSL/Compose.v => theories/Lang/CSL/Queue/Composition.v (94%) rename {examples/CSL => theories/Lang/CSL/Queue}/Frame.v (90%) create mode 100644 theories/Lang/CSL/Queue/Layout.v create mode 100644 theories/Lang/CSL/Queue/Operations.v rename {examples/CSL => theories/Lang/CSL/Queue}/Program.v (85%) rename {examples/CSL => theories/Lang/CSL/Queue}/Recurrence.v (75%) rename examples/CSL/HeapQ.v => theories/Lang/CSL/Queue/Representation.v (96%) rename examples/CSL/Sep2.v => theories/Lang/CSL/Queue/Separation.v (91%) create mode 100644 theories/Lang/CSL/Queue/Sequential.v rename examples/CSL/Queue.v => theories/Lang/CSL/Queue/Ticl.v (90%) rename {examples/CSL => theories/Lang/CSL/Queue}/Trace.v (96%) create mode 100644 theories/Lang/CSL/Segments.v create mode 100644 theories/Lang/CSL/Ticl.v create mode 100644 theories/Utils/Relations.v diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v index 1670374..98d6813 100644 --- a/examples/CSL/Allocator/Execution.v +++ b/examples/CSL/Allocator/Execution.v @@ -4,7 +4,8 @@ From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin Utils.Vectors. -From examples Require Import CSL.HeapQ CSL.Allocator.Layout +From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model. Import ICtree ICTreeNotations ListNotations VectorNotations. @@ -12,46 +13,6 @@ Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. Local Open Scope list_scope. -Definition emit_list {X} (xs : list SObs) (t : ictreeW SObs X) : ictreeW SObs X := - List.fold_right (fun o k => log o;; k) t xs. -Definition turn_observations (event : option SObs) : list SObs := - match event with None => [] | Some o => [o] end. - -(** A finite derivation stops at the first source yield. The handler premise - is its actual effect semantics, not an allocator transition assumption. *) -Inductive ThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := -| segment_yield (k : unit -> thread sE) sigma : - ThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma -| segment_guard t sigma logs t' sigma' : - ThreadSegment t sigma logs t' sigma' -> - ThreadSegment (Guard t) sigma logs t' sigma' -| segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 - before after t' sigma' : - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> - ThreadSegment (k result) sigma1 after t' sigma' -> - ThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) - sigma (before ++ after) t' sigma' -| segment_equ t u sigma logs u' t' sigma' : - t ≅ u -> ThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> - ThreadSegment t sigma logs t' sigma'. - -(** Only finite leading guards and raw tree equivalence are forgotten. - A real [Br] node is never included in this closure. *) -Inductive guard_equ : thread sE -> thread sE -> Prop := -| guard_equ_equ t u : t ≅ u -> guard_equ t u -| guard_equ_left t u : guard_equ t u -> guard_equ (Guard t) u -| guard_equ_right t u : guard_equ t u -> guard_equ t (Guard u) -| guard_equ_sym t u : guard_equ t u -> guard_equ u t -| guard_equ_trans t u v : guard_equ t u -> guard_equ u v -> guard_equ t v. - -(** These are the actual [CUntilNone] continuations, including halt flow. *) -Definition until_tail {A} (body : CProg (option A)) - (K : option unit -> thread sE) (flow : option (option A)) : thread sE := - match flow with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) - end. Definition client_next base client : option (option unit) -> thread sE := until_tail (client_round base client) (fun _ => Ret tt). @@ -123,8 +84,6 @@ Definition allocator_pool (base : nat) (s : AState) : pool sE 3 := Definition source_pool0 base : pool sE 3 := [denote (remote_client base true); denote (remote_client base false); denote (CUntilNone (owner_round base))]%vector. -Definition pool_guard_equ {n} (ts us : pool sE n) : Prop := - forall i, guard_equ (ts $ i) (us $ i). Definition state_agrees (sigma : SSig) (s : AState) : Prop := heq (fst sigma) (aheap s) /\ snd sigma = acount s. @@ -165,68 +124,7 @@ Lemma source_pool0_initial capacity c : pool_equ (source_pool0 1) (allocator_pool 1 (initial_state capacity c)). Proof. apply pool_equ_refl. Qed. -Lemma execution_pool_guard_equ {n} (ts us : pool sE n) : - pool_equ ts us -> pool_guard_equ ts us. -Proof. intros H i; apply guard_equ_equ, H. Qed. - -Lemma execution_pool_guard_replace {n} (ts us : pool sE n) - (i : Fin.t n) t u : - pool_guard_equ ts us -> guard_equ t u -> - pool_guard_equ (ts @ i := t) (us @ i := u). -Proof. - intros Hpool Htu j; destruct (Fin.eq_dec j i) as [->|Hneq]. - - rewrite !Vector.nth_replace_eq; exact Htu. - - rewrite !Vector.nth_replace_neq by congruence; apply Hpool. -Qed. -(** Silent checked writes, with the continuation held fixed while the state - handler is simplified. No congruence on a pool of bisimilar threads is - used here. *) -Local Lemma allocator_interp_rr_write_present n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c : - h a <> None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (upd h a v,c). -Proof. - intro Present. - pose proof (sinterp_wr' a h c v - (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_rr_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Local Lemma allocator_interp_nd_write_present n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c : - h a <> None -> - interp_nd (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some tt)) - (Some i) (upd h a v,c). -Proof. - intro Present. - pose proof (sinterp_wr' a h c v - (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_nd_source_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. Lemma interp_rr_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) first count (K : option unit -> thread sE) m h c : @@ -241,10 +139,10 @@ Proof. - cbn [init_links init_links_heap]; rewrite interp_rr_ret; reflexivity. - cbn [init_links init_links_heap]; rewrite interp_rr_bind. etransitivity. - + apply allocator_interp_rr_write_present. + + apply interp_rr_write_present. specialize (Allocated 0 ltac:(cbn; lia)). now rewrite Nat.add_0_r in Allocated. - + apply IH; intros offset O; apply upd_preserves_present. + + apply IH; intros offset O; apply upd_mono. replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. apply Allocated; cbn; lia. Qed. @@ -262,10 +160,10 @@ Proof. - cbn [init_links init_links_heap]; rewrite interp_nd_source_ret; reflexivity. - cbn [init_links init_links_heap]; rewrite interp_nd_source_bind. etransitivity. - + apply allocator_interp_nd_write_present. + + apply interp_nd_source_write_present. specialize (Allocated 0 ltac:(cbn; lia)). now rewrite Nat.add_0_r in Allocated. - + apply IH; intros offset O; apply upd_preserves_present. + + apply IH; intros offset O; apply upd_mono. replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. apply Allocated; cbn; lia. Qed. @@ -283,13 +181,13 @@ Lemma interp_rr_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) Proof. unfold init_page, page_heap. do 5 (rewrite interp_rr_bind; etransitivity; - [apply allocator_interp_rr_write_present; - repeat apply upd_preserves_present; + [apply interp_rr_write_present; + repeat apply upd_mono; rewrite page_backing_in by (unfold remote_head, drain_head, mailbox, local_head, page_size; lia); discriminate |]). apply interp_rr_init_links; intros offset O. - repeat apply upd_preserves_present. + repeat apply upd_mono. rewrite page_backing_in by (unfold page_size; lia); discriminate. Qed. @@ -303,13 +201,13 @@ Lemma interp_nd_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) Proof. unfold init_page, page_heap. do 5 (rewrite interp_nd_source_bind; etransitivity; - [apply allocator_interp_nd_write_present; - repeat apply upd_preserves_present; + [apply interp_nd_source_write_present; + repeat apply upd_mono; rewrite page_backing_in by (unfold remote_head, drain_head, mailbox, local_head, page_size; lia); discriminate |]). apply interp_nd_init_links; intros offset O. - repeat apply upd_preserves_present. + repeat apply upd_mono. rewrite page_backing_in by (unfold page_size; lia); discriminate. Qed. @@ -326,18 +224,9 @@ Lemma interp_rr_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) m (page_heap base capacity h,c). Proof. intros Positive Free First. - pose proof (sinterp_alloc_first h (page_size capacity) base c - (fun a : nat => (Ret a : ictree sE nat)) - (page_size_positive capacity) Positive Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - unfold new_page; rewrite interp_rr_bind, interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + unfold new_page; rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=base) by + (try apply page_size_positive; assumption). rewrite interp_rr_bind; etransitivity. - apply interp_rr_init_page. - rewrite interp_rr_ret; reflexivity. @@ -354,18 +243,9 @@ Lemma interp_nd_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) (page_heap base capacity h,c). Proof. intros Positive Free First. - pose proof (sinterp_alloc_first h (page_size capacity) base c - (fun a : nat => (Ret a : ictree sE nat)) - (page_size_positive capacity) Positive Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - unfold new_page; rewrite interp_nd_source_bind, interp_nd_source_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. + unfold new_page; rewrite interp_nd_source_bind. + rewrite interp_nd_source_alloc_first with (base:=base) by + (try apply page_size_positive; assumption). rewrite interp_nd_source_bind; etransitivity. - apply interp_nd_init_page. - rewrite interp_nd_source_ret; reflexivity. @@ -420,7 +300,7 @@ Qed. (** Empty heaps accept the very first candidate, even when capacity is zero: the allocation request is always for at least the five metadata cells. *) Lemma sh_alloc_page_hemp capacity c : - runStateT (sh (SAlloc (page_size capacity))) (hemp,c) ~ + runStateT (sh (inl (HAlloc (page_size capacity)))) (hemp,c) ~ Ret (1,(hunion (hblock 1 (page_size capacity)) hemp,c)). Proof. apply sh_alloc_first. @@ -459,49 +339,6 @@ Qed. (** Source read probes after dynamic initialization. Instantiating [address] with metadata, link, or payload addresses combines these equations with the corresponding [page_heap_*] lookup laws, without assuming a fixture. *) -Local Lemma allocator_interp_rr_read_value n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c : - h a = Some value -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m (h,c). -Proof. - intro Lookup. - pose proof (sinterp_rd a h c value - (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_rr_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Local Lemma allocator_interp_nd_read_value n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c : - h a = Some value -> - interp_nd (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some value)) (Some i) (h,c). -Proof. - intro Lookup. - pose proof (sinterp_rd a h c value - (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_nd_source_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. Lemma interp_rr_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (address : nat -> nat) value (K : option nat -> thread sE) m c : @@ -513,7 +350,7 @@ Lemma interp_rr_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) m (page_heap 1 capacity hemp,c). Proof. intro Lookup; rewrite interp_rr_bind, interp_rr_new_page_hemp. - apply allocator_interp_rr_read_value; exact Lookup. + apply interp_rr_read_value; exact Lookup. Qed. Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -526,7 +363,7 @@ Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) (page_heap 1 capacity hemp,c). Proof. intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. - apply allocator_interp_nd_read_value; exact Lookup. + apply interp_nd_source_read_value; exact Lookup. Qed. Lemma interp_rr_new_page_read_missing n @@ -538,17 +375,8 @@ Lemma interp_rr_new_page_read_missing n (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ (stuck : ictreeW SObs (unit * SSig)). Proof. - intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp, interp_rr_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; - [exact (sinterp_srd_stuck (address 1) (page_heap 1 capacity hemp) c Missing) - |reflexivity|reflexivity] - |intro result; reflexivity] - |eapply equ_clos_sbisim_goal; [apply bind_stuck_equ|reflexivity|reflexivity]] - end. + intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp. + apply interp_rr_read_missing; exact Missing. Qed. Lemma interp_nd_new_page_read_missing n @@ -560,18 +388,8 @@ Lemma interp_nd_new_page_read_missing n (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ (stuck : ictreeW SObs (unit * SSig)). Proof. - intro Missing. - rewrite interp_nd_source_bind, interp_nd_new_page_hemp, interp_nd_source_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; - [exact (sinterp_srd_stuck (address 1) (page_heap 1 capacity hemp) c Missing) - |reflexivity|reflexivity] - |intro result; reflexivity] - |eapply equ_clos_sbisim_goal; [apply bind_stuck_equ|reflexivity|reflexivity]] - end. + intro Missing; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. + apply interp_nd_source_read_missing; exact Missing. Qed. (** The children are the actual scoped-fork children: their [None] branch @@ -651,755 +469,6 @@ Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. Local Open Scope list_scope. -Lemma emit_list_nil {X} (t : ictreeW SObs X) : emit_list [] t = t. -Proof. reflexivity. Qed. - -Lemma emit_list_cons {X} o xs (t : ictreeW SObs X) : - emit_list (o :: xs) t ≅ Vis (Log o) (fun _ => emit_list xs t). -Proof. - change ((log o ;; emit_list xs t) ≅ Vis (Log o) (fun _ => emit_list xs t)). - unfold log, ICtree.trigger; rewrite bind_vis. - step; constructor; intros []; rewrite bind_ret_l; reflexivity. -Qed. - -Lemma emit_list_app {X} xs ys (t : ictreeW SObs X) : - emit_list (xs ++ ys) t = emit_list xs (emit_list ys t). -Proof. unfold emit_list; rewrite List.fold_right_app; reflexivity. Qed. - -Lemma emit_list_equ {X} xs (t u : ictreeW SObs X) : - t ≅ u -> emit_list xs t ≅ emit_list xs u. -Proof. - intro E; induction xs as [|o xs IH]; [exact E|]. - rewrite !emit_list_cons; step; constructor; intro x; exact IH. -Qed. - -Lemma emit_list_sbisim {X} xs (t u : ictreeW SObs X) : - t ~ u -> emit_list xs t ~ emit_list xs u. -Proof. - intro E; induction xs as [|o xs IH]; [exact E|]. - rewrite !emit_list_cons; apply sb_vis; intro x; exact IH. -Qed. - -Lemma emit_list_bind {X Y} xs (t : ictreeW SObs X) - (k : X -> ictreeW SObs Y) : - emit_list xs t >>= k ≅ emit_list xs (t >>= k). -Proof. - induction xs as [|o xs IH]; [reflexivity|]. - change (((log o ;; emit_list xs t) >>= k) ≅ - (log o ;; emit_list xs (t >>= k))). - etransitivity; [apply bind_bind|]. - apply equ_clo_bind_eq; intros []; exact IH. -Qed. - -Lemma emit_list_ret_bind {X Y} xs (x : X) (k : X -> ictreeW SObs Y) : - emit_list xs (Ret x) >>= k ≅ emit_list xs (k x). -Proof. - etransitivity; [apply emit_list_bind|]. - apply emit_list_equ, bind_ret_l. -Qed. - -(** Return values are observable labels, including when they contain heaps. - This proves equality of actual responses; it never identifies merely - pointwise-equal heap functions. *) -Lemma emit_list_ret_injective {X} xs ys (x y : X) : - emit_list xs (Ret x) ~ emit_list ys (Ret y) -> xs = ys /\ x = y. -Proof. - revert ys; induction xs as [|o xs IH]; intros [|p ys] E. - - split; [reflexivity|]. exact (@sbisim_ret_inv (writerE SObs) _ X x y E). - - rewrite emit_list_cons in E. - exfalso; exact (@sbisim_ret_vis_inv (writerE SObs) _ X x (Log p) - (fun _ => emit_list ys (Ret y)) E). - - rewrite emit_list_cons in E. - exfalso; eapply (@sbisim_ret_vis_inv (writerE SObs) _ X y (Log o) - (fun _ => emit_list xs (Ret x))); symmetry; exact E. - - rewrite !emit_list_cons in E. - pose proof (@sbisim_vis_invT (writerE SObs) _ X - (Log o) (Log p) (fun _ => emit_list xs (Ret x)) - (fun _ => emit_list ys (Ret y)) tt E) as [_ Eo]. - injection Eo as Eo; subst p. - pose proof (@sbisim_vis_invE (writerE SObs) _ X (Log o) - (fun _ => emit_list xs (Ret x)) (fun _ => emit_list ys (Ret y)) - tt E tt) as Etail. - destruct (IH ys Etail) as [-> ->]; auto. -Qed. - -Lemma handler_response_unique (e : sE) (sigma : SSig) - (result : encode e) (sigma1 : SSig) (before : list SObs) - (result' : encode e) (sigma2 : SSig) (before' : list SObs) : - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> - runStateT (sh e) sigma ~ emit_list before' (Ret (result',sigma2)) -> - before = before' /\ result = result' /\ sigma1 = sigma2. -Proof. - intros E1 E2. - assert (E : emit_list before (Ret (result,sigma1)) ~ - emit_list before' (Ret (result',sigma2))). - { transitivity (runStateT (sh e) sigma); [symmetry; exact E1|exact E2]. } - destruct (emit_list_ret_injective _ _ _ _ E) as [Ex Er]. - inversion Er; subst; auto. -Qed. - -Lemma sbisim_stuck_is_stuck {E} {HE : Encode E} {X} (t : ictree E X) : - t ~ (stuck : ictree E X) -> is_stuck t. -Proof. - intros Ets [l [u Hstep]]. - destruct (sbisim_trans t stuck u l eq Ets Hstep) - as [l' [u' [Hbad _]]]. - eapply trans_stuck; exact Hbad. -Qed. - -Lemma emit_list_ret_not_stuck {X} xs (x : X) : - ~ (emit_list xs (Ret x) ~ (stuck : ictreeW SObs X)). -Proof. - intro E; apply sbisim_stuck_is_stuck in E. - destruct xs as [|o xs]. - - apply E; exists (val x), stuck; apply trans_ret. - - apply E; exists (obs (Log o) tt), (emit_list xs (Ret x)). - rewrite emit_list_cons. - exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => emit_list xs (Ret x))). -Qed. - -(** Raw congruence is allowed on both ends, but no source-side [sbisim] - congruence is used. *) -Lemma ThreadSegment_equ_input t u sigma xs residual sigma' : - t ≅ u -> ThreadSegment t sigma xs residual sigma' -> - ThreadSegment u sigma xs residual sigma'. -Proof. - intros E H; eapply segment_equ; [symmetry; exact E|exact H|reflexivity]. -Qed. - -Lemma ThreadSegment_equ_output t sigma xs residual residual' sigma' : - ThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> - ThreadSegment t sigma xs residual' sigma'. -Proof. intros H E; eapply segment_equ; [reflexivity|exact H|exact E]. Qed. - -Lemma ThreadSegment_yield_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall k : unit -> thread sE, - t ≅ Vis (inl Yield) k -> - xs = [] /\ sigma' = sigma /\ k tt ≅ residual. -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - intros k E; split; [reflexivity|]; split; [reflexivity|]. - symmetry; exact (equ_vis_invE E tt). - - intros k E; step in E; cbn in E; inversion E. - - intros k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - intros k E. - assert (Eu : u ≅ Vis (inl Yield) k). - { transitivity t; [symmetry; exact Etu|exact E]. } - destruct (IH k Eu) as [Ex [Es Ek]]. - split; [exact Ex|]; split; [exact Es|]. - transitivity u'; assumption. -Qed. - -Lemma ThreadSegment_yield_inv k sigma xs residual sigma' : - ThreadSegment (Vis (inl Yield) k) sigma xs residual sigma' -> - xs = [] /\ sigma' = sigma /\ k tt ≅ residual. -Proof. intro H; eapply ThreadSegment_yield_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_guard_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall u, t ≅ Guard u -> ThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t v sigma xs v' residual sigma' Etv H IH Eout]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E; apply equ_guard_invE in E. - eapply ThreadSegment_equ_input; [exact E|exact H]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E. - eapply ThreadSegment_equ_output; [|exact Eout]. - apply IH; transitivity t; [symmetry; exact Etv|exact E]. -Qed. - -Lemma ThreadSegment_guard_inv t sigma xs residual sigma' : - ThreadSegment (Guard t) sigma xs residual sigma' -> - ThreadSegment t sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : - ThreadSegment (Guard t) sigma xs residual sigma' <-> - ThreadSegment t sigma xs residual sigma'. -Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. - -Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall (e : sE) (k : encode e -> thread sE), - t ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) -> - exists result sigma1 before after, - xs = before ++ after /\ - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ - ThreadSegment (k result) sigma1 after residual sigma'. -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e0 k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - intros e k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - intros e k E; step in E; cbn in E; inversion E. - - intros e k E. - pose proof (equ_vis_invT E) as [_ Ee]. - assert (Eevent : e0 = e) by congruence; subst e. - exists result, sigma1, before, after. - split; [reflexivity|]; split; [exact Eh|]. - eapply ThreadSegment_equ_input; [exact (equ_vis_invE E result)|exact H]. - - intros e k E. - assert (Eu : u ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k))). - { transitivity t; [symmetry; exact Etu|exact E]. } - destruct (IH e k Eu) as [r [sigma1 [before [after [Ex [Eh Htail]]]]]]. - exists r, sigma1, before, after; split; [exact Ex|]; split; [exact Eh|]. - eapply ThreadSegment_equ_output; eassumption. -Qed. - -Lemma ThreadSegment_user_inv (e : sE) (k : encode e -> thread sE) - sigma xs residual sigma' : - ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma' -> - exists result sigma1 before after, - xs = before ++ after /\ - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ - ThreadSegment (k result) sigma1 after residual sigma'. -Proof. intro H; eapply ThreadSegment_user_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_ret_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> ~ (t ≅ Ret tt). -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intro E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - apply IH; transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_ret_absurd sigma xs residual sigma' : - ~ ThreadSegment (Ret tt) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_ret_absurd_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_fork_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall k : bool -> thread sE, ~ (t ≅ Vis (inr (inl Fork)) k). -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros k E. - - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - step in E; cbn in E; inversion E. - - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - apply (IH k); transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_fork_absurd k sigma xs residual sigma' : - ~ ThreadSegment (Vis (inr (inl Fork)) k) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_fork_absurd_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_br_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall n (k : Fin.t (S n) -> thread sE), ~ (t ≅ Br n k). -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n k E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - apply (IH n k); transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_br_absurd n k sigma xs residual sigma' : - ~ ThreadSegment (Br n k) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_br_absurd_equ; [exact H|reflexivity]. Qed. - -(** A finite first-yield derivation cannot be manufactured by repeatedly - unfolding a divergent guard. A user case provides its actual response as - the witness needed for the first visible raw transition. *) -Lemma ThreadSegment_can_step t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> exists l u, trans l t u. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - exists (obs (inl Yield) tt), (k tt); apply trans_vis. - - destruct IH as [l [u Hstep]]; exists l, u; now apply trans_guard. - - exists (obs (inr (inr e) : CEff) result), (k result); apply trans_vis. - - destruct IH as [l [v Hstep]]; exists l, v; rewrite Etu; exact Hstep. -Qed. - -Lemma ThreadSegment_divergent_absurd t sigma xs residual sigma' : - is_stuck t -> ~ ThreadSegment t sigma xs residual sigma'. -Proof. intros Hdiv Hseg; apply Hdiv; eapply ThreadSegment_can_step; exact Hseg. Qed. - -Lemma ThreadSegment_stuck_absurd sigma xs residual sigma' : - ~ ThreadSegment (stuck : thread sE) sigma xs residual sigma'. -Proof. apply ThreadSegment_divergent_absurd, stuck_is_stuck. Qed. - -Lemma ThreadSegment_spin_absurd sigma xs residual sigma' : - ~ ThreadSegment (spin : thread sE) sigma xs residual sigma'. -Proof. - intro H; eapply ThreadSegment_br_absurd_equ; [exact H|]. - apply unfold_spin. -Qed. - -Lemma ThreadSegment_fault_absurd (e : sE) (k : encode e -> thread sE) - sigma xs residual sigma' : - runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)) -> - ~ ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma'. -Proof. - intros Ef Hseg. - destruct (ThreadSegment_user_inv e k sigma xs residual sigma' Hseg) - as [result [sigma1 [before [after [_ [Eh _]]]]]]. - apply (emit_list_ret_not_stuck before (result,sigma1)). - transitivity (runStateT (sh e) sigma); [symmetry; exact Eh|exact Ef]. -Qed. - -Lemma ThreadSegment_deterministic t sigma xs u sigma1 ys v sigma2 : - ThreadSegment t sigma xs u sigma1 -> - ThreadSegment t sigma ys v sigma2 -> - xs = ys /\ sigma1 = sigma2 /\ u ≅ v. -Proof. - intros H1; revert ys v sigma2. - induction H1 as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros ys v sigma2 H2. - - destruct (ThreadSegment_yield_inv k sigma ys v sigma2 H2) - as [Ex [Es Ek]]. - split; [symmetry; exact Ex|]; split; [symmetry; exact Es|exact Ek]. - - apply IH; now apply ThreadSegment_guard_inv in H2. - - destruct (ThreadSegment_user_inv e k sigma ys v sigma2 H2) - as [r [sigma0 [before0 [after0 [Ey [Eh0 Htail]]]]]]. - destruct (handler_response_unique e sigma result sigma1 before - r sigma0 before0 Eh Eh0) as [Eb [Er Es]]. - subst before0; subst r; subst sigma0. - destruct (IH after0 v sigma2 Htail) as [Ea [Es Er]]. - split; [subst ys; now rewrite Ea|]; split; assumption. - - assert (H2u : ThreadSegment u sigma ys v sigma2). - { eapply ThreadSegment_equ_input; [exact Etu|exact H2]. } - destruct (IH ys v sigma2 H2u) as [Ex [Es Er]]. - split; [exact Ex|]; split; [exact Es|]. - transitivity u'; [symmetry; exact Eout|exact Er]. -Qed. - -#[global] Instance guard_equ_Equivalence : Equivalence guard_equ. -Proof. - split. - - intro t; apply guard_equ_equ; reflexivity. - - intros t u; apply guard_equ_sym. - - intros t u v; apply guard_equ_trans. -Qed. - -Lemma guard_equ_sbisim t u : guard_equ t u -> t ~ u. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - rewrite E; reflexivity. - - rewrite sb_guard; exact IH. - - rewrite sb_guard; exact IH. - - symmetry; exact IH. - - transitivity u; assumption. -Qed. - -(** This stronger same-residual transport follows from the output-equ rule. - Symmetry in the finite guard closure is handled by proving both directions - together, rather than assuming a reverse simulation. *) -Lemma guard_equ_segment_iff t u : guard_equ t u -> - forall sigma xs residual sigma', - ThreadSegment t sigma xs residual sigma' <-> - ThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; - intros sigma xs residual sigma'. - - split; intro Hseg. - + eapply ThreadSegment_equ_input; [exact E|exact Hseg]. - + eapply ThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. - - rewrite ThreadSegment_guard_iff; apply IH. - - rewrite ThreadSegment_guard_iff; apply IH. - - symmetry; apply IH. - - transitivity (ThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. -Qed. - -Lemma guard_equ_segment t u sigma xs t' sigma' : - guard_equ t u -> ThreadSegment t sigma xs t' sigma' -> - exists u', ThreadSegment u sigma xs u' sigma' /\ guard_equ t' u'. -Proof. - intros E Hseg; exists t'; split. - - apply (proj1 (guard_equ_segment_iff t u E sigma xs t' sigma')); exact Hseg. - - apply guard_equ_equ; reflexivity. -Qed. - -Lemma guard_equ_br_yield_absurd n (k : Fin.t (S n) -> thread sE) - (ky : unit -> thread sE) : ~ guard_equ (Br n k) (Vis (inl Yield) ky). -Proof. - intro E; apply guard_equ_sbisim in E. - eapply (@sbisim_vis_br_inv CEff _ unit n (inl Yield) ky k); symmetry; exact E. -Qed. - -(** Equivalence of pools is used only for genuine raw [equ]. Guard removal - below is deliberately restricted to the focused slot. *) -Lemma segment_nd_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) - t u focus sigma : - t ≅ u -> - interp_nd (S n) (ts @ i := t) focus sigma ~ - interp_nd (S n) (ts @ i := u) focus sigma. -Proof. - intro E. - pose proof (interp_nd_equ (S n) (ts @ i := t) (ts @ i := u) - focus sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. - rewrite Ep; reflexivity. -Qed. - -Lemma segment_rr_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) - t u focus m sigma : - t ≅ u -> - interp_schedule_rr sh (S n) (ts @ i := t) focus m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := u) focus m sigma. -Proof. - intro E. - pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := t) (ts @ i := u) - focus m sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. - rewrite Ep; reflexivity. -Qed. - -Lemma segment_nd_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : - interp_nd (S n) (ts @ i := Guard t) (Some i) sigma ~ - interp_nd (S n) (ts @ i := t) (Some i) sigma. -Proof. - erewrite interp_nd_guard by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma segment_rr_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t m sigma : - interp_schedule_rr sh (S n) (ts @ i := Guard t) (Some i) m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma. -Proof. - erewrite interp_schedule_rr_guard by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma guard_equ_focused_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) t u sigma : - guard_equ t u -> - interp_nd (S n) (ts @ i := t) (Some i) sigma ~ - interp_nd (S n) (ts @ i := u) (Some i) sigma. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_nd_replace_equ; exact E. - - etransitivity; [apply segment_nd_focused_guard|exact IH]. - - etransitivity; [exact IH|symmetry; apply segment_nd_focused_guard]. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. -Qed. - -Lemma guard_equ_focused_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) t u m sigma : - guard_equ t u -> - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := u) (Some i) m sigma. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_rr_replace_equ; exact E. - - etransitivity; [apply segment_rr_focused_guard|exact IH]. - - etransitivity; [exact IH|symmetry; apply segment_rr_focused_guard]. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. -Qed. - -Lemma segment_nd_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) sigma : - interp_nd (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) sigma ~ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - interp_nd (S n) (ts @ i := k x) (Some i) sigma'). -Proof. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma segment_rr_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - interp_schedule_rr sh (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ~ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). -Proof. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma segment_interp_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) - t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - interp_nd (S n) (ts @ i := t) (Some i) sigma ~ - emit_list xs (interp_nd (S n) (ts @ i := residual) None sigma'). -Proof. - intro H; revert n ts i. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. - - cbn [emit_list]. - erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_nd_focused_guard|apply IH]. - - etransitivity; [apply segment_nd_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => interp_nd (S n) (ts @ i := k x) (Some i) sigma0). - + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. -Qed. - -Lemma segment_interp_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ - emit_list xs (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'). -Proof. - intro H; revert n ts i m. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. - - cbn [emit_list]. - erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_rr_focused_guard|apply IH]. - - etransitivity; [apply segment_rr_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0). - + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. -Qed. - -(** Exact equations retain the finite administrative guard path. In particular - RR selection is not a visible branch after refinement: its three guards - must not be used as a guarded [sbisim] coinduction hypothesis. These laws - expose them for induction on an actual [trans_] derivation instead. *) -Lemma segment_rr_guard_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma : - observe (ts $ i) = GuardF t -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - Guard (interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -Lemma segment_rr_yield_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - k m sigma : - observe (ts $ i) = VisF (inl Yield) k -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - Guard (interp_schedule_rr sh (S n) (ts @ i := k tt) None m sigma). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -Lemma segment_rr_user_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - observe (ts $ i) = VisF (inr (inr e)) k -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - Guard (Guard (Guard - (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')))). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). - rewrite interp_erase_user, interp_state_vis. - apply equ_clo_bind with (S := eq); [reflexivity|]. - intros [x sigma'] r <-; apply guard_equ_node. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node, interp_state_tau. -Qed. - -Lemma segment_rr_select_exact n (ts : pool sE (S n)) m sigma : - interp_schedule_rr sh (S n) ts None m sigma ≅ - Guard (Guard (Guard - (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma))). -Proof. - unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, schedule_no_focus_nonempty. - rewrite interp_erase_yield. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node. - rewrite (unfold_run_round_robin - (Br n (fun i => schedule (S n) ts (Some i))) m). - change (interp_state sh - (interp_yield (interp_spawn - (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) sigma ≅ - Guard (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma)). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -(** A stronger certificate for the initialized workers: primitive handlers - return by raw equivalence. This retains finite administrative guards for - round-robin divergence matching; source validity still uses ThreadSegment. *) -Inductive ExactThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := -| exact_segment_yield (k : unit -> thread sE) sigma : - ExactThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma -| exact_segment_guard t sigma logs t' sigma' : - ExactThreadSegment t sigma logs t' sigma' -> - ExactThreadSegment (Guard t) sigma logs t' sigma' -| exact_segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 - before after t' sigma' : - runStateT (sh e) sigma ≅ emit_list before (Ret (result,sigma1)) -> - ExactThreadSegment (k result) sigma1 after t' sigma' -> - ExactThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) - sigma (before ++ after) t' sigma' -| exact_segment_equ t u sigma logs u' t' sigma' : - t ≅ u -> ExactThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> - ExactThreadSegment t sigma logs t' sigma'. - -Lemma ExactThreadSegment_segment t sigma xs residual sigma' : - ExactThreadSegment t sigma xs residual sigma' -> - ThreadSegment t sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - apply segment_yield. - - apply segment_guard; exact IH. - - eapply segment_user; [|exact IH]. - eapply equ_clos_sbisim_goal; [exact Eh|reflexivity|reflexivity]. - - eapply segment_equ; eassumption. -Qed. - -Lemma ExactThreadSegment_equ_input t u sigma xs residual sigma' : - t ≅ u -> ExactThreadSegment t sigma xs residual sigma' -> - ExactThreadSegment u sigma xs residual sigma'. -Proof. - intros E H; eapply exact_segment_equ; [symmetry; exact E|exact H|reflexivity]. -Qed. - -Lemma ExactThreadSegment_equ_output t sigma xs residual residual' sigma' : - ExactThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> - ExactThreadSegment t sigma xs residual' sigma'. -Proof. intros H E; eapply exact_segment_equ; [reflexivity|exact H|exact E]. Qed. - -Lemma ExactThreadSegment_guard_inv_equ t sigma xs residual sigma' : - ExactThreadSegment t sigma xs residual sigma' -> - forall u, t ≅ Guard u -> ExactThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t v sigma xs v' residual sigma' Etv H IH Eout]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E; apply equ_guard_invE in E. - eapply ExactThreadSegment_equ_input; [exact E|exact H]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E. - eapply ExactThreadSegment_equ_output; [|exact Eout]. - apply IH; transitivity t; [symmetry; exact Etv|exact E]. -Qed. - -Lemma ExactThreadSegment_guard_inv t sigma xs residual sigma' : - ExactThreadSegment (Guard t) sigma xs residual sigma' -> - ExactThreadSegment t sigma xs residual sigma'. -Proof. intro H; eapply ExactThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ExactThreadSegment_guard_iff t sigma xs residual sigma' : - ExactThreadSegment (Guard t) sigma xs residual sigma' <-> - ExactThreadSegment t sigma xs residual sigma'. -Proof. split; [apply ExactThreadSegment_guard_inv|apply exact_segment_guard]. Qed. - -Lemma guard_equ_exact_segment_iff t u : guard_equ t u -> - forall sigma xs residual sigma', - ExactThreadSegment t sigma xs residual sigma' <-> - ExactThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; - intros sigma xs residual sigma'. - - split; intro Hseg. - + eapply ExactThreadSegment_equ_input; [exact E|exact Hseg]. - + eapply ExactThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. - - rewrite ExactThreadSegment_guard_iff; apply IH. - - rewrite ExactThreadSegment_guard_iff; apply IH. - - symmetry; apply IH. - - transitivity (ExactThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. -Qed. - -(** Raw source equations retain the outer option; in particular a successful - remote publication must return through its caller before reaching Yield. *) -Lemma source_raw_bind {A B} (p : CProg A) (next : A -> CProg B) - (K : option B -> thread sE) : - (denote_flow (CBind p next) >>= K) ≅ - (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end). -Proof. - cbn [denote_flow]; rewrite bind_bind. - apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. -Qed. - -Lemma source_raw_ret {A} (x : A) (K : option A -> thread sE) : - (denote_flow (CRet x) >>= K) ≅ K (Some x). -Proof. cbn [denote_flow]; apply bind_ret_l. Qed. - -Lemma source_raw_until {A} (body : CProg (option A)) - (K : option unit -> thread sE) : - (denote_flow (CUntilNone body) >>= K) ≅ - (denote_flow body >>= until_tail body K). -Proof. - set (loop_body := fun _ : unit => - flow <- denote_flow body;; - match flow with - | None => Ret (inr (None : option unit)) - | Some None => Ret (inr (Some tt)) - | Some (Some _) => Ret (inl tt) - end). - change ((ICtree.iter loop_body tt >>= K) ≅ - (denote_flow body >>= fun flow => - match flow with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) - end)). - transitivity ((loop_body tt >>= fun lr => - match lr with - | inl j => Guard (ICtree.iter loop_body j) - | inr result => Ret result - end) >>= K). - - apply equ_clo_bind with (S := eq). - + apply unfold_iter. - + intros r r' <-; reflexivity. - - etransitivity; [apply bind_bind|]. - unfold loop_body at 1. - etransitivity; [apply bind_bind|]. - apply equ_clo_bind_eq; intros [[x|]|]; cbn. - + etransitivity; [apply bind_ret_l|]. apply bind_guard. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. -Qed. - Lemma source_owner_read base : owner_residual base ORead ≅ (denote_flow (detach_remote base) >>= owner_after_detach base). @@ -1415,208 +484,16 @@ Proof. apply equ_clo_bind_eq; intros [[]|]; reflexivity. Qed. -Local Definition source_segment_to (t : thread sE) (sigma : SSig) - (logs : list SObs) (target : thread sE) (sigma' : SSig) : Prop := - exists residual, ExactThreadSegment t sigma logs residual sigma' /\ - guard_equ residual target. - -Local Lemma source_to_equ t u sigma logs target sigma' : - t ≅ u -> source_segment_to u sigma logs target sigma' -> - source_segment_to t sigma logs target sigma'. -Proof. - intros Htu (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ; [exact Htu|exact Hseg|reflexivity]. -Qed. - -Local Lemma source_to_bind {A B} (p : CProg A) (next : A -> CProg B) - (K : option B -> thread sE) sigma logs target sigma' : - source_segment_to (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end) - sigma logs target sigma' -> - source_segment_to (denote_flow (CBind p next) >>= K) sigma logs target sigma'. -Proof. - intro H; eapply source_to_equ; [apply source_raw_bind|exact H]. -Qed. -Local Lemma source_to_ret {A} (x : A) (K : option A -> thread sE) - sigma logs target sigma' : - source_segment_to (K (Some x)) sigma logs target sigma' -> - source_segment_to (denote_flow (CRet x) >>= K) sigma logs target sigma'. -Proof. - intro H; eapply source_to_equ; [apply source_raw_ret|exact H]. -Qed. -Local Lemma source_to_until {A} (body : CProg (option A)) - (K : option unit -> thread sE) sigma logs target sigma' : - source_segment_to (denote_flow body >>= until_tail body K) - sigma logs target sigma' -> - source_segment_to (denote_flow (CUntilNone body) >>= K) - sigma logs target sigma'. -Proof. - intro H; eapply source_to_equ; [apply source_raw_until|exact H]. -Qed. -Local Lemma source_to_read a v (K : option nat -> thread sE) - h c logs target sigma' : - h a = Some v -> - source_segment_to (K (Some v)) (h,c) logs target sigma' -> - source_segment_to (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. -Proof. - intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) - (u := Vis (inr (inr (SRd a))) (fun v => K (Some v))). - - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intro x; rewrite !bind_ret_l; reflexivity. - - change (ExactThreadSegment (Vis (inr (inr (SRd a))) (fun v => K (Some v))) - (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_rd_some a h c v Hr); reflexivity. - - reflexivity. -Qed. - -Local Lemma source_upd_present h a v x : h x <> None -> upd h a v x <> None. -Proof. - intro H; unfold upd; destruct (Nat.eqb x a); [discriminate|exact H]. -Qed. - -Local Lemma source_to_write a v (K : option unit -> thread sE) - h c logs target sigma' : - h a <> None -> - source_segment_to (K (Some tt)) (upd h a v,c) logs target sigma' -> - source_segment_to (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. -Proof. - intros Hp (residual & Hseg & Htail). - destruct (h a) as [w|] eqn:Hw; [|contradiction]. - exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) - (u := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). - - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - - change (ExactThreadSegment (Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) - (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (sh_wr_some a h c v w Hw); reflexivity. - - reflexivity. -Qed. - -Local Lemma source_to_emit tag block (K : option unit -> thread sE) - h c logs target sigma' : - source_segment_to (K (Some tt)) (h,S c) logs target sigma' -> - source_segment_to (denote_flow (CEmit tag block) >>= K) (h,c) - (SPop tag block c :: logs) target sigma'. -Proof. - intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) - (u := Vis (inr (inr (SEmit tag block))) (fun _ => K (Some tt))). - - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - - change (ExactThreadSegment - (Vis (inr (inr (SEmit tag block))) (fun _ => K (Some tt))) - (h,c) ([SPop tag block c] ++ logs) residual sigma'). - eapply exact_segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite sh_emit; reflexivity. - - reflexivity. -Qed. - -Local Lemma source_to_cas_success a expected desired - (K : option bool -> thread sE) h c logs target sigma' : - h a = Some expected -> - source_segment_to (K (Some true)) (upd h a desired,c) logs target sigma' -> - source_segment_to (denote_flow (CCAS a expected desired) >>= K) - (h,c) logs target sigma'. -Proof. - intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) - (u := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). - - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intro b; rewrite !bind_ret_l; reflexivity. - - change (ExactThreadSegment - (Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) - (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_cas_success a expected desired h c Hr); reflexivity. - - reflexivity. -Qed. - -Local Lemma source_to_cas_failure a expected desired current - (K : option bool -> thread sE) h c logs target sigma' : - h a = Some current -> current <> expected -> - source_segment_to (K (Some false)) (h,c) logs target sigma' -> - source_segment_to (denote_flow (CCAS a expected desired) >>= K) - (h,c) logs target sigma'. -Proof. - intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) - (u := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). - - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intro b; rewrite !bind_ret_l; reflexivity. - - change (ExactThreadSegment - (Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) - (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_cas_failure a expected desired current h c Hr Hne); - reflexivity. - - reflexivity. -Qed. - -Local Lemma source_to_yield (K : option unit -> thread sE) sigma target : - guard_equ (K (Some tt)) target -> - source_segment_to (denote_flow CYield >>= K) sigma [] target sigma. -Proof. - intro Htail; exists (K (Some tt)); split; [|exact Htail]. - eapply exact_segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). - - cbn [denote_flow]; unfold source_yield; rewrite !bind_bind, bind_vis. - step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - - apply exact_segment_yield. - - reflexivity. -Qed. - -(** Finite syntax normalization is used only for raw equ and leading guards. - It never changes a scheduler focus or invokes pool sbisim congruence. *) -Ltac allocator_raw_equ := - cbn beta iota zeta; - first [reflexivity | - lazymatch goal with - | |- (denote_flow (CBind _ _) >>= _) ≅ _ => - etransitivity; [apply source_raw_bind|]; allocator_raw_equ - | |- (denote_flow (CRet _) >>= _) ≅ _ => - etransitivity; [apply source_raw_ret|]; allocator_raw_equ - | |- ((?t >>= ?k) >>= ?j) ≅ _ => - etransitivity; [apply bind_bind|]; allocator_raw_equ - | |- (Ret _ >>= _) ≅ _ => - etransitivity; [apply bind_ret_l|]; allocator_raw_equ - | |- _ ≅ (denote_flow (CBind _ _) >>= _) => symmetry; allocator_raw_equ - | |- _ ≅ (denote_flow (CRet _) >>= _) => symmetry; allocator_raw_equ - | |- _ ≅ ((_ >>= _) >>= _) => symmetry; allocator_raw_equ - | |- _ ≅ (Ret _ >>= _) => symmetry; allocator_raw_equ - | |- Guard _ ≅ Guard _ => apply guard_equ_node; allocator_raw_equ - end]. - -#[local] Instance source_guard_equ_proper : - Proper (equ eq ==> equ eq ==> iff) guard_equ. -Proof. - intros t t' Ht u u' Hu; split; intro H. - - eapply guard_equ_trans; [apply guard_equ_equ; symmetry; exact Ht|]. - eapply guard_equ_trans; [exact H|apply guard_equ_equ; exact Hu]. - - eapply guard_equ_trans; [apply guard_equ_equ; exact Ht|]. - eapply guard_equ_trans; [exact H|apply guard_equ_equ; symmetry; exact Hu]. -Qed. Ltac allocator_residual_raw := unfold remote_residual, owner_residual, remote_free, remote_client, detach_remote, remote_link_tail, remote_cas_tail, detach_cas_tail, owner_offer_tail, denote, client_next, remote_after_free, owner_next, owner_after_collect, owner_after_detach; - allocator_raw_equ. + csl_raw_equ. Ltac allocator_residual_alignment := cbn beta iota zeta; @@ -1637,7 +514,7 @@ Ltac allocator_residual_alignment := rewrite source_owner_read; apply guard_equ_equ; allocator_residual_raw]. Ltac allocator_present := - first [congruence | apply source_upd_present; allocator_present]. + first [congruence | apply upd_mono; allocator_present]. Ltac allocator_segment_steps := repeat first @@ -1647,26 +524,26 @@ Ltac allocator_segment_steps := end | progress (rewrite Nat.eqb_refl) | lazymatch goal with - | |- source_segment_to (denote_flow (CBind _ _) >>= _) _ _ _ _ => - apply source_to_bind - | |- source_segment_to (denote_flow (CRet _) >>= _) _ _ _ _ => - apply source_to_ret - | |- source_segment_to (denote_flow (CUntilNone _) >>= _) _ _ _ _ => - apply source_to_until - | |- source_segment_to (denote_flow (CRead _) >>= _) _ _ _ _ => - eapply source_to_read; [eassumption|] - | |- source_segment_to (denote_flow (CWrite _ _) >>= _) _ _ _ _ => - eapply source_to_write; [allocator_present|] - | |- source_segment_to (denote_flow (CEmit _ _) >>= _) _ _ _ _ => - apply source_to_emit - | |- source_segment_to (denote_flow (CCAS _ _ _) >>= _) _ _ _ _ => - first [eapply source_to_cas_success; [congruence|] | - eapply source_to_cas_failure; + | |- exact_source_segment_to (denote_flow (CBind _ _) >>= _) _ _ _ _ => + apply exact_source_bind + | |- exact_source_segment_to (denote_flow (CRet _) >>= _) _ _ _ _ => + apply exact_source_ret + | |- exact_source_segment_to (denote_flow (CUntilNone _) >>= _) _ _ _ _ => + apply exact_source_until + | |- exact_source_segment_to (denote_flow (CRead _) >>= _) _ _ _ _ => + eapply exact_source_read; [eassumption|] + | |- exact_source_segment_to (denote_flow (CWrite _ _) >>= _) _ _ _ _ => + eapply exact_source_write; [allocator_present|] + | |- exact_source_segment_to (denote_flow (CEmit _ _) >>= _) _ _ _ _ => + apply exact_source_emit + | |- exact_source_segment_to (denote_flow (CCAS _ _ _) >>= _) _ _ _ _ => + first [eapply exact_source_cas_success; [congruence|] | + eapply exact_source_cas_failure; [eassumption|apply Nat.eqb_neq; eassumption|]] end | progress ( lazymatch goal with - | |- source_segment_to ?src ?sigma ?logs ?target ?sigma' => + | |- exact_source_segment_to ?src ?sigma ?logs ?target ?sigma' => let src' := eval cbv beta iota zeta delta [remote_residual owner_residual denote remote_client remote_free remote_attempt remote_link_tail remote_cas_tail client_round @@ -1674,9 +551,9 @@ Ltac allocator_segment_steps := detach_cas_tail reclaim_step owner_offer_tail offer_block until_tail client_next remote_after_free owner_next owner_after_collect owner_after_detach] in src in - change (source_segment_to src' sigma logs target sigma') + change (exact_source_segment_to src' sigma logs target sigma') end) ]; - apply source_to_yield; allocator_residual_alignment. + apply exact_source_yield; allocator_residual_alignment. (** The checked model branches provide precisely the successful heap reads. Repeated checked writes remain allocated even if addresses coincide; no @@ -1687,7 +564,7 @@ Lemma turn_source_exact_segment base who s t event : turn base who s = Some (t,event) -> exists residual, ExactThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ + (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. destruct s as [h c op r0 r1]; destruct who; @@ -1705,22 +582,22 @@ Proof. apply Nat.eqb_eq in H; subst end. all: cbn [allocator_pool slot_of_actor Vector.nth aheap acount - owner_state remote0_state remote1_state turn_observations]. + owner_state remote0_state remote1_state event_obs]. all: lazymatch goal with | |- exists residual, ExactThreadSegment ?src ?sigma ?logs residual ?sigma' /\ guard_equ residual ?target => - change (source_segment_to src sigma logs target sigma') + change (exact_source_segment_to src sigma logs target sigma') end. all: allocator_segment_steps. Qed. Local Transparent denote_flow ICtree.iter ICtree.bind. -Lemma turn_source_segment_checked base who s t event : +Lemma turn_source_segment base who s t event : turn base who s = Some (t,event) -> exists residual, ThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ + (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intro Hturn; destruct (turn_source_exact_segment base who s t event Hturn) @@ -1728,13 +605,6 @@ Proof. exists residual; split; [now apply ExactThreadSegment_segment|exact Htail]. Qed. -Lemma turn_source_segment base capacity who s t event : - allocator_inv base capacity s -> turn base who s = Some (t,event) -> - exists residual, - ThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (aheap s,acount s) (turn_observations event) residual (aheap t,acount t) /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who). -Proof. intros _; apply turn_source_segment_checked. Qed. Lemma turn_other_slots base who s t event : turn base who s = Some (t,event) -> @@ -1775,26 +645,24 @@ Theorem selected_turn_source_segment base capacity (ts : pool sE 3) turn base who s = Some (t,event) -> exists residual sigma', ThreadSegment (ts $ slot_of_actor who) sigma - (turn_observations event) residual sigma' /\ + (event_obs event) residual sigma' /\ state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hagree Hinv Hturn. pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. - pose proof (allocator_inv_state_equiv base capacity s - (source_reheap sigma s) Hreheap Hinv) as Hactualinv. destruct (turn_respects_heq_some base who s (source_reheap sigma s) t event Hreheap Hturn) as (actual & Hactual & Hnext). - destruct (turn_source_segment base capacity who - (source_reheap sigma s) actual event Hactualinv Hactual) + destruct (turn_source_segment base who + (source_reheap sigma s) actual event Hactual) as (canonical & Hseg & Htail). change (ThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (fst sigma,snd sigma) (turn_observations event) canonical + (fst sigma,snd sigma) (event_obs event) canonical (aheap actual,acount actual)) in Hseg. destruct sigma as [h c]; cbn [fst snd] in Hseg. destruct (guard_equ_segment ((allocator_pool base s) $ slot_of_actor who) - (ts $ slot_of_actor who) (h,c) (turn_observations event) + (ts $ slot_of_actor who) (h,c) (event_obs event) canonical (aheap actual,acount actual) (guard_equ_sym _ _ (Hpool (slot_of_actor who))) Hseg) as (residual & Hraw & Hrawtail). @@ -1813,14 +681,14 @@ Theorem selected_source_segment_exact base capacity (ts : pool sE 3) state_agrees sigma s -> allocator_inv base capacity s -> turn base who s = Some (t,event) -> ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> - logs = turn_observations event /\ state_agrees sigma' t /\ + logs = event_obs event /\ state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hagree Hinv Hturn Hseg. destruct (selected_turn_source_segment base capacity ts sigma s who t event Hpool Hagree Hinv Hturn) as (other & sigma2 & Hother & Hstate & Htail). destruct (ThreadSegment_deterministic (ts $ slot_of_actor who) sigma - logs residual sigma' (turn_observations event) other sigma2 Hseg Hother) + logs residual sigma' (event_obs event) other sigma2 Hseg Hother) as [Hlogs [Hsigma Hresidual]]. subst sigma2; split; [exact Hlogs|]; split; [exact Hstate|]. eapply guard_equ_trans; [apply guard_equ_equ; exact Hresidual|exact Htail]. @@ -1833,7 +701,7 @@ Theorem selected_source_segment_turn base capacity (ts : pool sE 3) ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> exists t event, turn base who s = Some (t,event) /\ - logs = turn_observations event /\ state_agrees sigma' t /\ + logs = event_obs event /\ state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hagree Hinv Hseg. @@ -1870,7 +738,7 @@ Proof. destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). destruct (selected_turn_source_segment base capacity ts sigma s who t event Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & _). - exists (turn_observations event), residual, sigma'; exact Hseg. + exists (event_obs event), residual, sigma'; exact Hseg. Qed. Theorem initialized_worker_no_terminal_prefix base capacity (ts : pool sE 3) @@ -1926,13 +794,6 @@ Proof. exact (ThreadSegment_fault_absurd e k sigma logs u sigma' Hfault Hfalse). Qed. -Local Lemma source_replace_current n (ts : pool sE n) (i : Fin.t n) : - pool_equ (ts @ i := (ts $ i)) ts. -Proof. - intro j; destruct (Fin.eq_dec j i) as [->|Hne]. - - rewrite Vector.nth_replace_eq; reflexivity. - - rewrite Vector.nth_replace_neq by congruence; reflexivity. -Qed. Local Lemma source_replace_turn base who s t event residual : turn base who s = Some (t,event) -> @@ -1945,8 +806,6 @@ Proof. exact (turn_other_slots base who s t event Hturn j Hne). Qed. -Local Lemma source_equ_sbisim {X} (t u : ictreeW SObs X) : t ≅ u -> t ~ u. -Proof. intro E; rewrite E; reflexivity. Qed. (** Each equation encompasses every branch of the phase table. The result retains the actual residual at None focus: guard_equ is not silently @@ -1957,21 +816,21 @@ Theorem turn_interp_nd base capacity who s t event : guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_nd 3 (allocator_pool base s) (Some (slot_of_actor who)) (aheap s,acount s) ~ - emit_list (turn_observations event) + emit_list (event_obs event) (interp_nd 3 (allocator_pool base t @ slot_of_actor who := residual) None (aheap t,acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_segment base capacity who s t event Hinv Hturn) + destruct (turn_source_segment base who s t event Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - - symmetry; apply source_equ_sbisim, interp_nd_equ, source_replace_current. + - symmetry; apply equ_sbisim, interp_nd_equ, source_replace_current. - etransitivity. + exact (segment_interp_nd 2 (allocator_pool base s) (slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) (aheap s,acount s) - (turn_observations event) residual (aheap t,acount t) Hseg). - + apply emit_list_sbisim, source_equ_sbisim, interp_nd_equ. + (event_obs event) residual (aheap t,acount t) Hseg). + + apply emit_list_sbisim, equ_sbisim, interp_nd_equ. exact (source_replace_turn base who s t event residual Hturn). Qed. @@ -1981,23 +840,23 @@ Theorem turn_interp_rr base capacity who s t event cursor : guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_rr sh 3 (allocator_pool base s) (Some (slot_of_actor who)) cursor (aheap s,acount s) ~ - emit_list (turn_observations event) + emit_list (event_obs event) (interp_schedule_rr sh 3 (allocator_pool base t @ slot_of_actor who := residual) None cursor (aheap t,acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_segment base capacity who s t event Hinv Hturn) + destruct (turn_source_segment base who s t event Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - - symmetry; apply source_equ_sbisim, interp_schedule_rr_equ, + - symmetry; apply equ_sbisim, interp_schedule_rr_equ, source_replace_current. - etransitivity. + exact (segment_interp_rr 2 (allocator_pool base s) (slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) cursor (aheap s,acount s) - (turn_observations event) residual (aheap t,acount t) Hseg). - + apply emit_list_sbisim, source_equ_sbisim, interp_schedule_rr_equ. + (event_obs event) residual (aheap t,acount t) Hseg). + + apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. exact (source_replace_turn base who s t event residual Hturn). Qed. @@ -2010,7 +869,7 @@ Theorem selected_turn_interp_nd base capacity (ts : pool sE 3) state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_nd 3 ts (Some (slot_of_actor who)) sigma ~ - emit_list (turn_observations event) + emit_list (event_obs event) (interp_nd 3 (ts @ slot_of_actor who := residual) None sigma'). Proof. intros Hpool Hagree Hinv Hturn. @@ -2018,9 +877,9 @@ Proof. Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. etransitivity. - - symmetry; apply source_equ_sbisim, interp_nd_equ, source_replace_current. + - symmetry; apply equ_sbisim, interp_nd_equ, source_replace_current. - exact (segment_interp_nd 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) sigma (turn_observations event) residual sigma' Hseg). + (ts $ slot_of_actor who) sigma (event_obs event) residual sigma' Hseg). Qed. Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) @@ -2032,7 +891,7 @@ Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_rr sh 3 ts (Some (slot_of_actor who)) cursor sigma ~ - emit_list (turn_observations event) + emit_list (event_obs event) (interp_schedule_rr sh 3 (ts @ slot_of_actor who := residual) None cursor sigma'). Proof. intros Hpool Hagree Hinv Hturn. @@ -2040,272 +899,20 @@ Proof. Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. etransitivity. - - symmetry; apply source_equ_sbisim, interp_schedule_rr_equ, + - symmetry; apply equ_sbisim, interp_schedule_rr_equ, source_replace_current. - exact (segment_interp_rr 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) cursor sigma (turn_observations event) residual sigma' Hseg). + (ts $ slot_of_actor who) cursor sigma (event_obs event) residual sigma' Hseg). Qed. From Coinduction Require Import coinduction rel tactics. Local Open Scope nat_scope. -Fixpoint rr_guards {X} (n : nat) (t : ictreeW SObs X) : ictreeW SObs X := - match n with 0 => t | S n => Guard (rr_guards n t) end. - -Lemma rr_guards_trans {X} n l (t u : ictreeW SObs X) : - trans l t u -> trans l (rr_guards n t) u. -Proof. intro H; induction n; cbn [rr_guards]; [exact H|now apply trans_guard]. Qed. - -(** This proof relation consumes a guard on BOTH sides in a silent round. - Its finite prefixes cannot turn silent divergence into a visible event. *) -CoInductive rr_aligned {X} : ictreeW SObs X -> ictreeW SObs X -> Prop := -| rr_align_guard t u n m t' u' : - t ≅ rr_guards (S n) t' -> u ≅ rr_guards (S m) u' -> - rr_aligned t' u' -> rr_aligned t u -| rr_align_log t u n m o t' u' : - t ≅ rr_guards n (Vis (Log o) (fun _ => t')) -> - u ≅ rr_guards m (Vis (Log o) (fun _ => u')) -> - rr_aligned t' u' -> rr_aligned t u. - -Lemma rr_aligned_equ {X} (t u a b : ictreeW SObs X) : - t ≅ a -> u ≅ b -> rr_aligned t u -> rr_aligned a b. -Proof. - intros Et Eu H; destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. - - eapply rr_align_guard; [| |exact H]. - + transitivity t; [symmetry; exact Et|exact El]. - + transitivity u; [symmetry; exact Eu|exact Er]. - - eapply rr_align_log; [| |exact H]. - + transitivity t; [symmetry; exact Et|exact El]. - + transitivity u; [symmetry; exact Eu|exact Er]. -Qed. - -Lemma rr_aligned_sym {X} : forall t u : ictreeW SObs X, - rr_aligned t u -> rr_aligned u t. -Proof. - cofix IH; intros t u H; - destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. - - eapply rr_align_guard; [exact Er|exact El|apply IH; exact H]. - - eapply rr_align_log; [exact Er|exact El|apply IH; exact H]. -Qed. - -Lemma rr_aligned_match {X} l T U : - @trans_ (writerE SObs) _ X l T U -> - forall u, rr_aligned (go T) u -> - exists u', trans l u u' /\ rr_aligned (go U) u'. -Proof. - intro TR; induction TR as - [l inner target TR IH - |n pick k result Eresult - |e k answer result Eresult - |result value Eresult]; intros u A. - - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; - subst; clear A; rename Hnext into A. - + apply equ_guard_invE in El; destruct n as [|n]. - * cbn [rr_guards] in El. - assert (Ai : rr_aligned (go (observe inner)) tr). - { eapply rr_aligned_equ; [|reflexivity|exact A]. - transitivity inner; [symmetry; exact El|apply ictree_eta]. } - destruct (IH tr Ai) as (next & Tnext & Anext). - exists next; split; [rewrite Er; now apply rr_guards_trans|exact Anext]. - * apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. - eapply rr_align_guard; eassumption. - + destruct n as [|n]. - * cbn [rr_guards] in El; step in El; cbn in El; inversion El. - * apply equ_guard_invE in El. - apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. - eapply rr_align_log; eassumption. - - inversion A as [left right p q tl tr El Er Hnext|left right p q o tl tr El Er Hnext]; - subst; clear A; rename Hnext into A. - + step in El; cbn [rr_guards] in El; inversion El. - + destruct p; step in El; cbn [rr_guards] in El; inversion El. - - destruct e as [o]; destruct answer. - inversion A as [left right n m tl tr El Er Hnext|left right n m p tl tr El Er Hnext]; - subst; clear A; rename Hnext into A. - + step in El; cbn [rr_guards] in El; inversion El. - + destruct n as [|n]. - * cbn [rr_guards] in El. - pose proof (equ_vis_invT El) as [_ Ep]; injection Ep as Ep; subst p. - pose proof (equ_vis_invE El tt) as Ek. - exists tr; split. - -- rewrite Er; apply rr_guards_trans. - exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => tr)). - -- eapply rr_aligned_equ; [|reflexivity|exact A]. - transitivity (k tt); [symmetry; exact Ek|]. - transitivity result; [exact Eresult|apply ictree_eta]. - * step in El; cbn [rr_guards] in El; inversion El. - - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; - subst; clear A; rename Hnext into A. - + step in El; cbn [rr_guards] in El; inversion El. - + destruct n; step in El; cbn [rr_guards] in El; inversion El. -Qed. - -Lemma rr_aligned_trans {X} (t u next : ictreeW SObs X) l : - rr_aligned t u -> trans l t next -> - exists other, trans l u other /\ rr_aligned next other. -Proof. - intros A TR. - assert (Ae : rr_aligned (go (observe t)) u). - { eapply rr_aligned_equ; [apply ictree_eta|reflexivity|exact A]. } - destruct (rr_aligned_match l (observe t) (observe next) TR u Ae) - as (other & To & Ao). - exists other; split; [exact To|]. - eapply rr_aligned_equ; [symmetry; apply ictree_eta|reflexivity|exact Ao]. -Qed. - -Lemma rr_aligned_sbisim {X} : forall t u : ictreeW SObs X, - rr_aligned t u -> t ~ u. -Proof. - unfold sbisim; apply_coinduction; fold_sbisim. - intros R IH t u A; split; intros l next TR. - - destruct (rr_aligned_trans t u next l A TR) as (other & To & Ao). - exists l, other; split; [exact To|]; split; [now apply IH|reflexivity]. - - destruct (rr_aligned_trans u t next l (rr_aligned_sym t u A) TR) - as (other & To & Ao). - exists l, other; split; [exact To|]; split. - + apply IH, rr_aligned_sym; exact Ao. - + reflexivity. -Qed. - -Lemma rr_guards_equ {X} n (t u : ictreeW SObs X) : - t ≅ u -> rr_guards n t ≅ rr_guards n u. -Proof. - intro E; induction n; cbn [rr_guards]; [exact E|now apply guard_equ_node]. -Qed. -Lemma rr_guards_add {X} n m (t : ictreeW SObs X) : - rr_guards (n + m) t = rr_guards n (rr_guards m t). -Proof. induction n; cbn [rr_guards Nat.add]; [reflexivity|now rewrite IHn]. Qed. -Lemma rr_guards_guard {X} n (t : ictreeW SObs X) : - rr_guards n (Guard t) = rr_guards (S n) t. -Proof. induction n; cbn [rr_guards]; [reflexivity|now rewrite IHn]. Qed. - -(** A finite proof prefix, not an additional evaluator or scheduler. *) -Inductive rr_token := RRGuard | RRLog (o : SObs). -Fixpoint rr_prefix {X} (word : list rr_token) (t : ictreeW SObs X) : ictreeW SObs X := - match word with - | [] => t - | RRGuard :: rest => Guard (rr_prefix rest t) - | RRLog o :: rest => Vis (Log o) (fun _ => rr_prefix rest t) - end. -Fixpoint rr_prefix_events (word : list rr_token) : list SObs := - match word with - | [] => [] - | RRGuard :: rest => rr_prefix_events rest - | RRLog o :: rest => o :: rr_prefix_events rest - end. -Lemma rr_prefix_app {X} left right (t : ictreeW SObs X) : - rr_prefix (left ++ right) t = rr_prefix left (rr_prefix right t). -Proof. - induction left as [|[|o] rest IH]; cbn [List.app rr_prefix]; - [reflexivity|now rewrite IH|now rewrite IH]. -Qed. -Lemma rr_prefix_equ {X} word (t u : ictreeW SObs X) : - t ≅ u -> rr_prefix word t ≅ rr_prefix word u. -Proof. - intro E; induction word as [|[|o] rest IH]; cbn [rr_prefix]. - - exact E. - - now apply guard_equ_node. - - apply vis_equ_node; intros []; exact IH. -Qed. -Lemma rr_prefix_events_app left right : - rr_prefix_events (left ++ right) = rr_prefix_events left ++ rr_prefix_events right. -Proof. - induction left as [|[|o] rest IH]; cbn [List.app rr_prefix_events]; - [reflexivity|exact IH|now rewrite IH]. -Qed. -Lemma rr_prefix_events_logs logs : rr_prefix_events (List.map RRLog logs) = logs. -Proof. induction logs; cbn [List.map rr_prefix_events]; [reflexivity|now rewrite IHlogs]. Qed. -Lemma rr_prefix_emit {X} logs (t : ictreeW SObs X) : - rr_prefix (List.map RRLog logs) t ≅ emit_list logs t. -Proof. - induction logs as [|o rest IH]; [reflexivity|]. - cbn [List.map rr_prefix]; rewrite emit_list_cons. - apply vis_equ_node; intros []; exact IH. -Qed. -Lemma rr_prefix_no_events {X} word (t : ictreeW SObs X) : - rr_prefix_events word = [] -> rr_prefix word t = rr_guards (List.length word) t. -Proof. - induction word as [|[|o] rest IH]; cbn [rr_prefix_events rr_prefix List.length rr_guards]; - intro E; [reflexivity|now rewrite IH|discriminate]. -Qed. -Lemma rr_prefix_one_event {X} word o (t : ictreeW SObs X) : - rr_prefix_events word = [o] -> exists n m, - rr_prefix word t ≅ rr_guards n (Vis (Log o) (fun _ => rr_guards m t)). -Proof. - induction word as [|[|p] rest IH]; cbn [rr_prefix_events]; intro E; [discriminate| |]. - - destruct (IH E) as (n & m & H). - exists (S n), m; cbn [rr_prefix rr_guards]; now apply guard_equ_node. - - injection E as Ep Er; subst p. - exists 0, (List.length rest); cbn [rr_prefix rr_guards]. - apply vis_equ_node; intros []; rewrite (rr_prefix_no_events rest t Er); reflexivity. -Qed. - -Local Lemma exact_rr_user_replaced n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - interp_schedule_rr sh (S n) - (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ≅ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')). -Proof. - etransitivity. - - eapply segment_rr_user_exact; rewrite Vector.nth_replace_eq; reflexivity. - - apply equ_clo_bind with (S := eq); [reflexivity|]. - intros [x sigma'] y <-; rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma exact_segment_rr_prefix n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma logs residual sigma' : - ExactThreadSegment t sigma logs residual sigma' -> - exists word, rr_prefix_events word = logs /\ - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ≅ - rr_prefix word (Guard - (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma')). -Proof. - intro H; revert n ts i m. - induction H as - [k sigma - |t sigma logs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma logs u' residual sigma' Etu H IH Eout]; intros n ts i m. - - exists []; split; [reflexivity|]; cbn [rr_prefix]. - etransitivity. - + eapply segment_rr_yield_exact; rewrite Vector.nth_replace_eq; reflexivity. - + rewrite Vector.replace_replace_eq; reflexivity. - - destruct (IH n ts i m) as (word & Ew & Et). - exists (RRGuard :: word); split; [exact Ew|]; cbn [rr_prefix]. - etransitivity. - + eapply segment_rr_guard_exact; rewrite Vector.nth_replace_eq; reflexivity. - + apply guard_equ_node; rewrite Vector.replace_replace_eq; exact Et. - - destruct (IH n ts i m) as (word & Ew & Et). - exists (List.map RRLog before ++ RRGuard :: RRGuard :: RRGuard :: word); split. - + rewrite rr_prefix_events_app, rr_prefix_events_logs; cbn [rr_prefix_events]. - now rewrite Ew. - + etransitivity; [apply exact_rr_user_replaced|]. - set (resume := fun response : (encode e * SSig)%type => - let '(x,sigma0) := response in - rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0)). - transitivity (emit_list before (Ret (result,sigma1)) >>= resume). - * apply equ_clo_bind with (S := eq); [exact Eh|intros x y <-; reflexivity]. - * etransitivity; [apply emit_list_ret_bind|]; unfold resume. - transitivity (emit_list before - (rr_guards 3 (rr_prefix word (Guard - (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'))))). - -- apply emit_list_equ, rr_guards_equ; exact Et. - -- rewrite rr_prefix_app; cbn [rr_prefix rr_guards]. - symmetry; apply rr_prefix_emit. - - destruct (IH n ts i m) as (word & Ew & Et). - exists word; split; [exact Ew|]. - etransitivity. - + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|exact Etu]. - + etransitivity; [exact Et|]. - apply rr_prefix_equ, guard_equ_node, interp_schedule_rr_equ, replace_pool_equ; - [apply pool_equ_refl|exact Eout]. -Qed. - Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event : pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> exists residual, ExactThreadSegment (ts $ slot_of_actor who) (aheap s,acount s) - (turn_observations event) residual (aheap t,acount t) /\ + (event_obs event) residual (aheap t,acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hturn. @@ -2313,14 +920,14 @@ Proof. exists residual; split; [|exact Htail]. apply (proj2 (guard_equ_exact_segment_iff (ts $ slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) - (Hpool (slot_of_actor who)) (aheap s,acount s) (turn_observations event) + (Hpool (slot_of_actor who)) (aheap s,acount s) (event_obs event) residual (aheap t,acount t))); exact Hseg. Qed. Lemma selected_turn_rr_prefix base (ts : pool sE 3) s who t event cursor : pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> exists residual word, - rr_prefix_events word = turn_observations event /\ + rr_prefix_events word = event_obs event /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_rr sh 3 ts (Some (slot_of_actor who)) cursor (aheap s,acount s) ≅ rr_prefix word (Guard (interp_schedule_rr sh 3 @@ -2330,7 +937,7 @@ Proof. destruct (selected_turn_exact_segment base ts s who t event Hpool Hturn) as (residual & Hseg & Htail). destruct (exact_segment_rr_prefix 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) cursor (aheap s,acount s) (turn_observations event) + (ts $ slot_of_actor who) cursor (aheap s,acount s) (event_obs event) residual (aheap t,acount t) Hseg) as (word & Ew & Et). exists residual, word; split; [exact Ew|]; split; [exact Htail|]. etransitivity; [|exact Et]. @@ -2364,7 +971,7 @@ Proof. assert (Hnextpool : pool_guard_equ (ts @ slot_of_actor who := residual) (allocator_pool base next)). { eapply selected_source_pool_update; eauto. } - destruct event as [o|]; cbn [turn_observations] in Ew. + destruct event as [o|]; cbn [event_obs] in Ew. - destruct (rr_prefix_one_event word o (Guard next_tree) Ew) as (n & m & Eword). eapply rr_align_log with (n := 3 + n) (m := 0) (o := o) (t' := rr_guards m (Guard next_tree)) (u' := Guard next_model). @@ -2408,14 +1015,6 @@ Qed. From Coinduction Require Import coinduction rel tactics. Local Notation st L := (coinduction.t (sb L)). -Lemma nd_st_emit_list {X} (R : ictreeW SObs X -> ictreeW SObs X -> Prop) - logs t u : - st eq R t u -> st eq R (emit_list logs t) (emit_list logs u). -Proof. - intro H; induction logs as [|o rest IH]; [exact H|]. - change (st eq R (log o ;; emit_list rest t) (log o ;; emit_list rest u)). - apply st_clo_bind_eq; [reflexivity|intros []; exact IH]. -Qed. Lemma allocator_pool_nd_bisim base capacity : forall s ts, allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> @@ -2436,14 +1035,14 @@ Proof. apply ExactThreadSegment_segment in Hseg. pose proof (segment_interp_nd 2 ts (slot_of_actor (actor_of_slot i)) (ts $ slot_of_actor (actor_of_slot i)) (aheap s,acount s) - (turn_observations event) residual (aheap next,acount next) Hseg) as Esegment. + (event_obs event) residual (aheap next,acount next) Hseg) as Esegment. rewrite slot_of_actor_of_slot in Esegment, Hnextpool. assert (Efocus : interp_nd 3 ts (Some i) (aheap s,acount s) ~ - emit_list (turn_observations event) + emit_list (event_obs event) (interp_nd 3 (ts @ i := residual) None (aheap next,acount next))). { etransitivity; [|exact Esegment]. - symmetry; apply source_equ_sbisim, interp_nd_equ, + symmetry; apply equ_sbisim, interp_nd_equ, source_replace_current. } assert (Hnextinv : allocator_inv base capacity next). @@ -2456,10 +1055,10 @@ Proof. etransitivity; [exact (IH next (ts @ i := residual) Hnextinv Hnextpool)|]. apply (coinduction.gfp_t (sb eq) R); symmetry; exact (sb_guard (model_nd base next)). } - destruct event as [o|]; cbn [turn_observations]. + destruct event as [o|]; cbn [event_obs]. - eapply equ_clos_st_goal; [reflexivity|symmetry; exact (emit_list_cons o [] (Guard (model_nd base next)))|]. - apply (nd_st_emit_list R [o]); exact Hcontinue. + apply (emit_list_st R [o]); exact Hcontinue. - exact Hcontinue. Qed. diff --git a/examples/CSL/Allocator/Layout.v b/examples/CSL/Allocator/Layout.v index a763f70..19236d0 100644 --- a/examples/CSL/Allocator/Layout.v +++ b/examples/CSL/Allocator/Layout.v @@ -6,10 +6,11 @@ none of the queue's ownership or chain predicates is used here. *) From Stdlib Require Import List Lia Arith.PeanoNat. -From examples Require Import CSL.HeapQ CSL.Layout. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout. Import ListNotations. Local Open Scope list_scope. +Local Open Scope nat_scope. Definition page_size (capacity : nat) : nat := 5 + 2 * capacity. Definition remote_head (base : nat) : nat := base. @@ -200,22 +201,6 @@ Definition page_heap (base capacity : nat) (h : Heap) : Heap := (mailbox base true) 0) (local_head base) (match capacity with 0 => 0 | S _ => base + 5 end)). -Lemma upd_preserves_present h a v x : - h x <> None -> upd h a v x <> None. -Proof. - intro H; destruct (Nat.eq_dec x a) as [-> | Hne]. - - rewrite upd_eq; discriminate. - - rewrite upd_neq by exact Hne; exact H. -Qed. - -Lemma upd_lookup_agree h f a v x : - h x = f x -> upd h a v x = upd f a v x. -Proof. - intro H; destruct (Nat.eq_dec x a) as [-> | Hne]. - - now rewrite !upd_eq. - - now rewrite !upd_neq by exact Hne. -Qed. - Lemma init_links_heap_lookup_agree first count h f x : h x = f x -> init_links_heap first count h x = init_links_heap first count f x. Proof. @@ -352,7 +337,7 @@ Lemma page_heap_in base capacity h x : page_heap base capacity h x <> None. Proof. intro Hin; unfold page_heap; apply init_links_heap_dom; right. - repeat apply upd_preserves_present. + repeat apply upd_mono. rewrite page_backing_in by exact Hin; discriminate. Qed. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v index 2972380..9a4fae2 100644 --- a/examples/CSL/Allocator/Liveness.v +++ b/examples/CSL/Allocator/Liveness.v @@ -1,6 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield. + ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield ICTree.Logic.Trace Utils.Relations. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution. @@ -17,8 +17,6 @@ Record AExecution := { Definition valid_execution (capacity c : nat) (e : AExecution) : Prop := states e 0 = initial_state capacity c /\ forall k, turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). -Definition infinitely (P : nat -> Prop) : Prop := - forall n, exists k, n <= k /\ P k. Definition event_is (tag : nat) (e : AExecution) (k : nat) : bool := match emitted e k with None => false | Some o => Nat.eqb (stag o) tag end. Definition pending_turn (e : AExecution) (k : nat) : bool := @@ -27,8 +25,6 @@ Definition pending_turn (e : AExecution) (k : nat) : bool := | Remote0 => match remote0_state (states e k) with RPoll => false | _ => true end | Remote1 => match remote1_state (states e k) with RPoll => false | _ => true end end. -Definition count_if (p : nat -> bool) (lo len : nat) : nat := - List.length (List.filter p (List.seq lo len)). Definition fair (e : AExecution) : Prop := forall actor, infinitely (fun k => selected e k = actor). Definition actor_eqb (a b : Actor) : bool := @@ -90,18 +86,6 @@ Lemma execution_step capacity c e k : turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). Proof. intros [_ H]; apply H. Qed. -Lemma count_if_zero p lo : count_if p lo 0 = 0. -Proof. reflexivity. Qed. -Lemma count_if_succ p lo len : - count_if p lo (S len) = (if p lo then 1 else 0) + count_if p (S lo) len. -Proof. - unfold count_if; cbn [List.seq List.filter]; destruct (p lo); reflexivity. -Qed. -Lemma count_if_add p lo left right : - count_if p lo (left + right) = count_if p lo left + count_if p (lo + left) right. -Proof. - unfold count_if; rewrite List.seq_app, List.filter_app, List.length_app; reflexivity. -Qed. Lemma actor_eqb_spec a b : actor_eqb a b = true <-> a = b. Proof. destruct a,b; cbn [actor_eqb]; split; intro H; congruence. Qed. Lemma owner_turn_spec e k : owner_turn e k = true <-> selected e k = Owner. @@ -151,7 +135,7 @@ Lemma execution_run_turns capacity c e lo len : valid_execution capacity c e -> run_turns 1 (List.map (selected e) (List.seq lo len)) (states e lo) = Some (states e (lo + len), - List.flat_map (fun k => turn_observations (emitted e k)) (List.seq lo len)). + List.flat_map (fun k => event_obs (emitted e k)) (List.seq lo len)). Proof. intro Hvalid; revert lo; induction len as [|len IH]; intro lo. - cbn [List.seq List.map run_turns List.flat_map]; now rewrite Nat.add_0_r. @@ -163,7 +147,8 @@ Qed. From Stdlib Require Import List Lia Arith.PeanoNat. From TICL Require Import Lang.CSL. -From examples Require Import CSL.HeapQ CSL.Allocator.Layout CSL.Allocator.Model. +From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Model. Import ListNotations. Local Open Scope nat_scope. @@ -415,36 +400,7 @@ Proof. pose proof (contention_pending_rank_bound (states e lo)); lia. Qed. -(** Both searches are finite and constructive. In particular an unbounded - double-negation search for a future successful CAS is not used. *) -Lemma infinitely_count_if (p : nat -> bool) : - infinitely (fun k => p k = true) -> - forall wanted lo, exists len, wanted <= count_if p lo len. -Proof. - intros Hinf wanted; induction wanted as [|wanted IH]; intro lo. - - exists 0; rewrite count_if_zero; lia. - - destruct (Hinf lo) as [k [Hlo Hk]]. - destruct (IH (S k)) as [len Hlen]. - exists ((k - lo) + S len). - rewrite count_if_add. - replace (lo + (k - lo)) with k by lia. - rewrite count_if_succ, Hk; cbn; lia. -Qed. -Lemma contention_finite_bool_search (p : nat -> bool) lo len : - (exists k, lo <= k < lo + len /\ p k = true) \/ - (forall k, lo <= k < lo + len -> p k = false). -Proof. - revert lo; induction len as [|len IH]; intro lo. - - right; intros k Hk; lia. - - destruct (p lo) eqn:Hlo. - + left; exists lo; split; [lia|exact Hlo]. - + destruct (IH (S lo)) as [[k [Hk Hp]]|Hnone]. - * left; exists k; split; [lia|exact Hp]. - * right; intros k Hk; destruct (Nat.eq_dec k lo) as [->|Hne]. - -- exact Hlo. - -- apply Hnone; lia. -Qed. Theorem remote_free_lockfree capacity c e : valid_execution capacity c e -> @@ -453,7 +409,7 @@ Theorem remote_free_lockfree capacity c e : Proof. intros Hvalid Hpending lo. destruct (infinitely_count_if (pending_turn e) Hpending 17 lo) as [len Hmany]. - destruct (contention_finite_bool_search (event_is tag_retire e) lo len) + destruct (finite_bool_search (event_is tag_retire e) lo len) as [[k [Hk Hevent]]|Hnone]. - exists k; split; [lia|exact Hevent]. - pose proof (no_publication_pending_bound capacity c e lo len Hvalid Hnone); lia. @@ -513,11 +469,6 @@ Proof. rewrite slot_of_actor_of_slot; apply Hsteps. Qed. -Lemma source_pool_equ_guard_trans {n} (ts us vs : pool sE n) : - pool_equ ts us -> pool_guard_equ us vs -> pool_guard_equ ts vs. -Proof. - intros E H i; eapply guard_equ_trans; [apply guard_equ_equ, E|apply H]. -Qed. Theorem source_execution_complete capacity c se : valid_source_execution capacity c se -> @@ -525,7 +476,7 @@ Theorem source_execution_complete capacity c se : valid_execution capacity c e /\ (forall k, state_agrees (source_states se k) (states e k) /\ pool_guard_equ (source_pools se k) (allocator_pool 1 (states e k))) /\ - (forall k, source_emitted se k = turn_observations (emitted e k)) /\ + (forall k, source_emitted se k = event_obs (emitted e k)) /\ (forall k, selected e k = source_selected se k). Proof. intros (Hpool0 & Hstate0 & Hsegments) e. @@ -612,23 +563,6 @@ Proof. eapply source_reachable_step; eassumption. Qed. -Lemma ThreadSegment_branchfree t sigma logs residual sigma' : - ThreadSegment t sigma logs residual sigma' -> - BranchFree t -> BranchFree residual. -Proof. - intro H; induction H as - [k sigma|t sigma logs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma logs u' residual sigma' Etu H IH Eout]; intro Hbf. - - apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; auto. - - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; assumption. - - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; auto. - - eapply branchfree_equ_impl; [exact Eout|]. - apply IH; eapply branchfree_equ_impl; eassumption. -Qed. Lemma source_pool0_branchfree i : BranchFree (source_pool0 1 $ i). Proof. @@ -673,14 +607,6 @@ Qed. (** The raw scheduler presents all three physical choices, including idle polls. Its scheduling Yield is erased, whereas the following Br contributes a genuine tau transition. Focus is retained through all source effects. *) -Lemma source_scheduler_offer (ts : pool sE 3) : - observe (schedule 3 ts None) = - VisF (inl Yield) (fun _ => Br 2 (fun i => schedule 3 ts (Some i))). -Proof. apply schedule_no_focus_nonempty. Qed. - -Lemma source_scheduler_choice (ts : pool sE 3) (i : Fin.t 3) : - trans tau (Br 2 (fun j => schedule 3 ts (Some j))) (schedule 3 ts (Some i)). -Proof. eapply trans_br with (x := i); reflexivity. Qed. Lemma source_scheduler_choice_inv (ts : pool sE 3) l next : trans l (Br 2 (fun i => schedule 3 ts (Some i))) next -> @@ -691,63 +617,12 @@ Proof. rewrite slot_of_actor_of_slot; exact E. Qed. -Lemma source_scheduler_focused_yield (ts : pool sE 3) i k : - observe (ts $ i) = VisF (inl Yield) k -> - observe (schedule 3 ts (Some i)) = GuardF (schedule 3 (ts @ i := k tt) None). -Proof. apply schedule_focused_yield. Qed. -Lemma source_scheduler_focused_guard (ts : pool sE 3) i t : - observe (ts $ i) = GuardF t -> - observe (schedule 3 ts (Some i)) = GuardF (schedule 3 (ts @ i := t) (Some i)). -Proof. apply schedule_focused_guard. Qed. -Lemma source_scheduler_focused_user (ts : pool sE 3) i (e : sE) - (k : encode e -> thread sE) : - observe (ts $ i) = VisF (inr (inr e)) k -> - observe (schedule 3 ts (Some i)) = - VisF (inr (inr e)) (fun x => schedule 3 (ts @ i := k x) (Some i)). -Proof. apply schedule_focused_user_event. Qed. -Inductive finite_steps {E : Type} {HE : Encode E} {X : Type} : - ictree E X -> list (@label E HE) -> ictree E X -> Prop := -| finite_steps_nil t : finite_steps t [] t -| finite_steps_cons t u v l labels : - trans l t u -> finite_steps u labels v -> finite_steps t (l :: labels) v. -Definition turn_labels (event : option SObs) : list (@label (writerE SObs) _) := - match event with None => [tau] | Some o => [tau; obs (Log o) tt] end. -Lemma turn_labels_nonempty event : turn_labels event <> []. -Proof. destruct event; discriminate. Qed. -Lemma finite_steps_app {E : Type} {HE : Encode E} {X : Type} - (t u v : ictree E X) left right : - finite_steps t left u -> finite_steps u right v -> - finite_steps t (left ++ right) v. -Proof. - intros H; induction H; intro Htail; cbn [List.app]; - [exact Htail|econstructor; eauto]. -Qed. -Lemma finite_steps_sbisim {E : Type} {HE : Encode E} {X : Type} - (t t' : ictree E X) labels : - finite_steps t labels t' -> forall u : ictree E X, t ~ u -> - exists u', finite_steps u labels u' /\ t' ~ u'. -Proof. - intro H; induction H as [t|t mid last l labels Hstep Htail IH]; intros u Eeq. - - exists u; split; [constructor|exact Eeq]. - - destruct (sbisim_trans t u mid l eq Eeq Hstep) - as (l' & mid' & Hstep' & El & Emid). - subst l'; destruct (IH mid' Emid) as (last' & Htail' & Elast). - exists last'; split; [econstructor; eassumption|exact Elast]. -Qed. -Lemma finite_steps_emit_list {X} logs (t : ictreeW SObs X) : - finite_steps (emit_list logs t) (List.map (fun o => obs (Log o) tt) logs) t. -Proof. - induction logs as [|o logs IH]; [constructor|]. - cbn [List.map]; econstructor; [|exact IH]. - rewrite emit_list_cons. - exact (@trans_vis (writerE SObs) _ X (Log o) tt (fun _ => emit_list logs t)). -Qed. Lemma model_turn_finite_steps base who s next event : turn base who s = Some (next,event) -> @@ -815,11 +690,6 @@ Fixpoint run_turn_labels (base : nat) (script : list Actor) (s : AState) end end. -Definition label_logs (labels : list (@label (writerE SObs) _)) : list SObs := - List.flat_map (fun l => match l with obs (Log o) _ => [o] | _ => [] end) labels. -Definition label_taus (labels : list (@label (writerE SObs) _)) : nat := - List.length (List.filter (fun l => match l with tau => true | _ => false end) labels). - Lemma run_turns_labels base script : forall s last logs, run_turns base script s = Some (last,logs) -> exists labels, run_turn_labels base script s = Some labels /\ @@ -871,47 +741,6 @@ Proof. transitivity model; [symmetry; exact Eresidual|exact Emodel]. Qed. -Lemma source_pool_replace_current n (ts : pool sE n) i : - pool_equ (ts @ i := (ts $ i)) ts. -Proof. - intro j; destruct (Fin.eq_dec j i) as [->|Hne]. - - rewrite Vector.nth_replace_eq; reflexivity. - - rewrite Vector.nth_replace_neq by congruence; reflexivity. -Qed. - -Theorem source_segment_scheduler_steps (ts : pool sE 3) sigma i logs residual sigma' ts' : - ThreadSegment (ts $ i) sigma logs residual sigma' -> - pool_equ ts' (ts @ i := residual) -> - exists next, - finite_steps (interp_nd 3 ts None sigma) - (tau :: List.map (fun o => obs (Log o) tt) logs) next /\ - next ~ interp_nd 3 ts' None sigma'. -Proof. - intros Hseg Epool. - assert (Efocused : interp_nd 3 ts (Some i) sigma ~ - emit_list logs (interp_nd 3 ts' None sigma')). - { - transitivity (interp_nd 3 (ts @ i := (ts $ i)) (Some i) sigma). - - rewrite (interp_nd_equ 3 _ _ (Some i) sigma (source_pool_replace_current 3 ts i)); - reflexivity. - - transitivity (emit_list logs (interp_nd 3 (ts @ i := residual) None sigma')). - + eapply segment_interp_nd; exact Hseg. - + apply emit_list_sbisim. - rewrite <- (interp_nd_equ 3 _ _ None sigma' Epool); reflexivity. - } - assert (Hbranch : trans tau (Br 2 (fun j => interp_nd 3 ts (Some j) sigma)) - (interp_nd 3 ts (Some i) sigma)). - { eapply trans_br with (x := i); reflexivity. } - pose proof (interp_nd_select 2 ts sigma) as Eselect; symmetry in Eselect. - destruct (sbisim_trans _ _ _ tau eq Eselect Hbranch) - as (l & focused & Hchoose & El & Efocus); subst l. - assert (Eemit : emit_list logs (interp_nd 3 ts' None sigma') ~ focused). - { transitivity (interp_nd 3 ts (Some i) sigma); [symmetry; exact Efocused|exact Efocus]. } - destruct (finite_steps_sbisim _ _ _ - (finite_steps_emit_list logs (interp_nd 3 ts' None sigma')) focused Eemit) - as (next & Hlogs & Enext). - exists next; split; [econstructor; eassumption|symmetry; exact Enext]. -Qed. Theorem valid_source_execution_scheduler_steps capacity c se k : valid_source_execution capacity c se -> @@ -941,35 +770,12 @@ Definition selected_source_pending (se : SourceExecution) k : Prop := Definition remote_first_event base client pc : sE := match pc with - | RPoll => SRd (mailbox base client) - | RRead _ => SRd (remote_head base) - | RLink block old => SWr block old - | RCAS block old => SCAS (remote_head base) old block + | RPoll => inl (HRead (mailbox base client)) + | RRead _ => inl (HRead (remote_head base)) + | RLink block old => inl (HWrite block old) + | RCAS block old => inl (HCAS (remote_head base) old block) end. -Lemma source_raw_read_head a (K : option nat -> thread sE) : - (denote_flow (CRead a) >>= K) ≅ Vis (inr (inr (SRd a))) (fun v => K (Some v)). -Proof. - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intro x; rewrite !bind_ret_l; reflexivity. -Qed. -Lemma source_raw_write_head a v (K : option unit -> thread sE) : - (denote_flow (CWrite a v) >>= K) ≅ Vis (inr (inr (SWr a v))) (fun _ => K (Some tt)). -Proof. - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. -Qed. -Lemma source_raw_cas_head a old desired (K : option bool -> thread sE) : - (denote_flow (CCAS a old desired) >>= K) ≅ - Vis (inr (inr (SCAS a old desired))) (fun b => K (Some b)). -Proof. - cbn [denote_flow]; unfold heap_event; rewrite !bind_bind, bind_vis. - step; constructor; intro x; rewrite !bind_ret_l; reflexivity. -Qed. - Lemma remote_residual_first_event base client pc : exists k : encode (remote_first_event base client pc) -> thread sE, remote_residual base client pc ≅ @@ -1080,12 +886,13 @@ Proof. intro n; destruct (Hlive n) as (k & Hnk & Hevent). apply event_is_spec in Hevent as (block & idx & Hevent). exists k; split; [exact Hnk|]; exists block, idx. - rewrite Hlogs, Hevent; cbn [turn_observations]; now left. + rewrite Hlogs, Hevent; cbn [event_obs]; now left. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. From TICL Require Import Lang.CSL. -From examples Require Import CSL.HeapQ CSL.Allocator.Layout CSL.Allocator.Model +From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Model CSL.Allocator.Execution. Import ListNotations. Local Open Scope nat_scope. @@ -1432,23 +1239,6 @@ Proof. unfold owner_round_bound in Hbound; lia. Qed. -Lemma owner_finite_first (P : nat -> Prop) - (dec : forall j, sumbool (P j) (not (P j))) lo len : - (forall j, lo <= j < lo + len -> ~ P j) \/ - exists j, lo <= j < lo + len /\ P j /\ forall i, lo <= i < j -> ~ P i. -Proof. - revert lo; induction len as [|len IH]; intro lo. - - left; intros; lia. - - destruct (dec lo) as [Hyes|Hno]. - + right; exists lo; split; [lia|]; split; [exact Hyes|]. - intros i Hi; lia. - + destruct (IH (S lo)) as [Hnone|(j & Hj & HP & Hfirst)]. - * left; intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; - [exact Hno|apply Hnone; lia]. - * right; exists j; split; [lia|]; split; [exact HP|]. - intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; - [exact Hno|apply Hfirst; lia]. -Qed. Definition round_completion_dec e k : sumbool (round_completion e k) (not (round_completion e k)). Proof. @@ -1462,7 +1252,7 @@ Theorem owner_round_selection_bound capacity c e lo len : count_if (owner_turn e) lo (S j - lo) <= 3 * capacity + 5. Proof. intros Hv Hcount. - destruct (owner_finite_first (round_completion e) (round_completion_dec e) lo len) + destruct (finite_first (round_completion e) (round_completion_dec e) lo len) as [Hnone|(j & Hj & Hdone & Hfirst)]. - pose proof (no_round_completion_owner_bound capacity c e lo len Hv Hnone); lia. - exists j; split; [exact Hj|]; split; [exact Hdone|]. @@ -1658,7 +1448,7 @@ Theorem retired_reclaimed_owner_selection_bound capacity c e k block idx len : count_if (owner_turn e) (S k) (j-k) <= 6 * capacity + 10. Proof. intros Hv Hret Hcount. - destruct (owner_finite_first (fun j => block_event tag_reclaim block (emitted e j)) + destruct (finite_first (fun j => block_event tag_reclaim block (emitted e j)) (fun j => block_event_dec tag_reclaim block (emitted e j)) (S k) len) as [Hnone|(j & Hj & [idx' Hreclaim] & Hfirst)]. - pose proof (no_reclaim_owner_bound capacity c e k block idx len Hv Hret Hnone); lia. @@ -1676,16 +1466,12 @@ Lemma infinitely_owner_count e : infinitely (fun k => selected e k = Owner) -> forall lo n, exists len, n <= count_if (owner_turn e) lo len. Proof. - intros Hinf lo n; induction n as [|n IH]. - - exists 0; rewrite count_if_zero; lia. - - destruct IH as [len Hlen]. - destruct (Hinf (lo+len)) as (k & Hk & Howner). - exists (len + ((k-(lo+len))+1)). - rewrite count_if_add, count_if_add. - replace (lo + len + (k - (lo + len))) with k by lia. - rewrite count_if_succ, count_if_zero. - assert (Heq : owner_turn e k = true) by (apply owner_turn_spec; exact Howner). - rewrite Heq; lia. + intros Hinf lo n. + apply infinitely_count_if. + intro start. + destruct (Hinf start) as (k & Hk & Howner). + exists k; split; [exact Hk|]. + apply owner_turn_spec; exact Howner. Qed. Theorem retired_eventually_reclaimed capacity c e : @@ -1733,7 +1519,7 @@ Theorem retired_reallocation_requires_reclaim capacity c e k j block idx alloc_i reclaim_idx < alloc_idx /\ emitted e q = Some (SPop tag_reclaim block reclaim_idx). Proof. intros Hv Hkj Hret Halloc. - destruct (owner_finite_first (fun q => block_event tag_reclaim block (emitted e q)) + destruct (finite_first (fun q => block_event tag_reclaim block (emitted e q)) (fun q => block_event_dec tag_reclaim block (emitted e q)) (S k) (j-S k)) as [Hnone|(q & Hq & [qi Hreclaim] & _)]. - exfalso; eapply retired_not_reallocated_before_reclaim; @@ -1765,13 +1551,13 @@ Proof. assert (Eretire : emitted e k = Some (SPop tag_retire block idx)). { rewrite Hlogs in Hretire. - destruct (emitted e k) as [o|] eqn:E; cbn [turn_observations] in Hretire; + destruct (emitted e k) as [o|] eqn:E; cbn [event_obs] in Hretire; [destruct Hretire as [<-|[]]; reflexivity|contradiction]. } destruct (retired_eventually_reclaimed capacity c e Hmodel Howner' k block idx Eretire) as (j & idx' & Hkj & Hij & Ereclaim). exists j, idx'; repeat split; try assumption. - rewrite Hlogs, Ereclaim; cbn [turn_observations]; now left. + rewrite Hlogs, Ereclaim; cbn [event_obs]; now left. Qed. From Stdlib Require Import List Lia Arith.PeanoNat. @@ -1927,9 +1713,9 @@ Proof. eapply equ_sbt_closed_goal; [apply emit_list_cons|apply emit_list_cons|]. apply step_sb_vis. - intros []; exists tt; split; [|reflexivity]. - apply nd_st_emit_list; apply IH. + apply emit_list_st; apply IH. - intros []; exists tt; split; [|reflexivity]. - apply nd_st_emit_list; apply IH. + apply emit_list_st; apply IH. Qed. Theorem run_rr_allocator_demo_bisim c : @@ -1945,74 +1731,10 @@ Proof. apply demo_rr_cycle_bisim. Qed. -Fixpoint after_logs (xs : list SObs) (w : WorldW SObs) : WorldW SObs := - match xs with - | [] => w - | o :: rest => after_logs rest (Obs (Log o) tt) - end. -Lemma after_logs_not_done xs w : not_done w -> not_done (after_logs xs w). -Proof. - revert w; induction xs as [|o rest IH]; intros w Hd; cbn [after_logs]. - - exact Hd. - - apply IH; constructor. -Qed. - -Lemma af_emit_list {X} xs (t : ictreeW SObs X) w P : - not_done w -> - <( t, {after_logs xs w} |= AF visW {P} )> -> - <( {emit_list xs t}, w |= AF visW {P} )>. -Proof. - revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. - change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. - apply afl_log; [exact Hd|]. - apply IH; [constructor|exact H]. -Qed. - -Lemma agaf_emit_list {X} xs (t : ictreeW SObs X) w P : - not_done w -> - <( t, {after_logs xs w} |= AG (AF visW {P}) )> -> - <( {emit_list xs t}, w |= AG (AF visW {P}) )>. -Proof. - revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. - assert (Htail : <( {emit_list rest t}, {Obs (Log o) tt} - |= AG (AF visW {P}) )>). - { apply IH; [constructor|exact H]. } - assert (Haf : <( {emit_list rest t}, {Obs (Log o) tt} |= AF visW {P} )>). - { pose proof Htail as HH; cdestruct HH; assumption. } - assert (Hprefix : <( {emit_list (o :: rest) t}, w |= AF visW {P} )>). - { change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. - apply afl_log; assumption. } - rewrite emit_list_cons in Hprefix |- *. - apply (proj1 (@ag_vis (writerE SObs) _ X (Log o) - (fun _ => emit_list rest t) tt w _)); split. - - exact Hprefix. - - intros []; exact Htail. -Qed. - -Lemma af_emit_list_member {X} xs (t : ictreeW SObs X) w P o : - not_done w -> List.In o xs -> P o -> - <( {emit_list xs t}, w |= AF visW {P} )>. -Proof. - revert w; induction xs as [|a rest IH]; intros w Hd Hin HP; - [contradiction|]. - change <( {log a ;; emit_list rest t}, w |= AF visW {P} )>. - apply afl_log; [exact Hd|]. - destruct Hin as [<-|Hin]. - - cleft; apply ticll_vis; constructor; exact HP. - - apply IH; [constructor|exact Hin|exact HP]. -Qed. - -Lemma af_emit_list_ret {X} xs (r : X) w (Q : X -> WorldW SObs -> Prop) : - not_done w -> Q r (after_logs xs w) -> - <[ {emit_list xs (Ret r)}, w |= AF AX done {Q} ]>. -Proof. - revert w; induction xs as [|o rest IH]; intros w Hd HQ. - - cleft; apply axr_ret; assumption. - - change <[ {log o ;; emit_list rest (Ret r)}, w |= AF AX done {Q} ]>. - apply afr_log; [exact Hd|]. - apply IH; [constructor|exact HQ]. -Qed. + + + Lemma demo_cycle_fresh_member c kind : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v index 8e72e5e..8e4e023 100644 --- a/examples/CSL/Allocator/Model.v +++ b/examples/CSL/Allocator/Model.v @@ -1,7 +1,8 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Sorting.Permutation. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.Refine. -From examples Require Import CSL.HeapQ CSL.Allocator.Layout. +From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout. Import ICtree ICTreeNotations ListNotations. Local Open Scope ictree_scope. @@ -285,16 +286,6 @@ Proof. - exact state_equiv_trans. Qed. -Local Lemma trees_upd_heq h k a v : - heq h k -> heq (upd h a v) (upd k a v). -Proof. - intros H x; unfold upd; destruct (Nat.eqb x a); [reflexivity | apply H]. -Qed. - -Local Lemma trees_upd_lookup h a v x : - upd h a v x = if Nat.eqb x a then Some v else h x. -Proof. reflexivity. Qed. - (** Both faults and successful turns are preserved. In particular this statement does not assume the ownership invariant or heap finiteness. *) Lemma turn_respects_heq base who s t : @@ -313,7 +304,7 @@ Proof. destruct who; [destruct op | destruct r0 | destruct r1]; cbn [turn]. all: repeat first - [ progress (rewrite trees_upd_lookup) + [ progress (rewrite upd_unfold) | progress (rewrite <- Hh) | progress (cbn [aheap acount owner_state remote0_state remote1_state]) | match goal with @@ -327,7 +318,7 @@ Proof. all: unfold state_equiv; cbn [aheap acount owner_state remote0_state remote1_state]. all: split; - [ repeat apply trees_upd_heq; exact Hh + [ repeat apply upd_heq; exact Hh | repeat split; reflexivity ]. Qed. @@ -629,7 +620,8 @@ Qed. From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. From TICL Require Import Lang.CSL. -From examples Require Import CSL.HeapQ CSL.Allocator.Layout. +From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout. Import ListNotations. Local Open Scope list_scope. diff --git a/examples/CSL/Allocator/NegativeTests.v b/examples/CSL/Allocator/NegativeTests.v index ebd9e7c..eef6e07 100644 --- a/examples/CSL/Allocator/NegativeTests.v +++ b/examples/CSL/Allocator/NegativeTests.v @@ -1,5 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. +From TICL Require Import Utils.Relations. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. diff --git a/examples/CSL/HeapTests.v b/examples/CSL/HeapTests.v index a09489c..1a7bde4 100644 --- a/examples/CSL/HeapTests.v +++ b/examples/CSL/HeapTests.v @@ -9,31 +9,31 @@ Local Open Scope ictree_scope. Lemma allocated_read_returns a h c v : h a = Some v -> - runStateT (sh (SRd a)) (h,c) ≅ Ret (v,(h,c)). + runStateT (sh (inl (HRead a))) (h,c) ≅ Ret (v,(h,c)). Proof. apply sh_rd_some. Qed. Lemma empty_read_faults a c : - interp_state sh (srd a) (hemp,c) ≅ + interp_state sh (heap_read (E:=sE) a) (hemp,c) ≅ (stuck : ictreeW SObs (nat * SSig)). Proof. apply sinterp_srd_stuck; reflexivity. Qed. Lemma empty_write_faults a v c : - interp_state sh (swr a v) (hemp,c) ≅ + interp_state sh (heap_write (E:=sE) a v) (hemp,c) ≅ (stuck : ictreeW SObs (unit * SSig)). Proof. apply sinterp_swr_stuck; reflexivity. Qed. Lemma allocated_write_updates a h c v old : h a = Some old -> - runStateT (sh (SWr a v)) (h,c) ≅ Ret (tt,(upd h a v,c)). + runStateT (sh (inl (HWrite a v))) (h,c) ≅ Ret (tt,(upd h a v,c)). Proof. apply sh_wr_some. Qed. Lemma emit_records_current_index q v h c : - runStateT (sh (SEmit q v)) (h,c) ≅ + runStateT (sh (inr (Log (q,v)))) (h,c) ≅ (log (SPop q v c);; Ret (tt,(h,S c))). Proof. apply sh_emit. Qed. Lemma alloc_empty_two : - runStateT (sh (SAlloc 2)) (hemp,5) ~ + runStateT (sh (inl (HAlloc 2))) (hemp,5) ~ Ret (1,(hunion (hblock 1 2) hemp,5)). Proof. apply sh_alloc_first; try lia. @@ -41,7 +41,7 @@ Proof. Qed. Lemma alloc_skips_partial_overlap : - runStateT (sh (SAlloc 2)) (Pcm.hsingle 2 99,5) ~ + runStateT (sh (inl (HAlloc 2))) (Pcm.hsingle 2 99,5) ~ Ret (3,(hunion (hblock 3 2) (Pcm.hsingle 2 99),5)). Proof. apply sh_alloc_first; try lia. @@ -53,7 +53,7 @@ Proof. Qed. Lemma alloc_zero_stuck c : - interp_state sh (salloc 0) (hemp,c) ≅ + interp_state sh (heap_alloc (E:=sE) 0) (hemp,c) ≅ (stuck : ictreeW SObs (nat * SSig)). Proof. apply sinterp_salloc_zero. Qed. @@ -61,19 +61,19 @@ Definition full_heap : Heap := fun _ : nat => Some 7. Lemma alloc_full_heap_stuck size c : Nat.lt 0 size -> - runStateT (sh (SAlloc size)) (full_heap,c) ≅ + runStateT (sh (inl (HAlloc size))) (full_heap,c) ≅ (stuck : ictreeW SObs (nat * SSig)). Proof. - intro Pos; apply alloc_search_no_space; [exact Pos |]. + intro Pos; apply (alloc_search_no_space (W:=SObs)); [exact Pos |]. intros j J Free; specialize (Free 0 Pos); discriminate Free. Qed. Example cas_replacement_preserves_frame frame c : frame <> 2 -> interp_state sh - (b <- scas 2 7 9 ;; - current <- srd 2 ;; - framed <- srd frame ;; + (b <- heap_cas (E:=sE) 2 7 9 ;; + current <- heap_read (E:=sE) 2 ;; + framed <- heap_read (E:=sE) frame ;; Ret (b,current,framed)) (full_heap,c) ~ Ret ((true,9,7),(upd full_heap 2 9,c)). Proof. @@ -88,9 +88,9 @@ Qed. Example cas_mismatch_preserves_entire_state frame c : interp_state sh - (b <- scas 2 8 9 ;; - current <- srd 2 ;; - framed <- srd frame ;; + (b <- heap_cas (E:=sE) 2 8 9 ;; + current <- heap_read (E:=sE) 2 ;; + framed <- heap_read (E:=sE) frame ;; Ret (b,current,framed)) (full_heap,c) ~ Ret ((false,7,7),(full_heap,c)). Proof. @@ -103,9 +103,9 @@ Qed. Example cas_same_value_still_succeeds frame c : interp_state sh - (b <- scas 2 7 7 ;; - current <- srd 2 ;; - framed <- srd frame ;; + (b <- heap_cas (E:=sE) 2 7 7 ;; + current <- heap_read (E:=sE) 2 ;; + framed <- heap_read (E:=sE) frame ;; Ret (b,current,framed)) (full_heap,c) ~ Ret ((true,7,7),(upd full_heap 2 7,c)). Proof. @@ -119,7 +119,7 @@ Qed. Example cas_missing_faults_before_continuation c : interp_state sh - (b <- scas 1 0 9 ;; + (b <- heap_cas (E:=sE) 1 0 9 ;; semit 10 (if b then 1 else 0) ;; Ret b) (Pcm.hsingle 2 99,c) ~ (stuck : ictreeW SObs (bool * SSig)). diff --git a/examples/CSL/InterpTests.v b/examples/CSL/InterpTests.v index b006c93..20a9997 100644 --- a/examples/CSL/InterpTests.v +++ b/examples/CSL/InterpTests.v @@ -9,130 +9,6 @@ Import ICtree ICTreeNotations VectorNotations. Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. -Local Ltac source_observe := - lazy [observe _observe Vector.nth Vector.replace Vector.caseS' - denote denote_flow ICtree.bind ICtree.subst' rr_pick - Nat.modulo Nat.divmod Fin.of_nat_lt]; reflexivity. - -Local Ltac pool_simpl := - cbv [Vector.replace Vector.caseS' rr_pick Nat.modulo Nat.divmod Fin.of_nat_lt]. - -Local Ltac finish_pool := - repeat first - [ progress pool_simpl - | rewrite vector_remove_head - | rewrite vector_remove_tail - | erewrite interp_schedule_rr_ret by source_observe - | rewrite interp_schedule_rr_select - | rewrite interp_schedule_rr_empty ]; - reflexivity. - -Local Ltac read_result value := - lazymatch goal with - | |- (interp_state sh (srd ?a) (?h,?c) >>= ?K) ~ ?rhs => - let Hp := fresh "Hread" in - assert (Hp : interp_state sh (srd a) (h,c) ≅ Guard (Ret (value,(h,c)))) by - (etransitivity; [unfold srd; apply interp_state_vis|]; - transitivity (Ret (value,(h,c)) >>= fun result : (nat * SSig)%type => - let '(x,σ') := result in Guard (interp_state sh (Ret x) σ')); - [ apply equ_clo_bind with (S := eq); - [ apply sh_rd_some; reflexivity | intros r r' <-; reflexivity ] - | etransitivity; [apply bind_ret_l|]; - step; constructor; apply interp_state_ret ]); - transitivity (Ret (value,(h,c)) >>= K); - [ apply sbisim_clo_bind_eq; - [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] - | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] - end. - -Local Ltac write_result old := - lazymatch goal with - | |- (interp_state sh (swr ?a ?v) (?h,?c) >>= ?K) ~ ?rhs => - let Hp := fresh "Hwrite" in - assert (Hp : interp_state sh (swr a v) (h,c) ≅ - Guard (Ret (tt,(upd h a v,c)))) by - (etransitivity; [unfold swr; apply interp_state_vis|]; - transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => - let '(_,σ') := result in Guard (interp_state sh (Ret tt) σ')); - [ apply equ_clo_bind with (S := eq); - [ apply (sh_wr_some a h c v old); reflexivity - | intros r r' <-; reflexivity ] - | etransitivity; [apply bind_ret_l|]; - step; constructor; apply interp_state_ret ]); - transitivity (Ret (tt,(upd h a v,c)) >>= K); - [ apply sbisim_clo_bind_eq; - [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] - | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] - end. - -Local Ltac emit_result := - lazymatch goal with - | |- (interp_state sh (semit ?q ?v) (?h,?c) >>= ?K) ~ ?rhs => - let Hp := fresh "Hemit" in - assert (Hp : interp_state sh (semit q v) (h,c) ≅ - (log (SPop q v c);; Guard (Ret (tt,(h,S c))))) by - (etransitivity; [unfold semit; apply interp_state_vis|]; - transitivity ((log (SPop q v c);; Ret (tt,(h,S c))) >>= - fun result : (unit * SSig)%type => - let '(_,σ') := result in Guard (interp_state sh (Ret tt) σ')); - [ apply equ_clo_bind with (S := eq); - [ apply sh_emit | intros r r' <-; reflexivity ] - | etransitivity; [apply bind_bind|]; - apply equ_clo_bind_eq; intros []; - etransitivity; [apply bind_ret_l|]; - step; constructor; apply interp_state_ret ]); - transitivity ((log (SPop q v c);; Ret (tt,(h,S c))) >>= K); - [ apply sbisim_clo_bind_eq; - [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|]; - apply sbisim_clo_bind_eq; [reflexivity|intros []; apply sb_guard] - | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_bind|reflexivity|]; - apply sbisim_clo_bind_eq; [reflexivity|intros []]; - eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] - end. - -Local Ltac alloc_result base Halloc := - lazymatch goal with - | |- (interp_state sh (salloc ?size) (?h,?c) >>= ?K) ~ ?rhs => - let Hp := fresh "Halloc_state" in - assert (Hp : interp_state sh (salloc size) (h,c) ~ - Ret (base,(hunion (hblock base size) h,c))) by - (eapply equ_clos_sbisim_goal; - [ unfold salloc; apply interp_state_vis | reflexivity | ]; - transitivity (Ret (base,(hunion (hblock base size) h,c)) >>= - fun result : (nat * SSig)%type => - let '(x,σ') := result in Guard (interp_state sh (Ret x) σ')); - [ apply sbisim_clo_bind_eq; - [ exact Halloc | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|]; - rewrite sb_guard, interp_state_ret; reflexivity ]); - transitivity (Ret (base,(hunion (hblock base size) h,c)) >>= K); - [ apply sbisim_clo_bind_eq; - [ exact Hp | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] - end. - -Local Ltac cas_result value next_heap Hcas := - lazymatch goal with - | |- (interp_state sh (scas ?a ?expected ?desired) (?h,?c) >>= ?K) ~ ?rhs => - let Hp := fresh "Hcas_state" in - assert (Hp : interp_state sh (scas a expected desired) (h,c) ≅ - Guard (Ret (value,(next_heap,c)))) by - (etransitivity; [unfold scas; apply interp_state_vis|]; - transitivity (Ret (value,(next_heap,c)) >>= fun result : (bool * SSig)%type => - let '(b,σ') := result in Guard (interp_state sh (Ret b) σ')); - [ apply equ_clo_bind with (S := eq); - [ exact Hcas | intros r r' <-; reflexivity ] - | etransitivity; [apply bind_ret_l|]; - step; constructor; apply interp_state_ret ]); - transitivity (Ret (value,(next_heap,c)) >>= K); - [ apply sbisim_clo_bind_eq; - [ eapply equ_clos_sbisim_goal; [exact Hp|reflexivity|apply sb_guard] - | intro result; reflexivity ] - | eapply equ_clos_sbisim_goal; [apply bind_ret_l|reflexivity|] ] - end. Definition shared_write_program : CProg unit := CBind (CFork (CBind (CRead 4) (fun v => CEmit 2 v))) @@ -150,17 +26,18 @@ Proof. (denote_flow (CBind (CWrite 4 9) (fun _ => CYield)) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) 0 (Pcm.hsingle 4 0,0) ~ (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). - rewrite interp_rr_bind, interp_rr_write. - write_result 0. + rewrite interp_rr_bind. + rewrite interp_rr_write_present by discriminate. rewrite interp_rr_yield, interp_schedule_rr_select. change (interp_schedule_rr sh 2 ([Ret tt; Ret tt]%vector @ Fin.F1 := (denote_flow (CBind (CRead 4) (fun v => CEmit 2 v)) >>= fun _ => Ret tt)) (Some Fin.F1) 1 (upd (Pcm.hsingle 4 0) 4 9,0) ~ (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). - rewrite interp_rr_bind, interp_rr_read. - read_result 9. - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_read_value with (value:=9) by reflexivity. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. finish_pool. Qed. @@ -207,14 +84,16 @@ Proof. (denote_flow (CBind (CEmit 1 10) (fun _ => CRet (None : option unit))) >>= next)) (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_ret. change (interp_schedule_rr sh 2 ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := (denote_flow (CEmit 1 11) >>= done)) (Some (Fin.FS Fin.F1)) 0 (hemp,1) ~ (log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. erewrite interp_schedule_rr_ret by source_observe. pool_simpl; rewrite vector_remove_tail, vector_remove_head. rewrite interp_schedule_rr_select. @@ -222,7 +101,8 @@ Proof. ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 20) >>= done)) (Some Fin.F1) 1 (hemp,2) ~ (log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. unfold done; finish_pool. Qed. @@ -248,7 +128,8 @@ Proof. (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ (log (SPop 1 7 0);; log (SPop 2 9 1);; log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. change (interp_schedule_rr sh 2 ([Ret tt; denote (CEmit 1 8)]%vector @ Fin.F1 := @@ -256,14 +137,16 @@ Proof. >>= fun _ => Ret tt)) (Some Fin.F1) 1 (hemp,1) ~ (log (SPop 2 9 1);; log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. change (interp_schedule_rr sh 2 ([denote (CEmit 2 10); Ret tt]%vector @ Fin.FS Fin.F1 := (denote_flow (CEmit 1 8) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) 2 (hemp,2) ~ (log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. erewrite interp_schedule_rr_ret by source_observe. pool_simpl; rewrite vector_remove_tail, vector_remove_head. rewrite interp_schedule_rr_select. @@ -271,7 +154,8 @@ Proof. ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 10) >>= fun _ => Ret tt)) (Some Fin.F1) 3 (hemp,3) ~ (log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. finish_pool. Qed. @@ -283,10 +167,6 @@ Lemma allocation_zero_read_seen : run_rr allocation_zero_read hemp 0 ~ (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1))). Proof. - assert (Halloc : runStateT (sh (SAlloc 2)) (hemp,0) ~ - Ret (1,(hunion (hblock 1 2) hemp,0))). - { apply sh_alloc_first; try lia. - apply block_freeb_spec; reflexivity. } unfold run_rr, allocation_zero_read. change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := @@ -295,9 +175,13 @@ Proof. fun _ => Ret tt)) (Some Fin.F1) 0 (hemp,0) ~ (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1)))). - rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Halloc. - rewrite interp_rr_bind, interp_rr_read; read_result 0. - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=1) by + (try lia; apply block_freeb_spec; reflexivity). + rewrite interp_rr_bind. + rewrite interp_rr_read_value with (value:=0) by reflexivity. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. finish_pool. Qed. @@ -316,17 +200,11 @@ Lemma shared_alloc_seen : run_rr shared_alloc_program hemp 0 ~ (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2))). Proof. - assert (Hparent : runStateT (sh (SAlloc 2)) (hemp,0) ~ - Ret (1,(hunion (hblock 1 2) hemp,0))). - { apply sh_alloc_first; try lia. - apply block_freeb_spec; reflexivity. } - assert (Hchild : runStateT (sh (SAlloc 2)) (alloc_parent_heap,1) ~ - Ret (3,(hunion (hblock 3 2) alloc_parent_heap,1))). - { apply sh_alloc_first; try lia. - - apply block_freeb_spec; reflexivity. - - intros j J L F; assert (j = 1 \/ j = 2) as Cases by lia. - destruct Cases as [-> | ->]; - specialize (F 0 ltac:(lia)); discriminate F. } + assert (First : forall j, Nat.lt 0 j -> Nat.lt j 3 -> + ~ block_free alloc_parent_heap j 2). + { intros j J L F; assert (j = 1 \/ j = 2) as Cases by lia. + destruct Cases as [-> | ->]; + specialize (F 0 ltac:(lia)); discriminate F. } unfold shared_alloc_program; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 ([denote (allocating_thread 2); Ret tt]%vector @ Fin.FS Fin.F1 := @@ -335,9 +213,13 @@ Proof. CBind (CEmit 1 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). - rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Hparent. - rewrite interp_rr_bind, interp_rr_write; write_result 0. - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=1) by + (try lia; apply block_freeb_spec; reflexivity). + rewrite interp_rr_bind. + rewrite interp_rr_write_present by discriminate. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_yield, interp_schedule_rr_select. change (interp_schedule_rr sh 2 ([Ret tt; Ret tt]%vector @ Fin.F1 := @@ -346,9 +228,13 @@ Proof. CBind (CEmit 2 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) (Some Fin.F1) 1 (alloc_parent_heap,1) ~ (log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). - rewrite interp_rr_bind, interp_rr_alloc; alloc_result 3 Hchild. - rewrite interp_rr_bind, interp_rr_write; write_result 0. - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=3) by + (try lia; first [apply block_freeb_spec; reflexivity | exact First]). + rewrite interp_rr_bind. + rewrite interp_rr_write_present by discriminate. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_yield. finish_pool. Qed. @@ -365,18 +251,6 @@ Lemma shared_cas_seen : (log (SPop 10 1 0);; log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2))). Proof. - assert (Halloc : runStateT (sh (SAlloc 1)) (hemp,0) ~ - Ret (1,(hunion (hblock 1 1) hemp,0))). - { apply sh_alloc_first; try lia. - apply block_freeb_spec; reflexivity. } - assert (Hparent : runStateT (sh (SCAS 1 0 10)) - (hunion (hblock 1 1) hemp,0) ≅ - Ret (true,(upd (hunion (hblock 1 1) hemp) 1 10,0))). - { apply sh_cas_success; reflexivity. } - assert (Hchild : runStateT (sh (SCAS 1 0 20)) - (upd (hunion (hblock 1 1) hemp) 1 10,1) ≅ - Ret (false,(upd (hunion (hblock 1 1) hemp) 1 10,1))). - { eapply sh_cas_failure; [reflexivity|discriminate]. } unfold run_rr, shared_cas_program. change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := @@ -389,7 +263,9 @@ Proof. (Some Fin.F1) 0 (hemp,0) ~ (log (SPop 10 1 0);; log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind, interp_rr_alloc; alloc_result 1 Halloc. + rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=1) by + (try lia; apply block_freeb_spec; reflexivity). rewrite interp_rr_bind, interp_rr_fork. change (interp_schedule_rr sh 2 ([denote (CBind (CCAS 1 0 20) (fun won => @@ -400,9 +276,11 @@ Proof. (Some (Fin.FS Fin.F1)) 0 (hunion (hblock 1 1) hemp,0) ~ (log (SPop 10 1 0);; log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind, interp_rr_cas. - cas_result true (upd (hunion (hblock 1 1) hemp) 1 10) Hparent. - rewrite interp_rr_bind, interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_cas_value with (current:=0) by reflexivity. + cbn [Nat.eqb]. + rewrite interp_rr_bind, interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_rr_yield, interp_schedule_rr_select. change (interp_schedule_rr sh 2 ([Ret tt; Ret tt]%vector @ Fin.F1 := @@ -410,8 +288,10 @@ Proof. CEmit 20 (if won then 1 else 0))) >>= fun _ => Ret tt)) (Some Fin.F1) 1 (upd (hunion (hblock 1 1) hemp) 1 10,1) ~ (log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind, interp_rr_cas. - cas_result false (upd (hunion (hblock 1 1) hemp) 1 10) Hchild. - rewrite interp_rr_emit; emit_result. + rewrite interp_rr_bind. + rewrite interp_rr_cas_value with (current:=10) by apply upd_eq. + cbn [Nat.eqb]. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. finish_pool. Qed. diff --git a/examples/CSL/Layout.v b/examples/CSL/Layout.v index b161ea8..a71b147 100644 --- a/examples/CSL/Layout.v +++ b/examples/CSL/Layout.v @@ -1,158 +1,18 @@ -(** * Layout: a generic queue constructor and the concrete rotating queue. - - SHARED between the two proof families. Everything here is a construction - or an elementary fact about it; no separation-logic notion appears. - - [qheap hdr ns vs] is the heap that IS the queue [ns]/[vs] headed at [hdr]. - Proving [qrep] and [qex] for it once means every per-variant file contains - an address layout and a payload list, and no heap reasoning at all. *) +(** Concrete queue layout and address-bound frame fixtures. *) From Stdlib Require Import List Lia Arith.PeanoNat. -From examples Require Import CSL.HeapQ. +From TICL Require Import + Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame. Import ListNotations. Local Open Scope list_scope. +Local Open Scope nat_scope. -(** ** A generic queue heap *) - -Fixpoint nodeval (ns vs: list nat) (x: nat) : option nat := - match ns, vs with - | a :: ns', v :: vs' => - if Nat.eqb x a then Some v - else if Nat.eqb x (S a) then Some (hdf ns' 0) - else nodeval ns' vs' x - | _, _ => None - end. - -Definition qheap (hdr: nat) (ns vs: list nat) : Heap := - fun x => if Nat.eqb x hdr then Some (last ns 0) - else if Nat.eqb x (S hdr) then Some (hdf ns 0) - else nodeval ns vs x. - -Lemma nodeval_dom: forall ns vs x, - nodeval ns vs x <> None -> In x (cells ns). -Proof. - induction ns as [| a ns IH]; intros vs x H. - - destruct vs; cbn in H; congruence. - - destruct vs as [| v vs]; [cbn in H; congruence |]. - apply in_cells; cbn [nodeval] in H. - destruct (Nat.eqb_spec x a) as [Ex | Hna]; - [exists a; split; [apply in_eq | now left] |]. - destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; - [exists a; split; [apply in_eq | now right] |]. - apply IH in H; apply in_cells in H as (b & Hb & Hx). - exists b; split; [now apply in_cons | exact Hx]. -Qed. - -Lemma nodeval_in: forall ns vs x, - length ns = length vs -> In x (cells ns) -> nodeval ns vs x <> None. -Proof. - induction ns as [| a ns IH]; intros [| v vs] x Hlen Hx; - cbn in Hlen; try discriminate; [cbn in Hx; contradiction |]. - cbn [nodeval]. - destruct (Nat.eqb_spec x a) as [Ex | Hna]; [discriminate |]. - destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; [discriminate |]. - apply (IH vs); [lia |]. - apply in_cells in Hx as (b & Hb & Hxb). - apply in_cells; destruct Hb as [Eb | Hb]; [| exists b; split; assumption]. - exfalso; destruct Hxb as [Ex | Ex]; [apply Hna | apply Hnsa]; congruence. -Qed. - -Lemma chain_mono: forall h h' ns vs fin, - chain h ns vs fin -> - (forall x, In x (cells ns) -> h' x = h x) -> - chain h' ns vs fin. -Proof. - intros h h'; induction ns as [| a ns IH]; intros [| v vs] fin Hc Hag; - cbn in *; try contradiction; auto. - destruct Hc as (Ha & Hsa & Hc). - split; [| split]. - - rewrite Hag; [exact Ha | auto]. - - rewrite Hag; [exact Hsa | auto]. - - apply (IH vs fin Hc); intros x Hx; apply Hag; auto. -Qed. - -Lemma nodeval_chain: forall hdr ns vs, - qwf hdr ns -> length ns = length vs -> chain (nodeval ns vs) ns vs 0. -Proof. - intros hdr; induction ns as [| a ns IH]; intros [| v vs] Hwf Hlen; - cbn in Hlen; try discriminate; [exact I |]. - destruct (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). - cbn [chain nodeval]. - rewrite Nat.eqb_refl. - split; [reflexivity |]. - destruct (Nat.eqb_spec (S a) a) as [C | _]; [lia |]. - rewrite Nat.eqb_refl. - split; [reflexivity |]. - eapply chain_mono; [apply (IH vs (qwf_tail _ _ _ Hwf)); lia |]. - intros x Hx; cbn [nodeval]. - destruct (Nat.eqb_spec x a) as [Ex | Hna]; [rewrite Ex in Hx; contradiction |]. - destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; - [rewrite Ex in Hx; contradiction | reflexivity]. -Qed. - -Theorem qheap_qrep: forall hdr ns vs, - qwf hdr ns -> length ns = length vs -> ns <> [] -> - qrep hdr ns vs (qheap hdr ns vs). -Proof. - intros hdr ns vs Hwf Hlen Hne. - pose proof (qwf_hdr_cells _ _ Hwf) as Hhnc. - pose proof (qwf_shdr_cells _ _ Hwf) as Hshnc. - assert (Hhdr: qheap hdr ns vs hdr = Some (last ns 0)) - by (unfold qheap; now rewrite Nat.eqb_refl). - assert (Hshdr: qheap hdr ns vs (S hdr) = Some (hdf ns 0)). - { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [C | _]; [lia |]. - now rewrite Nat.eqb_refl. } - assert (Hcell: forall x, In x (cells ns) -> qheap hdr ns vs x = nodeval ns vs x). - { intros x Hx; unfold qheap. - destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex in Hx; contradiction |]. - destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; - [rewrite Ex in Hx; contradiction | reflexivity]. } - split; [exact Hwf | split; [exact Hshdr | split; [| split]]]. - - unfold tailok; destruct ns as [| a ns]; [contradiction | exact Hhdr]. - - eapply chain_mono; [apply (nodeval_chain hdr ns vs Hwf Hlen) |]. - intros x Hx; now apply Hcell. - - split. - + unfold qheap. - destruct (Nat.eqb_spec 0 hdr) as [C | _]; - [exfalso; apply (qwf_zero _ _ Hwf); rewrite C; apply in_eq |]. - destruct (Nat.eqb_spec 0 (S hdr)) as [C | _]; [lia |]. - destruct (nodeval ns vs 0) eqn:E; [| reflexivity]. - exfalso; apply (qwf_zero _ _ Hwf), in_cons, in_cons. - apply (nodeval_dom ns vs 0); congruence. - + intros x Hx; unfold qcells in Hx. - destruct Hx as [Ex | [Ex | Hx]]. - * rewrite <- Ex, Hhdr; discriminate. - * rewrite <- Ex, Hshdr; discriminate. - * rewrite (Hcell x Hx); revert Hx; now apply nodeval_in. -Qed. - -Theorem qheap_qex: forall hdr ns vs, qex hdr ns (qheap hdr ns vs). -Proof. - intros hdr ns vs x Hx; unfold qheap in Hx. - destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex; apply in_eq |]. - destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; - [rewrite Ex; apply in_cons, in_eq |]. - apply in_cons, in_cons, (nodeval_dom ns vs x), Hx. -Qed. -(** ** Two elementary frame shapes *) - -Definition hsingle (a v: nat) : Heap := - fun x => if Nat.eqb x a then Some v else None. - -Lemma hsingle_dom: forall a v x, hsingle a v x <> None -> x = a. -Proof. - intros a v x H; unfold hsingle in H. - destruct (Nat.eqb_spec x a) as [Ex | Hne]; [exact Ex | congruence]. -Qed. - -Lemma hemp_dom: forall x, hemp x <> None -> False. -Proof. intros x H; apply H; reflexivity. Qed. (** ** The concrete rotating queue, frozen across every frame variant. @@ -209,44 +69,6 @@ Proof. unfold high; intros x H1 H2; lia. Qed. Lemma high_nonzero: forall x, high x -> x <> 0. Proof. unfold high; intros x H; lia. Qed. -(** The uniform vocabulary in which a frame's CONTENT is described: a list of - (address, value) pairs the frame holds. Both proof families state "the - frame is intact" as [cellsat Wcells h]. *) -Definition cellsat (W: list (nat * nat)) (h: Heap) : Prop := - Forall (fun p => h (fst p) = Some (snd p)) W. - -Lemma cellsat_heq: forall W h1 h2, heq h1 h2 -> cellsat W h1 -> cellsat W h2. -Proof. - intros W k1 k2 Heq H; unfold cellsat in *. - rewrite Forall_forall in *; intros p Hp; rewrite <- Heq; now apply H. -Qed. - -Lemma cellsat_agree: forall W h h', - (forall p, In p W -> h' (fst p) = h (fst p)) -> cellsat W h -> cellsat W h'. -Proof. - intros W h h' Hag H; unfold cellsat in *. - rewrite Forall_forall in *; intros p Hp; rewrite Hag by exact Hp; now apply H. -Qed. - -(** ** PCM facts about the disjoint-heap monoid. - - [hdisj]/[hunion] come from the frozen [HeapQ.v] resource model; these are - the four elementary consequences both proof families use. *) - -Lemma hunion_some: forall h f x v, h x = Some v -> hunion h f x = Some v. -Proof. intros h f x v H; unfold hunion; now rewrite H. Qed. - -Lemma hunion_eq: forall h f x, h x <> None -> hunion h f x = h x. -Proof. - intros h f x H; destruct (h x) as [v |] eqn:E; [| congruence]. - now apply hunion_some. -Qed. - -Lemma hunion_none: forall h f x, h x = None -> hunion h f x = f x. -Proof. intros h f x H; unfold hunion; now rewrite H. Qed. - -Lemma hunion_dom: forall h f x, h x <> None -> hunion h f x <> None. -Proof. intros h f x H; now rewrite hunion_eq. Qed. (** The two compatibility conditions, derived once from the address bound. Every frame variant states only [HighHeap fv]; both proof families read @@ -272,230 +94,12 @@ Qed. Lemma ns1_low: forall x, In x ns1 -> x < 7. Proof. unfold ns1; cbn; intros x H; intuition lia. Qed. -(** ** Runtime-base contiguous queue layout *) - -Fixpoint node_addrs (first count : nat) : list nat := - match count with - | 0 => [] - | S rest => first :: node_addrs (first + 2) rest - end. - -Definition queue_nodes (hdr count : nat) : list nat := - node_addrs (hdr + 2) count. +(** ** Instantiating the compatibility conditions from an address bound. -Fixpoint fill_nodes_heap (first : nat) (values : list nat) (h : Heap) : Heap := - match values with - | [] => h - | value :: rest => - fill_nodes_heap (first + 2) rest - (upd (upd h first value) (S first) - (match rest with [] => 0 | _ :: _ => first + 2 end)) - end. + Every frame variant is described by "I allocate only addresses at least + 8"; the owned queue lives below 8 ([Layout.h1_low]). These two lemmas turn + that numeric statement into the two compatibility conditions, once. *) -Definition init_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := - let ns := queue_nodes hdr (length values) in - fill_nodes_heap (hdr + 2) values - (upd (upd h hdr (last ns 0)) (S hdr) (hdf ns 0)). +Lemma qrepX1: qrepX hdr1 ns1 vs1 h1. +Proof. split; [apply qrep1 | apply qex1]. Qed. -Definition new_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := - init_queue_heap hdr values - (hunion (hblock hdr (2 * S (length values))) h). - -Lemma node_addrs_in first count x : - In x (node_addrs first count) <-> - exists j, Nat.lt j count /\ x = first + 2*j. -Proof. - revert first x; induction count as [| count IH]; intros first x. - - cbn [node_addrs]; split; [contradiction | intros (j & Hj & _); lia]. - - cbn [node_addrs In]; rewrite IH; split. - + intros [Hx | (j & Hj & Hx)]. - * exists 0; split; lia. - * exists (S j); split; lia. - + intros (j & Hj & Hx); destruct j as [| j]. - * left; lia. - * right; exists j; split; lia. -Qed. - -Lemma node_addrs_length first count : length (node_addrs first count) = count. -Proof. - revert first; induction count as [| count IH]; intro first; - cbn [node_addrs length]; [reflexivity | now rewrite IH]. -Qed. - -Lemma queue_nodes_length hdr count : length (queue_nodes hdr count) = count. -Proof. apply node_addrs_length. Qed. - -Lemma node_addrs_nodup first count : NoDup (node_addrs first count). -Proof. - revert first; induction count as [| count IH]; intro first; cbn [node_addrs]. - - constructor. - - constructor; [| apply IH]. - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. -Qed. - -Lemma queue_nodes_qwf hdr count : Nat.lt 0 hdr -> qwf hdr (queue_nodes hdr count). -Proof. - intro Hhdr; unfold qwf, queue_nodes. - change (NoDup (node_addrs hdr (S count)) /\ - ~ In 0 (node_addrs hdr (S count)) /\ - (forall a b, In a (node_addrs hdr (S count)) -> - In b (node_addrs hdr (S count)) -> a <> S b)). - split; [apply node_addrs_nodup | split]. - - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. - - intros a b Ha Hb. - apply node_addrs_in in Ha as (j & Hj & Ha). - apply node_addrs_in in Hb as (k & Hk & Hb). - lia. -Qed. - -Lemma node_cells_range first count x : - In x (cells (node_addrs first count)) <-> - Nat.le first x /\ Nat.lt x (first + 2 * count). -Proof. - revert first x; induction count as [| count IH]; intros first x. - - cbn [node_addrs cells]; split; [contradiction | lia]. - - change ((first = x \/ S first = x \/ - In x (cells (node_addrs (first + 2) count))) <-> - Nat.le first x /\ Nat.lt x (first + 2 * S count)). - rewrite IH; split. - + intros [Hx | [Hx | Hx]]; lia. - + intros [Hlo Hhi]. - destruct (Nat.eq_dec first x) as [Hx | Hx]; [now left |]. - destruct (Nat.eq_dec (S first) x) as [Hsx | Hsx]; [now right; left |]. - right; right; split; lia. -Qed. - -Lemma queue_cells_range hdr count x : - In x (qcells hdr (queue_nodes hdr count)) <-> - Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count). -Proof. - change (In x (cells (node_addrs hdr (S count))) <-> - Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count)). - apply node_cells_range. -Qed. - -Lemma qheap_queue_nodes_rep hdr values : - Nat.lt 0 hdr -> - qrep hdr (queue_nodes hdr (length values)) values - (qheap hdr (queue_nodes hdr (length values)) values). -Proof. - intro Hhdr; destruct values as [| value values]. - - change (qrep hdr [] [] (qheap hdr [] [])). - assert (Htail : qheap hdr [] [] hdr = Some 0). - { unfold qheap; now rewrite Nat.eqb_refl. } - assert (Hhead : qheap hdr [] [] (S hdr) = Some 0). - { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [Hbad | Hne]; [lia |]. - now rewrite Nat.eqb_refl. } - split; [exact (queue_nodes_qwf hdr 0 Hhdr) |]. - split; [exact Hhead |]. - split; [change (qheap hdr [] [] hdr <> None); rewrite Htail; discriminate |]. - split; [exact I | split]. - + unfold qheap; destruct (Nat.eqb_spec 0 hdr) as [Hbad | Hne]; [lia |]. - reflexivity. - + intros x [Hx | [Hx | []]]; subst x; - [rewrite Htail | rewrite Hhead]; discriminate. - - apply qheap_qrep. - + now apply queue_nodes_qwf. - + apply queue_nodes_length. - + discriminate. -Qed. - -Lemma nodeval_node_addrs_out first values x : - (Nat.lt x first \/ Nat.le (first + 2 * length values) x) -> - nodeval (node_addrs first (length values)) values x = None. -Proof. - intro Hout; destruct (nodeval (node_addrs first (length values)) values x) eqn:E; - [| reflexivity]. - exfalso. - assert (Hin : In x (cells (node_addrs first (length values)))). - { apply (nodeval_dom (node_addrs first (length values)) values x); rewrite E; discriminate. } - apply node_cells_range in Hin; lia. -Qed. - -(** Filling a strided list changes exactly its node cells. *) -Lemma fill_nodes_heap_lookup first values h x : - fill_nodes_heap first values h x = - match nodeval (node_addrs first (length values)) values x with - | Some value => Some value - | None => h x - end. -Proof. - revert first h x; induction values as [| value values IH]; intros first h x. - - reflexivity. - - cbn [fill_nodes_heap length node_addrs]; rewrite IH; cbn [nodeval]. - destruct (Nat.eqb_spec x first) as [Hx | Hfirst]. - + subst x; rewrite nodeval_node_addrs_out by (left; lia). - rewrite upd_neq by lia; apply upd_eq. - + destruct (Nat.eqb_spec x (S first)) as [Hx | Hsfirst]. - * subst x; rewrite nodeval_node_addrs_out by (left; lia). - rewrite upd_eq; destruct values; reflexivity. - * rewrite upd_neq by exact Hsfirst. - rewrite upd_neq by exact Hfirst; reflexivity. -Qed. - -Lemma init_queue_heap_agrees hdr values h : - heq (init_queue_heap hdr values h) - (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). -Proof. - intro x; unfold init_queue_heap; rewrite fill_nodes_heap_lookup. - unfold hunion, qheap, queue_nodes. - destruct (Nat.eqb_spec x hdr) as [Hx | Hhdr]. - - subst x; rewrite nodeval_node_addrs_out by (left; lia). - rewrite upd_neq by lia; apply upd_eq. - - destruct (Nat.eqb_spec x (S hdr)) as [Hx | Hshdr]. - + subst x; rewrite nodeval_node_addrs_out by (left; lia); apply upd_eq. - + rewrite upd_neq by exact Hshdr. - rewrite upd_neq by exact Hhdr; reflexivity. -Qed. - -Lemma new_queue_heap_agrees hdr values h : - Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> - heq (new_queue_heap hdr values h) - (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). -Proof. - intros Hhdr Hfree x; unfold new_queue_heap. - rewrite (init_queue_heap_agrees hdr values _ x); unfold hunion. - destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; - [reflexivity |]. - assert (Hout : hblock hdr (2 * S (length values)) x = None). - { apply hblock_out. - destruct (Nat.lt_ge_cases x hdr) as [Hlo | Hlo]; [now left | right]. - destruct (Nat.lt_ge_cases x (hdr + 2 * S (length values))) as [Hhi | Hhi]; - [| exact Hhi]. - exfalso. - pose proof (qheap_queue_nodes_rep hdr values Hhdr) as Hq. - apply (qrep_fp _ _ _ _ Hq x). - - apply queue_cells_range; split; assumption. - - exact E. } - now rewrite Hout. -Qed. - -Lemma new_queue_heap_disjoint hdr values h : - block_free h hdr (2 * S (length values)) -> - hdisj (qheap hdr (queue_nodes hdr (length values)) values) h. -Proof. - intros Hfree x. - destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; - [right | now left]. - assert (Hin : In x (qcells hdr (queue_nodes hdr (length values)))). - { apply (qheap_qex hdr (queue_nodes hdr (length values)) values x); rewrite E; discriminate. } - apply queue_cells_range in Hin as [Hlo Hhi]. - replace x with (hdr + (x - hdr)) by lia. - apply Hfree; lia. -Qed. - -Lemma fill_nodes_heap_finite first values h : - heap_finite h -> heap_finite (fill_nodes_heap first values h). -Proof. - revert first h; induction values as [| value values IH]; intros first h Hh. - - exact Hh. - - cbn [fill_nodes_heap]; apply IH, heap_finite_upd, heap_finite_upd, Hh. -Qed. - -Lemma new_queue_heap_finite hdr values h : - heap_finite h -> heap_finite (new_queue_heap hdr values h). -Proof. - intro Hh; unfold new_queue_heap, init_queue_heap. - apply fill_nodes_heap_finite, heap_finite_upd, heap_finite_upd. - apply heap_finite_hunion; [apply heap_finite_hblock | exact Hh]. -Qed. diff --git a/examples/CSL/Lex.v b/examples/CSL/Lex.v deleted file mode 100644 index b387b9b..0000000 --- a/examples/CSL/Lex.v +++ /dev/null @@ -1,67 +0,0 @@ -(** * Lex: the lexicographic variant used by the SCHEDULED composition. - - NEW in this experiment. The frozen [Recurrence.v] rank is [lexnat], a - lexicographic order on [nat * nat]: (occurrence bound still to outrun, - position of the observed element). A composed run needs a THIRD - component, and it is a genuinely new obligation rather than a bigger - number: - - - the first component (occurrence bound) falls on EVERY scheduler turn, - because every turn of either queue emits exactly one observation; - - the second component (position of the element in the FOCUSED queue) falls - only on the focused queue's own turns and is UNCHANGED by the foreign - queue's turns; - - the third component is the SCHEDULER PHASE, and it is what makes a - foreign turn count as progress at all: a turn of the other queue leaves - the focused queue's position alone, so without a phase component the - variant would not decrease and the composition proof would not close. - - So the third component is exactly the "scheduler-phase progress argument" - the composition needs on top of the reused position argument. Nothing - here is ordinal: the whole rank is [nat * (nat * nat)]. *) - -From Stdlib Require Import - Relations - Arith.Wf_nat - Arith.PeanoNat - Lia. - -(** One lexicographic layer over [nat]. *) -Definition lexn {A} (R: relation A) : relation (nat * A) := - fun p q => fst p < fst q \/ (fst p = fst q /\ R (snd p) (snd q)). - -Lemma lexn_wf {A} (R: relation A): well_founded R -> well_founded (lexn R). -Proof. - intros HR [a b]; revert b. - induction a as [a IHa] using (well_founded_induction lt_wf). - intro b. - induction b as [b IHb] using (well_founded_induction HR). - constructor; intros [c d] [Hlt | (Heq & Hlt)]; cbn in *. - - now apply IHa. - - subst c; now apply IHb. -Qed. - -(** The rank of the composed proof. *) -Definition rank3 : relation (nat * (nat * nat)) := lexn (lexn lt). - -Lemma rank3_wf: well_founded rank3. -Proof. apply lexn_wf, lexn_wf, lt_wf. Qed. - -(** The three ways the rank falls, stated as the composition proof uses them. - [rank3_bound] is the reused occurrence argument, [rank3_pos] the reused - position argument, [rank3_phase] the NEW scheduler-phase argument. *) - -Lemma rank3_bound: forall b b' p p' q q', - b' < b -> rank3 (b', (p', q')) (b, (p, q)). -Proof. intros; left; cbn; assumption. Qed. - -Lemma rank3_pos: forall b p p' q q', - p' < p -> rank3 (b, (p', q')) (b, (p, q)). -Proof. intros; right; cbn; split; [reflexivity | left; cbn; assumption]. Qed. - -Lemma rank3_phase: forall b p q q', - q' < q -> rank3 (b, (p, q')) (b, (p, q)). -Proof. - intros; right; cbn; split; [reflexivity |]. - right; cbn; split; [reflexivity | assumption]. -Qed. diff --git a/examples/CSL/NegativeTests.v b/examples/CSL/NegativeTests.v index b4a08a8..d56877b 100644 --- a/examples/CSL/NegativeTests.v +++ b/examples/CSL/NegativeTests.v @@ -3,8 +3,10 @@ From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.State.Mod ICTree.Interp.Yield.RoundRobin ICTree.Logic.AG ICTree.Logic.Trans Logic.Core. -From examples Require Import - CSL.HeapQ CSL.Layout CSL.Overlap CSL.Recurrence CSL.SLang CSL.Program CSL.Queue. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Recurrence + Lang.CSL.Queue.Alternating Lang.CSL.Queue.Program Lang.CSL.Queue.Ticl + Lang.CSL.Queue.Operations. +From examples Require Import CSL.Layout CSL.Overlap. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -13,9 +15,9 @@ Local Open Scope list_scope. (* Ownership controls retain their original statements in CSL.Overlap: overlap_rejected, overlap_frame_not_preserved, null_frame_disjoint_but_bad. - The sequential controls remain CSL.Recurrence.empty_queue_no_ag and - CSL.Recurrence.absent_never_observed; they do not quantify over concurrent pools. - CSL.SLang.sfresh_excludes_retained rules out reusing an old tagged observation. *) + Sequential controls live in Lang.CSL.Queue.Recurrence and do not quantify + over concurrent pools. Lang.CSL.Queue.Alternating.sfresh_excludes_retained + rules out reusing an old tagged observation. *) Lemma empty_heap_parallel_stuck : run_rr (parallel_queues 2 10) hemp 0 ~ @@ -29,10 +31,10 @@ Proof. assert (Hfault : interp_state sh (turn 1 2) (hemp,0) ≅ (stuck : ictreeW SObs (unit * SSig))). { - unfold turn, turnk. + unfold turn, turnk, queue_turn. etransitivity; [apply interp_state_bind|]. lazymatch goal with - | |- (interp_state sh (srd 3) (hemp,0) >>= ?next) ≅ _ => + | |- (interp_state sh (heap_read (E:=sE) 3) (hemp,0) >>= ?next) ≅ _ => etransitivity; [ apply equ_clo_bind with (S := eq) (k2 := next); [exact (sinterp_srd_stuck 3 hemp 0 eq_refl) | intros x y <-; reflexivity] @@ -78,11 +80,11 @@ Proof. etransitivity; [apply queue_pool_turn |]. assert (Hfault : interp_state sh (turn 1 u) (h,0) ~ (stuck : ictreeW SObs (unit * SSig))). - { unfold turn, turnk. + { unfold turn, turnk, queue_turn. etransitivity; [eapply sinterp_rd; exact Hhead |]. eapply equ_clos_sbisim_goal; [apply interp_state_bind | reflexivity |]. lazymatch goal with - | |- (interp_state sh (srd 0) (h,0) >>= ?next) ~ _ => + | |- (interp_state sh (heap_read (E:=sE) 0) (h,0) >>= ?next) ~ _ => eapply equ_clos_sbisim_goal; [ etransitivity; [ apply equ_clo_bind with (S := eq) (k2 := next); diff --git a/examples/CSL/Overlap.v b/examples/CSL/Overlap.v index e29fa14..2a03ac8 100644 --- a/examples/CSL/Overlap.v +++ b/examples/CSL/Overlap.v @@ -19,7 +19,9 @@ From Stdlib Require Import Lia Arith.PeanoNat. -From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace + Lang.CSL.Queue.Frame. +From examples Require Import CSL.Layout. Import ListNotations. Local Open Scope list_scope. @@ -28,7 +30,7 @@ Local Open Scope list_scope. (** The candidate frame claims address 3, which is the queue's HEAD POINTER cell -- squarely inside [qcells hdr1 ns1]. *) -Definition fbad : Heap := Layout.hsingle 3 42. +Definition fbad : Heap := Pcm.hsingle 3 42. Lemma three_in_footprint: In 3 (qcells hdr1 ns1). Proof. unfold hdr1, ns1, qcells; cbn; tauto. Qed. @@ -38,7 +40,7 @@ Theorem overlap_rejected: ~ hdisj h1 fbad. Proof. intro Hd; destruct (Hd 3) as [H | H]. - apply (qrep_fp hdr1 ns1 vs1 h1 qrep1 3 three_in_footprint); exact H. - - unfold fbad, Layout.hsingle in H; cbn in H; discriminate. + - unfold fbad, Pcm.hsingle in H; cbn in H; discriminate. Qed. (** (b) ...and the conclusion it would license is FALSE. The cell the @@ -75,11 +77,11 @@ Qed. (** The candidate frame allocates address 0, which the language's representation uses as the end-of-list terminator. *) -Definition fnull : Heap := Layout.hsingle 0 1. +Definition fnull : Heap := Pcm.hsingle 0 1. (** (a) The compatibility check rejects it. *) Theorem null_frame_rejected: fnull 0 <> None. -Proof. unfold fnull, Layout.hsingle; cbn; discriminate. Qed. +Proof. unfold fnull, Pcm.hsingle; cbn; discriminate. Qed. (** (b) ...and the conclusion it would license is FALSE: the extended heap is not a representation of the queue at all, so the frozen recurrence theorem @@ -90,12 +92,12 @@ Theorem null_frame_disjoint_but_bad: Proof. split. - intro x; destruct (h1 x) eqn:E; [| now left]. - right; unfold fnull, Layout.hsingle. - destruct (Nat.eqb_spec x 0) as [Ex | Hne]; [| reflexivity]. - exfalso; rewrite Ex in E. + right; unfold fnull, Pcm.hsingle. + destruct (Nat.eq_dec 0 x) as [Ex | Hne]; [| reflexivity]. + exfalso; rewrite <- Ex in E. pose proof (qrep_null hdr1 ns1 vs1 h1 qrep1) as H0; congruence. - intro Hq; pose proof (qrep_null _ _ _ _ Hq) as H0. - unfold hunion, fnull, Layout.hsingle in H0; cbn in H0; discriminate. + unfold hunion, fnull, Pcm.hsingle in H0; cbn in H0; discriminate. Qed. (** ** The two conditions are independent diff --git a/examples/CSL/QLang.v b/examples/CSL/QLang.v deleted file mode 100644 index e3a7741..0000000 --- a/examples/CSL/QLang.v +++ /dev/null @@ -1,265 +0,0 @@ -(** * QLang: a small heap language with a SAFE handler, and the rotation body. - - Three deliberate departures from the reference language [Lang.HeapImp], - each of which is a research decision rather than a convenience: - - 1. **The handler is safe.** A read or a write outside the current heap's - domain produces [ICtree.stuck]. [HeapImp]'s [Put] never checks, and its - [Get] on an unmapped address is also stuck; here BOTH are checked, so an - out-of-footprint access invalidates every [AG] specification rather than - silently corrupting an unrelated cell. The footprint discipline is - therefore forced by the temporal proof, not assumed alongside it. - - 2. **The observation is heap-free.** [HeapImp] logs the WHOLE memory on - every write, which puts numeric addresses into the world and makes any - world-literal specification frame-unstable. Here the only logged event - is the popped payload together with an occurrence index, so the world - never mentions an address. - - 3. **The observation is occurrence-tagged.** [Pop v k] carries the number - of pops that preceded it. A retained [Obs (Log (Pop v k)) tt] world - cannot satisfy an occurrence-indexed formula for a later index, which is - what makes "the same element is popped AGAIN" a checkable statement - rather than a re-reading of a stale world. - - The projection back to the reference alphabet is [qval]: the reference - [examples/Queue.v] logs the popped payload [h : T] and specifies - [visW {fun h => h = nl}]; here the corresponding formula is - [visW {fun o => qval o = nl}]. *) - -From Stdlib Require Import - List - Lia - Arith.PeanoNat. - -From ExtLib Require Import - Structures.MonadState - Data.Monads.StateMonad. - -From TICL Require Import - ICTree.Core - ICTree.Equ - ICTree.SBisim - ICTree.Interp.State.Mod - ICTree.Events.State - ICTree.Events.Writer - ICTree.Logic.Trans - ICTree.Logic.CanStep - ICTree.Logic.AX - ICTree.Logic.AF - ICTree.Logic.AG - ICTree.Logic.Bind - ICTree.Logic.Iter - ICTree.Logic.State - Logic.Core. - -From examples Require Import CSL.HeapQ. - -Import ICtree ICTreeNotations TiclNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope ticl_scope. -Local Open Scope list_scope. - -(** Needed so that [equ] rewrites go through inside [sbisim] goals; the - reference files [Lang/MeQ.v] and [examples/Queue.v] do the same. *) -Local Typeclasses Transparent equ. -Local Typeclasses Transparent sbisim. - -(** ** The observation alphabet and its projection *) - -Record QObs : Type := Pop { qval: nat ; qidx: nat }. - -(** ** Events *) - -Variant heapE : Type := - | Rd (a: nat) - | Wr (a: nat) (v: nat) - | Emit (v: nat). - -Global Instance encode_heapE: Encode heapE := - fun e => match e with Rd _ => nat | Wr _ _ => unit | Emit _ => unit end. - -(** The three instructions. They are written as raw [Vis] nodes rather than - [ICtree.trigger]: [trigger e] unfolds to exactly this shape through the - identity [ReSum]/[ReSumRet] instances, and keeping the [Vis] explicit lets - every equation below go through [interp_state_vis] without any [resum] - bookkeeping. *) -Definition rd (a: nat) : ictree heapE nat := Vis (Rd a) (fun x: nat => Ret x). -Definition wr (a v: nat) : ictree heapE unit := Vis (Wr a v) (fun _: unit => Ret tt). -Definition emit (v: nat) : ictree heapE unit := Vis (Emit v) (fun _: unit => Ret tt). - -(** The interpretation state: the OWNED heap and the PRIVATE occurrence - counter. The counter is not part of the heap and no heap operation reads - it; it exists to index the observations. *) -Notation Sig := (Heap * nat)%type. - -(** ** The safe handler *) -Definition h_heapE: heapE ~> stateT Sig (ictreeW QObs) := - fun e => - mkStateT (fun s => - match e return ictreeW QObs (encode e * Sig) with - | Rd a => match fst s a with - | Some v => Ret (v, s) - | None => ICtree.stuck - end - | Wr a v => match fst s a with - | Some _ => Ret (tt, (upd (fst s) a v, snd s)) - | None => ICtree.stuck - end - | Emit v => log (Pop v (snd s)) ;; Ret (tt, (fst s, S (snd s))) - end). - -(** *** Handler equations. These are pure computation on the handler; no - [interp_state] appears, so they are safe to reduce. *) - -Lemma h_rd_some: forall a h c v, - h a = Some v -> runStateT (h_heapE (Rd a)) (h, c) ≅ Ret (v, (h, c)). -Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. - -Lemma h_rd_none: forall a h c, - h a = None -> runStateT (h_heapE (Rd a)) (h, c) ≅ ICtree.stuck. -Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. - -Lemma h_wr_some: forall a h c v w, - h a = Some w -> runStateT (h_heapE (Wr a v)) (h, c) ≅ Ret (tt, (upd h a v, c)). -Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. - -Lemma h_emit: forall v h c, - runStateT (h_heapE (Emit v)) (h, c) ≅ (log (Pop v c) ;; Ret (tt, (h, S c))). -Proof. intros; cbn; reflexivity. Qed. - -(** *** Lifting the handler equations through [interp_state]. *) - -Lemma interp_rd {X}: forall a h c v (k: nat -> ictree heapE X), - h a = Some v -> - interp_state h_heapE (x <- rd a ;; k x) (h, c) ~ interp_state h_heapE (k v) (h, c). -Proof. - intros a h c v k H. - unfold rd; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis. - rewrite (h_rd_some a h c v H), bind_ret_l. - apply sb_guard. -Qed. - -Lemma interp_wr {X}: forall a h c v w (k: unit -> ictree heapE X), - h a = Some w -> - interp_state h_heapE (x <- wr a v ;; k x) (h, c) - ~ interp_state h_heapE (k tt) (upd h a v, c). -Proof. - intros a h c v w k H. - unfold wr; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis. - rewrite (h_wr_some a h c v w H), bind_ret_l. - apply sb_guard. -Qed. - -Lemma interp_emit {X}: forall v h c (k: unit -> ictree heapE X), - interp_state h_heapE (x <- emit v ;; k x) (h, c) - ~ (log (Pop v c) ;; interp_state h_heapE (k tt) (h, S c)). -Proof. - intros v h c k. - unfold emit; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, h_emit, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l; apply sb_guard. -Qed. - -(** A read outside the footprint cannot step: this is the whole content of - "the handler is safe", and it is what makes an out-of-footprint access - invalidate every [AG] specification instead of corrupting a cell. *) -Lemma interp_rd_nostep {X}: forall a h c (k: nat -> ictree heapE X) w, - h a = None -> - ~ can_step (interp_state h_heapE (x <- rd a ;; k x) (h, c)) w. -Proof. - intros a h c k w H. - unfold rd; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, (h_rd_none a h c H). - intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; - revert TR; apply ktrans_stuck. -Qed. - -(** ** The rotating queue program. - - One iteration: read the head pointer, read and EMIT the head payload, read - the head's link, detach, find the node to append after, and re-link. No - allocation and no free: the same four cells are rewritten forever. *) - -Definition rot_body (hdr: nat) : ictree heapE (unit + unit) := - a <- rd (S hdr) ;; - v <- rd a ;; - _ <- emit v ;; - n <- rd (S a) ;; - _ <- wr (S hdr) n ;; - z0 <- rd hdr ;; - _ <- wr (S (if Nat.eqb n 0 then hdr else z0)) a ;; - _ <- wr (S a) 0 ;; - _ <- wr hdr a ;; - Ret (inl tt). - -Definition rotate (hdr: nat) : ictree heapE unit := - ICtree.iter (fun _: unit => rot_body hdr) tt. - -Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW QObs (unit * Sig) := - interp_state h_heapE (rotate hdr) (h, c). - -Lemma interp_wr' {X}: forall a h c v (k: unit -> ictree heapE X), - h a <> None -> - interp_state h_heapE (x <- wr a v ;; k x) (h, c) - ~ interp_state h_heapE (k tt) (upd h a v, c). -Proof. - intros a h c v k H; destruct (h a) as [w |] eqn:E; [| contradiction]. - eapply interp_wr; eauto. -Qed. - -(** ** The body correspondence. - - ONE completed rotation is strongly bisimilar to a SINGLE logged step - followed by a return. Three things are packed into this one statement: - - - **hidden-segment termination.** Every read and write in the body is - silent and finite, so the whole heap segment collapses; there is no - stuttering to reason about, and in particular no next-sensitive - stuttering theorem is needed. This holds ONLY because every access is - inside the footprint: an out-of-footprint access would leave [ICtree.stuck] - in place of a [Ret] and the collapse would fail ([interp_rd_nostep]). - - - **operation correctness.** The resulting heap is [rot_heap], which - [HeapQ.rot_heap_spec] proves implements the abstract pop-and-push. - - - **the observation.** The single event is [Pop v c] where [v] is the - payload READ OUT OF the head node's cell and [c] is the occurrence - counter before the pop. *) -Theorem rot_body_spec: forall hdr a ns v vs h c, - qrep hdr (a :: ns) (v :: vs) h -> - interp_state h_heapE (rot_body hdr) (h, c) - ~ (log (Pop v c) ;; - Ret (@inl unit unit tt, (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))). -Proof. - intros hdr a ns v vs h c Hq. - pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). - cbn in Hhd, Htl. - destruct Hch as (Ha & Hsa & Hch). - pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). - pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. - assert (Hhdrdom: h hdr <> None) by (rewrite Htl; discriminate). - assert (Hsadom: h (S a) <> None) by (rewrite Hsa; discriminate). - assert (Hshdrdom: h (S hdr) <> None) by (rewrite Hhd; discriminate). - assert (Hread_hdr: upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) - by (rewrite upd_neq by congruence; exact Htl). - unfold rot_body. - rewrite (interp_rd (S hdr) h c a _ Hhd). - rewrite (interp_rd a h c v _ Ha). - rewrite interp_emit. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite (interp_rd (S a) h (S c) (hdf ns 0) _ Hsa). - rewrite (interp_wr' (S hdr) h (S c) (hdf ns 0) _ Hshdrdom). - rewrite (interp_rd hdr (upd h (S hdr) (hdf ns 0)) (S c) (last (a :: ns) 0) _ Hread_hdr). - rewrite (zof_compute hdr a ns Hwf). - rewrite (interp_wr' (S (zof hdr ns)) _ (S c) a _ (upd_mono _ _ _ _ Hzdom)). - rewrite (interp_wr' (S a) _ (S c) 0 _ - (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom))). - rewrite (interp_wr' hdr _ (S c) a _ - (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom)))). - rewrite interp_state_ret. - reflexivity. -Qed. diff --git a/examples/CSL/QueueTests.v b/examples/CSL/QueueTests.v index 8d7cd82..70909d2 100644 --- a/examples/CSL/QueueTests.v +++ b/examples/CSL/QueueTests.v @@ -3,8 +3,8 @@ From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.State.Mod ICTree.Logic.Trans Logic.Core ICTree.Events.Yield ICTree.Interp.Yield.RoundRobin Utils.Vectors. -From examples Require Import - CSL.HeapQ CSL.Layout CSL.Frame CSL.Sep2 CSL.SLang CSL.Trace CSL.Program CSL.Queue. +From TICL Require Import Lang.CSL.Queue. +From examples Require Import CSL.Layout. Import ICtree ICTreeNotations TiclNotations VectorNotations ListNotations. Local Open Scope ictree_scope. @@ -28,7 +28,7 @@ Proof. Qed. Lemma demo_h1_owned : qrepX 2 [4;6] [7;9] demo_h1. -Proof. exact Frame.qrepX1. Qed. +Proof. exact Layout.qrepX1. Qed. Lemma demo_h2_owned : qrepX 10 [12] [8] demo_h2. Proof. @@ -120,8 +120,7 @@ Proof. (qstep v [d] (qstep u [b;a] (qstep v [d] (qstep u [a;b] h)))) 4). etransitivity. - - exact (run_rr_parallel_bisim u v x z h 0 [a;b] [x;y] [d] [z] 0 0 - H1 H2 Hd F1 F2). + - exact (run_rr_parallel_bisim u v h 0). - reference_turn H1. reference_turn H2a. reference_turn H1b. @@ -285,73 +284,6 @@ Lemma allocated_duplicate_queue2_fresh k : |= AG (AF visW {spopped_after 2 7 k}) )>. Proof. exact (rotate_agaf_pop_alloc_q2_fresh [7;7] [7] 7 7 k 0 0 0 eq_refl eq_refl). Qed. -Local Lemma interp_rr_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) - values (K : option nat -> thread sE) m c : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (hemp,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) - (Some i) m (new_queue_heap 1 values hemp,c). -Proof. - assert (Free : block_free hemp 1 (2 * S (length values))) - by (intros offset O; reflexivity). - assert (First : forall j, Nat.lt 0 j -> Nat.lt j 1 -> - ~ block_free hemp j (2 * S (length values))) by (intros; lia). - pose proof (sinterp_alloc_first hemp (2 * S (length values)) 1 c - (fun a : nat => (Ret a : ictree sE nat)) ltac:(lia) ltac:(lia) Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - unfold new_queue; rewrite interp_rr_bind, interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. - rewrite interp_rr_bind; etransitivity. - - apply interp_rr_init_queue; intros offset O. - unfold hunion; rewrite (hblock_in 1 (2 * S (length values)) offset O). - discriminate. - - rewrite interp_rr_ret; reflexivity. -Qed. - -Local Ltac probe_read value := - lazymatch goal with - | |- (interp_state sh (srd ?a) (?h,?c) >>= ?next) ~ _ => - let Hr := fresh "Hread" in - pose proof (sinterp_rd a h c value - (fun x : nat => (Ret x : ictree sE nat)) eq_refl) as Hr; - rewrite bind_ret_r, interp_state_ret in Hr; - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hr | intro result; reflexivity] |]; - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |] - end. - -Local Ltac probe_emit := - lazymatch goal with - | |- (interp_state sh (semit ?q ?v) (?h,?c) >>= ?next) ~ _ => - let He := fresh "Hemit" in - assert (He : interp_state sh (semit q v) (h,c) ~ - (log (SPop q v c);; Ret (tt,(h,S c)))) by - (let Hraw := fresh "Hraw" in - pose proof (sinterp_emit q v h c - (fun x : unit => (Ret x : ictree sE unit))) as Hraw; - rewrite bind_ret_r in Hraw; - etransitivity; [exact Hraw |]; - apply sbisim_clo_bind_eq; [reflexivity | intros []]; - rewrite interp_state_ret; reflexivity); - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact He | intro result; reflexivity] |]; - eapply equ_clos_sbisim_goal; [apply bind_bind | reflexivity |]; - apply sbisim_clo_bind_eq; [reflexivity | intros []]; - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |] - end. - -Local Ltac probe_finish := - cbv [Vector.replace Vector.caseS']; - erewrite interp_schedule_rr_ret by reflexivity; - rewrite vector_remove_head, interp_schedule_rr_empty; reflexivity. Definition initialized_queue_probe : CProg unit := CBind (new_queue [7;9]) (fun hdr => @@ -371,10 +303,11 @@ Proof. (Some Fin.F1) 0 (hemp,0) ~ (log (SPop 1 7 0);; Ret (tt,(new_queue_heap 1 [7;9] hemp,1)))). rewrite interp_rr_bind, interp_rr_new_queue_empty. - rewrite interp_rr_bind, interp_rr_read; probe_read 3. - rewrite interp_rr_bind, interp_rr_read; probe_read 7. - rewrite interp_rr_emit; probe_emit. - probe_finish. + rewrite interp_rr_bind, interp_rr_read_value with (value:=3) by reflexivity. + rewrite interp_rr_bind, interp_rr_read_value with (value:=7) by reflexivity. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + finish_pool. Qed. Definition empty_queue_probe : CProg unit := @@ -395,9 +328,10 @@ Proof. (Some Fin.F1) 0 (hemp,0) ~ (log (SPop 0 0 0);; Ret (tt,(new_queue_heap 1 [] hemp,1)))). rewrite interp_rr_bind, interp_rr_new_queue_empty. - rewrite interp_rr_bind, interp_rr_read; probe_read 0. - rewrite interp_rr_bind, interp_rr_read; probe_read 0. - rewrite interp_rr_emit; probe_emit. - probe_finish. + rewrite interp_rr_bind, interp_rr_read_value with (value:=0) by reflexivity. + rewrite interp_rr_bind, interp_rr_read_value with (value:=0) by reflexivity. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + finish_pool. Qed. diff --git a/examples/CSL/README.md b/examples/CSL/README.md index 742b62a..488ec4e 100644 --- a/examples/CSL/README.md +++ b/examples/CSL/README.md @@ -1,12 +1,43 @@ # Cooperative heap queues `TICL.Lang.CSL` is a typed cooperative fork/yield language over a disjoint heap -PCM. `Program.allocated_parallel_queues values1 values2` constructs two linked +PCM. `Lang.CSL.Queue.Program.allocated_parallel_queues values1 values2` constructs two linked queues by source execution on `hemp`, then starts their workers. The lower-level -`Program.parallel_queues u v` remains available for preallocated heaps. Both +`Lang.CSL.Queue.Program.parallel_queues u v` remains available for preallocated heaps. Both workers own **different queues in one shared heap**; they do not concurrently modify one queue, and the facade does not assert a general CSL parallel rule. +## Library ownership + +Import `Lang.CSL` for the language, interpreter, source segments, and structural +TICL matrix. Import `Lang.CSL.Queue` for the reusable queue development. The old +example-local implementation modules were moved, not retained as compatibility +re-export files. + +| Layer | Canonical reusable content | +| --- | --- | +| `ICTree.Trace` | Observation-polymorphic finite log prefixes, labeled finite steps, guarded prefix alignment | +| `ICTree.Logic.Trace` | Structural AF/AGAF rules for finite observation prefixes | +| `ICTree.Logic.Bind` | Five exact `*_log_iff` rules, shared by the CSL emit matrix | +| `ICTree.Logic.State` | Ghost-ranked `aul_state_iter_ghost` over arbitrary handlers | +| `ICTree.Interp.State.Mod` | Generic `interp_state_trigger_bind` normalization | +| `Utils.Relations` | One lexicographic construction, finite first-index search, interval counts, and infinite-occurrence facts | +| `Lang.CSL.Heap` | Checked heap laws shared by both observation alphabets | +| `Lang.CSL.Segments` | Exact and bisimilar first-yield segments, guard transport, arbitrary-pool ND/RR equations | +| `Lang.CSL.Queue` | Queue representation/layout, one polymorphic rotation implementation and proof, framing, composition, source programs, and recurrence | + +Concrete address layouts, overlap counterexamples, allocator-specific state +machines and their fairness/rank arguments, and regression consumers remain in +`examples/CSL`. No library module imports an example. The exact and bisimilar +segment judgments remain distinct; administrative guards are not replaced by +visible scheduler steps. + +Operational consumers use the public checked-operation normal forms instead of +local read/write/emit/allocation/CAS tactics. Temporal consumers use the source +matrix, log-prefix rules, and state-iteration rules. Queue recurrence shares the +same ghost-ranked rule with active queue composition; it does not reprove the +underlying fixed point. + ## Actual execution and proof boundary The source execution is: @@ -49,15 +80,15 @@ instructions, preserving fault behavior and the entire post-emit heap suffix. `queue_pool_bisim` matches both failed-read cases and takes its coinductive step at a real `Log (SPop ...)` transition, not at an administrative guard. `Program.run_rr_parallel_bisim` proves equivalence of the actual `run_rr` source -execution to the tagged cyclic reference. The reference alone is not the -implementation or evidence of source execution. +execution to the tagged cyclic reference for any heap, without unused queue +representation premises. The reference alone is not evidence of source execution. `Program.run_rr_allocated_parallel` proves that actual silent allocation and checked initialization from `hemp` reach a finite heap with two PCM-separated queues and the original worker execution, at the same observation counter. It also covers empty input lists. No initialized heap is assumed. -`Queue.v` exposes recurrence directly for +`Lang.CSL.Queue.Ticl` exposes recurrence directly for `run_rr (allocated_parallel_queues values1 values2) hemp c`: - `rotate_agaf_pop_alloc`: queue 1 ordinary recurrence. @@ -89,7 +120,16 @@ The canonical heap is `nat -> option nat`, with pointwise `heq`, pointwise support. `heap_finite` is an existential proof bound, not a new carrier or runtime field. `SSig` remains `(Heap * nat)%type`; results remain `(result, SSig)`. -`CAlloc size` uses `SAlloc` and a guarded, constructive search inside the shared +`Events.HeapE` supplies the single shared command algebra: `HRead`, `HWrite`, +`HAlloc`, `HFree`, and `HCAS`. `ICTree.Events.Heap` supplies the polymorphic +`heap_read`, `heap_write`, `heap_alloc`, `heap_free`, and `heap_cas` triggers. +Neither module imports a language, concrete heap, allocator, or observation type. +CSL uses `sE := heapE + writerE (nat * nat)`; QLang uses +`qE := heapE + writerE nat`. Their observation handlers are separate from the +shared checked `heap_handler`, whose allocation search is polymorphic in the +observation alphabet. + +`CAlloc size` uses `heap_alloc`/`HAlloc` and a guarded, constructive search inside the shared handler. It returns the least positive base whose entire interval is free and initializes exactly `size` cells to zero, preserving every old allocated value and address zero. It neither emits nor yields, and advances neither the @@ -101,8 +141,23 @@ infinite heap with no suitable interval silently diverges, as proved by Reads and writes remain checked; writes never allocate implicitly. Emit records `SPop tag value c`, preserves the heap, and increments the global observation -counter. The scheduler cursor is separate. There is no variable store, CAS, -lock, or implicit read/write yield. +counter. CAS faults on an absent cell, updates and returns `true` on a matching +value, and otherwise returns `false` without changing the heap. It does not log. +The scheduler cursor is separate. There is no variable store, lock, or implicit +read/write yield. + +`HFree a` removes exactly one cell via `Pcm.hfree`, without a presence check, +observation, or counter change. An absent free succeeds; a subsequent read of +that address faults. `free_local_frame` still requires ownership of the removed +cell. Physical free is available to raw CSL threads, not a new `CFree` syntax +constructor; the allocator example's `remote_free` remains CAS-based free-list +publication, not heap deletion. + +HeapImp lowers the same five commands to its existing `Get`/`Put` effects. +Its association-list policies remain different: writes may create a cell, +allocation starts at `fresh_addr` (zero on an empty heap), and allocation of zero +cells still performs `Put`. Writes, free of an absent cell, and successful CAS +including same-value CAS retain full-memory logging. Failed CAS does not `Put`. `qrep` reserves address zero through `h 0 = None`; the handler itself has no special address-zero check. Header `hdr` stores tail and `S hdr` stores head; @@ -116,6 +171,31 @@ disjointness and a frame that leaves address zero unallocated. uses `compose3` and pointwise footprint agreement; it does not equate heap functions by Leibniz equality. +## Structural temporal interface + +`From TICL Require Import Lang.CSL.` exports `Lang.CSL.Ticl`. Its 100 source rules +are the full name product +`{anl,anr,aul,aur,ag}_csl_{nd,rr}_{read,write,emit,yield,fork,ret,bind,until_none,alloc,cas}`. +They apply to arbitrary nonempty focused pools and continuations, not only queue +or allocator fixtures. Another 30 rules use suffixes `select`, `alloc_finite`, +and `heap_free`, giving 130 independently named equivalences. + +Silent rules transport the interpreted residual in the same world. Emit rules +keep the current-prefix obligation in the old world and place only the successor +in `Obs (Log (SPop tag value c)) tt`. ND yield checks every branch, including the +single branch of a singleton pool; RR yield selects `rr_pick n m` and advances +only the cursor. Fork prepends its child but keeps the parent focused. Bind and +until preserve the pool and the outer `None` halt flow. These rules assert no +fairness or unconditional loop termination. + +`interp_nd_source_` and `interp_rr_` expose the checked success and fault normal +forms in `Lang.CSL.Interp`; the promoted read/write helpers are public there. +Finite-allocation rules quantify over the first-fit witness supplied by +`heap_finite`, rather than requiring a caller-chosen address. Raw `heap_free` +rules take a `unit` continuation and preserve focus, pool size, cursor, counter, +and observation world. Fault rules compose with the generic stuck rules: +strong AN and AG are false, while AU may match its target immediately. + ## Runtime queue construction `new_queue values` allocates one block of `2 * S (length values)` cells, then @@ -146,50 +226,34 @@ Q = /home/eioannidis/ticl-sl/spark_submission/experiments/heap-backed-rotating-q S = /home/eioannidis/ticl-sl/spark_submission/experiments/separate-active-composition-from-unused-framing/proofs ``` -| Source | Destination | +| Source | Current owner | | --- | --- | | `P/Pcm.v`, complete | `theories/Lang/CSL/Pcm.v` | | `S/SLang.v`, heap prefix | `theories/Lang/CSL/Heap.v` | -| `Q/HeapQ.v` | `examples/CSL/HeapQ.v` | -| `Q/QLang.v` | `examples/CSL/QLang.v` | -| `Q/Recurrence.v` | `examples/CSL/Recurrence.v` | -| `Q/Trace.v` | `examples/CSL/Trace.v` | -| `Q/Layout.v` | `examples/CSL/Layout.v` | -| `Q/Frame.v` | `examples/CSL/Frame.v` | -| `S/Sep2.v` | `examples/CSL/Sep2.v` | -| `S/SLang.v`, imports/scopes and turn/scheduler suffix | `examples/CSL/SLang.v` | -| `S/Lex.v` | `examples/CSL/Lex.v` | -| `S/Compose.v` | `examples/CSL/Compose.v` | +| `Q/HeapQ.v` | `theories/Lang/CSL/Queue/Representation.v` | +| `Q/QLang.v` | `theories/Lang/CSL/Queue/Sequential.v`, shared `Operations.v` | +| `Q/Recurrence.v` | `theories/Lang/CSL/Queue/Recurrence.v`, `ICTree/Logic/State.v`, `Utils/Relations.v` | +| `Q/Trace.v` | `theories/Lang/CSL/Queue/Trace.v` | +| `Q/Layout.v` | `theories/Lang/CSL/Queue/Layout.v`; concrete fixtures in `examples/CSL/Layout.v` | +| `Q/Frame.v` | `theories/Lang/CSL/Queue/Frame.v` | +| `S/Sep2.v` | `theories/Lang/CSL/Queue/Separation.v` | +| `S/SLang.v`, turn/scheduler suffix | `theories/Lang/CSL/Queue/Alternating.v`, shared `Operations.v` | +| `S/Lex.v` | `theories/Utils/Relations.v` | +| `S/Compose.v` | `theories/Lang/CSL/Queue/Composition.v` | | `Q/Overlap.v` | `examples/CSL/Overlap.v` | -The transformations were: - -- Preserve all of `Pcm.v`, including proofs and transparent `HeapPCM`. -- Extract `Heap.v` from `From Stdlib Require Import` up to, excluding, - `(** ** A turn:`. Replace its `HQ.HeapQ` import with an export of canonical - `Pcm` and the boolean `upd` definition; add no `hdom` alias. Only Pcm is - exported. Add write-none, continuation-free fault, and pointwise update - agreement proofs in this owning heap layer. -- In `HeapQ.v`, replace the span from `Definition Heap :=` up to `Lemma upd_eq:` - with `From TICL Require Export Lang.CSL.Heap.`. This removes the duplicate - foundation and unused local points-to definition, retaining all queue proofs, - including `rot_detach_split` and both `rot_heap_spec` conjuncts. -- Rewrite old `ICTree.Interp.State` imports to `.State.Mod`, and `From HQ Require - Import/Export ...` to `From examples Require Import/Export CSL....`, preserving - the import/export distinction. -- For the example `SLang.v`, retain donor imports/scopes before the observation - alphabet and the suffix beginning `(** ** A turn:`. Export canonical Heap and - import CSL.HeapQ rather than duplicating events or handlers. Append its own - `turnk_bind` and `srun_turn` proofs; it imports neither the source program nor - the round-robin policy. -- Keep `Layout.hsingle` private to that layout and qualify Overlap's definitions - and unfolds with `Layout.hsingle`. PCM tests use `Pcm.hsingle`. +The initial donor integration preserved the resource and observable contracts. +The current library cutover consolidates the duplicated heap handlers, rotation +programs/proofs, lexicographic induction, finite search, trace algebra, and +source-constructor normalization. `Pcm.hsingle`, `cellsat`, and the PCM framing +laws have one owning heap layer. The queue model retains `rot_detach_split` and +both `rot_heap_spec` conjuncts; no ownership premise was dropped from framing. No `Layout2.v`, frozen donor TICL installation, or older exact-domain heap donor -was used. `QLang` remains the distinct untagged sequential reference required by -the inherited proof chain. `SLang.sbody` alternates `turnk 1 u` and `turnk 2 v` -according to parity and increments its iteration index; `srun` interprets that -cyclic reference with the tagged handler. +was used. `Queue.Sequential` retains the untagged sequential observation +alphabet; `Queue.Alternating.sbody` alternates `turnk 1 u` and `turnk 2 v` +according to parity. Both instantiate `Queue.Operations.queue_turn` and +`queue_turn_spec`, so their memory operations and resource proof have one owner. The new refiner's modulo-counter mechanism follows the read-only provenance `git show 161d1eadedb7479b162fcde688e750b3a45ae37e:theories/Interp/Refine.v`. @@ -202,7 +266,7 @@ donor dependency and changes no generic scheduler or refiner API. ## Behavioral verification -The six retained regression modules compile: +The existing operational regression modules and the shared-event/temporal suites compile: - `PcmTests`: same-cell and overlapping-block ownership exclusion, distinct-cell separation, and the actual fresh-block split beside an unchanged points-to frame. @@ -227,6 +291,26 @@ The six retained regression modules compile: `[]` and `[8]` succeeds, but the first worker then faults on its null payload read; that execution is `stuck` and fails queue-1 recurrence. Sequential controls are not claims about arbitrary concurrent pools. +- `examples/HeapEventTests`: allocation/free/reallocation through shared triggers, + single-cell deletion with a surviving block cell and frame, absent free, + checked read-after-free, all 15 trigger embeddings, and the distinct HeapImp + zero-allocation/write/free/CAS instrumentation policies. +- `TiclTests`: 23 temporal consumers using the new structural cells, including + first-fit and finite allocation, shared write/CAS ordering, scoped child halt, + universal ND versus cursor-dependent RR selection, productive and silent loops, + strong termination/fault controls, immediate AU matching, and one-step raw free + completion. Final heap postconditions use pointwise `heq`. + +The shared-event and structural-rule extension passed its event-only, backend, +interpreter/helper, temporal-interface, and consumer compilation gates, followed +by `dune build`. All 130 public names were individually checked after importing +only the `Lang.CSL` umbrella. The current focused checks are: + +```sh +dune build _build/default/examples/HeapEventTests.vo \ + _build/default/examples/CSL/TiclTests.vo +dune build +``` The initial baseline, every dependency gate, and the final `make build` passed. The allocation extension rejected both requested temporary mutations with @@ -263,6 +347,23 @@ The changed `.v` files contain no `Admitted`, `admit`, `Axiom`, `Parameter`, `Classical`, or choice declaration. Imports were checked for obsolete State paths, HQ dependencies, donor runtime paths, and layer violations. +The structural-rule audit separately checked `anl_csl_nd_yield`, +`anr_csl_rr_emit`, `aul_csl_nd_until_none`, `aur_csl_rr_cas`, +`ag_csl_rr_until_none`, `aur_csl_nd_alloc_finite`, `ag_csl_rr_alloc_finite`, +`anr_csl_nd_heap_free`, `ag_csl_rr_heap_free`, `nd_emit_loop_ag`, and +`rr_emit_loop_ag` through `rocq_assumptions`. Each reports only the inherited +`FunctionalExtensionality.functional_extensionality_dep` and +`Eqdep.Eq_rect_eq.eq_rect_eq`. No new axiom or unfinished proof command was +introduced; the new heap postconditions do not identify functions by +functional extensionality. + +The library extraction audit found `Utils.Relations.finite_first` closed under +the global context. `ICTree.Logic.State.aul_state_iter_ghost` and +`ICTree.Trace.rr_aligned_sbisim` use only inherited UIP. The generalized +`Lang.CSL.Segments.source_segment_scheduler_steps` uses inherited UIP and +dependent functional extensionality. Boolean-observation smoke proofs exercise +the promoted trace and AF-return rules independently of `SObs`. + The previously recorded baseline `examples.Queue.Queue.rotate_agaf_pop` prints: ```text diff --git a/examples/CSL/TiclTests.v b/examples/CSL/TiclTests.v new file mode 100644 index 0000000..79a6f0a --- /dev/null +++ b/examples/CSL/TiclTests.v @@ -0,0 +1,784 @@ +From Stdlib Require Import Arith.PeanoNat Lia Fin Vector Program.Equality. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import + Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Events.Yield ICTree.Events.Heap + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin + ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG + ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep + Logic.Core Utils.Vectors. +From examples Require Import CSL.InterpTests. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. + +Local Definition allocate_then_emit : CProg unit := + CBind (CAlloc 2) (fun base => CEmit 9 base). + +(** Allocation is silent; its emission and final return are distinct steps. *) + +Lemma rr_alloc_first_fit_ticl : + <[ {run_rr allocate_then_emit (Pcm.hsingle 2 99) 5}, Pure |= + AX (AX done {fun result w => + heq (fst (snd result)) (hunion (hblock 3 2) (Pcm.hsingle 2 99)) /\ + snd (snd result) = 6 /\ w = Obs (Log (SPop 9 3 5)) tt}) ]>. +Proof. + assert (Free : block_free (Pcm.hsingle 2 99) 3 2) + by (apply block_freeb_spec; reflexivity). + assert (First : forall j, Nat.lt 0 j -> Nat.lt j 3 -> + ~ block_free (Pcm.hsingle 2 99) j 2). + { intros j J L F; assert (j = 1 \/ j = 2) by lia. + destruct H; subst j; + [specialize (F 1 ltac:(lia)) | specialize (F 0 ltac:(lia))]; discriminate F. } + unfold run_rr. + change [denote allocate_then_emit]%vector with + ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). + unfold allocate_then_emit. + rewrite anr_csl_rr_bind. + rewrite anr_csl_rr_alloc with (base:=3) by (try lia; assumption). + rewrite anr_csl_rr_emit. + split. + - apply ticll_top; constructor. + - cbn beta iota. + erewrite interp_schedule_rr_ret by source_observe. + pool_simpl; rewrite vector_remove_head, interp_schedule_rr_empty. + apply axr_ret; [constructor |]. + cbn; split; [intro address; reflexivity | split; reflexivity]. +Qed. + +Lemma nd_alloc_finite_observed h c : heap_finite h -> + <( {run_nd allocate_then_emit h c}, Pure |= + AF (visW {fun o => stag o = 9 /\ sidx o = c /\ Nat.lt 0 (sval o)}) )>. +Proof. + intro Finite; unfold run_nd. + change [denote allocate_then_emit]%vector with + ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). + unfold allocate_then_emit. + rewrite aul_csl_nd_bind. + rewrite aul_csl_nd_alloc_finite by (try assumption; lia). + intros base Base Free First. + rewrite aul_csl_nd_emit. + right; split. + - apply ticll_top; constructor. + - cleft; apply ticll_vis; constructor; cbn; repeat split; auto. +Qed. + +Lemma rr_alloc_finite_observed h c : heap_finite h -> + <( {run_rr allocate_then_emit h c}, Pure |= + AF (visW {fun o => stag o = 9 /\ sidx o = c /\ Nat.lt 0 (sval o)}) )>. +Proof. + intro Finite; unfold run_rr. + change [denote allocate_then_emit]%vector with + ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). + unfold allocate_then_emit. + rewrite aul_csl_rr_bind. + rewrite aul_csl_rr_alloc_finite by (try assumption; lia). + intros base Base Free First. + rewrite aul_csl_rr_emit. + right; split. + - apply ticll_top; constructor. + - cleft; apply ticll_vis; constructor; cbn; repeat split; auto. +Qed. + +(** Shared-state scheduling and scoped source continuations. *) + +Lemma rr_shared_write_ticl : + <[ {run_rr shared_write_program (Pcm.hsingle 4 0) 0}, Pure |= + AF (AX done {fun result w => + heq (fst (snd result)) (upd (Pcm.hsingle 4 0) 4 9) /\ + snd (snd result) = 1 /\ w = Obs (Log (SPop 2 9 0)) tt}) ]>. +Proof. + unfold run_rr. + change [denote shared_write_program]%vector with + ([Ret tt]%vector @ Fin.F1 := (denote_flow shared_write_program >>= fun _ => Ret tt)). + unfold shared_write_program. + rewrite aur_csl_rr_bind, aur_csl_rr_fork. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([denote (CBind (CRead 4) (fun v => CEmit 2 v)); Ret tt]%vector + @ Fin.FS Fin.F1 := + (denote_flow (CBind (CWrite 4 9) (fun _ => CYield)) >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (Pcm.hsingle 4 0,0)}, Pure |= {formula} ]>) end. + rewrite aur_csl_rr_bind. + rewrite aur_csl_rr_write by discriminate. + rewrite aur_csl_rr_yield. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([Ret tt; Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CRead 4) (fun v => CEmit 2 v)) >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (upd (Pcm.hsingle 4 0) 4 9,0)}, Pure |= {formula} ]>) end. + rewrite aur_csl_rr_bind. + rewrite aur_csl_rr_read with (value:=9) by apply upd_eq. + rewrite aur_csl_rr_emit. + right; split. + - apply ticll_top; constructor. + - cleft. + repeat first + [ progress pool_simpl + | rewrite vector_remove_head + | rewrite vector_remove_tail + | erewrite interp_schedule_rr_ret by source_observe + | rewrite interp_schedule_rr_select + | rewrite interp_schedule_rr_empty ]. + apply axr_ret; [constructor |]. + cbn; split; [intro address; reflexivity | split; reflexivity]. +Qed. + +Lemma rr_shared_cas_ticl : + <[ {run_rr shared_cas_program hemp 0}, Pure |= + AX ({<( visW {fun o => o = SPop 10 1 0} )>} AN + (AX done {fun result w => + heq (fst (snd result)) (upd (hunion (hblock 1 1) hemp) 1 10) /\ + snd (snd result) = 2 /\ w = Obs (Log (SPop 20 0 1)) tt})) ]>. +Proof. + unfold run_rr. + change [denote shared_cas_program]%vector with + ([Ret tt]%vector @ Fin.F1 := (denote_flow shared_cas_program >>= fun _ => Ret tt)). + unfold shared_cas_program. + rewrite anr_csl_rr_bind. + rewrite anr_csl_rr_alloc with (base:=1) by + (try lia; apply block_freeb_spec; reflexivity). + rewrite anr_csl_rr_bind, anr_csl_rr_fork. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([denote (CBind (CCAS 1 0 20) (fun won => CEmit 20 (if won then 1 else 0))); Ret tt]%vector + @ Fin.FS Fin.F1 := + (denote_flow (CBind (CCAS 1 0 10) (fun won => + CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))) >>= fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) 0 (hunion (hblock 1 1) hemp,0)}, Pure |= {formula} ]>) end. + rewrite anr_csl_rr_bind. + rewrite anr_csl_rr_cas with (current:=0) by reflexivity. + cbn [Nat.eqb]. + rewrite anr_csl_rr_bind, anr_csl_rr_emit. + split. + - apply ticll_top; constructor. + - rewrite anr_csl_rr_yield. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([Ret tt; Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CCAS 1 0 20) (fun won => + CEmit 20 (if won then 1 else 0))) >>= fun _ => Ret tt)) + (Some Fin.F1) 1 (upd (hunion (hblock 1 1) hemp) 1 10,1)}, + {Obs (Log (SPop 10 1 0)) tt} |= {formula} ]>) end. + rewrite anr_csl_rr_bind. + rewrite anr_csl_rr_cas with (current:=10) by apply upd_eq. + cbn [Nat.eqb]. + rewrite anr_csl_rr_emit. + split. + + apply ticll_vis; constructor; reflexivity. + + repeat first + [ progress pool_simpl + | rewrite vector_remove_head + | rewrite vector_remove_tail + | erewrite interp_schedule_rr_ret by source_observe + | rewrite interp_schedule_rr_select + | rewrite interp_schedule_rr_empty ]. + apply axr_ret; [constructor |]. + cbn; split; [intro address; reflexivity | split; reflexivity]. +Qed. + +Lemma rr_scoped_child_ticl : + <[ {run_rr scoped_child_program hemp 0}, Pure |= + AX ({<( visW {fun o => o = SPop 1 10 0} )>} AN + ({<( visW {fun o => o = SPop 1 11 1} )>} AN + (AX done {fun result w => heq (fst (snd result)) hemp /\ + snd (snd result) = 3 /\ w = Obs (Log (SPop 2 20 2)) tt}))) ]>. +Proof. + set (body := CBind (CFork (CEmit 2 20)) + (fun _ => CBind (CEmit 1 10) (fun _ => CRet (None : option unit)))). + set (haltk := fun _ : option unit => (Ret tt : thread sE)). + set (after := fun r : option unit => + match r with None => haltk None | Some _ => denote_flow (CEmit 1 11) >>= haltk end). + set (next := until_tail body after). + unfold run_rr, scoped_child_program. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CUntilNone body) (fun _ => CEmit 1 11)) >>= haltk)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= {formula} ]>) end. + rewrite anr_csl_rr_bind, anr_csl_rr_until_none. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := (denote_flow body >>= next)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= {formula} ]>) end. + unfold body at 1; rewrite anr_csl_rr_bind, anr_csl_rr_fork. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CBind (CEmit 1 10) (fun _ => CRet (None : option unit))) >>= next)) + (Some (Fin.FS Fin.F1)) 0 (hemp,0)}, Pure |= {formula} ]>) end. + rewrite anr_csl_rr_bind, anr_csl_rr_emit. + split. + - apply ticll_top; constructor. + - rewrite anr_csl_rr_ret. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 2 + ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := + (denote_flow (CEmit 1 11) >>= haltk)) + (Some (Fin.FS Fin.F1)) 0 (hemp,1)}, + {Obs (Log (SPop 1 10 0)) tt} |= {formula} ]>) end. + rewrite anr_csl_rr_emit. + split. + + apply ticll_vis; constructor; reflexivity. + + erewrite interp_schedule_rr_ret by source_observe. + pool_simpl; rewrite vector_remove_tail, vector_remove_head. + rewrite anr_csl_rr_select. + lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => + change (<[ {interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 20) >>= haltk)) + (Some Fin.F1) 1 (hemp,2)}, + {Obs (Log (SPop 1 11 1)) tt} |= {formula} ]>) end. + rewrite anr_csl_rr_emit. + split. + * apply ticll_vis; constructor; reflexivity. + * erewrite interp_schedule_rr_ret by source_observe. + pool_simpl; rewrite vector_remove_head, interp_schedule_rr_empty. + apply axr_ret; [constructor |]. + cbn; split; [intro address; reflexivity | split; reflexivity]. +Qed. + +(** Universal ND choices versus cursor-dependent round-robin choices. *) + +Local Definition choice_good : CProg unit := CEmit 1 7. +Local Definition choice_bad : CProg unit := + CBind (CRead 99) (fun _ => CEmit 2 9). + +Lemma nd_yield_bad_successor : + ~ <( {interp_nd 2 + ([Ret tt; denote choice_bad] @ Fin.F1 := + (denote_flow CYield >>= fun _ => denote choice_good)) + (Some Fin.F1) (hemp,0)}, + Pure |= AX (AF (visW {fun _ => True})) )>. +Proof. + intro H. + apply anl_csl_nd_yield in H. + destruct H as [_ Hnext]. + specialize (Hnext (Fin.FS Fin.F1)). + change <( {interp_nd 2 + ([denote choice_good; Ret tt] @ Fin.FS Fin.F1 := + (denote_flow (CBind (CRead 99) (fun _ => CEmit 2 9)) >>= + fun _ => Ret tt)) + (Some (Fin.FS Fin.F1)) (hemp,0)}, + Pure |= AF (visW {fun _ => True}) )> in Hnext. + apply (proj1 (aul_csl_nd_bind 1 [denote choice_good; Ret tt] + (Fin.FS Fin.F1) (CRead 99) (fun _ => CEmit 2 9) + (fun _ => Ret tt) hemp 0 Pure + <( ⊤ )> <( visW {fun _ => True} )>)) in Hnext. + pose proof (interp_nd_source_read_missing 1 [denote choice_good; Ret tt] + (Fin.FS Fin.F1) 99 + (fun flow => match flow with + | None => Ret tt + | Some _ => denote_flow (CEmit 2 9);; Ret tt + end) + hemp 0 eq_refl) as Hmissing. + rewrite Hmissing in Hnext. + apply aul_stuck in Hnext. + apply ticll_vis in Hnext. + inversion Hnext. +Qed. + +Lemma nd_yield_all_emit : + <( {interp_nd 2 + ([Ret tt; denote (CEmit 2 9)] @ Fin.F1 := + (denote_flow CYield >>= fun _ => denote choice_good)) + (Some Fin.F1) (hemp,0)}, + Pure |= AX (AF (visW {fun _ => True})) )>. +Proof. + apply (proj2 (anl_csl_nd_yield 1 [Ret tt; denote (CEmit 2 9)] Fin.F1 + (fun _ => denote choice_good) hemp 0 Pure + <( ⊤ )> <( AF (visW {fun _ => True}) )>)). + split. + - apply ticll_top; constructor. + - intro j; dependent destruction j. + + apply (proj2 (aul_csl_nd_emit 1 [Ret tt; denote (CEmit 2 9)] Fin.F1 + 1 7 (fun _ => Ret tt) hemp 0 Pure + <( ⊤ )> <( visW {fun _ => True} )>)). + right; split. + * apply ticll_top; constructor. + * cleft. apply ticll_vis; constructor; exact I. + + dependent destruction j. + * apply (proj2 (aul_csl_nd_emit 1 [denote choice_good; Ret tt] + (Fin.FS Fin.F1) 2 9 (fun _ => Ret tt) hemp 0 Pure + <( ⊤ )> <( visW {fun _ => True} )>)). + right; split. + -- apply ticll_top; constructor. + -- cleft. apply ticll_vis; constructor; exact I. + * inversion j. +Qed. + +Lemma rr_yield_cursor0_observed : + <( {interp_schedule_rr sh 2 + ([Ret tt; denote choice_bad] @ Fin.F1 := + (denote_flow CYield >>= fun _ => denote choice_good)) + (Some Fin.F1) 0 (hemp,0)}, + Pure |= AX (visW {fun o => o = SPop 1 7 0}) )>. +Proof. + apply (proj2 (anl_csl_rr_yield 1 [Ret tt; denote choice_bad] Fin.F1 + (fun _ => denote choice_good) 0 hemp 0 Pure + <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)). + apply (proj2 (anl_csl_rr_emit 1 [Ret tt; denote choice_bad] Fin.F1 + 1 7 (fun _ => Ret tt) 1 hemp 0 Pure + <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)). + split. + - apply ticll_top; constructor. + - apply ticll_vis; constructor; reflexivity. +Qed. + +Lemma rr_yield_cursor1_blocked : + ~ <( {interp_schedule_rr sh 2 + ([Ret tt; denote choice_bad] @ Fin.F1 := + (denote_flow CYield >>= fun _ => denote choice_good)) + (Some Fin.F1) 1 (hemp,0)}, + Pure |= AX (visW {fun o => o = SPop 1 7 0}) )>. +Proof. + intro H. + apply (proj1 (anl_csl_rr_yield 1 [Ret tt; denote choice_bad] Fin.F1 + (fun _ => denote choice_good) 1 hemp 0 Pure + <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)) in H. + apply (proj1 (anl_csl_rr_bind 1 [denote choice_good; Ret tt] + (Fin.FS Fin.F1) (CRead 99) (fun _ => CEmit 2 9) + (fun _ => Ret tt) 2 hemp 0 Pure + <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)) in H. + pose proof (interp_rr_read_missing 1 [denote choice_good; Ret tt] + (Fin.FS Fin.F1) 99 + (fun flow => match flow with + | None => Ret tt + | Some _ => denote_flow (CEmit 2 9);; Ret tt + end) + 2 hemp 0 eq_refl) as Hmissing. + rewrite Hmissing in H. + exact (anl_stuck H). +Qed. + +(** Actual observations sustain AG; guard-only divergence does not. *) + +Theorem nd_emit_loop_ag : + <( {run_nd + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + hemp 0}, Pure |= AG ⊤ )>. +Proof. + assert (Hproductive : forall c w, not_done w -> + <( {run_nd + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + hemp c}, {w} |= AG ⊤ )>). + { + coinduction R CIH; intros c w Hw. + unfold run_nd, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_nd 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,c)) w). + rewrite interp_nd_source_until_none, interp_nd_source_bind, + interp_nd_source_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_nd_source_ret. + erewrite interp_nd_guard by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. + } + unfold run_nd, denote. + change <( {interp_nd 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,0)}, Pure |= AG ⊤ )>. + rewrite ag_csl_nd_until_none, ag_csl_nd_bind, ag_csl_nd_emit. + split. + - split; constructor. + - rewrite ag_csl_nd_ret. + erewrite interp_nd_guard by reflexivity. + cbn [Vector.replace]. + apply Hproductive. + constructor. +Qed. + +Theorem rr_emit_loop_ag : + <( {run_rr + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + hemp 0}, Pure |= AG ⊤ )>. +Proof. + assert (Hproductive : forall c w, not_done w -> + <( {run_rr + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + hemp c}, {w} |= AG ⊤ )>). + { + coinduction R CIH; intros c w Hw. + unfold run_rr, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_schedule_rr sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,c)) w). + rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_rr_ret. + erewrite interp_schedule_rr_guard by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. + } + unfold run_rr, denote. + change <( {interp_schedule_rr sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= AG ⊤ )>. + rewrite ag_csl_rr_until_none, ag_csl_rr_bind, ag_csl_rr_emit. + split. + - split; constructor. + - rewrite ag_csl_rr_ret. + erewrite interp_schedule_rr_guard by reflexivity. + cbn [Vector.replace]. + apply Hproductive. + constructor. +Qed. + +Theorem nd_silent_loop_no_ag : + ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) hemp 0}, + Pure |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { + unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. + } + assert (Hguard : run_nd p hemp 0 ≅ Guard (run_nd p hemp 0)). + { + unfold run_nd. + etransitivity. + - apply (interp_nd_equ 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; + [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_nd. + rewrite (SBisim.trans_schedule_focused_guard + 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, Mod.interp_state_tau. + reflexivity. + } + assert (Hstuck : run_nd p hemp 0 ≅ + (stuck : ictreeW SObs (unit * SSig))). + { + unfold equ. + coinduction R CIH. + rewrite Hguard, unfold_stuck. + constructor. + exact CIH. + } + rewrite Hstuck. + apply ag_stuck. +Qed. + +Theorem rr_silent_loop_no_ag : + ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) hemp 0}, + Pure |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { + unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. + } + assert (Hguard : run_rr p hemp 0 ≅ Guard (run_rr p hemp 0)). + { + unfold run_rr. + etransitivity. + - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; + [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_schedule_rr. + rewrite unfold_run_round_robin, + (schedule_focused_guard + 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, Mod.interp_state_tau. + reflexivity. + } + assert (Hstuck : run_rr p hemp 0 ≅ + (stuck : ictreeW SObs (unit * SSig))). + { + unfold equ. + coinduction R CIH. + rewrite Hguard, unfold_stuck. + constructor. + exact CIH. + } + rewrite Hstuck. + apply ag_stuck. +Qed. + +(** Termination, faults, immediate until matching, and physical deletion. *) + +Lemma rr_ret_next_done : + <[ {run_rr (CRet tt) hemp 0}, Pure |= AX done {fun _ _ => True} ]>. +Proof. + unfold run_rr, denote. + change (<[ {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CRet tt) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= AX done {fun _ _ => True} ]>). + apply (proj2 (anr_csl_rr_ret 0 [Ret tt]%vector Fin.F1 tt + (fun _ => Ret tt) 0 hemp 0 Pure _ _)). + pose proof (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 + (hemp,0) eq_refl) as Hret. + cbn in Hret. + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ Hret _ _ eq_refl)). + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ + (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). + apply axr_ret; [constructor | exact I]. +Qed. + +Lemma rr_ret_no_prefix_next : + ~ <( {run_rr (CRet tt) hemp 0}, Pure |= AX ⊤ )>. +Proof. + unfold run_rr, denote. + change (not <( {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CRet tt) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= AX ⊤ )>). + rewrite anl_csl_rr_ret. + intro H. + apply (@anl_ret (writerE SObs) _ (unit * SSig) (tt,(hemp,0)) + Pure <[⊤]> <[⊤]>). + eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ + (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). + eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ + (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 + (hemp,0) eq_refl) _ _ eq_refl)). + exact H. +Qed. + +Lemma rr_ret_no_ag : + ~ <( {run_rr (CRet tt) hemp 0}, Pure |= AG ⊤ )>. +Proof. + unfold run_rr, denote. + change (not <( {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CRet tt) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0)}, Pure |= AG ⊤ )>). + rewrite ag_csl_rr_ret. + intro H. + apply (@ag_ret (writerE SObs) _ (unit * SSig) (tt,(hemp,0)) Pure <(⊤)>). + eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ + (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). + eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ + (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 + (hemp,0) eq_refl) _ _ eq_refl)). + exact H. +Qed. + + +Lemma nd_fault_controls : + (not <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_nd (CWrite 1 9) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_nd (CWrite 1 9) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_nd (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_nd (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_nd (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_nd (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_nd (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AX ⊤ )> /\ + not <( {run_nd (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AG ⊤ )>). +Proof. + assert (Hcontrol : forall t : ictreeW SObs (unit * SSig), t ~ (stuck : ictreeW SObs (unit * SSig)) -> + (not <( {t}, Pure |= AX ⊤ )> /\ not <( {t}, Pure |= AG ⊤ )>)). + { intros t Hstuck; split; intro H. + - apply (@anl_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)> <(⊤)>). + exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ Hstuck _ _ eq_refl) H). + - apply (@ag_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)>). + exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ Hstuck _ _ eq_refl) H). } + split; [apply Hcontrol |]. + - unfold run_nd, denote. + change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CRead 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_nd_source_bind. + apply interp_nd_source_read_missing; reflexivity. + - split; [apply Hcontrol |]. + + unfold run_nd, denote. + change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CWrite 1 9) >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + apply interp_nd_source_write_missing; reflexivity. + + split; [apply Hcontrol |]. + * unfold run_nd, denote. + change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CCAS 1 0 9) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_nd_source_bind. + apply interp_nd_source_cas_missing; reflexivity. + * split; apply Hcontrol. + -- unfold run_nd, denote. + change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 0) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_nd_source_bind. + apply interp_nd_source_alloc_zero. + -- unfold run_nd, denote. + change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) ((fun _ => Some 7),0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_nd_source_bind. + apply interp_nd_source_alloc_no_space; [lia |]. + intros base Positive Free. + specialize (Free 0 ltac:(lia)); discriminate. +Qed. + +Lemma rr_fault_controls : + (not <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_rr (CWrite 1 9) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_rr (CWrite 1 9) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_rr (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_rr (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_rr (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ + not <( {run_rr (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ + (not <( {run_rr (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AX ⊤ )> /\ + not <( {run_rr (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AG ⊤ )>). +Proof. + assert (Hcontrol : forall t : ictreeW SObs (unit * SSig), t ~ (stuck : ictreeW SObs (unit * SSig)) -> + (not <( {t}, Pure |= AX ⊤ )> /\ not <( {t}, Pure |= AG ⊤ )>)). + { intros t Hstuck; split; intro H. + - apply (@anl_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)> <(⊤)>). + exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ Hstuck _ _ eq_refl) H). + - apply (@ag_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)>). + exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ Hstuck _ _ eq_refl) H). } + split; [apply Hcontrol |]. + - unfold run_rr, denote. + change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CRead 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_rr_bind. + apply interp_rr_read_missing; reflexivity. + - split; [apply Hcontrol |]. + + unfold run_rr, denote. + change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CWrite 1 9) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + apply interp_rr_write_missing; reflexivity. + + split; [apply Hcontrol |]. + * unfold run_rr, denote. + change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CCAS 1 0 9) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_rr_bind. + apply interp_rr_cas_missing; reflexivity. + * split; apply Hcontrol. + -- unfold run_rr, denote. + change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 0) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_rr_bind. + apply interp_rr_alloc_zero. + -- unfold run_rr, denote. + change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CAlloc 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 ((fun _ => Some 7),0) ~ (stuck : ictreeW SObs (unit * SSig))). + rewrite interp_rr_bind. + apply interp_rr_alloc_no_space; [lia |]. + intros base Positive Free. + specialize (Free 0 ltac:(lia)); discriminate. +Qed. + +Lemma nd_stuck_until_now : + <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= ⊤ AU pure )>. +Proof. + cleft. apply ticll_pure; reflexivity. +Qed. + +Lemma rr_stuck_until_now : + <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= ⊤ AU pure )>. +Proof. + cleft. apply ticll_pure; reflexivity. +Qed. + + +Lemma nd_heap_free_next_done : + <[ {interp_nd 1 [heap_free (E:=CEff) 1;; Ret tt]%vector + (Some Fin.F1) (Pcm.hsingle 1 9,7)}, Pure |= + AX done {fun r w => snd (snd r) = 7 /\ + heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>. +Proof. + change (<[ {interp_nd 1 ([Ret tt]%vector @ Fin.F1 := + (heap_free (E:=CEff) 1 >>= fun _ => Ret tt)) + (Some Fin.F1) (Pcm.hsingle 1 9,7)}, Pure |= + AX done {fun r w => snd (snd r) = 7 /\ + heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>). + apply (proj2 (anr_csl_nd_heap_free 0 [Ret tt]%vector Fin.F1 1 + (fun _ => Ret tt) (Pcm.hsingle 1 9) 7 Pure _ _)). + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ + (interp_nd_ret 0 [Ret tt]%vector Fin.F1 + (Pcm.hfree 1 (Pcm.hsingle 1 9),7) eq_refl) _ _ eq_refl)). + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ + (interp_nd_empty (Pcm.hfree 1 (Pcm.hsingle 1 9),7)) _ _ eq_refl)). + apply axr_ret; [constructor |]. + split; [reflexivity |]. split; [apply heq_refl | reflexivity]. +Qed. + +Lemma rr_heap_free_next_done : + <[ {interp_schedule_rr sh 1 [heap_free (E:=CEff) 1;; Ret tt]%vector + (Some Fin.F1) 0 (Pcm.hsingle 1 9,7)}, Pure |= + AX done {fun r w => snd (snd r) = 7 /\ + heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>. +Proof. + change (<[ {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := + (heap_free (E:=CEff) 1 >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (Pcm.hsingle 1 9,7)}, Pure |= + AX done {fun r w => snd (snd r) = 7 /\ + heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>). + apply (proj2 (anr_csl_rr_heap_free 0 [Ret tt]%vector Fin.F1 1 + (fun _ => Ret tt) 0 (Pcm.hsingle 1 9) 7 Pure _ _)). + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ + (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 + (Pcm.hfree 1 (Pcm.hsingle 1 9),7) eq_refl) _ _ eq_refl)). + eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ + (@KripkeSetoidSBisim _ _ _) _ _ _ + (interp_schedule_rr_empty sh 0 (Pcm.hfree 1 (Pcm.hsingle 1 9),7)) _ _ eq_refl)). + apply axr_ret; [constructor |]. + split; [reflexivity |]. split; [apply heq_refl | reflexivity]. +Qed. diff --git a/examples/HeapEventTests.v b/examples/HeapEventTests.v new file mode 100644 index 0000000..df1b5b2 --- /dev/null +++ b/examples/HeapEventTests.v @@ -0,0 +1,201 @@ +From TICL Require Import ICTree.Events.Heap. + +(* Raw command clients require no language-specific module. *) +Check (heap_read (E:=heapE)). +Check (heap_write (E:=heapE)). +Check (heap_alloc (E:=heapE)). +Check (heap_free (E:=heapE)). +Check (heap_cas (E:=heapE)). + +From Stdlib Require Import Arith.PeanoNat Lia List. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Heap ICTree.Events.Writer ICTree.Interp.State.Mod + Lang.CSL.Heap Lang.CSL.Denote Lang.HeapImp. +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. +Module HI := TICL.Lang.HeapImp.HeapImp. + +Check (heap_read (E:=(heapE + writerE nat)%type) : + nat -> ictree (heapE + writerE nat) nat). +Check (heap_write (E:=(heapE + writerE nat)%type) : + nat -> nat -> ictree (heapE + writerE nat) unit). +Check (heap_alloc (E:=(heapE + writerE nat)%type) : + nat -> ictree (heapE + writerE nat) nat). +Check (heap_free (E:=(heapE + writerE nat)%type) : + nat -> ictree (heapE + writerE nat) unit). +Check (heap_cas (E:=(heapE + writerE nat)%type) : + nat -> nat -> nat -> ictree (heapE + writerE nat) bool). + +Check (heap_read (E:=CEff) : nat -> ictree CEff nat). +Check (heap_write (E:=CEff) : nat -> nat -> ictree CEff unit). +Check (heap_alloc (E:=CEff) : nat -> ictree CEff nat). +Check (heap_free (E:=CEff) : nat -> ictree CEff unit). +Check (heap_cas (E:=CEff) : nat -> nat -> nat -> ictree CEff bool). + +Local Definition heapimp_empty : HI.Mem := + {| HI.store := nil; HI.heap := nil |}. +Local Definition alloc_free_alloc : ictree sE (nat * nat) := + a <- heap_alloc 1;; heap_free a;; b <- heap_alloc 1;; Ret (a,b). +Local Definition two_cell_frame : Pcm.Heap := + hunion (hblock 1 2) (Pcm.hsingle 9 42). + +Lemma shared_heap_alloc_free_reuses_cell : + interp_state sh alloc_free_alloc (hemp,7) ~ + Ret ((1,1), + (hunion (hblock 1 1) (Pcm.hfree 1 (hunion (hblock 1 1) hemp)),7)). +Proof. + unfold alloc_free_alloc. + etransitivity. + - eapply sinterp_alloc_first with (base:=1); try lia. + apply block_freeb_spec; reflexivity. + - etransitivity; [apply sinterp_free |]. + etransitivity. + + eapply sinterp_alloc_first with (base:=1); try lia. + apply block_freeb_spec; reflexivity. + + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. +Qed. + +Lemma shared_heap_free_preserves_other_cells : + (interp_state sh + (heap_free 1;; + other <- heap_read 2;; + framed <- heap_read 9;; + Ret (other,framed)) (two_cell_frame,7) ~ + Ret ((0,42),(Pcm.hfree 1 two_cell_frame,7))) /\ + Pcm.hfree 1 two_cell_frame 1 = None. +Proof. + split. + - etransitivity; [apply sinterp_free |]. + etransitivity; [eapply sinterp_rd with (v:=0); reflexivity |]. + etransitivity; [eapply sinterp_rd with (v:=42); reflexivity |]. + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. + - reflexivity. +Qed. + +Lemma shared_heap_free_absent_succeeds : + (interp_state sh (heap_free (E:=sE) 42) (hemp,7) ~ + Ret (tt,(Pcm.hfree 42 hemp,7))) /\ + heq (Pcm.hfree 42 hemp) hemp. +Proof. + split. + - pose proof (sinterp_free 42 hemp 7 + (fun x : unit => (Ret x : ictree sE unit))) as Hfree. + rewrite bind_ret_r, interp_state_ret in Hfree. + exact Hfree. + - intro a; unfold Pcm.hfree, hemp. + destruct (Nat.eq_dec 42 a); reflexivity. +Qed. + +Lemma shared_heap_read_after_free_stuck : + interp_state sh (heap_free 1;; heap_read 1) (Pcm.hsingle 1 9,7) ~ + (stuck : ictreeW SObs (nat * SSig)). +Proof. + etransitivity; [apply sinterp_free |]. + eapply equ_clos_sbisim_goal; + [apply sinterp_srd_stuck; reflexivity | reflexivity | reflexivity]. +Qed. + +Lemma heapimp_alloc_zero_preserved : + (instr_stateE (HI.h_heapimp (HAlloc 0)) heapimp_empty ~ + (log heapimp_empty;; Ret (0,heapimp_empty))) /\ + interp_state sh (heap_alloc (E:=sE) 0) (hemp,7) ≅ + (stuck : ictreeW SObs (nat * SSig)). +Proof. + split. + - unfold HI.h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + cbn [HI.fresh_addr HI.heap_init HI.heap HI.store heapimp_empty]. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_put | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, interp_state_ret; reflexivity. + - apply sinterp_salloc_zero. +Qed. + +Lemma heapimp_free_absent_still_logs : + instr_stateE (HI.h_heapimp (HFree 42)) heapimp_empty ~ + (log (HI.free_heap 42 heapimp_empty);; + Ret (tt,HI.free_heap 42 heapimp_empty)). +Proof. + unfold HI.h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + apply interp_state_put. +Qed. + +Lemma heapimp_write_absent_still_allocates : + (instr_stateE (HI.h_heapimp (HWrite 1 9)) heapimp_empty ~ + (log (HI.update_heap 1 9 heapimp_empty);; + Ret (tt,HI.update_heap 1 9 heapimp_empty))) /\ + interp_state sh (heap_write (E:=sE) 1 9) (hemp,7) ≅ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + split. + - unfold HI.h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + apply interp_state_put. + - apply sinterp_swr_stuck; reflexivity. +Qed. + +Lemma heapimp_cas_same_value_logs : + let m := HI.update_heap 1 7 heapimp_empty in + (instr_stateE (HI.h_heapimp (HCAS 1 7 7)) m ~ + (log (HI.update_heap 1 7 m);; Ret (true,HI.update_heap 1 7 m))) /\ + (instr_stateE (HI.h_heapimp (HCAS 1 8 9)) m ~ Ret (false,m)). +Proof. + cbn zeta. + assert (Lookup : ExtLib.Structures.Maps.lookup 1 + (HI.heap (HI.update_heap 1 7 heapimp_empty)) = Some 7). + { unfold HI.update_heap; cbn. + pose proof (ExtLib.Structures.Maps.mapsto_add_eq (R:=@eq nat) (V:=nat) + (HI.heap heapimp_empty) 1 7) as Hlookup. + now apply ExtLib.Structures.Maps.mapsto_lookup in Hlookup. } + split. + - unfold HI.h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + rewrite Lookup; cbn [Nat.eqb]. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_put | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, interp_state_ret; reflexivity. + - unfold HI.h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + rewrite Lookup; cbn [Nat.eqb]. + rewrite interp_state_ret; reflexivity. +Qed. diff --git a/theories/Events/HeapE.v b/theories/Events/HeapE.v new file mode 100644 index 0000000..bf81f3a --- /dev/null +++ b/theories/Events/HeapE.v @@ -0,0 +1,15 @@ +From TICL Require Import Events.Core. + +Variant heapE : Type := +| HRead (a : nat) +| HWrite (a v : nat) +| HAlloc (size : nat) +| HFree (a : nat) +| HCAS (a expected desired : nat). + +#[global] Instance Encode_heapE : Encode heapE := + fun e => match e with + | HRead _ | HAlloc _ => nat + | HWrite _ _ | HFree _ => unit + | HCAS _ _ _ => bool + end. diff --git a/theories/ICTree/Events/Heap.v b/theories/ICTree/Events/Heap.v new file mode 100644 index 0000000..1321578 --- /dev/null +++ b/theories/ICTree/Events/Heap.v @@ -0,0 +1,27 @@ +From TICL Require Import ICTree.Core. +From TICL Require Export Events.Core Events.HeapE. + +Definition heap_read {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} + (a : nat) : ictree E nat := + @ICtree.trigger heapE E Encode_heapE HE RS RR (HRead a). + +Definition heap_write {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} + (a v : nat) : ictree E unit := + @ICtree.trigger heapE E Encode_heapE HE RS RR (HWrite a v). + +Definition heap_alloc {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} + (size : nat) : ictree E nat := + @ICtree.trigger heapE E Encode_heapE HE RS RR (HAlloc size). + +Definition heap_free {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} + (a : nat) : ictree E unit := + @ICtree.trigger heapE E Encode_heapE HE RS RR (HFree a). + +Definition heap_cas {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} + (a expected desired : nat) : ictree E bool := + @ICtree.trigger heapE E Encode_heapE HE RS RR (HCAS a expected desired). diff --git a/theories/ICTree/Interp/State/Mod.v b/theories/ICTree/Interp/State/Mod.v index 995a134..45ee669 100644 --- a/theories/ICTree/Interp/State/Mod.v +++ b/theories/ICTree/Interp/State/Mod.v @@ -123,6 +123,20 @@ Proof. reflexivity. Qed. +(** A trigger's administrative guard disappears under strong bisimulation. *) +Local Typeclasses Transparent equ. +Lemma interp_state_trigger_bind {E F} {HE : Encode E} {HF : Encode F} {W X} + (h : E ~> stateT W (ictree F)) (e : E) + (k : (encode e * W)%type -> ictree F X) (s : W) : + (interp_state h (@ICtree.trigger E E HE HE ReSum_refl ReSumRet_refl e) s >>= k) ~ + (runStateT (h e) s >>= k). +Proof. + rewrite interp_state_trigger, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intro result]. + rewrite bind_guard, sb_guard, bind_ret_l; reflexivity. +Qed. +Local Typeclasses Opaque equ. + (** [interp_state] applied on branch events commutes with the branching structure. *) Lemma interp_state_br `{Encode E} `{Encode F} `(h: E ~> stateT W (ictree F)) {X} (n : nat) (k : fin' n -> ictree E X) (w : W) : diff --git a/theories/ICTree/Logic/Bind.v b/theories/ICTree/Logic/Bind.v index 575ea88..f8106d0 100644 --- a/theories/ICTree/Logic/Bind.v +++ b/theories/ICTree/Logic/Bind.v @@ -642,6 +642,77 @@ Section BindLemmas. (** ** Convenience lemmas for [bind] and instrumentation events [log s]. *) Typeclasses Transparent equ. + + (** A log retains the current world for its prefix obligation and has + exactly one successor, at the world recording that log. *) + Lemma anl_log_iff {X W} (s : W) (k : ictreeW W X) w (φ ψ : ticll (writerE W)) : + <( {log s;; k}, w |= φ AN ψ )> <-> + <( {log s;; k}, w |= φ )> /\ <( k, {Obs (Log s) tt} |= ψ )>. + Proof. + unfold log, ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl. + rewrite !bind_vis; setoid_rewrite bind_ret_l. + rewrite (anl_vis (Log s) _ tt). + split. + - intros [Hφ Hnext]; split; [exact Hφ | exact (Hnext tt)]. + - intros [Hφ Hnext]; split; [exact Hφ | intros []; exact Hnext]. + Qed. + + Lemma anr_log_iff {X W} (s : W) (k : ictreeW W X) w + (φ : ticll (writerE W)) (ψ : ticlr (writerE W) X) : + <[ {log s;; k}, w |= φ AN ψ ]> <-> + <( {log s;; k}, w |= φ )> /\ <[ k, {Obs (Log s) tt} |= ψ ]>. + Proof. + unfold log, ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl. + rewrite !bind_vis; setoid_rewrite bind_ret_l. + rewrite (anr_vis (Log s) _ tt). + split. + - intros [Hφ Hnext]; split; [exact Hφ | exact (Hnext tt)]. + - intros [Hφ Hnext]; split; [exact Hφ | intros []; exact Hnext]. + Qed. + + Lemma aul_log_iff {X W} (s : W) (k : ictreeW W X) w (φ ψ : ticll (writerE W)) : + <( {log s;; k}, w |= φ AU ψ )> <-> + <( {log s;; k}, w |= ψ )> \/ + (<( {log s;; k}, w |= φ )> /\ <( k, {Obs (Log s) tt} |= φ AU ψ )>). + Proof. + unfold log, ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl. + rewrite !bind_vis; setoid_rewrite bind_ret_l. + rewrite <- (aul_vis (Log s) _ tt). + split. + - intros [Hψ | [Hφ Hnext]]; + [left; exact Hψ | right; split; [exact Hφ | exact (Hnext tt)]]. + - intros [Hψ | [Hφ Hnext]]; + [left; exact Hψ | right; split; [exact Hφ | intros []; exact Hnext]]. + Qed. + + Lemma aur_log_iff {X W} (s : W) (k : ictreeW W X) w + (φ : ticll (writerE W)) (ψ : ticlr (writerE W) X) : + <[ {log s;; k}, w |= φ AU ψ ]> <-> + <[ {log s;; k}, w |= ψ ]> \/ + (<( {log s;; k}, w |= φ )> /\ <[ k, {Obs (Log s) tt} |= φ AU ψ ]>). + Proof. + unfold log, ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl. + rewrite !bind_vis; setoid_rewrite bind_ret_l. + rewrite <- (aur_vis (Log s) _ tt). + split. + - intros [Hψ | [Hφ Hnext]]; + [left; exact Hψ | right; split; [exact Hφ | exact (Hnext tt)]]. + - intros [Hψ | [Hφ Hnext]]; + [left; exact Hψ | right; split; [exact Hφ | intros []; exact Hnext]]. + Qed. + + Lemma ag_log_iff {X W} (s : W) (k : ictreeW W X) w (φ : ticll (writerE W)) : + <( {log s;; k}, w |= AG φ )> <-> + <( {log s;; k}, w |= φ )> /\ <( k, {Obs (Log s) tt} |= AG φ )>. + Proof. + unfold log, ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl. + rewrite !bind_vis; setoid_rewrite bind_ret_l. + rewrite <- (ag_vis (Log s) _ tt). + split. + - intros [Hφ Hnext]; split; [exact Hφ | exact (Hnext tt)]. + - intros [Hφ Hnext]; split; [exact Hφ | intros []; exact Hnext]. + Qed. + Lemma anl_log{X S}: forall (s: S) (k: ictreeW S X) w ψ φ, <( k, {Obs (Log s) tt} |= ψ )> -> <( {log s;; k }, w |= φ )> -> diff --git a/theories/ICTree/Logic/State.v b/theories/ICTree/Logic/State.v index 1b1fbb0..2990cf9 100644 --- a/theories/ICTree/Logic/State.v +++ b/theories/ICTree/Logic/State.v @@ -1000,6 +1000,40 @@ Section StateLemmas. Qed. End StateLemmas. +(** A state-iteration rule with a well-founded rank on ghost data. The + invariant relates that data to the control and concrete state; neither + the concrete state nor the observation world must determine the rank. + The proof uses the structural one-iteration and bind laws. *) +Theorem aul_state_iter_ghost {E Sg W} {HE: Encode E} + (hh: E ~> stateT Sg (ictreeW W)) {X I G} + (Rv: relation G) (Inv: G -> I -> Sg -> Prop) + (bd: I -> ictree E (I + X)) (phi psi: ticllW W): + well_founded Rv -> + forall (g: G) (i: I) (s: Sg) (w: WorldW W), + not_done w -> + Inv g i s -> + (forall g i s w, + not_done w -> + Inv g i s -> + <( {interp_state hh (bd i) s}, w |= phi AU psi )> + \/ (exists g' i' s' w', + not_done w' + /\ <[ {interp_state hh (bd i) s}, w + |= phi AU AX done= {(inl i', s')} w' ]> + /\ Inv g' i' s' + /\ Rv g' g)) -> + <( {interp_state hh (ICtree.iter bd i) s}, w |= phi AU psi )>. +Proof. + intros Hwf g. + induction g as [g IH] using (well_founded_induction Hwf). + intros i s w Hd Hinv Hbody. + destruct (Hbody g i s w Hd Hinv) + as [Hnow | (g' & i' & s' & w' & Hd' & Hstep & Hinv' & Hlt)]. + - rewrite interp_state_unfold_iter; now apply ticll_bind_l. + - eapply aul_state_iter_next_eq; [exact Hstep | exact Hd' |]. + eapply (IH g'); eauto. +Qed. + (** * Lemmas for [stateE] handler [h_stateW] *) Section StateELemmas. (** S: State, s: initial state *) diff --git a/theories/ICTree/Logic/Trace.v b/theories/ICTree/Logic/Trace.v new file mode 100644 index 0000000..e92da01 --- /dev/null +++ b/theories/ICTree/Logic/Trace.v @@ -0,0 +1,70 @@ +From Stdlib Require Import List. +From TICL Require Export ICTree.Trace. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer + ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG + ICTree.Logic.Bind Logic.Core. + +Unset Implicit Arguments. +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. +Local Typeclasses Transparent equ sbisim. + +(** * Temporal properties of finite observation prefixes. *) + +Lemma af_emit_list {W X} xs (t : ictreeW W X) w P : + not_done w -> + <( t, {after_logs xs w} |= AF visW {P} )> -> + <( {emit_list xs t}, w |= AF visW {P} )>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. + change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; [exact Hd|]. + apply IH; [constructor|exact H]. +Qed. + +Lemma agaf_emit_list {W X} xs (t : ictreeW W X) w P : + not_done w -> + <( t, {after_logs xs w} |= AG (AF visW {P}) )> -> + <( {emit_list xs t}, w |= AG (AF visW {P}) )>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd H; [exact H|]. + assert (Htail : <( {emit_list rest t}, {Obs (Log o) tt} + |= AG (AF visW {P}) )>). + { apply IH; [constructor|exact H]. } + assert (Haf : <( {emit_list rest t}, {Obs (Log o) tt} |= AF visW {P} )>). + { pose proof Htail as HH; cdestruct HH; assumption. } + assert (Hprefix : <( {emit_list (o :: rest) t}, w |= AF visW {P} )>). + { change <( {log o ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; assumption. } + change <( {log o ;; emit_list rest t}, w |= AG (AF visW {P}) )>. + apply (proj2 (ag_log_iff o (emit_list rest t) w _)); split. + - exact Hprefix. + - exact Htail. +Qed. + +Lemma af_emit_list_member {W X} xs (t : ictreeW W X) w P o : + not_done w -> List.In o xs -> P o -> + <( {emit_list xs t}, w |= AF visW {P} )>. +Proof. + revert w; induction xs as [|a rest IH]; intros w Hd Hin HP; + [contradiction|]. + change <( {log a ;; emit_list rest t}, w |= AF visW {P} )>. + apply afl_log; [exact Hd|]. + destruct Hin as [<-|Hin]. + - cleft; apply ticll_vis; constructor; exact HP. + - apply IH; [constructor|exact Hin|exact HP]. +Qed. + +Lemma af_emit_list_ret {W X} xs (r : X) w (Q : X -> World (writerE W) -> Prop) : + not_done w -> Q r (after_logs xs w) -> + <[ {emit_list xs (Ret r)}, w |= AF AX done {Q} ]>. +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd HQ. + - cleft; apply axr_ret; assumption. + - change <[ {log o ;; emit_list rest (Ret r)}, w |= AF AX done {Q} ]>. + apply afr_log; [exact Hd|]. + apply IH; [constructor|exact HQ]. +Qed. diff --git a/theories/ICTree/SBisim.v b/theories/ICTree/SBisim.v index c8d2821..dde46fa 100644 --- a/theories/ICTree/SBisim.v +++ b/theories/ICTree/SBisim.v @@ -15,6 +15,7 @@ From Stdlib Require Import Classes.RelationPairs Vectors.Fin. +Import ICtree. Local Open Scope ictree_scope. Generalizable All Variables. @@ -44,6 +45,21 @@ Proof. exists l', t'; auto. Qed. +(** A tree bisimilar to silent divergence has no transition. *) +Lemma sbisim_stuck_is_stuck {E} {HE : Encode E} {X} (t : ictree E X) : + t ~ (stuck : ictree E X) -> is_stuck t. +Proof. + intros Ets [l [u Hstep]]. + destruct (sbisim_trans t stuck u l eq Ets Hstep) + as [l' [u' [Hbad _]]]. + eapply trans_stuck; exact Hbad. +Qed. + +(** Raw tree equivalence preserves every observable transition. *) +Lemma equ_sbisim {E} {HE : Encode E} {X} (t u : ictree E X) : + t ≅ u -> t ~ u. +Proof. intro Htu; rewrite Htu; reflexivity. Qed. + (** Lemma relating [trans] and strong simulation [ssim]*) Lemma ssim_trans `{HE: Encode E} {X}: forall (s t s': ictree E X) l (L: rel _ _), diff --git a/theories/ICTree/Trace.v b/theories/ICTree/Trace.v new file mode 100644 index 0000000..62bde13 --- /dev/null +++ b/theories/ICTree/Trace.v @@ -0,0 +1,365 @@ +From Stdlib Require Import List Arith.PeanoNat. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Events.Writer Logic.World. + +Unset Implicit Arguments. +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** * Finite observation traces and their operational laws. *) + +Definition emit_list {W X} (xs : list W) (t : ictreeW W X) : ictreeW W X := + List.fold_right (fun o k => log o;; k) t xs. + +(** The observations produced by one step, which emits at most one. *) +Definition event_obs {W} (event : option W) : list W := + match event with None => [] | Some o => [o] end. + +Definition label_logs {W} (labels : list (@label (writerE W) _)) : list W := + List.flat_map (fun l => match l with obs (Log o) _ => [o] | _ => [] end) labels. + +Definition label_taus {W} (labels : list (@label (writerE W) _)) : nat := + List.length (List.filter (fun l => match l with tau => true | _ => false end) labels). + +Fixpoint after_logs {W} (xs : list W) (w : World (writerE W)) : World (writerE W) := + match xs with + | [] => w + | o :: rest => after_logs rest (Obs (Log o) tt) + end. + +Lemma after_logs_not_done {W} (xs : list W) w : not_done w -> not_done (after_logs xs w). +Proof. + revert w; induction xs as [|o rest IH]; intros w Hd; cbn [after_logs]. + - exact Hd. + - apply IH; constructor. +Qed. + +Lemma emit_list_nil {W X} (t : ictreeW W X) : emit_list [] t = t. +Proof. reflexivity. Qed. + +Lemma emit_list_cons {W X} o xs (t : ictreeW W X) : + emit_list (o :: xs) t ≅ Vis (Log o) (fun _ => emit_list xs t). +Proof. + change ((log o ;; emit_list xs t) ≅ Vis (Log o) (fun _ => emit_list xs t)). + unfold log, ICtree.trigger; rewrite bind_vis. + step; constructor; intros []; rewrite bind_ret_l; reflexivity. +Qed. + +Lemma emit_list_app {W X} xs ys (t : ictreeW W X) : + emit_list (xs ++ ys) t = emit_list xs (emit_list ys t). +Proof. unfold emit_list; rewrite List.fold_right_app; reflexivity. Qed. + +Lemma emit_list_equ {W X} xs (t u : ictreeW W X) : + t ≅ u -> emit_list xs t ≅ emit_list xs u. +Proof. + intro E; induction xs as [|o xs IH]; [exact E|]. + rewrite !emit_list_cons; step; constructor; intro x; exact IH. +Qed. + +Lemma emit_list_sbisim {W X} xs (t u : ictreeW W X) : + t ~ u -> emit_list xs t ~ emit_list xs u. +Proof. + intro E; induction xs as [|o xs IH]; [exact E|]. + rewrite !emit_list_cons; apply sb_vis; intro x; exact IH. +Qed. + +Lemma emit_list_bind {W X Y} xs (t : ictreeW W X) + (k : X -> ictreeW W Y) : + emit_list xs t >>= k ≅ emit_list xs (t >>= k). +Proof. + induction xs as [|o xs IH]; [reflexivity|]. + change (((log o ;; emit_list xs t) >>= k) ≅ + (log o ;; emit_list xs (t >>= k))). + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros []; exact IH. +Qed. + +Lemma emit_list_ret_bind {W X Y} xs (x : X) (k : X -> ictreeW W Y) : + emit_list xs (Ret x) >>= k ≅ emit_list xs (k x). +Proof. + etransitivity; [apply emit_list_bind|]. + apply emit_list_equ, bind_ret_l. +Qed. + +(** Return values are observable labels, including when they contain heaps. + This proves equality of actual responses; it never identifies merely + pointwise-equal heap functions. *) +Lemma emit_list_ret_injective {W X} (xs ys : list W) (x y : X) : + emit_list xs (Ret x) ~ emit_list ys (Ret y) -> xs = ys /\ x = y. +Proof. + revert ys; induction xs as [|o xs IH]; intros [|p ys] E. + - split; [reflexivity|]. exact (@sbisim_ret_inv (writerE W) _ X x y E). + - rewrite emit_list_cons in E. + exfalso; exact (@sbisim_ret_vis_inv (writerE W) _ X x (Log p) + (fun _ => emit_list ys (Ret y)) E). + - rewrite emit_list_cons in E. + exfalso; eapply (@sbisim_ret_vis_inv (writerE W) _ X y (Log o) + (fun _ => emit_list xs (Ret x))); symmetry; exact E. + - rewrite !emit_list_cons in E. + pose proof (@sbisim_vis_invT (writerE W) _ X + (Log o) (Log p) (fun _ => emit_list xs (Ret x)) + (fun _ => emit_list ys (Ret y)) tt E) as [_ Eo]. + injection Eo as Eo; subst p. + pose proof (@sbisim_vis_invE (writerE W) _ X (Log o) + (fun _ => emit_list xs (Ret x)) (fun _ => emit_list ys (Ret y)) + tt E tt) as Etail. + destruct (IH ys Etail) as [-> ->]; auto. +Qed. + +Lemma emit_list_ret_not_stuck {W X} xs (x : X) : + ~ (emit_list xs (Ret x) ~ (stuck : ictreeW W X)). +Proof. + intro E; apply sbisim_stuck_is_stuck in E. + destruct xs as [|o xs]. + - apply E; exists (val x), stuck; apply trans_ret. + - apply E; exists (obs (Log o) tt), (emit_list xs (Ret x)). + rewrite emit_list_cons. + exact (@trans_vis (writerE W) _ X (Log o) tt (fun _ => emit_list xs (Ret x))). +Qed. + +Lemma emit_list_st {W X} (R : ictreeW W X -> ictreeW W X -> Prop) + logs t u : + coinduction.t (sb eq) R t u -> coinduction.t (sb eq) R (emit_list logs t) (emit_list logs u). +Proof. + intro H; induction logs as [|o rest IH]; [exact H|]. + change (coinduction.t (sb eq) R (log o ;; emit_list rest t) (log o ;; emit_list rest u)). + apply st_clo_bind_eq; [reflexivity|intros []; exact IH]. +Qed. + +Inductive finite_steps {E : Type} {HE : Encode E} {X : Type} : + ictree E X -> list (@label E HE) -> ictree E X -> Prop := +| finite_steps_nil t : finite_steps t [] t +| finite_steps_cons t u v l labels : + trans l t u -> finite_steps u labels v -> finite_steps t (l :: labels) v. + +Definition turn_labels {W} (event : option W) : list (@label (writerE W) _) := + match event with None => [tau] | Some o => [tau; obs (Log o) tt] end. + +Lemma turn_labels_nonempty {W} (event : option W) : turn_labels event <> []. +Proof. destruct event; discriminate. Qed. + +Lemma finite_steps_app {E : Type} {HE : Encode E} {X : Type} + (t u v : ictree E X) left right : + finite_steps t left u -> finite_steps u right v -> + finite_steps t (left ++ right) v. +Proof. + intros H; induction H; intro Htail; cbn [List.app]; + [exact Htail|econstructor; eauto]. +Qed. + +Lemma finite_steps_sbisim {E : Type} {HE : Encode E} {X : Type} + (t t' : ictree E X) labels : + finite_steps t labels t' -> forall u : ictree E X, t ~ u -> + exists u', finite_steps u labels u' /\ t' ~ u'. +Proof. + intro H; induction H as [t|t mid last l labels Hstep Htail IH]; intros u Eeq. + - exists u; split; [constructor|exact Eeq]. + - destruct (sbisim_trans t u mid l eq Eeq Hstep) + as (l' & mid' & Hstep' & El & Emid). + subst l'; destruct (IH mid' Emid) as (last' & Htail' & Elast). + exists last'; split; [econstructor; eassumption|exact Elast]. +Qed. + +Lemma finite_steps_emit_list {W X} logs (t : ictreeW W X) : + finite_steps (emit_list logs t) (List.map (fun o => obs (Log o) tt) logs) t. +Proof. + induction logs as [|o logs IH]; [constructor|]. + cbn [List.map]; econstructor; [|exact IH]. + rewrite emit_list_cons. + exact (@trans_vis (writerE W) _ X (Log o) tt (fun _ => emit_list logs t)). +Qed. + +(** * Guard/log alignment and finite prefixes. *) + +Fixpoint rr_guards {W X} (n : nat) (t : ictreeW W X) : ictreeW W X := + match n with 0 => t | S n => Guard (rr_guards n t) end. + +Lemma rr_guards_trans {W X} n l (t u : ictreeW W X) : + trans l t u -> trans l (rr_guards n t) u. +Proof. intro H; induction n; cbn [rr_guards]; [exact H|now apply trans_guard]. Qed. + +(** This proof relation consumes a guard on BOTH sides in a silent round. + Its finite prefixes cannot turn silent divergence into a visible event. *) +CoInductive rr_aligned {W X} : ictreeW W X -> ictreeW W X -> Prop := +| rr_align_guard t u n m t' u' : + t ≅ rr_guards (S n) t' -> u ≅ rr_guards (S m) u' -> + rr_aligned t' u' -> rr_aligned t u +| rr_align_log t u n m o t' u' : + t ≅ rr_guards n (Vis (Log o) (fun _ => t')) -> + u ≅ rr_guards m (Vis (Log o) (fun _ => u')) -> + rr_aligned t' u' -> rr_aligned t u. + +Lemma rr_aligned_equ {W X} (t u a b : ictreeW W X) : + t ≅ a -> u ≅ b -> rr_aligned t u -> rr_aligned a b. +Proof. + intros Et Eu H; destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. + - eapply rr_align_guard; [| |exact H]. + + transitivity t; [symmetry; exact Et|exact El]. + + transitivity u; [symmetry; exact Eu|exact Er]. + - eapply rr_align_log; [| |exact H]. + + transitivity t; [symmetry; exact Et|exact El]. + + transitivity u; [symmetry; exact Eu|exact Er]. +Qed. + +Lemma rr_aligned_sym {W X} : forall t u : ictreeW W X, + rr_aligned t u -> rr_aligned u t. +Proof. + cofix IH; intros t u H; + destruct H as [t u n m t' u' El Er H|t u n m o t' u' El Er H]. + - eapply rr_align_guard; [exact Er|exact El|apply IH; exact H]. + - eapply rr_align_log; [exact Er|exact El|apply IH; exact H]. +Qed. + +Lemma rr_aligned_match {W X} l T U : + @trans_ (writerE W) _ X l T U -> + forall u, rr_aligned (go T) u -> + exists u', trans l u u' /\ rr_aligned (go U) u'. +Proof. + intro TR; induction TR as + [l inner target TR IH + |n pick k result Eresult + |e k answer result Eresult + |result value Eresult]; intros u A. + - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + apply equ_guard_invE in El; destruct n as [|n]. + * cbn [rr_guards] in El. + assert (Ai : rr_aligned (go (observe inner)) tr). + { eapply rr_aligned_equ; [|reflexivity|exact A]. + transitivity inner; [symmetry; exact El|apply ictree_eta]. } + destruct (IH tr Ai) as (next & Tnext & Anext). + exists next; split; [rewrite Er; now apply rr_guards_trans|exact Anext]. + * apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. + eapply rr_align_guard; eassumption. + + destruct n as [|n]. + * cbn [rr_guards] in El; step in El; cbn in El; inversion El. + * apply equ_guard_invE in El. + apply IH; eapply rr_aligned_equ; [apply ictree_eta|reflexivity|]. + eapply rr_align_log; eassumption. + - inversion A as [left right p q tl tr El Er Hnext|left right p q o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct p; step in El; cbn [rr_guards] in El; inversion El. + - destruct e as [o]; destruct answer. + inversion A as [left right n m tl tr El Er Hnext|left right n m p tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct n as [|n]. + * cbn [rr_guards] in El. + pose proof (equ_vis_invT El) as [_ Ep]; injection Ep as Ep; subst p. + pose proof (equ_vis_invE El tt) as Ek. + exists tr; split. + -- rewrite Er; apply rr_guards_trans. + exact (@trans_vis (writerE W) _ X (Log o) tt (fun _ => tr)). + -- eapply rr_aligned_equ; [|reflexivity|exact A]. + transitivity (k tt); [symmetry; exact Ek|]. + transitivity result; [exact Eresult|apply ictree_eta]. + * step in El; cbn [rr_guards] in El; inversion El. + - inversion A as [left right n m tl tr El Er Hnext|left right n m o tl tr El Er Hnext]; + subst; clear A; rename Hnext into A. + + step in El; cbn [rr_guards] in El; inversion El. + + destruct n; step in El; cbn [rr_guards] in El; inversion El. +Qed. + +Lemma rr_aligned_trans {W X} (t u next : ictreeW W X) l : + rr_aligned t u -> trans l t next -> + exists other, trans l u other /\ rr_aligned next other. +Proof. + intros A TR. + assert (Ae : rr_aligned (go (observe t)) u). + { eapply rr_aligned_equ; [apply ictree_eta|reflexivity|exact A]. } + destruct (rr_aligned_match l (observe t) (observe next) TR u Ae) + as (other & To & Ao). + exists other; split; [exact To|]. + eapply rr_aligned_equ; [symmetry; apply ictree_eta|reflexivity|exact Ao]. +Qed. + +Lemma rr_aligned_sbisim {W X} : forall t u : ictreeW W X, + rr_aligned t u -> t ~ u. +Proof. + unfold sbisim; apply_coinduction; fold_sbisim. + intros R IH t u A; split; intros l next TR. + - destruct (rr_aligned_trans t u next l A TR) as (other & To & Ao). + exists l, other; split; [exact To|]; split; [now apply IH|reflexivity]. + - destruct (rr_aligned_trans u t next l (rr_aligned_sym t u A) TR) + as (other & To & Ao). + exists l, other; split; [exact To|]; split. + + apply IH, rr_aligned_sym; exact Ao. + + reflexivity. +Qed. + +Lemma rr_guards_equ {W X} n (t u : ictreeW W X) : + t ≅ u -> rr_guards n t ≅ rr_guards n u. +Proof. + intro E; induction n; cbn [rr_guards]; [exact E|step; constructor; assumption]. +Qed. +Lemma rr_guards_add {W X} n m (t : ictreeW W X) : + rr_guards (n + m) t = rr_guards n (rr_guards m t). +Proof. induction n; cbn [rr_guards Nat.add]; [reflexivity|now rewrite IHn]. Qed. +Lemma rr_guards_guard {W X} n (t : ictreeW W X) : + rr_guards n (Guard t) = rr_guards (S n) t. +Proof. induction n; cbn [rr_guards]; [reflexivity|now rewrite IHn]. Qed. + +(** A finite proof prefix, not an additional evaluator or scheduler. *) +Inductive rr_token {W : Type} := RRGuard | RRLog (o : W). +Fixpoint rr_prefix {W X} (word : list (@rr_token W)) (t : ictreeW W X) : ictreeW W X := + match word with + | [] => t + | RRGuard :: rest => Guard (rr_prefix rest t) + | RRLog o :: rest => Vis (Log o) (fun _ => rr_prefix rest t) + end. +Fixpoint rr_prefix_events {W} (word : list (@rr_token W)) : list W := + match word with + | [] => [] + | RRGuard :: rest => rr_prefix_events rest + | RRLog o :: rest => o :: rr_prefix_events rest + end. +Lemma rr_prefix_app {W X} left right (t : ictreeW W X) : + rr_prefix (left ++ right) t = rr_prefix left (rr_prefix right t). +Proof. + induction left as [|[|o] rest IH]; cbn [List.app rr_prefix]; + [reflexivity|now rewrite IH|now rewrite IH]. +Qed. +Lemma rr_prefix_equ {W X} word (t u : ictreeW W X) : + t ≅ u -> rr_prefix word t ≅ rr_prefix word u. +Proof. + intro E; induction word as [|[|o] rest IH]; cbn [rr_prefix]. + - exact E. + - step; constructor; assumption. + - step; constructor; intros []; exact IH. +Qed. +Lemma rr_prefix_events_app {W} (left right : list (@rr_token W)) : + rr_prefix_events (left ++ right) = rr_prefix_events left ++ rr_prefix_events right. +Proof. + induction left as [|[|o] rest IH]; cbn [List.app rr_prefix_events]; + [reflexivity|exact IH|now rewrite IH]. +Qed. +Lemma rr_prefix_events_logs {W} (logs : list W) : rr_prefix_events (List.map RRLog logs) = logs. +Proof. induction logs; cbn [List.map rr_prefix_events]; [reflexivity|now rewrite IHlogs]. Qed. +Lemma rr_prefix_emit {W X} logs (t : ictreeW W X) : + rr_prefix (List.map RRLog logs) t ≅ emit_list logs t. +Proof. + induction logs as [|o rest IH]; [reflexivity|]. + cbn [List.map rr_prefix]; rewrite emit_list_cons. + step; constructor; intros []; exact IH. +Qed. +Lemma rr_prefix_no_events {W X} word (t : ictreeW W X) : + rr_prefix_events word = [] -> rr_prefix word t = rr_guards (List.length word) t. +Proof. + induction word as [|[|o] rest IH]; cbn [rr_prefix_events rr_prefix List.length rr_guards]; + intro E; [reflexivity|now rewrite IH|discriminate]. +Qed. +Lemma rr_prefix_one_event {W X} word o (t : ictreeW W X) : + rr_prefix_events word = [o] -> exists n m, + rr_prefix word t ≅ rr_guards n (Vis (Log o) (fun _ => rr_guards m t)). +Proof. + induction word as [|[|p] rest IH]; cbn [rr_prefix_events]; intro E; [discriminate| |]. + - destruct (IH E) as (n & m & H). + exists (S n), m; cbn [rr_prefix rr_guards]; step; constructor; assumption. + - injection E as Ep Er; subst p. + exists 0, (List.length rest); cbn [rr_prefix rr_guards]. + step; constructor; intros []; rewrite (rr_prefix_no_events rest t Er); reflexivity. +Qed. diff --git a/theories/Lang/CSL.v b/theories/Lang/CSL.v index 3f742b4..4f047f7 100644 --- a/theories/Lang/CSL.v +++ b/theories/Lang/CSL.v @@ -1,3 +1,3 @@ From TICL Require Export Lang.CSL.Pcm Lang.CSL.Heap Lang.CSL.Syntax Lang.CSL.Denote - ICTree.Interp.Refine Lang.CSL.Interp. + ICTree.Interp.Refine Lang.CSL.Interp Lang.CSL.Segments Lang.CSL.Ticl. diff --git a/theories/Lang/CSL/Denote.v b/theories/Lang/CSL/Denote.v index 055c05c..8497222 100644 --- a/theories/Lang/CSL/Denote.v +++ b/theories/Lang/CSL/Denote.v @@ -1,13 +1,19 @@ From TICL Require Import - ICTree.Core ICTree.Equ ICTree.Events.Yield ICTree.Interp.Refine + ICTree.Core ICTree.Equ ICTree.Events.Yield ICTree.Events.Writer ICTree.Interp.Refine Lang.CSL.Heap Lang.CSL.Syntax. Import ICtree ICTreeNotations. Local Open Scope ictree_scope. Definition CEff := (yieldE + (forkE + sE))%type. -Definition heap_event (e : sE) : ictree CEff (encode e) := - Vis (inr (inr e)) (fun x => Ret x). +#[global] Instance ReSum_heap_CEff : ReSum heapE CEff := + fun e => inr (inr (inl e)). +#[global] Instance ReSumRet_heap_CEff : ReSumRet heapE CEff := + fun e response => response. +#[global] Instance ReSum_tagged_CEff : ReSum (writerE (nat * nat)) CEff := + fun e => inr (inr (inr e)). +#[global] Instance ReSumRet_tagged_CEff : ReSumRet (writerE (nat * nat)) CEff := + fun e response => response. Definition source_yield : ictree CEff unit := Vis (inl Yield) (fun _ => Ret tt). Definition source_fork : ictree CEff bool := @@ -15,9 +21,9 @@ Definition source_fork : ictree CEff bool := Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := match p in CProg A return ictree CEff (option A) with - | CRead a => x <- heap_event (SRd a);; Ret (Some x) - | CWrite a v => heap_event (SWr a v);; Ret (Some tt) - | CEmit q v => heap_event (SEmit q v);; Ret (Some tt) + | CRead a => x <- heap_read (E:=CEff) a;; Ret (Some x) + | CWrite a v => heap_write (E:=CEff) a v;; Ret (Some tt) + | CEmit q v => ICtree.trigger (E2:=CEff) (Log (q,v));; Ret (Some tt) | CYield => source_yield;; Ret (Some tt) | CFork body => child <- source_fork;; @@ -35,9 +41,9 @@ Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := | Some None => Ret (inr (Some tt)) | Some (Some _) => Ret (inl tt) end) tt - | CAlloc size => a <- heap_event (SAlloc size);; Ret (Some a) + | CAlloc size => a <- heap_alloc (E:=CEff) size;; Ret (Some a) | CCAS a expected desired => - b <- heap_event (SCAS a expected desired);; Ret (Some b) + b <- heap_cas (E:=CEff) a expected desired;; Ret (Some b) end. Definition denote (p : CProg unit) : thread sE := @@ -48,13 +54,13 @@ Proof. induction p as [a|a v|q v| |body IH|A x|A B body IH next IHnext|A body IH|size|a expected desired]; cbn [denote_flow]. - apply branchfree_bind. - + unfold heap_event; apply bf_vis; intro x; apply bf_ret. + + unfold heap_read, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. + intro x; apply bf_ret. - apply branchfree_bind. - + unfold heap_event; apply bf_vis; intros []; apply bf_ret. + + unfold heap_write, ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + intros []; apply bf_ret. - apply branchfree_bind. - + unfold heap_event; apply bf_vis; intros []; apply bf_ret. + + unfold ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + intros []; apply bf_ret. - apply branchfree_bind. + unfold source_yield; apply bf_vis; intros []; apply bf_ret. @@ -71,10 +77,10 @@ Proof. apply branchfree_bind; [exact IH|]. intros [[x|]|]; apply bf_ret. - apply branchfree_bind. - + unfold heap_event; apply bf_vis; intro a; apply bf_ret. + + unfold heap_alloc, ICtree.trigger; apply bf_vis; intro a; apply bf_ret. + intro a; apply bf_ret. - apply branchfree_bind. - + unfold heap_event; apply bf_vis; intro b; apply bf_ret. + + unfold heap_cas, ICtree.trigger; apply bf_vis; intro b; apply bf_ret. + intro b; apply bf_ret. Qed. diff --git a/theories/Lang/CSL/Heap.v b/theories/Lang/CSL/Heap.v index 41dd445..81f61da 100644 --- a/theories/Lang/CSL/Heap.v +++ b/theories/Lang/CSL/Heap.v @@ -24,11 +24,47 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Export Lang.CSL.Pcm. +From TICL Require Export Lang.CSL.Pcm ICTree.Events.Heap. Definition upd (h : Heap) (a v : nat) : Heap := fun x => if Nat.eqb x a then Some v else h x. +(** ** The algebra of [upd]. + + Elementary lookup facts about the primitive defined just above. Stated + with explicit binders: they are applied positionally. *) + +Lemma upd_unfold: forall h a v x, upd h a v x = if Nat.eqb x a then Some v else h x. +Proof. reflexivity. Qed. + +Lemma upd_eq: forall h a v, upd h a v a = Some v. +Proof. intros; unfold upd; now rewrite Nat.eqb_refl. Qed. + +Lemma upd_neq: forall h a v x, x <> a -> upd h a v x = h x. +Proof. intros; unfold upd; now apply Nat.eqb_neq in H as ->. Qed. + +Lemma upd_mono: forall h a v x, h x <> None -> upd h a v x <> None. +Proof. intros h a v x H; unfold upd; destruct (Nat.eqb x a); [discriminate | exact H]. Qed. + +Lemma upd_dom: forall h a v x, h a <> None -> (upd h a v x <> None <-> h x <> None). +Proof. + intros h a v x Ha; unfold upd; destruct (Nat.eqb_spec x a) as [-> | Hne]. + - split; [intros _; exact Ha | intros _; discriminate]. + - reflexivity. +Qed. + +Lemma upd_lookup_agree: forall h f a v x, h x = f x -> upd h a v x = upd f a v x. +Proof. + intros h f a v x H; destruct (Nat.eq_dec x a) as [-> | Hne]. + - now rewrite !upd_eq. + - now rewrite !upd_neq by exact Hne. +Qed. + +Lemma upd_heq: forall h k a v, heq h k -> heq (upd h a v) (upd k a v). +Proof. + intros h k a v H x; unfold upd; destruct (Nat.eqb x a); [reflexivity | apply H]. +Qed. + Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. @@ -43,28 +79,10 @@ Record SObs : Type := SPop { stag: nat ; sval: nat ; sidx: nat }. (** ** Events *) -Variant sE : Type := - | SRd (a: nat) - | SWr (a: nat) (v: nat) - | SEmit (q: nat) (v: nat) - | SAlloc (size: nat) - | SCAS (a expected desired : nat). - -Global Instance encode_sE: Encode sE := - fun e => match e with - | SRd _ => nat | SWr _ _ => unit | SEmit _ _ => unit - | SAlloc _ => nat - | SCAS _ _ _ => bool - end. - -Definition srd (a: nat) : ictree sE nat := Vis (SRd a) (fun x: nat => Ret x). -Definition swr (a v: nat) : ictree sE unit := Vis (SWr a v) (fun _: unit => Ret tt). -Definition semit (q v: nat) : ictree sE unit := - Vis (SEmit q v) (fun _: unit => Ret tt). -Definition salloc (size : nat) : ictree sE nat := - Vis (SAlloc size) (fun a => Ret a). -Definition scas (a expected desired : nat) : ictree sE bool := - Vis (SCAS a expected desired) (fun b => Ret b). +Definition sE : Type := (heapE + writerE (nat * nat))%type. + +Definition semit (q v : nat) : ictree sE unit := + ICtree.trigger (Log (q,v)). (** Interpretation state: the SHARED heap (which holds both queues and the outer frame) and one GLOBAL occurrence counter. *) @@ -82,68 +100,151 @@ Fixpoint block_freeb (h : Heap) (base size : nat) : bool := end end. -CoFixpoint alloc_search (h : Heap) (size candidate c : nat) - : ictreeW SObs (nat * SSig) := +CoFixpoint alloc_search {W : Type} (h : Heap) (size candidate c : nat) + : ictreeW W (nat * SSig) := match size with | 0 => stuck | S _ => if block_freeb h candidate size then Ret (candidate, (hunion (hblock candidate size) h, c)) - else Guard (alloc_search h size (S candidate) c) + else Guard (alloc_search (W:=W) h size (S candidate) c) end. (** ** Checked accesses and constructive allocation in one shared handler. *) -Definition sh: sE ~> stateT SSig (ictreeW SObs) := +Definition heap_handler {W : Type} : heapE ~> stateT SSig (ictreeW W) := fun e => mkStateT (fun s => - match e return ictreeW SObs (encode e * SSig) with - | SRd a => match fst s a with - | Some v => Ret (v, s) - | None => ICtree.stuck - end - | SWr a v => match fst s a with - | Some _ => Ret (tt, (upd (fst s) a v, snd s)) - | None => ICtree.stuck - end - | SEmit q v => log (SPop q v (snd s)) ;; Ret (tt, (fst s, S (snd s))) - | SAlloc size => alloc_search (fst s) size 1 (snd s) - | SCAS a expected desired => - match fst s a with - | None => stuck - | Some current => - if Nat.eqb current expected - then Ret (true, (upd (fst s) a desired, snd s)) - else Ret (false, s) - end - end). + match e return ictreeW W (encode e * SSig) with + | HRead a => match fst s a with + | Some v => Ret (v,s) + | None => stuck + end + | HWrite a v => match fst s a with + | Some _ => Ret (tt,(upd (fst s) a v,snd s)) + | None => stuck + end + | HAlloc size => alloc_search (W:=W) (fst s) size 1 (snd s) + | HFree a => Ret (tt,(Pcm.hfree a (fst s),snd s)) + | HCAS a expected desired => + match fst s a with + | None => stuck + | Some current => + if Nat.eqb current expected + then Ret (true,(upd (fst s) a desired,snd s)) + else Ret (false,s) + end + end). + +(** The checked read/write laws do not depend on the observation alphabet. *) +Lemma heap_handler_rd_some {W : Type} : forall a h c v, + h a = Some v -> + runStateT (heap_handler (W:=W) (HRead a)) (h,c) ≅ Ret (v,(h,c)). +Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. + +Lemma heap_handler_rd_none {W : Type} : forall a h c, + h a = None -> + runStateT (heap_handler (W:=W) (HRead a)) (h,c) ≅ stuck. +Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. + +Lemma heap_handler_wr_some {W : Type} : forall a h c v w, + h a = Some w -> + runStateT (heap_handler (W:=W) (HWrite a v)) (h,c) ≅ + Ret (tt,(upd h a v,c)). +Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. + +(** Adding another effect handler leaves the checked memory paths unchanged. *) +Section HeapInterp. + Context {W E : Type} {HE : Encode E} + (other : E ~> stateT SSig (ictreeW W)). + + Lemma interp_heap_rd {X} : forall a h c v (k : nat -> ictree (heapE + E) X), + h a = Some v -> + interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,c) ~ + interp_state (h_sum heap_handler other) (k v) (h,c). + Proof. + intros a h c v k H. + unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_rd_some (W:=W) a h c v H), bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_wr {X} : forall a h c v w (k : unit -> ictree (heapE + E) X), + h a = Some w -> + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,c) ~ + interp_state (h_sum heap_handler other) (k tt) (upd h a v,c). + Proof. + intros a h c v w k H. + unfold heap_write, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_wr_some (W:=W) a h c v w H), bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_wr_present {X} : forall a h c v (k : unit -> ictree (heapE + E) X), + h a <> None -> + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,c) ~ + interp_state (h_sum heap_handler other) (k tt) (upd h a v,c). + Proof. + intros a h c v k H; destruct (h a) as [w |] eqn:Ha; [| contradiction]. + eapply interp_heap_wr; eauto. + Qed. + + (** An out-of-footprint read cannot step, regardless of its continuation. *) + Lemma interp_heap_rd_nostep {X} : forall a h c (k : nat -> ictree (heapE + E) X) w, + h a = None -> + ~ can_step + (interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,c)) w. + Proof. + intros a h c k w H. + unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_rd_none (W:=W) a h c H). + intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; + revert TR; apply ktrans_stuck. + Qed. +End HeapInterp. + +Definition sh_tagged : writerE (nat * nat) ~> stateT SSig (ictreeW SObs) := + fun e => + match e with + | Log (tag,value) => mkStateT (fun '(h,c) => + log (SPop tag value c);; Ret (tt,(h,S c))) + end. + +Definition sh : sE ~> stateT SSig (ictreeW SObs) := + h_sum (heap_handler (W:=SObs)) sh_tagged. (** *** Handler equations *) Lemma sh_rd_some: forall a h c v, - h a = Some v -> runStateT (sh (SRd a)) (h, c) ≅ Ret (v, (h, c)). -Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. + h a = Some v -> runStateT (sh (inl (HRead a))) (h, c) ≅ Ret (v, (h, c)). +Proof. exact (heap_handler_rd_some (W:=SObs)). Qed. Lemma sh_rd_none: forall a h c, - h a = None -> runStateT (sh (SRd a)) (h, c) ≅ ICtree.stuck. -Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. + h a = None -> runStateT (sh (inl (HRead a))) (h, c) ≅ ICtree.stuck. +Proof. exact (heap_handler_rd_none (W:=SObs)). Qed. Lemma sh_wr_some: forall a h c v w, - h a = Some w -> runStateT (sh (SWr a v)) (h, c) ≅ Ret (tt, (upd h a v, c)). -Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. + h a = Some w -> runStateT (sh (inl (HWrite a v))) (h, c) ≅ Ret (tt, (upd h a v, c)). +Proof. exact (heap_handler_wr_some (W:=SObs)). Qed. Lemma sh_emit: forall q v h c, - runStateT (sh (SEmit q v)) (h, c) ≅ (log (SPop q v c) ;; Ret (tt, (h, S c))). + runStateT (sh (inr (Log (q,v)))) (h, c) ≅ (log (SPop q v c) ;; Ret (tt, (h, S c))). Proof. intros; cbn; reflexivity. Qed. Lemma sh_cas_success a expected desired h c : h a = Some expected -> - runStateT (sh (SCAS a expected desired)) (h,c) ≅ + runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ Ret (true,(upd h a desired,c)). Proof. intro H; cbn; rewrite H, Nat.eqb_refl; reflexivity. Qed. Lemma sh_cas_failure a expected desired current h c : h a = Some current -> current <> expected -> - runStateT (sh (SCAS a expected desired)) (h,c) ≅ Ret (false,(h,c)). + runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ Ret (false,(h,c)). Proof. intros H N; cbn; rewrite H. apply Nat.eqb_neq in N; rewrite N; reflexivity. @@ -151,50 +252,41 @@ Qed. Lemma sh_cas_missing a expected desired h c : h a = None -> - runStateT (sh (SCAS a expected desired)) (h,c) ≅ + runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ (stuck : ictreeW SObs (bool * SSig)). Proof. intro H; cbn; rewrite H; reflexivity. Qed. +Lemma sh_free a h c : + runStateT (sh (inl (HFree a))) (h,c) ≅ + Ret (tt,(Pcm.hfree a h,c)). +Proof. reflexivity. Qed. + (** *** Lifting through [interp_state] *) Lemma sinterp_rd {X}: forall a h c v (k: nat -> ictree sE X), h a = Some v -> - interp_state sh (x <- srd a ;; k x) (h, c) ~ interp_state sh (k v) (h, c). -Proof. - intros a h c v k H. - unfold srd; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis. - rewrite (sh_rd_some a h c v H), bind_ret_l. - apply sb_guard. -Qed. + interp_state sh (x <- heap_read (E:=sE) a ;; k x) (h, c) ~ interp_state sh (k v) (h, c). +Proof. exact (interp_heap_rd sh_tagged (X:=X)). Qed. Lemma sinterp_wr {X}: forall a h c v w (k: unit -> ictree sE X), h a = Some w -> - interp_state sh (x <- swr a v ;; k x) (h, c) + interp_state sh (x <- heap_write (E:=sE) a v ;; k x) (h, c) ~ interp_state sh (k tt) (upd h a v, c). -Proof. - intros a h c v w k H. - unfold swr; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis. - rewrite (sh_wr_some a h c v w H), bind_ret_l. - apply sb_guard. -Qed. +Proof. exact (interp_heap_wr sh_tagged (X:=X)). Qed. Lemma sinterp_wr' {X}: forall a h c v (k: unit -> ictree sE X), h a <> None -> - interp_state sh (x <- swr a v ;; k x) (h, c) + interp_state sh (x <- heap_write (E:=sE) a v ;; k x) (h, c) ~ interp_state sh (k tt) (upd h a v, c). -Proof. - intros a h c v k H; destruct (h a) as [w |] eqn:E; [| contradiction]. - eapply sinterp_wr; eauto. -Qed. +Proof. exact (interp_heap_wr_present sh_tagged (X:=X)). Qed. Lemma sinterp_emit {X}: forall q v h c (k: unit -> ictree sE X), interp_state sh (x <- semit q v ;; k x) (h, c) ~ (log (SPop q v c) ;; interp_state sh (k tt) (h, S c)). Proof. intros q v h c k. - unfold semit; rewrite bind_vis; setoid_rewrite bind_ret_l. + unfold semit, ICtree.trigger, resum, resum_ret, ReSum_inr, ReSumRet_inr; + rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis, sh_emit, bind_bind. apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite bind_ret_l; apply sb_guard. @@ -203,10 +295,10 @@ Qed. Lemma sinterp_cas_success {X} a expected desired h c (k : bool -> ictree sE X) : h a = Some expected -> - interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ interp_state sh (k true) (upd h a desired,c). Proof. - intro H; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis, (sh_cas_success a expected desired h c H), bind_ret_l. apply sb_guard. Qed. @@ -214,10 +306,10 @@ Qed. Lemma sinterp_cas_failure {X} a expected desired current h c (k : bool -> ictree sE X) : h a = Some current -> current <> expected -> - interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ interp_state sh (k false) (h,c). Proof. - intros H N; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + intros H N; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis, (sh_cas_failure a expected desired current h c H N), bind_ret_l. apply sb_guard. @@ -226,44 +318,48 @@ Qed. Lemma sinterp_cas_missing {X} a expected desired h c (k : bool -> ictree sE X) : h a = None -> - interp_state sh (b <- scas a expected desired;; k b) (h,c) ~ + interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ (stuck : ictreeW SObs (X * SSig)). Proof. - intro H; unfold scas; rewrite bind_vis; setoid_rewrite bind_ret_l. + intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis, (sh_cas_missing a expected desired h c H). rewrite bind_stuck_equ; reflexivity. Qed. +Lemma sinterp_free {X} a h c (k : unit -> ictree sE X) : + interp_state sh (heap_free (E:=sE) a >>= k) (h,c) ~ + interp_state sh (k tt) (Pcm.hfree a h,c). +Proof. + unfold heap_free, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl; + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, sh_free, bind_ret_l. + apply sb_guard. +Qed. + (** An out-of-footprint read cannot step. *) Lemma sinterp_rd_nostep {X}: forall a h c (k: nat -> ictree sE X) w, h a = None -> - ~ can_step (interp_state sh (x <- srd a ;; k x) (h, c)) w. -Proof. - intros a h c k w H. - unfold srd; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, (sh_rd_none a h c H). - intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; - revert TR; apply ktrans_stuck. -Qed. + ~ can_step (interp_state sh (x <- heap_read (E:=sE) a ;; k x) (h, c)) w. +Proof. exact (interp_heap_rd_nostep sh_tagged (X:=X)). Qed. Lemma sh_wr_none : forall a h c v, - h a = None -> runStateT (sh (SWr a v)) (h,c) ≅ stuck. + h a = None -> runStateT (sh (inl (HWrite a v))) (h,c) ≅ stuck. Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. Lemma sinterp_srd_stuck a h c : h a = None -> - interp_state sh (srd a) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). + interp_state sh (heap_read (E:=sE) a) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). Proof. - intro H; unfold srd. + intro H; unfold heap_read, ICtree.trigger. rewrite interp_state_vis, (sh_rd_none a h c H). apply bind_stuck_equ. Qed. Lemma sinterp_swr_stuck a v h c : h a = None -> - interp_state sh (swr a v) (h,c) ≅ (stuck : ictreeW SObs (unit * SSig)). + interp_state sh (heap_write (E:=sE) a v) (h,c) ≅ (stuck : ictreeW SObs (unit * SSig)). Proof. - intro H; unfold swr. + intro H; unfold heap_write, ICtree.trigger. rewrite interp_state_vis, (sh_wr_none a h c v H). apply bind_stuck_equ. Qed. @@ -292,22 +388,22 @@ Proof. replace (S base + offset)%nat with (base + S offset)%nat by lia; apply F; lia. Qed. -Lemma unfold_alloc_search h size candidate c : - alloc_search h size candidate c ≅ +Lemma unfold_alloc_search {W : Type} h size candidate c : + alloc_search (W:=W) h size candidate c ≅ match size with | 0 => stuck | S _ => if block_freeb h candidate size then Ret (candidate, (hunion (hblock candidate size) h, c)) - else Guard (alloc_search h size (S candidate) c) + else Guard (alloc_search (W:=W) h size (S candidate) c) end. Proof. step; cbn; unfold observe; cbn; reflexivity. Qed. -Lemma alloc_search_first h size start base c : +Lemma alloc_search_first {W : Type} h size start base c : Nat.lt 0 size -> Nat.le start base -> block_free h base size -> (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size) -> - alloc_search h size start c ~ + alloc_search (W:=W) h size start c ~ Ret (base, (hunion (hblock base size) h, c)). Proof. intros Pos L Free First; destruct size as [|size]; [lia |]. @@ -327,17 +423,18 @@ Proof. Qed. Lemma sh_alloc_zero h c : - runStateT (sh (SAlloc 0)) (h,c) ≅ + runStateT (sh (inl (HAlloc 0))) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). -Proof. apply unfold_alloc_search. Qed. +Proof. exact (unfold_alloc_search (W:=SObs) h 0 1 c). Qed. Lemma sh_alloc_first h size base c : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - runStateT (sh (SAlloc size)) (h,c) ~ + runStateT (sh (inl (HAlloc size))) (h,c) ~ Ret (base, (hunion (hblock base size) h, c)). Proof. - intros Pos B F First; apply alloc_search_first; try assumption; try lia. + intros Pos B F First. + apply (alloc_search_first (W:=SObs) h size 1 base c); try assumption; try lia. Qed. Lemma sh_alloc_finite h size c : @@ -345,7 +442,7 @@ Lemma sh_alloc_finite h size c : exists base, Nat.lt 0 base /\ block_free h base size /\ (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) /\ - runStateT (sh (SAlloc size)) (h,c) ~ + runStateT (sh (inl (HAlloc size))) (h,c) ~ Ret (base, (hunion (hblock base size) h, c)). Proof. intros [B Bound] Pos. @@ -374,21 +471,22 @@ Proof. Qed. Lemma sinterp_salloc_zero h c : - interp_state sh (salloc 0) (h,c) ≅ + interp_state sh (heap_alloc (E:=sE) 0) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). Proof. - unfold salloc; rewrite interp_state_vis, sh_alloc_zero. + unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. + rewrite interp_state_vis, sh_alloc_zero. apply bind_stuck_equ. Qed. Lemma sinterp_alloc_first {X} h size base c (k : nat -> ictree sE X) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_state sh (a <- salloc size;; k a) (h,c) ~ + interp_state sh (a <- heap_alloc (E:=sE) size;; k a) (h,c) ~ interp_state sh (k base) (hunion (hblock base size) h,c). Proof. intros Pos B F First. - unfold salloc; rewrite bind_vis; setoid_rewrite bind_ret_l. + unfold heap_alloc, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis, (sh_alloc_first h size base c Pos B F First), bind_ret_l. apply sb_guard. Qed. @@ -399,10 +497,10 @@ Proof. unfold upd; destruct (Nat.eqb_spec x a); [lia | apply Bound; lia]. Qed. -Lemma alloc_search_no_space h size start c : +Lemma alloc_search_no_space {W : Type} h size start c : Nat.lt 0 size -> (forall j, Nat.le start j -> ~ block_free h j size) -> - alloc_search h size start c ≅ (stuck : ictreeW SObs (nat * SSig)). + alloc_search (W:=W) h size start c ≅ (stuck : ictreeW W (nat * SSig)). Proof. intros Pos Full; destruct size as [|size]; [lia |]. revert start Full; __coinduction_equ R CIH; intros start Full. diff --git a/theories/Lang/CSL/Interp.v b/theories/Lang/CSL/Interp.v index b5b2177..eb28796 100644 --- a/theories/Lang/CSL/Interp.v +++ b/theories/Lang/CSL/Interp.v @@ -1,7 +1,8 @@ -From Stdlib Require Import Fin Vector. +From TICL Require Export ICTree.Trace. +From Stdlib Require Import Fin Vector List Arith.PeanoNat Lia. From TICL Require Import Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote - ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Logic.State Logic.World ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin ICTree.Interp.Refine @@ -11,6 +12,142 @@ Import ICtree ICTreeNotations VectorNotations. Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. +(** ** Head normalisation of [denote_flow]. + + What a single source instruction looks like at the head of a thread, + before any scheduling is applied. The [interp_*] families below are + built on top of these raw equations. *) + +Lemma source_raw_read_head a (K : option nat -> thread sE) : + (denote_flow (CRead a) >>= K) ≅ Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v)). +Proof. + cbn [denote_flow]; unfold heap_read, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_write_head a v (K : option unit -> thread sE) : + (denote_flow (CWrite a v) >>= K) ≅ Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold heap_write, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_cas_head a old desired (K : option bool -> thread sE) : + (denote_flow (CCAS a old desired) >>= K) ≅ + Vis (inr (inr (inl (HCAS a old desired)))) (fun b => K (Some b)). +Proof. + cbn [denote_flow]; unfold heap_cas, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_emit_head tag value (K : option unit -> thread sE) : + (denote_flow (CEmit tag value) >>= K) ≅ + Vis (inr (inr (inr (Log (tag,value))))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold ICtree.trigger, resum, resum_ret, + ReSum_tagged_CEff, ReSumRet_tagged_CEff. + rewrite bind_bind, bind_vis; step; constructor; intros []. + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_yield_head (K : option unit -> thread sE) : + (denote_flow CYield >>= K) ≅ Vis (inl Yield) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold source_yield. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_alloc_head size (K : option nat -> thread sE) : + (denote_flow (CAlloc size) >>= K) ≅ + Vis (inr (inr (inl (HAlloc size)))) (fun base => K (Some base)). +Proof. + cbn [denote_flow]; unfold heap_alloc, ICtree.trigger, resum, resum_ret, + ReSum_heap_CEff, ReSumRet_heap_CEff. + rewrite bind_bind, bind_vis; step; constructor; intro base. + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_fork_head (child : CProg unit) (K : option unit -> thread sE) : + (denote_flow (CFork child) >>= K) ≅ + Vis (inr (inl Fork)) + (fun spawned : bool => if spawned + then denote_flow child >>= fun _ => K None else K (Some tt)). +Proof. + cbn [denote_flow]; unfold source_fork. + rewrite bind_bind, bind_vis; step; constructor; intro spawned. + rewrite bind_ret_l; destruct spawned; cbn. + - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. + rewrite bind_ret_l; reflexivity. + - apply bind_ret_l. +Qed. + +(** These are the actual [CUntilNone] continuations, including halt flow. *) +Definition until_tail {A} (body : CProg (option A)) + (K : option unit -> thread sE) (flow : option (option A)) : thread sE := + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end. + +(** Raw source equations retain the outer option; in particular a successful + remote publication must return through its caller before reaching Yield. *) +Lemma source_raw_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) : + (denote_flow (CBind p next) >>= K) ≅ + (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. +Qed. + +Lemma source_raw_ret {A} (x : A) (K : option A -> thread sE) : + (denote_flow (CRet x) >>= K) ≅ K (Some x). +Proof. cbn [denote_flow]; apply bind_ret_l. Qed. + +Lemma source_raw_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) : + (denote_flow (CUntilNone body) >>= K) ≅ + (denote_flow body >>= until_tail body K). +Proof. + set (loop_body := fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr (None : option unit)) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end). + change ((ICtree.iter loop_body tt >>= K) ≅ + (denote_flow body >>= fun flow => + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) + end)). + transitivity ((loop_body tt >>= fun lr => + match lr with + | inl j => Guard (ICtree.iter loop_body j) + | inr result => Ret result + end) >>= K). + - apply equ_clo_bind with (S := eq). + + apply unfold_iter. + + intros r r' <-; reflexivity. + - etransitivity; [apply bind_bind|]. + unfold loop_body at 1. + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros [[x|]|]; cbn. + + etransitivity; [apply bind_ret_l|]. apply bind_guard. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. +Qed. + Definition scheduled (p : CProg unit) : completed sE := schedule 1 [denote p]%vector (Some Fin.F1). Definition scheduled_rr (p : CProg unit) : completed sE := @@ -33,100 +170,57 @@ Lemma run_rr_unfold p h c : interp_state sh (interp_yield (interp_spawn (scheduled_rr p))) (h,c). Proof. reflexivity. Qed. +(** Keep one scheduler continuation fixed while interpreting a raw user event. *) +Lemma interp_rr_user_bind n (ts : pool sE (S n)) (i : Fin.t (S n)) + (t : thread sE) (e : sE) (k : encode e -> thread sE) m sigma : + t ≅ Vis (inr (inr e)) k -> + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ + (interp_state sh (@ICtree.trigger sE sE _ _ ReSum_refl ReSumRet_refl e) sigma >>= + fun '(x,sigma') => + interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). +Proof. + intro Hnode. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) m sigma + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user with (e:=e) (k:=k) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite interp_state_trigger_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m σ : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m σ ≅ interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ. Proof. apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - cbn [denote_flow]; apply bind_ret_l. + apply source_raw_ret. Qed. Lemma interp_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : option nat -> thread sE) m σ : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m σ ~ - (interp_state sh (srd a) σ >>= fun '(x,σ') => + (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). Proof. - assert (Hnode : (denote_flow (CRead a) >>= K) ≅ - Vis (inr (inr (SRd a))) (fun x => K (Some x))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro x. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) - (ts @ i := Vis (inr (inr (SRd a))) (fun x => K (Some x))) - (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (nat * SSig)%type => - let '(x,σ') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). - assert (Hrhs : (interp_state sh (srd a) σ >>= resume) ≅ - ((runStateT (sh (SRd a)) σ >>= fun '(x,σ') => - Guard (interp_state sh (Ret x) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold srd; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret x) σ' >>= resume) ≅ resume (x,σ')). - { - transitivity (Ret (x,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_rr_user_bind n ts i _ (inl (HRead a)) + (fun x => K (Some x)) m σ). + apply source_raw_read_head. Qed. Lemma interp_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m sigma : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m sigma ~ - (interp_state sh (salloc size) sigma >>= fun '(base,sigma') => + (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). Proof. - assert (Hnode : (denote_flow (CAlloc size) >>= K) ≅ - Vis (inr (inr (SAlloc size))) (fun base => K (Some base))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro base. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) - (ts @ i := Vis (inr (inr (SAlloc size))) (fun base => K (Some base))) - (Some i) m sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (nat * SSig)%type => - let '(base,sigma') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). - assert (Hrhs : (interp_state sh (salloc size) sigma >>= resume) ≅ - ((runStateT (sh (SAlloc size)) sigma >>= fun '(base,sigma') => - Guard (interp_state sh (Ret base) sigma')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold salloc; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [base sigma']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret base) sigma' >>= resume) ≅ resume (base,sigma')). - { - transitivity (Ret (base,sigma') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_rr_user_bind n ts i _ (inl (HAlloc size)) + (fun base => K (Some base)) m sigma). + apply source_raw_alloc_head. Qed. Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -134,89 +228,23 @@ Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m sigma ~ - (interp_state sh (scas a expected desired) sigma >>= fun '(b,sigma') => + (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). Proof. - assert (Hnode : (denote_flow (CCAS a expected desired) >>= K) ≅ - Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro b. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) - (ts @ i := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) - (Some i) m sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (bool * SSig)%type => - let '(b,sigma') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). - assert (Hrhs : (interp_state sh (scas a expected desired) sigma >>= resume) ≅ - ((runStateT (sh (SCAS a expected desired)) sigma >>= fun '(b,sigma') => - Guard (interp_state sh (Ret b) sigma')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold scas; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [b sigma']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret b) sigma' >>= resume) ≅ resume (b,sigma')). - { - transitivity (Ret (b,sigma') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_rr_user_bind n ts i _ (inl (HCAS a expected desired)) + (fun b => K (Some b)) m sigma). + apply source_raw_cas_head. Qed. Lemma interp_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m σ : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m σ ~ - (interp_state sh (swr a v) σ >>= fun '(_,σ') => + (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). Proof. - assert (Hnode : (denote_flow (CWrite a v) >>= K) ≅ - Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) - (ts @ i := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) - (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (unit * SSig)%type => - let '(_,σ') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). - assert (Hrhs : (interp_state sh (swr a v) σ >>= resume) ≅ - ((runStateT (sh (SWr a v)) σ >>= fun '(_,σ') => - Guard (interp_state sh (Ret tt) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold swr; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [[] σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). - { - transitivity (Ret (tt,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_rr_user_bind n ts i _ (inl (HWrite a v)) + (fun _ => K (Some tt)) m σ). + apply source_raw_write_head. Qed. Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -225,43 +253,9 @@ Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (semit q v) σ >>= fun '(_,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). Proof. - assert (Hnode : (denote_flow (CEmit q v) >>= K) ≅ - Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CEmit q v) >>= K)) - (ts @ i := Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))) - (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (unit * SSig)%type => - let '(_,σ') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). - assert (Hrhs : (interp_state sh (semit q v) σ >>= resume) ≅ - ((runStateT (sh (SEmit q v)) σ >>= fun '(_,σ') => - Guard (interp_state sh (Ret tt) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold semit; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [[] σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). - { - transitivity (Ret (tt,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_rr_user_bind n ts i _ (inr (Log (q,v))) + (fun _ => K (Some tt)) m σ). + apply source_raw_emit_head. Qed. Lemma interp_rr_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -274,8 +268,7 @@ Lemma interp_rr_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) m σ. Proof. apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - cbn [denote_flow]; rewrite bind_bind. - apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. + apply source_raw_bind. Qed. Lemma interp_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -283,19 +276,11 @@ Lemma interp_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) interp_schedule_rr sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) m σ ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) None m σ. Proof. - assert (Hnode : (denote_flow CYield >>= K) ≅ - Vis (inl Yield) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold source_yield. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := (denote_flow CYield >>= K)) (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) - (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + (Some i) m σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. rewrite Hpool. erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. @@ -308,24 +293,13 @@ Lemma interp_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) (Some (Fin.FS i)) m σ. Proof. - assert (Hnode : (denote_flow (CFork p) >>= K) ≅ - Vis (inr (inl Fork)) - (fun child : bool => if child - then denote_flow p >>= fun _ => K None else K (Some tt))). - { - cbn [denote_flow]; unfold source_fork. - rewrite bind_bind, bind_vis; step; constructor; intro child. - rewrite bind_ret_l; destruct child; cbn. - - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. - rewrite bind_ret_l; reflexivity. - - apply bind_ret_l. - } pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (ts @ i := Vis (inr (inl Fork)) (fun child : bool => if child then denote_flow p >>= fun _ => K None else K (Some tt))) - (Some i) m σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + (Some i) m σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. rewrite Hpool. erewrite interp_schedule_rr_fork by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. @@ -344,35 +318,7 @@ Lemma interp_rr_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) end)) (Some i) m σ. Proof. apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - set (loop_body := fun _ : unit => - flow <- denote_flow body;; - match flow with - | None => Ret (inr (None : option unit)) - | Some None => Ret (inr (Some tt)) - | Some (Some _) => Ret (inl tt) - end). - change ((ICtree.iter loop_body tt >>= K) ≅ - (denote_flow body >>= fun r => - match r with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) - end)). - transitivity ((loop_body tt >>= fun lr => - match lr with - | inl j => Guard (ICtree.iter loop_body j) - | inr result => Ret result - end) >>= K). - - apply equ_clo_bind with (S := eq). - + apply unfold_iter. - + intros r r' <-; reflexivity. - - etransitivity; [apply bind_bind|]. - unfold loop_body at 1. - etransitivity; [apply bind_bind|]. - apply equ_clo_bind_eq; intros [[x|]|]; cbn. - + etransitivity; [apply bind_ret_l|]. apply bind_guard. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + apply source_raw_until. Qed. Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) h c : @@ -497,100 +443,55 @@ Proof. interp_state_tau, sb_guard; reflexivity. Qed. +Lemma interp_nd_user_bind n (ts : pool sE (S n)) (i : Fin.t (S n)) + (t : thread sE) (e : sE) (k : encode e -> thread sE) sigma : + t ≅ Vis (inr (inr e)) k -> + interp_nd (S n) (ts @ i := t) (Some i) sigma ~ + (interp_state sh (@ICtree.trigger sE sE _ _ ReSum_refl ReSumRet_refl e) sigma >>= + fun '(x,sigma') => interp_nd (S n) (ts @ i := k x) (Some i) sigma'). +Proof. + intro Hnode. + pose proof (interp_nd_equ (S n) + (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) sigma + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_nd_user with (e:=e) (k:=k) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite interp_state_trigger_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + Lemma interp_nd_source_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) σ : interp_nd (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ. Proof. apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. - cbn [denote_flow]; apply bind_ret_l. + apply source_raw_ret. Qed. Lemma interp_nd_source_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : option nat -> thread sE) σ : interp_nd (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ - (interp_state sh (srd a) σ >>= fun '(x,σ') => + (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ'). Proof. - assert (Hnode : (denote_flow (CRead a) >>= K) ≅ - Vis (inr (inr (SRd a))) (fun x => K (Some x))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro x. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_nd_equ (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) - (ts @ i := Vis (inr (inr (SRd a))) (fun x => K (Some x))) - (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (nat * SSig)%type => - let '(x,σ') := result in - interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ'). - assert (Hrhs : (interp_state sh (srd a) σ >>= resume) ≅ - ((runStateT (sh (SRd a)) σ >>= fun '(x,σ') => - Guard (interp_state sh (Ret x) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold srd; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret x) σ' >>= resume) ≅ resume (x,σ')). - { - transitivity (Ret (x,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_nd_user_bind n ts i _ (inl (HRead a)) + (fun x => K (Some x)) σ). + apply source_raw_read_head. Qed. Lemma interp_nd_source_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) sigma : interp_nd (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) sigma ~ - (interp_state sh (salloc size) sigma >>= fun '(base,sigma') => + (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => interp_nd (S n) (ts @ i := K (Some base)) (Some i) sigma'). Proof. - assert (Hnode : (denote_flow (CAlloc size) >>= K) ≅ - Vis (inr (inr (SAlloc size))) (fun base => K (Some base))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro base. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_nd_equ (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) - (ts @ i := Vis (inr (inr (SAlloc size))) (fun base => K (Some base))) - (Some i) sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (nat * SSig)%type => - let '(base,sigma') := result in - interp_nd (S n) (ts @ i := K (Some base)) (Some i) sigma'). - assert (Hrhs : (interp_state sh (salloc size) sigma >>= resume) ≅ - ((runStateT (sh (SAlloc size)) sigma >>= fun '(base,sigma') => - Guard (interp_state sh (Ret base) sigma')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold salloc; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [base sigma']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret base) sigma' >>= resume) ≅ resume (base,sigma')). - { - transitivity (Ret (base,sigma') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_nd_user_bind n ts i _ (inl (HAlloc size)) + (fun base => K (Some base)) sigma). + apply source_raw_alloc_head. Qed. Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -598,89 +499,23 @@ Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) interp_nd (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) sigma ~ - (interp_state sh (scas a expected desired) sigma >>= fun '(b,sigma') => + (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => interp_nd (S n) (ts @ i := K (Some b)) (Some i) sigma'). Proof. - assert (Hnode : (denote_flow (CCAS a expected desired) >>= K) ≅ - Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intro b. - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_nd_equ (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) - (ts @ i := Vis (inr (inr (SCAS a expected desired))) (fun b => K (Some b))) - (Some i) sigma (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (bool * SSig)%type => - let '(b,sigma') := result in - interp_nd (S n) (ts @ i := K (Some b)) (Some i) sigma'). - assert (Hrhs : (interp_state sh (scas a expected desired) sigma >>= resume) ≅ - ((runStateT (sh (SCAS a expected desired)) sigma >>= fun '(b,sigma') => - Guard (interp_state sh (Ret b) sigma')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold scas; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [b sigma']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret b) sigma' >>= resume) ≅ resume (b,sigma')). - { - transitivity (Ret (b,sigma') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_nd_user_bind n ts i _ (inl (HCAS a expected desired)) + (fun b => K (Some b)) sigma). + apply source_raw_cas_head. Qed. Lemma interp_nd_source_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) σ : interp_nd (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ - (interp_state sh (swr a v) σ >>= fun '(_,σ') => + (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). Proof. - assert (Hnode : (denote_flow (CWrite a v) >>= K) ≅ - Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_nd_equ (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) - (ts @ i := Vis (inr (inr (SWr a v))) (fun _ => K (Some tt))) - (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (unit * SSig)%type => - let '(_,σ') := result in - interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). - assert (Hrhs : (interp_state sh (swr a v) σ >>= resume) ≅ - ((runStateT (sh (SWr a v)) σ >>= fun '(_,σ') => - Guard (interp_state sh (Ret tt) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold swr; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [[] σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). - { - transitivity (Ret (tt,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_nd_user_bind n ts i _ (inl (HWrite a v)) + (fun _ => K (Some tt)) σ). + apply source_raw_write_head. Qed. Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -689,43 +524,9 @@ Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (semit q v) σ >>= fun '(_,σ') => interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). Proof. - assert (Hnode : (denote_flow (CEmit q v) >>= K) ≅ - Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold heap_event. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } - pose proof (interp_nd_equ (S n) - (ts @ i := (denote_flow (CEmit q v) >>= K)) - (ts @ i := Vis (inr (inr (SEmit q v))) (fun _ => K (Some tt))) - (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - set (resume := fun result : (unit * SSig)%type => - let '(_,σ') := result in - interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). - assert (Hrhs : (interp_state sh (semit q v) σ >>= resume) ≅ - ((runStateT (sh (SEmit q v)) σ >>= fun '(_,σ') => - Guard (interp_state sh (Ret tt) σ')) >>= resume)). - { - apply equ_clo_bind with (S := eq). - - unfold semit; apply interp_state_vis. - - intros r r' <-; reflexivity. - } - rewrite Hrhs, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [[] σ']; rewrite bind_guard, sb_guard. - assert (Hret : (interp_state sh (Ret tt) σ' >>= resume) ≅ resume (tt,σ')). - { - transitivity (Ret (tt,σ') >>= resume). - - apply equ_clo_bind with (S := eq); [apply interp_state_ret|]. - intros r r' <-; reflexivity. - - apply bind_ret_l. - } - rewrite Hret; unfold resume; rewrite Vector.replace_replace_eq; reflexivity. + apply (interp_nd_user_bind n ts i _ (inr (Log (q,v))) + (fun _ => K (Some tt)) σ). + apply source_raw_emit_head. Qed. Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -738,8 +539,7 @@ Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) σ. Proof. apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. - cbn [denote_flow]; rewrite bind_bind. - apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. + apply source_raw_bind. Qed. Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) @@ -747,19 +547,11 @@ Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) interp_nd (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ interp_nd (S n) (ts @ i := K (Some tt)) None σ. Proof. - assert (Hnode : (denote_flow CYield >>= K) ≅ - Vis (inl Yield) (fun _ => K (Some tt))). - { - cbn [denote_flow]; unfold source_yield. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. - } pose proof (interp_nd_equ (S n) (ts @ i := (denote_flow CYield >>= K)) (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) - (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + (Some i) σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. rewrite Hpool. erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. @@ -772,24 +564,13 @@ Lemma interp_nd_source_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) (Some (Fin.FS i)) σ. Proof. - assert (Hnode : (denote_flow (CFork p) >>= K) ≅ - Vis (inr (inl Fork)) - (fun child : bool => if child - then denote_flow p >>= fun _ => K None else K (Some tt))). - { - cbn [denote_flow]; unfold source_fork. - rewrite bind_bind, bind_vis; step; constructor; intro child. - rewrite bind_ret_l; destruct child; cbn. - - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. - rewrite bind_ret_l; reflexivity. - - apply bind_ret_l. - } pose proof (interp_nd_equ (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (ts @ i := Vis (inr (inl Fork)) (fun child : bool => if child then denote_flow p >>= fun _ => K None else K (Some tt))) - (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + (Some i) σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. rewrite Hpool. erewrite interp_nd_fork by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. @@ -808,33 +589,591 @@ Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) end)) (Some i) σ. Proof. apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. - set (loop_body := fun _ : unit => - flow <- denote_flow body;; - match flow with - | None => Ret (inr (None : option unit)) - | Some None => Ret (inr (Some tt)) - | Some (Some _) => Ret (inl tt) - end). - change ((ICtree.iter loop_body tt >>= K) ≅ - (denote_flow body >>= fun r => - match r with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) - end)). - transitivity ((loop_body tt >>= fun lr => - match lr with - | inl j => Guard (ICtree.iter loop_body j) - | inr result => Ret result - end) >>= K). - - apply equ_clo_bind with (S := eq). - + apply unfold_iter. - + intros r r' <-; reflexivity. - - etransitivity; [apply bind_bind|]. - unfold loop_body at 1. - etransitivity; [apply bind_bind|]. - apply equ_clo_bind_eq; intros [[x|]|]; cbn. - + etransitivity; [apply bind_ret_l|]. apply bind_guard. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + apply source_raw_until. +Qed. + +(** Silent checked writes, with the continuation held fixed while the state + handler is simplified. No congruence on a pool of bisimilar threads is + used here. *) +Lemma interp_rr_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c : + h a <> None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m (upd h a v,c). +Proof. + intro Present. + pose proof (sinterp_wr' a h c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c : + h a <> None -> + interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some tt)) + (Some i) (upd h a v,c). +Proof. + intro Present. + pose proof (sinterp_wr' a h c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. +Lemma interp_rr_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c : + h a = Some value -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m (h,c). +Proof. + intro Lookup. + pose proof (sinterp_rd a h c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c : + h a = Some value -> + interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) (ts @ i := K (Some value)) (Some i) (h,c). +Proof. + intro Lookup. + pose proof (sinterp_rd a h c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +(** Checked operations with their scheduler continuation held fixed. *) + +Lemma interp_rr_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c) ~ + (log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)). +Proof. + pose proof (sinterp_emit tag value h c + (fun x : unit => (Ret x : ictree sE unit))) as Hemit. + rewrite bind_ret_r in Hemit. + assert (Hstate : interp_state sh (semit tag value) (h,c) ~ + (log (SPop tag value c);; Ret (tt,(h,S c)))). + { etransitivity; [exact Hemit |]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. } + rewrite interp_rr_emit. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c : + h a = Some current -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c) ~ + (if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)). +Proof. + intro Lookup; rewrite interp_rr_cas. + destruct (Nat.eqb current expected) eqn:Cmp. + - apply Nat.eqb_eq in Cmp; subst current. + pose proof (sinterp_cas_success a expected desired h c + (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. + - apply Nat.eqb_neq in Cmp. + pose proof (sinterp_cas_failure a expected desired current h c + (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c). +Proof. + intros Pos Base Free First. + pose proof (sinterp_alloc_first h size base c + (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) m h c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_srd_stuck a h c Missing) as Hstate. + rewrite interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_swr_stuck a v h c Missing) as Hstate. + rewrite interp_rr_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) m h c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_cas_missing a expected desired h c + (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. + rewrite bind_ret_r in Hstate. + rewrite interp_rr_cas. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) m h c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) m (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + pose proof (sinterp_salloc_zero h c) as Hstate. + rewrite interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c : + Nat.lt 0 size -> + (forall base, Nat.lt 0 base -> ~ block_free h base size) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intros Pos Full. + assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ + (stuck : ictreeW SObs (nat * SSig))). + { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. + rewrite interp_state_vis. + change ((alloc_search (W:=SObs) h size 1 c >>= + fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). + etransitivity. + - apply equ_clo_bind with (S:=eq) + (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). + + apply (alloc_search_no_space (W:=SObs) h size 1 c Pos). + intros base Positive; apply Full; lia. + + intros result result' <-; reflexivity. + - + apply bind_stuck_equ. } + rewrite interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c : + interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c) ~ + (log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)). +Proof. + pose proof (sinterp_emit tag value h c + (fun x : unit => (Ret x : ictree sE unit))) as Hemit. + rewrite bind_ret_r in Hemit. + assert (Hstate : interp_state sh (semit tag value) (h,c) ~ + (log (SPop tag value c);; Ret (tt,(h,S c)))). + { etransitivity; [exact Hemit |]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. } + rewrite interp_nd_source_emit. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c : + h a = Some current -> + interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ + (if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)). +Proof. + intro Lookup; rewrite interp_nd_source_cas. + destruct (Nat.eqb current expected) eqn:Cmp. + - apply Nat.eqb_eq in Cmp; subst current. + pose proof (sinterp_cas_success a expected desired h c + (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. + - apply Nat.eqb_neq in Cmp. + pose proof (sinterp_cas_failure a expected desired current h c + (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ + interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c). +Proof. + intros Pos Base Free First. + pose proof (sinterp_alloc_first h size base c + (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) h c : + h a = None -> + interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_srd_stuck a h c Missing) as Hstate. + rewrite interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. Qed. + +Lemma interp_nd_source_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c : + h a = None -> + interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_swr_stuck a v h c Missing) as Hstate. + rewrite interp_nd_source_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) h c : + h a = None -> + interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intro Missing. + pose proof (sinterp_cas_missing a expected desired h c + (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. + rewrite bind_ret_r in Hstate. + rewrite interp_nd_source_cas. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option nat -> thread sE) h c : + interp_nd (S n) + (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + pose proof (sinterp_salloc_zero h c) as Hstate. + rewrite interp_nd_source_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c : + Nat.lt 0 size -> + (forall base, Nat.lt 0 base -> ~ block_free h base size) -> + interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ + (stuck : ictreeW SObs (unit * SSig)). +Proof. + intros Pos Full. + assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ + (stuck : ictreeW SObs (nat * SSig))). + { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. + rewrite interp_state_vis. + change ((alloc_search (W:=SObs) h size 1 c >>= + fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). + etransitivity. + - apply equ_clo_bind with (S:=eq) + (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). + + apply (alloc_search_no_space (W:=SObs) h size 1 c Pos). + intros base Positive; apply Full; lia. + + intros result result' <-; reflexivity. + - + apply bind_stuck_equ. } + rewrite interp_nd_source_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +(** Physical free is a raw shared command, not a source constructor. *) + +Lemma raw_heap_free_head a (K : unit -> thread sE) : + (heap_free (E:=CEff) a >>= K) ≅ + Vis (inr (inr (inl (HFree a)))) K. +Proof. + unfold heap_free, ICtree.trigger, resum, resum_ret, + ReSum_heap_CEff, ReSumRet_heap_CEff. + rewrite bind_vis; setoid_rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c : + interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c). +Proof. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree a)))) K) + (Some i) m (h,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head a K))) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user with (e:=inl (HFree a)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (sh_free a h c) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c : + interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c) ~ + interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c). +Proof. + pose proof (interp_nd_equ (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree a)))) K) + (Some i) (h,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head a K))) as Hpool. + rewrite Hpool. + erewrite interp_nd_user with (e:=inl (HFree a)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (sh_free a h c) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + + +(** Only finite leading guards and raw tree equivalence are forgotten. + A real [Br] node is never included in this closure. *) +Inductive guard_equ : thread sE -> thread sE -> Prop := +| guard_equ_equ t u : t ≅ u -> guard_equ t u +| guard_equ_left t u : guard_equ t u -> guard_equ (Guard t) u +| guard_equ_right t u : guard_equ t u -> guard_equ t (Guard u) +| guard_equ_sym t u : guard_equ t u -> guard_equ u t +| guard_equ_trans t u v : guard_equ t u -> guard_equ u v -> guard_equ t v. + +(** ** Pool-shape tactics for concrete round-robin computations. *) + +Ltac source_observe := + lazy [observe _observe Vector.nth Vector.replace Vector.caseS' + denote denote_flow ICtree.bind ICtree.subst' rr_pick + heap_read heap_write heap_alloc heap_cas ICtree.trigger + resum resum_ret ReSum_heap_CEff ReSumRet_heap_CEff + ReSum_tagged_CEff ReSumRet_tagged_CEff + Nat.modulo Nat.divmod Fin.of_nat_lt]; reflexivity. + +Ltac pool_simpl := + cbv [Vector.replace Vector.caseS' rr_pick Nat.modulo Nat.divmod Fin.of_nat_lt]. + +Ltac finish_pool := + repeat first + [ progress pool_simpl + | rewrite vector_remove_head + | rewrite vector_remove_tail + | erewrite interp_schedule_rr_ret by source_observe + | rewrite interp_schedule_rr_select + | rewrite interp_schedule_rr_empty ]; + reflexivity. diff --git a/theories/Lang/CSL/Pcm.v b/theories/Lang/CSL/Pcm.v index c4736a3..0b6164d 100644 --- a/theories/Lang/CSL/Pcm.v +++ b/theories/Lang/CSL/Pcm.v @@ -27,6 +27,7 @@ From Stdlib Require Import Basics Arith.PeanoNat Lia + List Relations. Generalizable All Variables. @@ -206,7 +207,7 @@ Arguments atrue {A _}. Notation "P ⋆ Q" := (asep P Q) (at level 55, right associativity): pcm_scope. Notation "P -⋆ Q" := (awand P Q) (at level 60, right associativity): pcm_scope. -(** ** The concrete model: finite partial maps as total functions. +(** ** The concrete model: partial maps as total functions. Representation: [nat -> option nat]. Equivalence: pointwise equality. Composition: union, defined exactly on disjoint pairs. This is the @@ -227,12 +228,66 @@ Definition hupd (a v: nat) (h: Heap) : Heap := Definition hfree (a: nat) (h: Heap) : Heap := fun b => if Nat.eq_dec a b then None else h b. +(** The empty heap has no allocated cell. *) + +Lemma hemp_dom: forall x, hemp x <> None -> False. +Proof. intros x H; apply H; reflexivity. Qed. + +(** Pointwise contents of a finite collection of heap cells. *) +Definition cellsat (W: list (nat * nat)) (h: Heap) : Prop := + Forall (fun p => h (fst p) = Some (snd p)) W. + +Lemma cellsat_heq: forall W h1 h2, heq h1 h2 -> cellsat W h1 -> cellsat W h2. +Proof. + intros W k1 k2 Heq H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite <- Heq; now apply H. +Qed. + +Lemma cellsat_agree: forall W h h', + (forall p, In p W -> h' (fst p) = h (fst p)) -> cellsat W h -> cellsat W h'. +Proof. + intros W h h' Hag H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite Hag by exact Hp; now apply H. +Qed. + Ltac hcase a := unfold hunion, hupd, hfree, hsingle, hemp in *; intros; repeat (destruct (Nat.eq_dec _ _)); subst; auto. Lemma hdisj_none: forall h1 h2 a v, hdisj h1 h2 -> h1 a = Some v -> h2 a = None. Proof. intros h1 h2 a v Hd Hs; destruct (Hd a) as [Hn | Hn]; congruence. Qed. +(** Elementary lookup consequences of [hunion]/[hdisj]. These read a single + address out of a union; the monoid laws below are stated pointwise on top + of them. *) + +Lemma hunion_some: forall h f x v, h x = Some v -> hunion h f x = Some v. +Proof. intros h f x v H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_eq: forall h f x, h x <> None -> hunion h f x = h x. +Proof. + intros h f x H; destruct (h x) as [v |] eqn:E; [| congruence]. + now apply hunion_some. +Qed. + +Lemma hunion_none: forall h f x, h x = None -> hunion h f x = f x. +Proof. intros h f x H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_dom: forall h f x, h x <> None -> hunion h f x <> None. +Proof. intros h f x H; now rewrite hunion_eq. Qed. + +Lemma hunion_null: forall h f, h 0 = None -> f 0 = None -> hunion h f 0 = None. +Proof. intros h f Hh Hf; unfold hunion; now rewrite Hh. Qed. + +Lemma hdisj_union: forall h1 h2 f, + hdisj h1 h2 -> hdisj h1 f -> hdisj h1 (hunion h2 f). +Proof. + intros h1 h2 f H12 H1f x. + destruct (h1 x) eqn:E1; [| now left]. + right; unfold hunion. + destruct (H12 x) as [C | E2]; [congruence |]; rewrite E2. + destruct (H1f x) as [C | Ef]; [congruence | exact Ef]. +Qed. + (** Every law is proved as a standalone lemma first, so that the instance is a list of [exact]s and its field order cannot silently drift. *) Lemma heq_refl: forall a, heq a a. diff --git a/theories/Lang/CSL/Queue.v b/theories/Lang/CSL/Queue.v new file mode 100644 index 0000000..271c43a --- /dev/null +++ b/theories/Lang/CSL/Queue.v @@ -0,0 +1,6 @@ +From TICL Require Export + Lang.CSL + Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout Lang.CSL.Queue.Operations + Lang.CSL.Queue.Sequential Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Trace + Lang.CSL.Queue.Frame Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating + Lang.CSL.Queue.Composition Lang.CSL.Queue.Program Lang.CSL.Queue.Ticl. diff --git a/examples/CSL/SLang.v b/theories/Lang/CSL/Queue/Alternating.v similarity index 71% rename from examples/CSL/SLang.v rename to theories/Lang/CSL/Queue/Alternating.v index a513aa4..e8d86ae 100644 --- a/examples/CSL/SLang.v +++ b/theories/Lang/CSL/Queue/Alternating.v @@ -25,7 +25,7 @@ From TICL Require Import Logic.Core. From TICL Require Export Lang.CSL.Heap. -From examples Require Import CSL.HeapQ. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Operations. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -41,58 +41,24 @@ Local Typeclasses Transparent sbisim. the standalone turn and the scheduler body without any bind-associativity reasoning. *) Definition turnk {X} (q hdr: nat) (kt: ictree sE X) : ictree sE X := - a <- srd (S hdr) ;; - v <- srd a ;; - _ <- semit q v ;; - n <- srd (S a) ;; - _ <- swr (S hdr) n ;; - z0 <- srd hdr ;; - _ <- swr (S (if Nat.eqb n 0 then hdr else z0)) a ;; - _ <- swr (S a) 0 ;; - _ <- swr hdr a ;; - kt. + queue_turn (semit q) hdr kt. Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). (** *** The turn correspondence. - Same three-in-one content as the frozen [QLang.rot_body_spec]: hidden - segment termination, operation correctness ([HeapQ.rot_heap_spec]) and the - observation, now queue-tagged. The proof script is the frozen one with - the final [interp_state_ret] dropped, because the tail is a parameter. *) + Instantiate [Operations.queue_turn_spec] with tagged observations. The + arbitrary tail reuses the same heap operation proof as sequential rotation. *) Theorem turnk_spec {X}: forall q hdr a ns pv vs h c (kt: ictree sE X), qrep hdr (a :: ns) (pv :: vs) h -> interp_state sh (turnk q hdr kt) (h, c) ~ (log (SPop q pv c) ;; interp_state sh kt (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c)). Proof. - intros q hdr a ns pv vs h c kt Hq. - pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). - cbn in Hhd, Htl. - destruct Hch as (Ha & Hsa & Hch). - pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). - pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. - assert (Hhdrdom: h hdr <> None) by (rewrite Htl; discriminate). - assert (Hsadom: h (S a) <> None) by (rewrite Hsa; discriminate). - assert (Hshdrdom: h (S hdr) <> None) by (rewrite Hhd; discriminate). - assert (Hread_hdr: upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) - by (rewrite upd_neq by congruence; exact Htl). - unfold turnk. - rewrite (sinterp_rd (S hdr) h c a _ Hhd). - rewrite (sinterp_rd a h c pv _ Ha). - rewrite sinterp_emit. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite (sinterp_rd (S a) h (S c) (hdf ns 0) _ Hsa). - rewrite (sinterp_wr' (S hdr) h (S c) (hdf ns 0) _ Hshdrdom). - rewrite (sinterp_rd hdr (upd h (S hdr) (hdf ns 0)) (S c) (last (a :: ns) 0) _ - Hread_hdr). - rewrite (zof_compute hdr a ns Hwf). - rewrite (sinterp_wr' (S (zof hdr ns)) _ (S c) a _ (upd_mono _ _ _ _ Hzdom)). - rewrite (sinterp_wr' (S a) _ (S c) 0 _ - (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom))). - rewrite (sinterp_wr' hdr _ (S c) a _ - (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom)))). - reflexivity. + intros q hdr a ns pv vs h c kt Hq; unfold turnk. + eapply (queue_turn_spec sh_tagged (semit q) (fun value index => SPop q value index)). + - intros; apply sinterp_emit. + - exact Hq. Qed. (** ** The nonpreemptive cyclic scheduler. @@ -180,8 +146,8 @@ Lemma turnk_bind {X} q hdr (kt : ictree sE X) : turnk q hdr kt ≅ (turn q hdr;; kt). Proof. unfold turn, turnk. - do 9 (rewrite bind_bind; apply equ_clo_bind_eq; intro). - rewrite bind_ret_l; reflexivity. + rewrite queue_turn_bind. + apply queue_turn_equ; symmetry; apply bind_ret_l. Qed. Lemma srun_turn u v n h c : diff --git a/examples/CSL/Compose.v b/theories/Lang/CSL/Queue/Composition.v similarity index 94% rename from examples/CSL/Compose.v rename to theories/Lang/CSL/Queue/Composition.v index 519486f..66e44fb 100644 --- a/examples/CSL/Compose.v +++ b/theories/Lang/CSL/Queue/Composition.v @@ -1,9 +1,7 @@ -(** * Compose: recurring per-queue progress for TWO ACTIVE queues. +(** * Recurring per-queue progress for two active queues. - This is the experiment's positive result. Both queues are running, under - the nonpreemptive cyclic scheduler that is part of the program - ([SLang.sbody]), and each one still satisfies the nested recurrence - formula of the frozen single-queue theorem. + Both queues execute under [Alternating.sbody]'s nonpreemptive cyclic + scheduler, preserving the single-queue recurrence contract. The claim is deliberately NOT "the second queue is a frame". A frame is a resource nobody touches; here the other queue is rewritten on every second @@ -12,15 +10,15 @@ - [step_focus] / [step_foreign] are the two resource-level turn lemmas. [step_foreign] is where active composition differs from framing: the focused queue's representation must survive a step of the OTHER - component, and that is [Sep2.foreign_pres], not a frame rule. + component, and that is [Separation.foreign_pres], not a frame rule. - - the temporal layer reuses the frozen loop rules unchanged + - the temporal layer reuses the structural iteration rules ([ICTree.Logic.State.ag_state_iter] for the outer [AG] and - [Recurrence.owned_aul_iter_ghost] for the inner [AF]). No fixed point + [ICTree.Logic.State.aul_state_iter_ghost] for the inner [AF]). No fixed point is unfolded anywhere in this file. - the variant is the reused natural position rank plus ONE new component, - the scheduler phase ([Lex.rank3]). The phase component is what makes a + the scheduler phase ([Utils.Relations.rank3]). The phase component makes a foreign turn count as progress; without it the composition does not close. It is still a [nat]: no ordinal is used or needed. @@ -53,7 +51,10 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame CSL.Recurrence CSL.Sep2 CSL.SLang CSL.Lex. +From TICL Require Import + Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace Lang.CSL.Queue.Layout + Lang.CSL.Queue.Frame Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Separation + Lang.CSL.Queue.Alternating Utils.Relations. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -95,9 +96,9 @@ Section Composition. (** ** The two resource-level turn lemmas *) - (** A turn of the FOCUSED queue. Reused: [HeapQ.rot_heap_spec]. New: the - foreign queue must survive it ([Sep2.foreign_pres_rot]) and footprint - disjointness must be transported ([HeapQ.qcells_rot]). *) + (** A focused turn reuses [Representation.rot_heap_spec], preserves the + foreign queue through [Separation.foreign_pres_rot], and transports + disjointness through [Representation.qcells_rot]. *) Lemma step_focus: forall nsf vsf nsg vsg a pv h, qrep fh (a :: nsf) (pv :: vsf) h -> qrep gh nsg vsg h -> @@ -169,7 +170,7 @@ Section Composition. Proof. intros n h c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). unfold sched. - apply (owned_aul_iter_ghost sh rank3 (Ig nlf nlg kb) (sbody u v) _ _ + apply (aul_state_iter_ghost sh rank3 (Ig nlf nlg kb) (sbody u v) _ _ rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n (h, c) w Hd). - exists nsf, vsf, nsg, vsg, df, dg; cbn. split; [exact Hqf |]; split; [exact Hqg |]; split; [exact Hdj |]; diff --git a/examples/CSL/Frame.v b/theories/Lang/CSL/Queue/Frame.v similarity index 90% rename from examples/CSL/Frame.v rename to theories/Lang/CSL/Queue/Frame.v index 1773da6..da67761 100644 --- a/examples/CSL/Frame.v +++ b/theories/Lang/CSL/Queue/Frame.v @@ -1,8 +1,6 @@ -(** * Frame: the separation-logic layer over the frozen recurrence proof. +(** * Separation and framing of heap-backed queue recurrence. - This file adds the RESOURCE reasoning that the recurrence experiment did - not need, and nothing else. It is used by the LOCAL proof family only; - the whole-state family in [Whole.v] never imports it. + This module separates resource reasoning from temporal recurrence: - the PRECISE representation predicate [qrepX = qrep /\ qex] and the transport theorem [qrepX_frame]: a heap that IS the queue, disjointly @@ -13,10 +11,8 @@ say [qrep = qrepX * True] with [qrepX] precise, so "the frame" is a function of the state rather than a re-chosen existential; - - the transport COROLLARIES, which are four-line applications of the - byte-frozen theorems of [Recurrence.v]. No temporal invariant, rank, - induction or coinduction is reopened: the corollaries only supply a - weaker precondition to an already-proved theorem; + - transport corollaries reuse [Recurrence.v] without reopening its temporal + invariant, rank, induction, or coinduction; - frame PRESERVATION: the run's heap after any number of rotations agrees with the initial heap outside the queue's footprint ([qstepN_agree]), so @@ -24,8 +20,7 @@ ([frame_assertion_preserved]). [Trace.run_stepN] is what makes "after n rotations" the same thing as "n observations into the run". - Nothing here mentions a particular frame. The frames live in the - per-variant files [variants/v*/FrameDef.v]. *) + All frame heaps are parameters; concrete fixtures remain in examples. *) From Stdlib Require Import List @@ -49,7 +44,9 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From examples Require Import CSL.HeapQ CSL.QLang CSL.Recurrence CSL.Trace CSL.Layout. +From TICL Require Import + Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential Lang.CSL.Queue.Recurrence + Lang.CSL.Queue.Trace Lang.CSL.Queue.Layout. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -213,10 +210,8 @@ Qed. (** ** The transport corollaries. - Each of these is an application of a BYTE-FROZEN theorem of - [Recurrence.v] to a weaker precondition. The temporal invariant [Rq], the - ghost invariant [InvQ], the lexicographic rank [lexnat] and the loop rule - [owned_aul_iter_ghost] are untouched, and no fixed point is unfolded. *) + Apply [Recurrence.v] with framed representation premises. The shared + [aul_state_iter_ghost] rule and queue invariants are reused unchanged. *) Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f c, qrepX hdr ns vs h -> @@ -354,14 +349,6 @@ Proof. eapply HA; [exact Hfeq | exact HAf]. Qed. -(** ** Instantiating the compatibility conditions from an address bound. - - Every frame variant is described by "I allocate only addresses at least - 8"; the owned queue lives below 8 ([Layout.h1_low]). These two lemmas turn - that numeric statement into the two compatibility conditions, once. *) - -Lemma qrepX1: qrepX hdr1 ns1 vs1 h1. -Proof. split; [apply qrep1 | apply qex1]. Qed. (** A newly initialized queue owns its block beside the unchanged old heap. *) Lemma new_queue_heap_owned hdr values h : diff --git a/theories/Lang/CSL/Queue/Layout.v b/theories/Lang/CSL/Queue/Layout.v new file mode 100644 index 0000000..02dc716 --- /dev/null +++ b/theories/Lang/CSL/Queue/Layout.v @@ -0,0 +1,344 @@ +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Lang.CSL.Queue.Representation. + +Import ListNotations. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** ** A generic queue heap *) + +Fixpoint nodeval (ns vs: list nat) (x: nat) : option nat := + match ns, vs with + | a :: ns', v :: vs' => + if Nat.eqb x a then Some v + else if Nat.eqb x (S a) then Some (hdf ns' 0) + else nodeval ns' vs' x + | _, _ => None + end. + +Definition qheap (hdr: nat) (ns vs: list nat) : Heap := + fun x => if Nat.eqb x hdr then Some (last ns 0) + else if Nat.eqb x (S hdr) then Some (hdf ns 0) + else nodeval ns vs x. + +Lemma nodeval_dom: forall ns vs x, + nodeval ns vs x <> None -> In x (cells ns). +Proof. + induction ns as [| a ns IH]; intros vs x H. + - destruct vs; cbn in H; congruence. + - destruct vs as [| v vs]; [cbn in H; congruence |]. + apply in_cells; cbn [nodeval] in H. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; + [exists a; split; [apply in_eq | now left] |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; + [exists a; split; [apply in_eq | now right] |]. + apply IH in H; apply in_cells in H as (b & Hb & Hx). + exists b; split; [now apply in_cons | exact Hx]. +Qed. + +Lemma nodeval_in: forall ns vs x, + length ns = length vs -> In x (cells ns) -> nodeval ns vs x <> None. +Proof. + induction ns as [| a ns IH]; intros [| v vs] x Hlen Hx; + cbn in Hlen; try discriminate; [cbn in Hx; contradiction |]. + cbn [nodeval]. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; [discriminate |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; [discriminate |]. + apply (IH vs); [lia |]. + apply in_cells in Hx as (b & Hb & Hxb). + apply in_cells; destruct Hb as [Eb | Hb]; [| exists b; split; assumption]. + exfalso; destruct Hxb as [Ex | Ex]; [apply Hna | apply Hnsa]; congruence. +Qed. + + +Lemma nodeval_chain: forall hdr ns vs, + qwf hdr ns -> length ns = length vs -> chain (nodeval ns vs) ns vs 0. +Proof. + intros hdr; induction ns as [| a ns IH]; intros [| v vs] Hwf Hlen; + cbn in Hlen; try discriminate; [exact I |]. + destruct (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). + cbn [chain nodeval]. + rewrite Nat.eqb_refl. + split; [reflexivity |]. + destruct (Nat.eqb_spec (S a) a) as [C | _]; [lia |]. + rewrite Nat.eqb_refl. + split; [reflexivity |]. + eapply chain_mono; [apply (IH vs (qwf_tail _ _ _ Hwf)); lia |]. + intros x Hx; cbn [nodeval]. + destruct (Nat.eqb_spec x a) as [Ex | Hna]; [rewrite Ex in Hx; contradiction |]. + destruct (Nat.eqb_spec x (S a)) as [Ex | Hnsa]; + [rewrite Ex in Hx; contradiction | reflexivity]. +Qed. + +Theorem qheap_qrep: forall hdr ns vs, + qwf hdr ns -> length ns = length vs -> ns <> [] -> + qrep hdr ns vs (qheap hdr ns vs). +Proof. + intros hdr ns vs Hwf Hlen Hne. + pose proof (qwf_hdr_cells _ _ Hwf) as Hhnc. + pose proof (qwf_shdr_cells _ _ Hwf) as Hshnc. + assert (Hhdr: qheap hdr ns vs hdr = Some (last ns 0)) + by (unfold qheap; now rewrite Nat.eqb_refl). + assert (Hshdr: qheap hdr ns vs (S hdr) = Some (hdf ns 0)). + { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [C | _]; [lia |]. + now rewrite Nat.eqb_refl. } + assert (Hcell: forall x, In x (cells ns) -> qheap hdr ns vs x = nodeval ns vs x). + { intros x Hx; unfold qheap. + destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex in Hx; contradiction |]. + destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; + [rewrite Ex in Hx; contradiction | reflexivity]. } + split; [exact Hwf | split; [exact Hshdr | split; [| split]]]. + - unfold tailok; destruct ns as [| a ns]; [contradiction | exact Hhdr]. + - eapply chain_mono; [apply (nodeval_chain hdr ns vs Hwf Hlen) |]. + intros x Hx; now apply Hcell. + - split. + + unfold qheap. + destruct (Nat.eqb_spec 0 hdr) as [C | _]; + [exfalso; apply (qwf_zero _ _ Hwf); rewrite C; apply in_eq |]. + destruct (Nat.eqb_spec 0 (S hdr)) as [C | _]; [lia |]. + destruct (nodeval ns vs 0) eqn:E; [| reflexivity]. + exfalso; apply (qwf_zero _ _ Hwf), in_cons, in_cons. + apply (nodeval_dom ns vs 0); congruence. + + intros x Hx; unfold qcells in Hx. + destruct Hx as [Ex | [Ex | Hx]]. + * rewrite <- Ex, Hhdr; discriminate. + * rewrite <- Ex, Hshdr; discriminate. + * rewrite (Hcell x Hx); revert Hx; now apply nodeval_in. +Qed. + +Theorem qheap_qex: forall hdr ns vs, qex hdr ns (qheap hdr ns vs). +Proof. + intros hdr ns vs x Hx; unfold qheap in Hx. + destruct (Nat.eqb_spec x hdr) as [Ex | Hnh]; [rewrite Ex; apply in_eq |]. + destruct (Nat.eqb_spec x (S hdr)) as [Ex | Hnsh]; + [rewrite Ex; apply in_cons, in_eq |]. + apply in_cons, in_cons, (nodeval_dom ns vs x), Hx. +Qed. + +(** ** Runtime-base contiguous queue layout *) + +Fixpoint node_addrs (first count : nat) : list nat := + match count with + | 0 => [] + | S rest => first :: node_addrs (first + 2) rest + end. + +Definition queue_nodes (hdr count : nat) : list nat := + node_addrs (hdr + 2) count. + +Fixpoint fill_nodes_heap (first : nat) (values : list nat) (h : Heap) : Heap := + match values with + | [] => h + | value :: rest => + fill_nodes_heap (first + 2) rest + (upd (upd h first value) (S first) + (match rest with [] => 0 | _ :: _ => first + 2 end)) + end. + +Definition init_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := + let ns := queue_nodes hdr (length values) in + fill_nodes_heap (hdr + 2) values + (upd (upd h hdr (last ns 0)) (S hdr) (hdf ns 0)). + +Definition new_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := + init_queue_heap hdr values + (hunion (hblock hdr (2 * S (length values))) h). + +Lemma node_addrs_in first count x : + In x (node_addrs first count) <-> + exists j, Nat.lt j count /\ x = first + 2*j. +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs]; split; [contradiction | intros (j & Hj & _); lia]. + - cbn [node_addrs In]; rewrite IH; split. + + intros [Hx | (j & Hj & Hx)]. + * exists 0; split; lia. + * exists (S j); split; lia. + + intros (j & Hj & Hx); destruct j as [| j]. + * left; lia. + * right; exists j; split; lia. +Qed. + +Lemma node_addrs_length first count : length (node_addrs first count) = count. +Proof. + revert first; induction count as [| count IH]; intro first; + cbn [node_addrs length]; [reflexivity | now rewrite IH]. +Qed. + +Lemma queue_nodes_length hdr count : length (queue_nodes hdr count) = count. +Proof. apply node_addrs_length. Qed. + +Lemma node_addrs_nodup first count : NoDup (node_addrs first count). +Proof. + revert first; induction count as [| count IH]; intro first; cbn [node_addrs]. + - constructor. + - constructor; [| apply IH]. + intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. +Qed. + +Lemma queue_nodes_qwf hdr count : Nat.lt 0 hdr -> qwf hdr (queue_nodes hdr count). +Proof. + intro Hhdr; unfold qwf, queue_nodes. + change (NoDup (node_addrs hdr (S count)) /\ + ~ In 0 (node_addrs hdr (S count)) /\ + (forall a b, In a (node_addrs hdr (S count)) -> + In b (node_addrs hdr (S count)) -> a <> S b)). + split; [apply node_addrs_nodup | split]. + - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. + - intros a b Ha Hb. + apply node_addrs_in in Ha as (j & Hj & Ha). + apply node_addrs_in in Hb as (k & Hk & Hb). + lia. +Qed. + +Lemma node_cells_range first count x : + In x (cells (node_addrs first count)) <-> + Nat.le first x /\ Nat.lt x (first + 2 * count). +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs cells]; split; [contradiction | lia]. + - change ((first = x \/ S first = x \/ + In x (cells (node_addrs (first + 2) count))) <-> + Nat.le first x /\ Nat.lt x (first + 2 * S count)). + rewrite IH; split. + + intros [Hx | [Hx | Hx]]; lia. + + intros [Hlo Hhi]. + destruct (Nat.eq_dec first x) as [Hx | Hx]; [now left |]. + destruct (Nat.eq_dec (S first) x) as [Hsx | Hsx]; [now right; left |]. + right; right; split; lia. +Qed. + +Lemma queue_cells_range hdr count x : + In x (qcells hdr (queue_nodes hdr count)) <-> + Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count). +Proof. + change (In x (cells (node_addrs hdr (S count))) <-> + Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count)). + apply node_cells_range. +Qed. + +Lemma qheap_queue_nodes_rep hdr values : + Nat.lt 0 hdr -> + qrep hdr (queue_nodes hdr (length values)) values + (qheap hdr (queue_nodes hdr (length values)) values). +Proof. + intro Hhdr; destruct values as [| value values]. + - change (qrep hdr [] [] (qheap hdr [] [])). + assert (Htail : qheap hdr [] [] hdr = Some 0). + { unfold qheap; now rewrite Nat.eqb_refl. } + assert (Hhead : qheap hdr [] [] (S hdr) = Some 0). + { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [Hbad | Hne]; [lia |]. + now rewrite Nat.eqb_refl. } + split; [exact (queue_nodes_qwf hdr 0 Hhdr) |]. + split; [exact Hhead |]. + split; [change (qheap hdr [] [] hdr <> None); rewrite Htail; discriminate |]. + split; [exact I | split]. + + unfold qheap; destruct (Nat.eqb_spec 0 hdr) as [Hbad | Hne]; [lia |]. + reflexivity. + + intros x [Hx | [Hx | []]]; subst x; + [rewrite Htail | rewrite Hhead]; discriminate. + - apply qheap_qrep. + + now apply queue_nodes_qwf. + + apply queue_nodes_length. + + discriminate. +Qed. + +Lemma nodeval_node_addrs_out first values x : + (Nat.lt x first \/ Nat.le (first + 2 * length values) x) -> + nodeval (node_addrs first (length values)) values x = None. +Proof. + intro Hout; destruct (nodeval (node_addrs first (length values)) values x) eqn:E; + [| reflexivity]. + exfalso. + assert (Hin : In x (cells (node_addrs first (length values)))). + { apply (nodeval_dom (node_addrs first (length values)) values x); rewrite E; discriminate. } + apply node_cells_range in Hin; lia. +Qed. + +(** Filling a strided list changes exactly its node cells. *) +Lemma fill_nodes_heap_lookup first values h x : + fill_nodes_heap first values h x = + match nodeval (node_addrs first (length values)) values x with + | Some value => Some value + | None => h x + end. +Proof. + revert first h x; induction values as [| value values IH]; intros first h x. + - reflexivity. + - cbn [fill_nodes_heap length node_addrs]; rewrite IH; cbn [nodeval]. + destruct (Nat.eqb_spec x first) as [Hx | Hfirst]. + + subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_neq by lia; apply upd_eq. + + destruct (Nat.eqb_spec x (S first)) as [Hx | Hsfirst]. + * subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_eq; destruct values; reflexivity. + * rewrite upd_neq by exact Hsfirst. + rewrite upd_neq by exact Hfirst; reflexivity. +Qed. + +Lemma init_queue_heap_agrees hdr values h : + heq (init_queue_heap hdr values h) + (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). +Proof. + intro x; unfold init_queue_heap; rewrite fill_nodes_heap_lookup. + unfold hunion, qheap, queue_nodes. + destruct (Nat.eqb_spec x hdr) as [Hx | Hhdr]. + - subst x; rewrite nodeval_node_addrs_out by (left; lia). + rewrite upd_neq by lia; apply upd_eq. + - destruct (Nat.eqb_spec x (S hdr)) as [Hx | Hshdr]. + + subst x; rewrite nodeval_node_addrs_out by (left; lia); apply upd_eq. + + rewrite upd_neq by exact Hshdr. + rewrite upd_neq by exact Hhdr; reflexivity. +Qed. + +Lemma new_queue_heap_agrees hdr values h : + Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> + heq (new_queue_heap hdr values h) + (hunion (qheap hdr (queue_nodes hdr (length values)) values) h). +Proof. + intros Hhdr Hfree x; unfold new_queue_heap. + rewrite (init_queue_heap_agrees hdr values _ x); unfold hunion. + destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; + [reflexivity |]. + assert (Hout : hblock hdr (2 * S (length values)) x = None). + { apply hblock_out. + destruct (Nat.lt_ge_cases x hdr) as [Hlo | Hlo]; [now left | right]. + destruct (Nat.lt_ge_cases x (hdr + 2 * S (length values))) as [Hhi | Hhi]; + [| exact Hhi]. + exfalso. + pose proof (qheap_queue_nodes_rep hdr values Hhdr) as Hq. + apply (qrep_fp _ _ _ _ Hq x). + - apply queue_cells_range; split; assumption. + - exact E. } + now rewrite Hout. +Qed. + +Lemma new_queue_heap_disjoint hdr values h : + block_free h hdr (2 * S (length values)) -> + hdisj (qheap hdr (queue_nodes hdr (length values)) values) h. +Proof. + intros Hfree x. + destruct (qheap hdr (queue_nodes hdr (length values)) values x) eqn:E; + [right | now left]. + assert (Hin : In x (qcells hdr (queue_nodes hdr (length values)))). + { apply (qheap_qex hdr (queue_nodes hdr (length values)) values x); rewrite E; discriminate. } + apply queue_cells_range in Hin as [Hlo Hhi]. + replace x with (hdr + (x - hdr)) by lia. + apply Hfree; lia. +Qed. + +Lemma fill_nodes_heap_finite first values h : + heap_finite h -> heap_finite (fill_nodes_heap first values h). +Proof. + revert first h; induction values as [| value values IH]; intros first h Hh. + - exact Hh. + - cbn [fill_nodes_heap]; apply IH, heap_finite_upd, heap_finite_upd, Hh. +Qed. + +Lemma new_queue_heap_finite hdr values h : + heap_finite h -> heap_finite (new_queue_heap hdr values h). +Proof. + intro Hh; unfold new_queue_heap, init_queue_heap. + apply fill_nodes_heap_finite, heap_finite_upd, heap_finite_upd. + apply heap_finite_hunion; [apply heap_finite_hblock | exact Hh]. +Qed. diff --git a/theories/Lang/CSL/Queue/Operations.v b/theories/Lang/CSL/Queue/Operations.v new file mode 100644 index 0000000..539e9bc --- /dev/null +++ b/theories/Lang/CSL/Queue/Operations.v @@ -0,0 +1,89 @@ +From Stdlib Require Import List Arith.PeanoNat. +From TICL Require Import + Lang.CSL.Queue.Representation ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Heap ICTree.Events.Writer ICTree.Interp.State.Mod. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Typeclasses Opaque equ sbisim. + +(** The memory operations of one rotation are independent of its observation alphabet. *) +Definition queue_turn {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} {X} + (emit_value : nat -> ictree E unit) (hdr : nat) (tail : ictree E X) : ictree E X := + a <- heap_read (S hdr);; + value <- heap_read a;; + emit_value value;; + next <- heap_read (S a);; + heap_write (S hdr) next;; + last <- heap_read hdr;; + heap_write (S (if Nat.eqb next 0 then hdr else last)) a;; + heap_write (S a) 0;; + heap_write hdr a;; + tail. + +Lemma queue_turn_equ {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} {X} + (emit_value : nat -> ictree E unit) hdr (t u : ictree E X) : + t ≅ u -> queue_turn emit_value hdr t ≅ queue_turn emit_value hdr u. +Proof. + intro Htu; unfold queue_turn. + do 9 (apply equ_clo_bind_eq; intro). + exact Htu. +Qed. + +Lemma queue_turn_bind {E : Type} `{HE : Encode E} `{RS : ReSum heapE E} + `{RR : @ReSumRet heapE E Encode_heapE HE RS} {X Y} + (emit_value : nat -> ictree E unit) hdr (tail : ictree E X) (k : X -> ictree E Y) : + (queue_turn emit_value hdr tail >>= k) ≅ queue_turn emit_value hdr (tail >>= k). +Proof. + unfold queue_turn. + do 9 (etransitivity; [apply bind_bind|]; apply equ_clo_bind_eq; intro). + reflexivity. +Qed. + +Lemma queue_turn_spec {E W : Type} {HE : Encode E} {X} + (other : E ~> stateT SSig (ictreeW W)) + (emit_value : nat -> ictree (heapE + E) unit) (observe_value : nat -> nat -> W) : + (forall value h c (tail : ictree (heapE + E) X), + interp_state (h_sum heap_handler other) (emit_value value;; tail) (h,c) ~ + (log (observe_value value c);; + interp_state (h_sum heap_handler other) tail (h,S c))) -> + forall hdr a ns value values h c (tail : ictree (heapE + E) X), + qrep hdr (a :: ns) (value :: values) h -> + interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) (h,c) ~ + (log (observe_value value c);; + interp_state (h_sum heap_handler other) tail + (rot_heap hdr a (hdf ns 0) (zof hdr ns) h,S c)). +Proof. + intros Emit hdr a ns value values h c tail Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + cbn in Hhd, Htl. + destruct Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. + assert (Hhdrdom : h hdr <> None) by (rewrite Htl; discriminate). + assert (Hsadom : h (S a) <> None) by (rewrite Hsa; discriminate). + assert (Hshdrdom : h (S hdr) <> None) by (rewrite Hhd; discriminate). + assert (Hread_hdr : upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) + by (rewrite upd_neq by congruence; exact Htl). + unfold queue_turn. + etransitivity; [apply (interp_heap_rd other (S hdr) h c a _ Hhd)|]. + etransitivity; [apply (interp_heap_rd other a h c value _ Ha)|]. + etransitivity; [apply Emit|]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + etransitivity; [apply (interp_heap_rd other (S a) h (S c) (hdf ns 0) _ Hsa)|]. + etransitivity; + [apply (interp_heap_wr_present other (S hdr) h (S c) (hdf ns 0) _ Hshdrdom)|]. + etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (hdf ns 0)) (S c) + (last (a :: ns) 0) _ Hread_hdr)|]. + cbn beta iota. + rewrite (zof_compute hdr a ns Hwf). + etransitivity; [apply (interp_heap_wr_present other (S (zof hdr ns)) _ (S c) a _ + (upd_mono _ _ _ _ Hzdom))|]. + etransitivity; [apply (interp_heap_wr_present other (S a) _ (S c) 0 _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom)))|]. + etransitivity; [apply (interp_heap_wr_present other hdr _ (S c) a _ + (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom))))|]. + reflexivity. +Qed. diff --git a/examples/CSL/Program.v b/theories/Lang/CSL/Queue/Program.v similarity index 85% rename from examples/CSL/Program.v rename to theories/Lang/CSL/Queue/Program.v index 866d5c2..d4cf410 100644 --- a/examples/CSL/Program.v +++ b/theories/Lang/CSL/Queue/Program.v @@ -3,7 +3,9 @@ From TICL Require Import ICTree.Core ICTree.Equ ICTree.Events.Yield Lang.CSL ICTree.Events.Writer ICTree.SBisim ICTree.Interp.State.Mod ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.SBisim Utils.Vectors. -From examples Require Import CSL.SLang CSL.HeapQ CSL.Sep2 CSL.Layout CSL.Frame. +From TICL Require Import Lang.CSL.Queue.Alternating Lang.CSL.Queue.Representation + Lang.CSL.Queue.Separation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame + Lang.CSL.Queue.Operations. Import ICtree ICTreeNotations ListNotations VectorNotations. Local Open Scope ictree_scope. @@ -54,15 +56,15 @@ Definition allocated_parallel_queues (values1 values2 : list nat) : CProg unit : Lemma denote_rotate_once q hdr : denote_flow (rotate_once q hdr) ≅ - (a <- heap_event (SRd (S hdr));; - v <- heap_event (SRd a);; - heap_event (SEmit q v);; - n <- heap_event (SRd (S a));; - heap_event (SWr (S hdr) n);; - z0 <- heap_event (SRd hdr);; - heap_event (SWr (S (if Nat.eqb n 0 then hdr else z0)) a);; - heap_event (SWr (S a) 0);; - heap_event (SWr hdr a);; + (a <- heap_read (E:=CEff) (S hdr);; + v <- heap_read (E:=CEff) a;; + ICtree.trigger (E2:=CEff) (Log (q,v));; + n <- heap_read (E:=CEff) (S a);; + heap_write (E:=CEff) (S hdr) n;; + z0 <- heap_read (E:=CEff) hdr;; + heap_write (E:=CEff) (S (if Nat.eqb n 0 then hdr else z0)) a;; + heap_write (E:=CEff) (S a) 0;; + heap_write (E:=CEff) hdr a;; Ret (Some tt)). Proof. unfold rotate_once; cbn [denote_flow]. @@ -145,7 +147,7 @@ Lemma interp_rr_rotate_once n (ts : pool sE (S n)) fun '(_, (h',c')) => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h',c')). Proof. - unfold rotate_once, turn, turnk. + unfold rotate_once, turn, turnk, queue_turn. rotate_effect interp_rr_read. rotate_effect interp_rr_read. rotate_effect interp_rr_emit. @@ -278,9 +280,9 @@ Local Ltac queue_prefix R law := Local Ltac queue_fault Hnone := cbv beta; lazymatch goal with - | |- interp_state sh (ICtree.bind (srd ?a) ?next) (?h,?c) ~ _ => + | |- interp_state sh (ICtree.bind (heap_read (E:=sE) ?a) ?next) (?h,?c) ~ _ => let Hfault := fresh "Hfault" in - assert (Hfault : interp_state sh (srd a >>= next) (h,c) ≅ stuck) by + assert (Hfault : interp_state sh (heap_read (E:=sE) a >>= next) (h,c) ≅ stuck) by (etransitivity; [apply interp_state_bind|]; etransitivity; [ apply equ_clo_bind with (S := eq) @@ -299,7 +301,7 @@ Proof. [apply (coinduction.gfp_bt (sb eq) R), queue_pool_turn|]. etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; apply srun_turn]. - unfold turn, turnk. + unfold turn, turnk, queue_turn. destruct (h (S (hdrof u v n))) as [a|] eqn:Hhead. - queue_prefix R ltac:(eapply sinterp_rd; exact Hhead). destruct (h a) as [payload|] eqn:Hpayload. @@ -323,13 +325,9 @@ Proof. [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. Qed. -Theorem run_rr_parallel_bisim : - forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, - qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> - run_rr (parallel_queues u v) h c ~ srun u v 0 h c. +Theorem run_rr_parallel_bisim u v h c : + run_rr (parallel_queues u v) h c ~ srun u v 0 h c. Proof. - intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 _ _ _ _ _. unfold parallel_queues; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 (queue_workers u v false false) (Some (queue_slot 0)) 0 (h,c) ~ srun u v 0 h c). @@ -338,32 +336,6 @@ Qed. (** Silent initialization in the real shared source scheduler. *) -Local Lemma interp_rr_write_present n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c : - h a <> None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (upd h a v,c). -Proof. - intro Present; destruct (h a) as [old|] eqn:E; [|contradiction]. - rewrite interp_rr_write. - assert (Hwrite : interp_state sh (swr a v) (h,c) ≅ - Guard (Ret (tt,(upd h a v,c)))). - { etransitivity; [unfold swr; apply interp_state_vis |]. - transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => - let '(_,sigma') := result in Guard (interp_state sh (Ret tt) sigma')). - - apply equ_clo_bind with (S := eq); - [exact (sh_wr_some a h c v old E) | intros x y <-; reflexivity]. - - etransitivity; [apply bind_ret_l |]. - step; constructor; apply interp_state_ret. } - transitivity (Ret (tt,(upd h a v,c)) >>= fun result : (unit * SSig)%type => - let '(_,sigma') := result in - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m sigma'). - - apply sbisim_clo_bind_eq. - + eapply equ_clos_sbisim_goal; [exact Hwrite | reflexivity | apply sb_guard]. - + intro result; reflexivity. - - rewrite bind_ret_l; reflexivity. -Qed. Lemma interp_rr_fill_nodes n (ts : pool sE (S n)) (i : Fin.t (S n)) first values (K : option unit -> thread sE) m h c : @@ -411,6 +383,37 @@ Proof. apply Allocated; lia. Qed. +Lemma interp_rr_new_queue_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + values hdr (K : option nat -> thread sE) m h c : + Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> + (forall j, Nat.lt 0 j -> Nat.lt j hdr -> + ~ block_free h j (2 * S (length values))) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (h,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) + (Some i) m (new_queue_heap hdr values h,c). +Proof. + intros Positive Free First. + unfold new_queue; rewrite interp_rr_bind. + rewrite interp_rr_alloc_first with (base:=hdr) by (try lia; assumption). + rewrite interp_rr_bind; etransitivity. + - apply interp_rr_init_queue; intros offset O. + unfold hunion; rewrite (hblock_in hdr (2 * S (length values)) offset O). + discriminate. + - rewrite interp_rr_ret; reflexivity. +Qed. + +Lemma interp_rr_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) + values (K : option nat -> thread sE) m c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (hemp,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) + (Some i) m (new_queue_heap 1 values hemp,c). +Proof. + apply interp_rr_new_queue_first; + [lia | intros offset Hlt; reflexivity | intros j Hj Hfirst; lia]. +Qed. + Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) values (K : option nat -> thread sE) m h c : heap_finite h -> @@ -426,26 +429,11 @@ Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) Proof. intro Finite. destruct (sh_alloc_finite h (2 * S (length values)) c Finite ltac:(lia)) - as (hdr & Positive & Free & First & Alloc). + as (hdr & Positive & Free & First & _). exists hdr; split; [exact Positive |]; split; [exact Free |]; split. - now apply new_queue_heap_finite. - split; [now apply new_queue_heap_owned |]. - pose proof (sinterp_alloc_first h (2 * S (length values)) hdr c - (fun a : nat => (Ret a : ictree sE nat)) ltac:(lia) Positive Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - unfold new_queue; rewrite interp_rr_bind, interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - eapply equ_clos_sbisim_goal; [apply bind_ret_l | reflexivity |]. - rewrite interp_rr_bind; etransitivity. - + apply interp_rr_init_queue; intros offset O. - unfold hunion; rewrite (hblock_in hdr (2 * S (length values)) offset O). - discriminate. - + rewrite interp_rr_ret; reflexivity. + apply interp_rr_new_queue_first; assumption. Qed. Theorem run_rr_allocated_parallel : forall values1 values2 c, diff --git a/examples/CSL/Recurrence.v b/theories/Lang/CSL/Queue/Recurrence.v similarity index 75% rename from examples/CSL/Recurrence.v rename to theories/Lang/CSL/Queue/Recurrence.v index 8d18e71..76d87eb 100644 --- a/examples/CSL/Recurrence.v +++ b/theories/Lang/CSL/Queue/Recurrence.v @@ -9,23 +9,16 @@ Here the queue is a preallocated linked structure in a heap, the pops are real heap reads, and the rotation is four real heap writes. - What is reused unchanged, and what had to change, is recorded in - FINDINGS.md; the two structural facts are: + The temporal proof uses two reusable structural iteration rules: - the outer [AG] needs NO adaptation. [ICTree.Logic.State.ag_state_iter] takes an invariant [R i sigma w], and the abstract queue can be existentially quantified inside it. There is no variant, so nothing has to be a function of the state. - - the inner [AF] DOES need an adaptation. [aul_state_iter_nat] and - [aul_state_iter] require the rank to be a function of - [(i, sigma, w)]. A heap representation has no such function without - first proving that [qrep] determines the abstract queue. The rank here - is a function of GHOST data (the abstract queue and the position of [nl] - in it), tied to the state by the invariant, so the loop rule is - re-derived over ghost data from [aul_state_iter_next_eq]. That - re-derivation is [owned_aul_iter_ghost] below, and it is the one place - the baseline's client-facing loop interface was not enough. *) + - the inner [AF] uses [ICTree.Logic.State.aul_state_iter_ghost]. + Its rank belongs to ghost queue data tied to the heap by the invariant; + it need not be a function of the concrete heap or observation world. *) From Stdlib Require Import List @@ -51,7 +44,8 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From examples Require Import CSL.HeapQ CSL.QLang. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential + Lang.CSL.Queue.Operations Utils.Relations. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -61,26 +55,6 @@ Local Open Scope list_scope. Local Typeclasses Transparent equ. Local Typeclasses Transparent sbisim. -(** ** The lexicographic control. - - Reused verbatim from the companion experiment's [proofs/Owned.v] - ([owned_aur_iter_lex]); the reference queue proof needs only a [nat] rank, - and so does the plain recurrence theorem below. The SECOND component is - what the freshness companion needs: it must first outrun a given occurrence - bound and only then reach the element. *) -Definition lexnat : relation (nat * nat) := - fun p q => fst p < fst q \/ (fst p = fst q /\ snd p < snd q). - -Lemma lexnat_wf: well_founded lexnat. -Proof. - intros [a b]; revert b. - induction a as [a IHa] using (well_founded_induction lt_wf). - intro b. - induction b as [b IHb] using (well_founded_induction lt_wf). - constructor; intros [c d] [Hlt | (Heq & Hlt)]; cbn in *. - - now apply IHa. - - subst c; now apply IHb. -Qed. (** ** The observation projection. @@ -106,49 +80,6 @@ Proof. destruct v0; destruct Hphi as (_ & Hle); cbn in Hle; lia. Qed. -(** ** The owned loop rule over GHOST data. - - [ICTree.Logic.State.aul_state_iter] and [aul_state_iter_nat] require the - variant to be a relation on [(i, sigma, w)] -- the private control, the - WHOLE interpretation state, and the world. For a heap-backed - representation there is no function from the state to the abstract queue - without first proving that [qrep] determines it, and the world must not - enter a variant at all. - - This rule moves both the invariant and the variant onto client-chosen - ghost data [G], tied to the state only by the invariant. It is derived - from the baseline's [aul_state_iter_next_eq] and [ticll_bind_l]; the - well-founded induction is in the ambient logic, so no TICL fixed-point - definition is unfolded here or at any call site. *) -Theorem owned_aul_iter_ghost {E Sg W} {HE: Encode E} - (hh: E ~> stateT Sg (ictreeW W)) {X I G} - (Rv: relation G) (Inv: G -> I -> Sg -> Prop) - (bd: I -> ictree E (I + X)) (phi psi: ticllW W): - well_founded Rv -> - forall (g: G) (i: I) (s: Sg) (w: WorldW W), - not_done w -> - Inv g i s -> - (forall g i s w, - not_done w -> - Inv g i s -> - <( {interp_state hh (bd i) s}, w |= phi AU psi )> - \/ (exists g' i' s' w', - not_done w' - /\ <[ {interp_state hh (bd i) s}, w - |= phi AU AX done= {(inl i', s')} w' ]> - /\ Inv g' i' s' - /\ Rv g' g)) -> - <( {interp_state hh (ICtree.iter bd i) s}, w |= phi AU psi )>. -Proof. - intros Hwf g. - induction g as [g IH] using (well_founded_induction Hwf). - intros i s w Hd Hinv Hbody. - destruct (Hbody g i s w Hd Hinv) - as [Hnow | (g' & i' & s' & w' & Hd' & Hstep & Hinv' & Hlt)]. - - rewrite interp_state_unfold_iter; now apply ticll_bind_l. - - eapply aul_state_iter_next_eq; [exact Hstep | exact Hd' |]. - eapply (IH g'); eauto. -Qed. Section Recurrence. (** [hdr] is the queue header, [nl] the observed element, [kb] the occurrence @@ -171,7 +102,7 @@ Section Recurrence. Lemma body_det: forall ns vs a v h c w, qrep hdr (a :: ns) (v :: vs) h -> not_done w -> - <[ {interp_state h_heapE (rot_body hdr) (h, c)}, w + <[ {interp_state h_qE (rot_body hdr) (h, c)}, w |= ⊤ AU AX done= {(@inl unit unit tt, (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))} {Obs (Log (Pop v c)) tt} ]>. @@ -188,7 +119,7 @@ Section Recurrence. The ghost data is the rank [(kb - c, d)]: [c] is the private occurrence counter and [d] is the position of [nl] in the abstract queue. Neither the heap nor the world appears in it. The whole proof is ONE - application of [owned_aul_iter_ghost] plus a body case analysis. *) + application of [aul_state_iter_ghost] plus a body case analysis. *) Definition InvQ (m: nat * nat) (_: unit) (s: Sig) : Prop := exists ns vs d, qrep hdr ns vs (fst s) /\ find nl vs = Some d @@ -198,11 +129,11 @@ Section Recurrence. not_done w -> qrep hdr ns vs h -> find nl vs = Some d -> - <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AF visW {P} )>. + <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AF visW {P} )>. Proof. intros h c ns vs d w Hd Hq Hf. unfold rotate. - apply (owned_aul_iter_ghost h_heapE lexnat InvQ (fun _: unit => rot_body hdr) + apply (aul_state_iter_ghost h_qE lexnat InvQ (fun _: unit => rot_body hdr) _ _ lexnat_wf (kb - c, d) tt (h, c) w Hd). - exists ns, vs, d; split; [exact Hq | split; [exact Hf | reflexivity]]. - clear h c ns vs d w Hd Hq Hf. @@ -215,7 +146,7 @@ Section Recurrence. lexnat (kb - S c, d') m -> (exists g' i' s' w', not_done w' - /\ <[ {interp_state h_heapE + /\ <[ {interp_state h_qE ((fun _: unit => rot_body hdr) tt) (h, c)}, w |= ⊤ AU AX done= {(@inl unit unit i', s')} w' ]> /\ InvQ g' i' s' @@ -256,11 +187,11 @@ Section Recurrence. not_done w -> qrep hdr ns vs h -> find nl vs = Some d -> - <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AG (AF visW {P}) )>. + <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AG (AF visW {P}) )>. Proof. intros h c ns vs d w Hd Hq Hf. unfold rotate. - apply (ag_state_iter h_heapE (h, c) Rq tt w); [assumption | |]. + apply (ag_state_iter h_qE (h, c) Rq tt w); [assumption | |]. - exists ns, vs, d; split; assumption. - intros [] s w' Hd' (ns1 & vs1 & d1 & Hq1 & Hf1). destruct s as (h1, c1); cbn in Hq1. @@ -345,9 +276,9 @@ Proof. assert (Hns: ~ can_step (run hdr h c) w). { unfold run, rotate; rewrite interp_state_unfold_iter. apply nostep_bind. - unfold rot_body. - rewrite (interp_rd (S hdr) h c 0 _ Hhd). - now apply interp_rd_nostep. } + unfold rot_body, queue_turn. + rewrite (interp_heap_rd q_emit_handler (S hdr) h c 0 _ Hhd). + now apply (interp_heap_rd_nostep q_emit_handler). } cdestruct H; now apply Hns. Qed. @@ -368,11 +299,11 @@ Theorem rotate_ag_obs: forall hdr h c ns vs w (Q: nat -> Prop), qrep hdr ns vs h -> ns <> [] -> obs_sat Q w -> - <( {interp_state h_heapE (rotate hdr) (h, c)}, w |= AG (now {obs_sat Q}) )>. + <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AG (now {obs_sat Q}) )>. Proof. intros hdr h c ns vs w Q HQ Hd Hq Hne Hw. unfold rotate. - apply (ag_state_iter h_heapE (h, c) + apply (ag_state_iter h_qE (h, c) (fun (_: unit) (s: Sig) (w: WorldW QObs) => (exists ns' vs', qrep hdr ns' vs' (fst s) /\ ns' <> [] /\ (forall x, In x vs' -> Q x)) diff --git a/examples/CSL/HeapQ.v b/theories/Lang/CSL/Queue/Representation.v similarity index 96% rename from examples/CSL/HeapQ.v rename to theories/Lang/CSL/Queue/Representation.v index 9737233..7a07cd4 100644 --- a/examples/CSL/HeapQ.v +++ b/theories/Lang/CSL/Queue/Representation.v @@ -1,4 +1,4 @@ -(** * HeapQ: a heap-backed rotating queue -- resource model and pure theory. +(** * Heap-backed queue representation and pure resource theory. This file contains NO temporal reasoning. It fixes @@ -19,9 +19,8 @@ - [qwf] states non-overlap directly ([a <> S b] for any two node names) rather than through an allocation policy. [qwf_aligned] shows that - two-word alignment is a sufficient concrete policy. No allocation - happens anywhere in this development; [qwf] is a precondition on a - PREALLOCATED structure. + two-word alignment is a sufficient concrete policy. The representation + predicate is independent of the allocator used to obtain those cells. - The tail pointer is constrained only when the queue is non-empty. That is what makes the intermediate ownership split of [Rotate.v] uniform: at @@ -43,18 +42,6 @@ Import ListNotations. From TICL Require Export Lang.CSL.Heap. -Lemma upd_eq: forall h a v, upd h a v a = Some v. -Proof. intros; unfold upd; now rewrite Nat.eqb_refl. Qed. - -Lemma upd_neq: forall h a v x, x <> a -> upd h a v x = h x. -Proof. intros; unfold upd; now apply Nat.eqb_neq in H as ->. Qed. - -Lemma upd_dom: forall h a v x, h a <> None -> (upd h a v x <> None <-> h x <> None). -Proof. - intros h a v x Ha; unfold upd; destruct (Nat.eqb_spec x a) as [-> | Hne]. - - split; [intros _; exact Ha | intros _; discriminate]. - - reflexivity. -Qed. (** ** Cells, footprints and well-formedness *) (** The two cells of a node named [a]: the payload cell [a] and the link cell @@ -256,9 +243,8 @@ Definition tailok (hdr: nat) (ns: list nat) (h: Heap) : Prop := experiment is weakened: every old hypothesis still implies the new one ([Frame.qrepX_qrep]). - The arity of the conjunction is unchanged, so every destructuring pattern - [(Hwf & Hhd & Htl & Hch & Hdom)] downstream still typechecks. [QLang.v] - and [Recurrence.v] are byte-identical to the recurrence experiment. *) + The grouped conjunction supports the common destructuring pattern + [(Hwf & Hhd & Htl & Hch & Hdom)] used by the queue operation proofs. *) Definition qrep (hdr: nat) (ns vs: list nat) (h: Heap) : Prop := qwf hdr ns /\ h (S hdr) = Some (hdf ns 0) @@ -795,9 +781,6 @@ Qed. (** ** Two facts the language layer needs about the rotation's footprint. *) -Lemma upd_mono: forall h a v x, h x <> None -> upd h a v x <> None. -Proof. intros h a v x H; unfold upd; destruct (Nat.eqb x a); [discriminate | exact H]. Qed. - Lemma last_in: forall (l: list nat) d, l <> [] -> In (last l d) l. Proof. intros l d H; destruct (exists_last H) as (l' & x & ->). @@ -840,3 +823,17 @@ Qed. Lemma rotl_cons: forall (v: nat) vs, rotl (v :: vs) = vs ++ [v]. Proof. reflexivity. Qed. + +Lemma chain_mono: forall h h' ns vs fin, + chain h ns vs fin -> + (forall x, In x (cells ns) -> h' x = h x) -> + chain h' ns vs fin. +Proof. + intros h h'; induction ns as [| a ns IH]; intros [| v vs] fin Hc Hag; + cbn in *; try contradiction; auto. + destruct Hc as (Ha & Hsa & Hc). + split; [| split]. + - rewrite Hag; [exact Ha | auto]. + - rewrite Hag; [exact Hsa | auto]. + - apply (IH vs fin Hc); intros x Hx; apply Hag; auto. +Qed. diff --git a/examples/CSL/Sep2.v b/theories/Lang/CSL/Queue/Separation.v similarity index 91% rename from examples/CSL/Sep2.v rename to theories/Lang/CSL/Queue/Separation.v index d98d998..07fb17d 100644 --- a/examples/CSL/Sep2.v +++ b/theories/Lang/CSL/Queue/Separation.v @@ -31,7 +31,8 @@ From Stdlib Require Import Lia Arith.PeanoNat. -From examples Require Import CSL.HeapQ CSL.Trace CSL.Layout CSL.Frame. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace + Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame. Import ListNotations. Local Open Scope list_scope. @@ -108,19 +109,6 @@ Qed. queue"), the outer frame [f] as an arbitrary null-avoiding heap. The conclusion supplies the composed run's three preconditions. *) -Lemma hdisj_union: forall h1 h2 f, - hdisj h1 h2 -> hdisj h1 f -> hdisj h1 (hunion h2 f). -Proof. - intros h1 h2 f H12 H1f x. - destruct (h1 x) eqn:E1; [| now left]. - right; unfold hunion. - destruct (H12 x) as [C | E2]; [congruence |]; rewrite E2. - destruct (H1f x) as [C | Ef]; [congruence | exact Ef]. -Qed. - -Lemma hunion_null: forall h f, h 0 = None -> f 0 = None -> hunion h f 0 = None. -Proof. intros h f Hh Hf; unfold hunion; now rewrite Hh. Qed. - Theorem compose3: forall u n1 vs1 h1 v n2 vs2 h2 f, qrepX u n1 vs1 h1 -> qrepX v n2 vs2 h2 -> diff --git a/theories/Lang/CSL/Queue/Sequential.v b/theories/Lang/CSL/Queue/Sequential.v new file mode 100644 index 0000000..52d4c69 --- /dev/null +++ b/theories/Lang/CSL/Queue/Sequential.v @@ -0,0 +1,164 @@ +(** * Checked sequential queue rotation with occurrence-indexed observations. + + Three deliberate departures from the reference language [Lang.HeapImp], + each of which is a research decision rather than a convenience: + + 1. **The handler is safe.** A read or a write outside the current heap's + domain produces [ICtree.stuck]. [HeapImp]'s [Put] never checks, and its + [Get] on an unmapped address is also stuck; here BOTH are checked, so an + out-of-footprint access invalidates every [AG] specification rather than + silently corrupting an unrelated cell. The footprint discipline is + therefore forced by the temporal proof, not assumed alongside it. + + 2. **The observation is heap-free.** [HeapImp] logs the WHOLE memory on + every write, which puts numeric addresses into the world and makes any + world-literal specification frame-unstable. Here the only logged event + is the popped payload together with an occurrence index, so the world + never mentions an address. + + 3. **The observation is occurrence-tagged.** [Pop v k] carries the number + of pops that preceded it. A retained [Obs (Log (Pop v k)) tt] world + cannot satisfy an occurrence-indexed formula for a later index, which is + what makes "the same element is popped AGAIN" a checkable statement + rather than a re-reading of a stale world. + + The projection back to the reference alphabet is [qval]: the reference + [examples/Queue.v] logs the popped payload [h : T] and specifies + [visW {fun h => h = nl}]; here the corresponding formula is + [visW {fun o => qval o = nl}]. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.State + ICTree.Events.Writer + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.Core + Lang.CSL.Heap. + +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Operations. + +Import ICtree ICTreeNotations TiclNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +(** Needed so that [equ] rewrites go through inside [sbisim] goals; the + reference files [Lang/MeQ.v] and [examples/Queue.v] do the same. *) +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** ** The observation alphabet and its projection *) + +Record QObs : Type := Pop { qval: nat ; qidx: nat }. + +(** ** Events *) + +Definition qE : Type := (heapE + writerE nat)%type. + +(** Memory commands use the shared heap triggers; payload emission is the + example-specific instruction in the right summand. *) +Definition emit (v: nat) : ictree qE unit := + @ICtree.trigger (writerE nat) qE _ _ ReSum_inr ReSumRet_inr (Log v). + +(** The interpretation state: the OWNED heap and the PRIVATE occurrence + counter. The counter is not part of the heap and no heap operation reads + it; it exists to index the observations. *) +Notation Sig := (Heap * nat)%type. + +(** ** The safe handler *) +Definition q_emit_handler: writerE nat ~> stateT Sig (ictreeW QObs) := + fun e => + mkStateT (fun '(h, c) => + match e return ictreeW QObs (encode e * Sig) with + | Log v => log (Pop v c) ;; Ret (tt, (h, S c)) + end). + +Definition h_qE: qE ~> stateT Sig (ictreeW QObs) := + h_sum (heap_handler (W:=QObs)) q_emit_handler. + +(** *** Payload emission equations *) + +Lemma h_emit: forall v h c, + runStateT (h_qE (inr (Log v))) (h, c) ≅ (log (Pop v c) ;; Ret (tt, (h, S c))). +Proof. intros; cbn; reflexivity. Qed. + +(** *** Lifting the handler equations through [interp_state]. *) + +Lemma interp_emit {X}: forall v h c (k: unit -> ictree qE X), + interp_state h_qE (x <- emit v ;; k x) (h, c) + ~ (log (Pop v c) ;; interp_state h_qE (k tt) (h, S c)). +Proof. + intros v h c k. + unfold emit, ICtree.trigger, resum, ReSum_inr, resum_ret, ReSumRet_inr. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis, h_emit, bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; apply sb_guard. +Qed. + +(** ** The rotating queue program. + + One iteration: read the head pointer, read and EMIT the head payload, read + the head's link, detach, find the node to append after, and re-link. No + allocation and no free: the same four cells are rewritten forever. *) + +Definition rot_body (hdr: nat) : ictree qE (unit + unit) := + queue_turn emit hdr (Ret (inl tt)). + +Definition rotate (hdr: nat) : ictree qE unit := + ICtree.iter (fun _: unit => rot_body hdr) tt. + +Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW QObs (unit * Sig) := + interp_state h_qE (rotate hdr) (h, c). + +(** ** The body correspondence. + + ONE completed rotation is strongly bisimilar to a SINGLE logged step + followed by a return. Three things are packed into this one statement: + + - **hidden-segment termination.** Every read and write in the body is + silent and finite, so the whole heap segment collapses; there is no + stuttering to reason about, and in particular no next-sensitive + stuttering theorem is needed. This holds ONLY because every access is + inside the footprint: an out-of-footprint access would leave [ICtree.stuck] + in place of a [Ret] and the collapse would fail ([interp_heap_rd_nostep]). + + - **operation correctness.** The resulting heap is [rot_heap], which + [Representation.rot_heap_spec] proves implements the abstract pop-and-push. + + - **the observation.** The single event is [Pop v c] where [v] is the + payload READ OUT OF the head node's cell and [c] is the occurrence + counter before the pop. *) +Theorem rot_body_spec: forall hdr a ns v vs h c, + qrep hdr (a :: ns) (v :: vs) h -> + interp_state h_qE (rot_body hdr) (h, c) + ~ (log (Pop v c) ;; + Ret (@inl unit unit tt, (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))). +Proof. + intros hdr a ns v vs h c Hq; unfold rot_body. + etransitivity. + - eapply (queue_turn_spec q_emit_handler emit Pop). + + intros; apply interp_emit. + + exact Hq. + - apply sbisim_clo_bind_eq; [reflexivity | intros []]. + apply equ_sbisim, interp_state_ret. +Qed. diff --git a/examples/CSL/Queue.v b/theories/Lang/CSL/Queue/Ticl.v similarity index 90% rename from examples/CSL/Queue.v rename to theories/Lang/CSL/Queue/Ticl.v index 72d26c1..a1a835b 100644 --- a/examples/CSL/Queue.v +++ b/theories/Lang/CSL/Queue/Ticl.v @@ -1,8 +1,9 @@ From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim ICTree.Logic.Trans Logic.Core. -From examples Require Import - CSL.HeapQ CSL.Layout CSL.Frame CSL.Sep2 CSL.SLang CSL.Compose CSL.Program. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout + Lang.CSL.Queue.Frame Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating + Lang.CSL.Queue.Composition Lang.CSL.Queue.Program. Import ICtree ICTreeNotations TiclNotations. Local Open Scope ictree_scope. @@ -17,9 +18,8 @@ Theorem rotate_agaf_pop_rr : |= AG (AF visW {spopped 1 nl1}) )>. Proof. intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 - H1 H2 Hd F1 F2). - exact (Compose.sched_agaf_q1 u v nl1 nl2 0 h c + rewrite (run_rr_parallel_bisim u v h c). + exact (Composition.sched_agaf_q1 u v nl1 nl2 0 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. @@ -31,9 +31,8 @@ Theorem rotate_agaf_pop_rr_q2 : |= AG (AF visW {spopped 2 nl2}) )>. Proof. intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 - H1 H2 Hd F1 F2). - exact (Compose.sched_agaf_q2 u v nl1 nl2 0 h c + rewrite (run_rr_parallel_bisim u v h c). + exact (Composition.sched_agaf_q2 u v nl1 nl2 0 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. @@ -45,9 +44,8 @@ Theorem rotate_agaf_pop_rr_fresh : |= AG (AF visW {spopped_after 1 nl1 k}) )>. Proof. intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 - H1 H2 Hd F1 F2). - exact (Compose.sched_agaf_q1_fresh u v nl1 nl2 k 0 h c + rewrite (run_rr_parallel_bisim u v h c). + exact (Composition.sched_agaf_q1_fresh u v nl1 nl2 k 0 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. @@ -59,9 +57,8 @@ Theorem rotate_agaf_pop_rr_q2_fresh : |= AG (AF visW {spopped_after 2 nl2 k}) )>. Proof. intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 - H1 H2 Hd F1 F2). - exact (Compose.sched_agaf_q2_fresh u v nl1 nl2 k 0 h c + rewrite (run_rr_parallel_bisim u v h c). + exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. diff --git a/examples/CSL/Trace.v b/theories/Lang/CSL/Queue/Trace.v similarity index 96% rename from examples/CSL/Trace.v rename to theories/Lang/CSL/Queue/Trace.v index 7e7b376..28bebdf 100644 --- a/examples/CSL/Trace.v +++ b/theories/Lang/CSL/Queue/Trace.v @@ -27,7 +27,7 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From examples Require Import CSL.HeapQ CSL.QLang. +From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -38,7 +38,7 @@ Local Typeclasses Transparent equ. Local Typeclasses Transparent sbisim. (** One completed rotation of the run: a single logged pop, then the run from - the rotated heap. This is [QLang.rot_body_spec] lifted through the + the rotated heap. This is [Sequential.rot_body_spec] lifted through the iteration; the [Guard] is discharged by [sb_guard], so no stuttering theory is needed. *) Lemma run_step: forall hdr a ns v vs h c, diff --git a/theories/Lang/CSL/Segments.v b/theories/Lang/CSL/Segments.v new file mode 100644 index 0000000..b95137e --- /dev/null +++ b/theories/Lang/CSL/Segments.v @@ -0,0 +1,960 @@ +From Stdlib Require Import List Arith.PeanoNat Fin Vector + Classes.Morphisms Classes.RelationClasses Program.Equality. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin Utils.Vectors. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. + +(** A finite derivation stops at the first source yield. The handler premise + is its actual effect semantics, not an allocator transition assumption. *) +Inductive ThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := +| segment_yield (k : unit -> thread sE) sigma : + ThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma +| segment_guard t sigma logs t' sigma' : + ThreadSegment t sigma logs t' sigma' -> + ThreadSegment (Guard t) sigma logs t' sigma' +| segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 + before after t' sigma' : + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> + ThreadSegment (k result) sigma1 after t' sigma' -> + ThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) + sigma (before ++ after) t' sigma' +| segment_equ t u sigma logs u' t' sigma' : + t ≅ u -> ThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> + ThreadSegment t sigma logs t' sigma'. + +Definition pool_guard_equ {n} (ts us : pool sE n) : Prop := + forall i, guard_equ (ts $ i) (us $ i). + +Lemma execution_pool_guard_equ {n} (ts us : pool sE n) : + pool_equ ts us -> pool_guard_equ ts us. +Proof. intros H i; apply guard_equ_equ, H. Qed. + +Lemma execution_pool_guard_replace {n} (ts us : pool sE n) + (i : Fin.t n) t u : + pool_guard_equ ts us -> guard_equ t u -> + pool_guard_equ (ts @ i := t) (us @ i := u). +Proof. + intros Hpool Htu j; destruct (Fin.eq_dec j i) as [->|Hneq]. + - rewrite !Vector.nth_replace_eq; exact Htu. + - rewrite !Vector.nth_replace_neq by congruence; apply Hpool. +Qed. + +Lemma source_replace_current n (ts : pool sE n) (i : Fin.t n) : + pool_equ (ts @ i := (ts $ i)) ts. +Proof. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + - rewrite Vector.nth_replace_eq; reflexivity. + - rewrite Vector.nth_replace_neq by congruence; reflexivity. +Qed. + +Lemma source_pool_equ_guard_trans {n} (ts us vs : pool sE n) : + pool_equ ts us -> pool_guard_equ us vs -> pool_guard_equ ts vs. +Proof. + intros E H i; eapply guard_equ_trans; [apply guard_equ_equ, E|apply H]. +Qed. + +Lemma handler_response_unique (e : sE) (sigma : SSig) + (result : encode e) (sigma1 : SSig) (before : list SObs) + (result' : encode e) (sigma2 : SSig) (before' : list SObs) : + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> + runStateT (sh e) sigma ~ emit_list before' (Ret (result',sigma2)) -> + before = before' /\ result = result' /\ sigma1 = sigma2. +Proof. + intros E1 E2. + assert (E : emit_list before (Ret (result,sigma1)) ~ + emit_list before' (Ret (result',sigma2))). + { transitivity (runStateT (sh e) sigma); [symmetry; exact E1|exact E2]. } + destruct (emit_list_ret_injective _ _ _ _ E) as [Ex Er]. + inversion Er; subst; auto. +Qed. + +(** Raw congruence is allowed on both ends, but no source-side [sbisim] + congruence is used. *) +Lemma ThreadSegment_equ_input t u sigma xs residual sigma' : + t ≅ u -> ThreadSegment t sigma xs residual sigma' -> + ThreadSegment u sigma xs residual sigma'. +Proof. + intros E H; eapply segment_equ; [symmetry; exact E|exact H|reflexivity]. +Qed. + +Lemma ThreadSegment_equ_output t sigma xs residual residual' sigma' : + ThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> + ThreadSegment t sigma xs residual' sigma'. +Proof. intros H E; eapply segment_equ; [reflexivity|exact H|exact E]. Qed. + +Lemma ThreadSegment_yield_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : unit -> thread sE, + t ≅ Vis (inl Yield) k -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros k E; split; [reflexivity|]; split; [reflexivity|]. + symmetry; exact (equ_vis_invE E tt). + - intros k E; step in E; cbn in E; inversion E. + - intros k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - intros k E. + assert (Eu : u ≅ Vis (inl Yield) k). + { transitivity t; [symmetry; exact Etu|exact E]. } + destruct (IH k Eu) as [Ex [Es Ek]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; assumption. +Qed. + +Lemma ThreadSegment_yield_inv k sigma xs residual sigma' : + ThreadSegment (Vis (inl Yield) k) sigma xs residual sigma' -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. +Proof. intro H; eapply ThreadSegment_yield_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_guard_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall u, t ≅ Guard u -> ThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t v sigma xs v' residual sigma' Etv H IH Eout]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E; apply equ_guard_invE in E. + eapply ThreadSegment_equ_input; [exact E|exact H]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E. + eapply ThreadSegment_equ_output; [|exact Eout]. + apply IH; transitivity t; [symmetry; exact Etv|exact E]. +Qed. + +Lemma ThreadSegment_guard_inv t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' -> + ThreadSegment t sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' <-> + ThreadSegment t sigma xs residual sigma'. +Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. + +Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall (e : sE) (k : encode e -> thread sE), + t ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) -> + exists result sigma1 before after, + xs = before ++ after /\ + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ + ThreadSegment (k result) sigma1 after residual sigma'. +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e0 k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros e k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - intros e k E; step in E; cbn in E; inversion E. + - intros e k E. + pose proof (equ_vis_invT E) as [_ Ee]. + assert (Eevent : e0 = e) by congruence; subst e. + exists result, sigma1, before, after. + split; [reflexivity|]; split; [exact Eh|]. + eapply ThreadSegment_equ_input; [exact (equ_vis_invE E result)|exact H]. + - intros e k E. + assert (Eu : u ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k))). + { transitivity t; [symmetry; exact Etu|exact E]. } + destruct (IH e k Eu) as [r [sigma1 [before [after [Ex [Eh Htail]]]]]]. + exists r, sigma1, before, after; split; [exact Ex|]; split; [exact Eh|]. + eapply ThreadSegment_equ_output; eassumption. +Qed. + +Lemma ThreadSegment_user_inv (e : sE) (k : encode e -> thread sE) + sigma xs residual sigma' : + ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma' -> + exists result sigma1 before after, + xs = before ++ after /\ + runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ + ThreadSegment (k result) sigma1 after residual sigma'. +Proof. intro H; eapply ThreadSegment_user_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_ret_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> ~ (t ≅ Ret tt). +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intro E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - apply IH; transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_ret_absurd sigma xs residual sigma' : + ~ ThreadSegment (Ret tt) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_ret_absurd_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_fork_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : bool -> thread sE, ~ (t ≅ Vis (inr (inl Fork)) k). +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros k E. + - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - step in E; cbn in E; inversion E. + - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. + - apply (IH k); transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_fork_absurd k sigma xs residual sigma' : + ~ ThreadSegment (Vis (inr (inl Fork)) k) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_fork_absurd_equ; [exact H|reflexivity]. Qed. + +Lemma ThreadSegment_br_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall n (k : Fin.t (S n) -> thread sE), ~ (t ≅ Br n k). +Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n k E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - step in E; cbn in E; inversion E. + - apply (IH n k); transitivity t; [symmetry; exact Etu|exact E]. +Qed. + +Lemma ThreadSegment_br_absurd n k sigma xs residual sigma' : + ~ ThreadSegment (Br n k) sigma xs residual sigma'. +Proof. intro H; eapply ThreadSegment_br_absurd_equ; [exact H|reflexivity]. Qed. + +(** A finite first-yield derivation cannot be manufactured by repeatedly + unfolding a divergent guard. A user case provides its actual response as + the witness needed for the first visible raw transition. *) +Lemma ThreadSegment_can_step t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> exists l u, trans l t u. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - exists (obs (inl Yield) tt), (k tt); apply trans_vis. + - destruct IH as [l [u Hstep]]; exists l, u; now apply trans_guard. + - exists (obs (inr (inr e) : CEff) result), (k result); apply trans_vis. + - destruct IH as [l [v Hstep]]; exists l, v; rewrite Etu; exact Hstep. +Qed. + +Lemma ThreadSegment_divergent_absurd t sigma xs residual sigma' : + is_stuck t -> ~ ThreadSegment t sigma xs residual sigma'. +Proof. intros Hdiv Hseg; apply Hdiv; eapply ThreadSegment_can_step; exact Hseg. Qed. + +Lemma ThreadSegment_stuck_absurd sigma xs residual sigma' : + ~ ThreadSegment (stuck : thread sE) sigma xs residual sigma'. +Proof. apply ThreadSegment_divergent_absurd, stuck_is_stuck. Qed. + +Lemma ThreadSegment_spin_absurd sigma xs residual sigma' : + ~ ThreadSegment (spin : thread sE) sigma xs residual sigma'. +Proof. + intro H; eapply ThreadSegment_br_absurd_equ; [exact H|]. + apply unfold_spin. +Qed. + +Lemma ThreadSegment_fault_absurd (e : sE) (k : encode e -> thread sE) + sigma xs residual sigma' : + runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)) -> + ~ ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma'. +Proof. + intros Ef Hseg. + destruct (ThreadSegment_user_inv e k sigma xs residual sigma' Hseg) + as [result [sigma1 [before [after [_ [Eh _]]]]]]. + apply (emit_list_ret_not_stuck before (result,sigma1)). + transitivity (runStateT (sh e) sigma); [symmetry; exact Eh|exact Ef]. +Qed. + +Lemma ThreadSegment_deterministic t sigma xs u sigma1 ys v sigma2 : + ThreadSegment t sigma xs u sigma1 -> + ThreadSegment t sigma ys v sigma2 -> + xs = ys /\ sigma1 = sigma2 /\ u ≅ v. +Proof. + intros H1; revert ys v sigma2. + induction H1 as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros ys v sigma2 H2. + - destruct (ThreadSegment_yield_inv k sigma ys v sigma2 H2) + as [Ex [Es Ek]]. + split; [symmetry; exact Ex|]; split; [symmetry; exact Es|exact Ek]. + - apply IH; now apply ThreadSegment_guard_inv in H2. + - destruct (ThreadSegment_user_inv e k sigma ys v sigma2 H2) + as [r [sigma0 [before0 [after0 [Ey [Eh0 Htail]]]]]]. + destruct (handler_response_unique e sigma result sigma1 before + r sigma0 before0 Eh Eh0) as [Eb [Er Es]]. + subst before0; subst r; subst sigma0. + destruct (IH after0 v sigma2 Htail) as [Ea [Es Er]]. + split; [subst ys; now rewrite Ea|]; split; assumption. + - assert (H2u : ThreadSegment u sigma ys v sigma2). + { eapply ThreadSegment_equ_input; [exact Etu|exact H2]. } + destruct (IH ys v sigma2 H2u) as [Ex [Es Er]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; [symmetry; exact Eout|exact Er]. +Qed. + +#[global] Instance guard_equ_Equivalence : Equivalence guard_equ. +Proof. + split. + - intro t; apply guard_equ_equ; reflexivity. + - intros t u; apply guard_equ_sym. + - intros t u v; apply guard_equ_trans. +Qed. + +Lemma guard_equ_sbisim t u : guard_equ t u -> t ~ u. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - rewrite E; reflexivity. + - rewrite sb_guard; exact IH. + - rewrite sb_guard; exact IH. + - symmetry; exact IH. + - transitivity u; assumption. +Qed. + +(** This stronger same-residual transport follows from the output-equ rule. + Symmetry in the finite guard closure is handled by proving both directions + together, rather than assuming a reverse simulation. *) +Lemma guard_equ_segment_iff t u : guard_equ t u -> + forall sigma xs residual sigma', + ThreadSegment t sigma xs residual sigma' <-> + ThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; + intros sigma xs residual sigma'. + - split; intro Hseg. + + eapply ThreadSegment_equ_input; [exact E|exact Hseg]. + + eapply ThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. + - rewrite ThreadSegment_guard_iff; apply IH. + - rewrite ThreadSegment_guard_iff; apply IH. + - symmetry; apply IH. + - transitivity (ThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. +Qed. + +Lemma guard_equ_segment t u sigma xs t' sigma' : + guard_equ t u -> ThreadSegment t sigma xs t' sigma' -> + exists u', ThreadSegment u sigma xs u' sigma' /\ guard_equ t' u'. +Proof. + intros E Hseg; exists t'; split. + - apply (proj1 (guard_equ_segment_iff t u E sigma xs t' sigma')); exact Hseg. + - apply guard_equ_equ; reflexivity. +Qed. + +Lemma guard_equ_br_yield_absurd n (k : Fin.t (S n) -> thread sE) + (ky : unit -> thread sE) : ~ guard_equ (Br n k) (Vis (inl Yield) ky). +Proof. + intro E; apply guard_equ_sbisim in E. + eapply (@sbisim_vis_br_inv CEff _ unit n (inl Yield) ky k); symmetry; exact E. +Qed. + +(** Equivalence of pools is used only for genuine raw [equ]. Guard removal + below is deliberately restricted to the focused slot. *) +Lemma segment_nd_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) + t u focus sigma : + t ≅ u -> + interp_nd (S n) (ts @ i := t) focus sigma ~ + interp_nd (S n) (ts @ i := u) focus sigma. +Proof. + intro E. + pose proof (interp_nd_equ (S n) (ts @ i := t) (ts @ i := u) + focus sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. + rewrite Ep; reflexivity. +Qed. + +Lemma segment_rr_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) + t u focus m sigma : + t ≅ u -> + interp_schedule_rr sh (S n) (ts @ i := t) focus m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := u) focus m sigma. +Proof. + intro E. + pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := t) (ts @ i := u) + focus m sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. + rewrite Ep; reflexivity. +Qed. + +Lemma segment_nd_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : + interp_nd (S n) (ts @ i := Guard t) (Some i) sigma ~ + interp_nd (S n) (ts @ i := t) (Some i) sigma. +Proof. + erewrite interp_nd_guard by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_rr_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t m sigma : + interp_schedule_rr sh (S n) (ts @ i := Guard t) (Some i) m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma. +Proof. + erewrite interp_schedule_rr_guard by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma guard_equ_focused_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) t u sigma : + guard_equ t u -> + interp_nd (S n) (ts @ i := t) (Some i) sigma ~ + interp_nd (S n) (ts @ i := u) (Some i) sigma. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_nd_replace_equ; exact E. + - etransitivity; [apply segment_nd_focused_guard|exact IH]. + - etransitivity; [exact IH|symmetry; apply segment_nd_focused_guard]. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. +Qed. + +Lemma guard_equ_focused_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) t u m sigma : + guard_equ t u -> + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ + interp_schedule_rr sh (S n) (ts @ i := u) (Some i) m sigma. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_rr_replace_equ; exact E. + - etransitivity; [apply segment_rr_focused_guard|exact IH]. + - etransitivity; [exact IH|symmetry; apply segment_rr_focused_guard]. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. +Qed. + +Lemma segment_nd_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) sigma : + interp_nd (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) sigma ~ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + interp_nd (S n) (ts @ i := k x) (Some i) sigma'). +Proof. + erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_rr_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + interp_schedule_rr sh (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ~ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). +Proof. + erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma segment_interp_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) + t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + interp_nd (S n) (ts @ i := t) (Some i) sigma ~ + emit_list xs (interp_nd (S n) (ts @ i := residual) None sigma'). +Proof. + intro H; revert n ts i. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. + - cbn [emit_list]. + erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_nd_focused_guard|apply IH]. + - etransitivity; [apply segment_nd_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => interp_nd (S n) (ts @ i := k x) (Some i) sigma0). + + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. +Qed. + +Lemma segment_interp_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ + emit_list xs (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'). +Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - cbn [emit_list]. + erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_rr_focused_guard|apply IH]. + - etransitivity; [apply segment_rr_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0). + + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. +Qed. + +(** Exact equations retain the finite administrative guard path. In particular + RR selection is not a visible branch after refinement: its three guards + must not be used as a guarded [sbisim] coinduction hypothesis. These laws + expose them for induction on an actual [trans_] derivation instead. *) +Lemma segment_rr_guard_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma : + observe (ts $ i) = GuardF t -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +Lemma segment_rr_yield_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + k m sigma : + observe (ts $ i) = VisF (inl Yield) k -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr sh (S n) (ts @ i := k tt) None m sigma). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +Lemma segment_rr_user_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + Guard (Guard (Guard + (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')))). +Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). + rewrite interp_erase_user, interp_state_vis. + apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] r <-; apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node, interp_state_tau. +Qed. + +Lemma segment_rr_select_exact n (ts : pool sE (S n)) m sigma : + interp_schedule_rr sh (S n) ts None m sigma ≅ + Guard (Guard (Guard + (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma))). +Proof. + unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, schedule_no_focus_nonempty. + rewrite interp_erase_yield. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + rewrite (unfold_run_round_robin + (Br n (fun i => schedule (S n) ts (Some i))) m). + change (interp_state sh + (interp_yield (interp_spawn + (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) sigma ≅ + Guard (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma)). + rewrite interp_erase_guard, interp_state_tau; reflexivity. +Qed. + +(** Primitive handlers return by raw equivalence in this stronger certificate. + Unlike [ThreadSegment], it retains the finite administrative guard path + needed for exact round-robin prefix alignment. *) +Inductive ExactThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := +| exact_segment_yield (k : unit -> thread sE) sigma : + ExactThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma +| exact_segment_guard t sigma logs t' sigma' : + ExactThreadSegment t sigma logs t' sigma' -> + ExactThreadSegment (Guard t) sigma logs t' sigma' +| exact_segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 + before after t' sigma' : + runStateT (sh e) sigma ≅ emit_list before (Ret (result,sigma1)) -> + ExactThreadSegment (k result) sigma1 after t' sigma' -> + ExactThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) + sigma (before ++ after) t' sigma' +| exact_segment_equ t u sigma logs u' t' sigma' : + t ≅ u -> ExactThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> + ExactThreadSegment t sigma logs t' sigma'. + +Lemma ExactThreadSegment_segment t sigma xs residual sigma' : + ExactThreadSegment t sigma xs residual sigma' -> + ThreadSegment t sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - apply segment_yield. + - apply segment_guard; exact IH. + - eapply segment_user; [|exact IH]. + eapply equ_clos_sbisim_goal; [exact Eh|reflexivity|reflexivity]. + - eapply segment_equ; eassumption. +Qed. + +Lemma ExactThreadSegment_equ_input t u sigma xs residual sigma' : + t ≅ u -> ExactThreadSegment t sigma xs residual sigma' -> + ExactThreadSegment u sigma xs residual sigma'. +Proof. + intros E H; eapply exact_segment_equ; [symmetry; exact E|exact H|reflexivity]. +Qed. + +Lemma ExactThreadSegment_equ_output t sigma xs residual residual' sigma' : + ExactThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> + ExactThreadSegment t sigma xs residual' sigma'. +Proof. intros H E; eapply exact_segment_equ; [reflexivity|exact H|exact E]. Qed. + +Lemma ExactThreadSegment_guard_inv_equ t sigma xs residual sigma' : + ExactThreadSegment t sigma xs residual sigma' -> + forall u, t ≅ Guard u -> ExactThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t v sigma xs v' residual sigma' Etv H IH Eout]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E; apply equ_guard_invE in E. + eapply ExactThreadSegment_equ_input; [exact E|exact H]. + - intros u E; step in E; cbn in E; inversion E. + - intros u E. + eapply ExactThreadSegment_equ_output; [|exact Eout]. + apply IH; transitivity t; [symmetry; exact Etv|exact E]. +Qed. + +Lemma ExactThreadSegment_guard_inv t sigma xs residual sigma' : + ExactThreadSegment (Guard t) sigma xs residual sigma' -> + ExactThreadSegment t sigma xs residual sigma'. +Proof. intro H; eapply ExactThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. + +Lemma ExactThreadSegment_guard_iff t sigma xs residual sigma' : + ExactThreadSegment (Guard t) sigma xs residual sigma' <-> + ExactThreadSegment t sigma xs residual sigma'. +Proof. split; [apply ExactThreadSegment_guard_inv|apply exact_segment_guard]. Qed. + +Lemma guard_equ_exact_segment_iff t u : guard_equ t u -> + forall sigma xs residual sigma', + ExactThreadSegment t sigma xs residual sigma' <-> + ExactThreadSegment u sigma xs residual sigma'. +Proof. + intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; + intros sigma xs residual sigma'. + - split; intro Hseg. + + eapply ExactThreadSegment_equ_input; [exact E|exact Hseg]. + + eapply ExactThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. + - rewrite ExactThreadSegment_guard_iff; apply IH. + - rewrite ExactThreadSegment_guard_iff; apply IH. + - symmetry; apply IH. + - transitivity (ExactThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. +Qed. + +Lemma ThreadSegment_branchfree t sigma logs residual sigma' : + ThreadSegment t sigma logs residual sigma' -> + BranchFree t -> BranchFree residual. +Proof. + intro H; induction H as + [k sigma|t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intro Hbf. + - apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; assumption. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - eapply branchfree_equ_impl; [exact Eout|]. + apply IH; eapply branchfree_equ_impl; eassumption. +Qed. + +(** An exact segment may end at a residual differing from its target only by + finite leading guards and raw tree equivalence. *) +Definition exact_source_segment_to (t : thread sE) (sigma : SSig) + (logs : list SObs) (target : thread sE) (sigma' : SSig) : Prop := + exists residual, ExactThreadSegment t sigma logs residual sigma' /\ + guard_equ residual target. + +Lemma exact_source_equ t u sigma logs target sigma' : + t ≅ u -> exact_source_segment_to u sigma logs target sigma' -> + exact_source_segment_to t sigma logs target sigma'. +Proof. + intros Htu (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ; [exact Htu|exact Hseg|reflexivity]. +Qed. + +Lemma exact_source_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) sigma logs target sigma' : + exact_source_segment_to (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end) + sigma logs target sigma' -> + exact_source_segment_to (denote_flow (CBind p next) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply exact_source_equ; [apply source_raw_bind|exact H]. +Qed. + +Lemma exact_source_ret {A} (x : A) (K : option A -> thread sE) + sigma logs target sigma' : + exact_source_segment_to (K (Some x)) sigma logs target sigma' -> + exact_source_segment_to (denote_flow (CRet x) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply exact_source_equ; [apply source_raw_ret|exact H]. +Qed. + +Lemma exact_source_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) sigma logs target sigma' : + exact_source_segment_to (denote_flow body >>= until_tail body K) + sigma logs target sigma' -> + exact_source_segment_to (denote_flow (CUntilNone body) >>= K) + sigma logs target sigma'. +Proof. + intro H; eapply exact_source_equ; [apply source_raw_until|exact H]. +Qed. + +Lemma exact_source_read a v (K : option nat -> thread sE) + h c logs target sigma' : + h a = Some v -> + exact_source_segment_to (K (Some v)) (h,c) logs target sigma' -> + exact_source_segment_to (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))). + - apply source_raw_read_head. + - change (ExactThreadSegment (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_rd_some a h c v Hr); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_write a v (K : option unit -> thread sE) + h c logs target sigma' : + h a <> None -> + exact_source_segment_to (K (Some tt)) (upd h a v,c) logs target sigma' -> + exact_source_segment_to (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. +Proof. + intros Hp (residual & Hseg & Htail). + destruct (h a) as [w|] eqn:Hw; [|contradiction]. + exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))). + - apply source_raw_write_head. + - change (ExactThreadSegment (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (sh_wr_some a h c v w Hw); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_emit tag block (K : option unit -> thread sE) + h c logs target sigma' : + exact_source_segment_to (K (Some tt)) (h,S c) logs target sigma' -> + exact_source_segment_to (denote_flow (CEmit tag block) >>= K) (h,c) + (SPop tag block c :: logs) target sigma'. +Proof. + intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))). + - apply source_raw_emit_head. + - change (ExactThreadSegment + (Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))) + (h,c) ([SPop tag block c] ++ logs) residual sigma'). + eapply exact_segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite sh_emit; reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_cas_success a expected desired + (K : option bool -> thread sE) h c logs target sigma' : + h a = Some expected -> + exact_source_segment_to (K (Some true)) (upd h a desired,c) logs target sigma' -> + exact_source_segment_to (denote_flow (CCAS a expected desired) >>= K) + (h,c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). + - apply source_raw_cas_head. + - change (ExactThreadSegment + (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_cas_success a expected desired h c Hr); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_cas_failure a expected desired current + (K : option bool -> thread sE) h c logs target sigma' : + h a = Some current -> current <> expected -> + exact_source_segment_to (K (Some false)) (h,c) logs target sigma' -> + exact_source_segment_to (denote_flow (CCAS a expected desired) >>= K) + (h,c) logs target sigma'. +Proof. + intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply exact_segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). + - apply source_raw_cas_head. + - change (ExactThreadSegment + (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) + (h,c) ([] ++ logs) residual sigma'). + eapply exact_segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (sh_cas_failure a expected desired current h c Hr Hne); + reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_yield (K : option unit -> thread sE) sigma target : + guard_equ (K (Some tt)) target -> + exact_source_segment_to (denote_flow CYield >>= K) sigma [] target sigma. +Proof. + intro Htail; exists (K (Some tt)); split; [|exact Htail]. + eapply exact_segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). + - apply source_raw_yield_head. + - apply exact_segment_yield. + - reflexivity. +Qed. + +(** Finite syntax normalization is used only for raw equ and leading guards. + It never changes a scheduler focus or invokes pool sbisim congruence. *) +Ltac csl_raw_equ := + cbn beta iota zeta; + first [reflexivity | + lazymatch goal with + | |- (denote_flow (CBind _ _) >>= _) ≅ _ => + etransitivity; [apply source_raw_bind|]; csl_raw_equ + | |- (denote_flow (CRet _) >>= _) ≅ _ => + etransitivity; [apply source_raw_ret|]; csl_raw_equ + | |- ((?t >>= ?k) >>= ?j) ≅ _ => + etransitivity; [apply bind_bind|]; csl_raw_equ + | |- (Ret _ >>= _) ≅ _ => + etransitivity; [apply bind_ret_l|]; csl_raw_equ + | |- _ ≅ (denote_flow (CBind _ _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ (denote_flow (CRet _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ ((_ >>= _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ (Ret _ >>= _) => symmetry; csl_raw_equ + | |- Guard _ ≅ Guard _ => apply guard_equ_node; csl_raw_equ + end]. + +#[global] Instance source_guard_equ_proper : + Proper (equ eq ==> equ eq ==> iff) guard_equ. +Proof. + intros t t' Ht u u' Hu; split; intro H. + - eapply guard_equ_trans; [apply guard_equ_equ; symmetry; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; exact Hu]. + - eapply guard_equ_trans; [apply guard_equ_equ; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; symmetry; exact Hu]. +Qed. + +Lemma exact_rr_user_replaced n (ts : pool sE (S n)) (i : Fin.t (S n)) + (e : sE) (k : encode e -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ≅ + (runStateT (sh e) sigma >>= fun '(x,sigma') => + rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')). +Proof. + etransitivity. + - eapply segment_rr_user_exact; rewrite Vector.nth_replace_eq; reflexivity. + - apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] y <-; rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma exact_segment_rr_prefix n (ts : pool sE (S n)) (i : Fin.t (S n)) + t m sigma logs residual sigma' : + ExactThreadSegment t sigma logs residual sigma' -> + exists word, rr_prefix_events word = logs /\ + interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ≅ + rr_prefix word (Guard + (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma')). +Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - exists []; split; [reflexivity|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_yield_exact; rewrite Vector.nth_replace_eq; reflexivity. + + rewrite Vector.replace_replace_eq; reflexivity. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (RRGuard :: word); split; [exact Ew|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_guard_exact; rewrite Vector.nth_replace_eq; reflexivity. + + apply guard_equ_node; rewrite Vector.replace_replace_eq; exact Et. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (List.map RRLog before ++ RRGuard :: RRGuard :: RRGuard :: word); split. + + rewrite rr_prefix_events_app, rr_prefix_events_logs; cbn [rr_prefix_events]. + now rewrite Ew. + + etransitivity; [apply exact_rr_user_replaced|]. + set (resume := fun response : (encode e * SSig)%type => + let '(x,sigma0) := response in + rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0)). + transitivity (emit_list before (Ret (result,sigma1)) >>= resume). + * apply equ_clo_bind with (S := eq); [exact Eh|intros x y <-; reflexivity]. + * etransitivity; [apply emit_list_ret_bind|]; unfold resume. + transitivity (emit_list before + (rr_guards 3 (rr_prefix word (Guard + (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'))))). + -- apply emit_list_equ, rr_guards_equ; exact Et. + -- rewrite rr_prefix_app; cbn [rr_prefix rr_guards]. + symmetry; apply rr_prefix_emit. + - destruct (IH n ts i m) as (word & Ew & Et). + exists word; split; [exact Ew|]. + etransitivity. + + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|exact Etu]. + + etransitivity; [exact Et|]. + apply rr_prefix_equ, guard_equ_node, interp_schedule_rr_equ, replace_pool_equ; + [apply pool_equ_refl|exact Eout]. +Qed. + +Theorem source_segment_scheduler_steps {n} (ts : pool sE (S n)) sigma i logs residual sigma' ts' : + ThreadSegment (ts $ i) sigma logs residual sigma' -> + pool_equ ts' (ts @ i := residual) -> + exists next, + finite_steps (interp_nd (S n) ts None sigma) + (tau :: List.map (fun o => obs (Log o) tt) logs) next /\ + next ~ interp_nd (S n) ts' None sigma'. +Proof. + intros Hseg Epool. + assert (Efocused : interp_nd (S n) ts (Some i) sigma ~ + emit_list logs (interp_nd (S n) ts' None sigma')). + { + transitivity (interp_nd (S n) (ts @ i := (ts $ i)) (Some i) sigma). + - rewrite (interp_nd_equ (S n) _ _ (Some i) sigma (source_replace_current (S n) ts i)); + reflexivity. + - transitivity (emit_list logs (interp_nd (S n) (ts @ i := residual) None sigma')). + + eapply segment_interp_nd; exact Hseg. + + apply emit_list_sbisim. + rewrite <- (interp_nd_equ (S n) _ _ None sigma' Epool); reflexivity. + } + assert (Hbranch : trans tau (Br n (fun j => interp_nd (S n) ts (Some j) sigma)) + (interp_nd (S n) ts (Some i) sigma)). + { eapply trans_br with (x := i); reflexivity. } + pose proof (interp_nd_select n ts sigma) as Eselect; symmetry in Eselect. + destruct (sbisim_trans _ _ _ tau eq Eselect Hbranch) + as (l & focused & Hchoose & El & Efocus); subst l. + assert (Eemit : emit_list logs (interp_nd (S n) ts' None sigma') ~ focused). + { transitivity (interp_nd (S n) ts (Some i) sigma); [symmetry; exact Efocused|exact Efocus]. } + destruct (finite_steps_sbisim _ _ _ + (finite_steps_emit_list logs (interp_nd (S n) ts' None sigma')) focused Eemit) + as (next & Hlogs & Enext). + exists next; split; [econstructor; eassumption|symmetry; exact Enext]. +Qed. diff --git a/theories/Lang/CSL/Ticl.v b/theories/Lang/CSL/Ticl.v new file mode 100644 index 0000000..7b0265c --- /dev/null +++ b/theories/Lang/CSL/Ticl.v @@ -0,0 +1,1815 @@ +From Stdlib Require Import Arith.PeanoNat Fin Vector. +From TICL Require Import + Lang.CSL.Syntax Lang.CSL.Pcm Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer + ICTree.Events.Yield ICTree.Events.Heap ICTree.Interp.Refine ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.RoundRobin ICTree.Logic.Trans + ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG + ICTree.Logic.Bind ICTree.Logic.State Logic.Core Utils.Vectors. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. +Local Typeclasses Transparent equ sbisim. + +(** ** Selection from an unfocused nonempty pool *) + +Lemma anl_csl_nd_select n (ts : pool sE (S n)) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + ts (None) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + ts (Some j) (h,c)}, {w} |= ψ )>)). +Proof. + rewrite interp_nd_select. + apply anl_br. +Qed. + +Lemma anr_csl_nd_select n (ts : pool sE (S n)) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + ts (None) (h,c)}, {w} |= φ AN ψ ]> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_nd (S n) + ts (Some j) (h,c)}, {w} |= ψ ]>)). +Proof. + rewrite interp_nd_select. + apply anr_br. +Qed. + +Lemma aul_csl_nd_select n (ts : pool sE (S n)) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + ts (None) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= ψ )> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + ts (Some j) (h,c)}, {w} |= φ AU ψ )>))). +Proof. + rewrite interp_nd_select. + symmetry; apply aul_br. +Qed. + +Lemma aur_csl_nd_select n (ts : pool sE (S n)) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + ts (None) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= ψ ]> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_nd (S n) + ts (Some j) (h,c)}, {w} |= φ AU ψ ]>))). +Proof. + rewrite interp_nd_select. + symmetry; apply aur_br. +Qed. + +Lemma ag_csl_nd_select n (ts : pool sE (S n)) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + ts (None) (h,c)}, {w} |= AG φ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + ts (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + ts (Some j) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_nd_select. + symmetry; apply ag_br. +Qed. + +Lemma anl_csl_rr_select n (ts : pool sE (S n)) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma anr_csl_rr_select n (ts : pool sE (S n)) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma aul_csl_rr_select n (ts : pool sE (S n)) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma aur_csl_rr_select n (ts : pool sE (S n)) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma ag_csl_rr_select n (ts : pool sE (S n)) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +(** ** Checked silent effects *) + +Lemma anl_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a = Some value -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. +Qed. + +Lemma anr_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some value -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. +Qed. + +Lemma aul_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a = Some value -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. +Qed. + +Lemma aur_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some value -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. +Qed. + +Lemma ag_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h c w + (φ : ticllW SObs) : + h a = Some value -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. +Qed. + +Lemma anl_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. +Qed. + +Lemma anr_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. +Qed. + +Lemma aul_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. +Qed. + +Lemma aur_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. +Qed. + +Lemma ag_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. +Qed. + +Lemma anl_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a <> None -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. +Qed. + +Lemma anr_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a <> None -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. +Qed. + +Lemma aul_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a <> None -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. +Qed. + +Lemma aur_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a <> None -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. +Qed. + +Lemma ag_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h c w + (φ : ticllW SObs) : + h a <> None -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= AG φ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. +Qed. + +Lemma anl_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. +Qed. + +Lemma anr_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. +Qed. + +Lemma aul_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. +Qed. + +Lemma aur_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. +Qed. + +Lemma ag_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= AG φ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. +Qed. + +Lemma anl_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. +Qed. + +Lemma anr_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. +Qed. + +Lemma aul_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. +Qed. + +Lemma aur_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. +Qed. + +Lemma ag_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h c w + (φ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. +Qed. + +Lemma anl_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. +Qed. + +Lemma anr_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. +Qed. + +Lemma aul_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. +Qed. + +Lemma aur_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. +Qed. + +Lemma ag_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= AG φ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. +Qed. + +Lemma anl_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a = Some current -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. +Qed. + +Lemma anr_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some current -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. +Qed. + +Lemma aul_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c w + (φ ψ : ticllW SObs) : + h a = Some current -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. +Qed. + +Lemma aur_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some current -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. +Qed. + +Lemma ag_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h c w + (φ : ticllW SObs) : + h a = Some current -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {if Nat.eqb current expected then + interp_nd (S n) + (ts @ i := K (Some true)) (Some i) (upd h a desired,c) + else + interp_nd (S n) + (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. +Qed. + +Lemma anl_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. +Qed. + +Lemma anr_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. +Qed. + +Lemma aul_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c w + (φ ψ : ticllW SObs) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. +Qed. + +Lemma aur_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. +Qed. + +Lemma ag_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h c w + (φ : ticllW SObs) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. +Qed. + +(** ** Source flow and pool structure *) + +Lemma anl_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_nd (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_nd (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_nd (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_nd (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {interp_nd (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. +Qed. + +(** ** Observable emission and cooperative selection *) + +Lemma anl_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ )>)). +Proof. + rewrite interp_nd_source_emit_log. + apply anl_log_iff. +Qed. + +Lemma anr_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ + <[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ ]>)). +Proof. + rewrite interp_nd_source_emit_log. + apply anr_log_iff. +Qed. + +Lemma aul_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ )> \/ + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ )>))). +Proof. + rewrite interp_nd_source_emit_log. + apply aul_log_iff. +Qed. + +Lemma aur_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ ]> \/ + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ + <[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ ]>))). +Proof. + rewrite interp_nd_source_emit_log. + apply aur_log_iff. +Qed. + +Lemma ag_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {log (SPop tag value c);; + interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= AG φ )>)). +Proof. + rewrite interp_nd_source_emit_log. + apply ag_log_iff. +Qed. + +Lemma anl_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ )>)). +Proof. + rewrite interp_rr_emit_log. + apply anl_log_iff. +Qed. + +Lemma anr_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ ]>)). +Proof. + rewrite interp_rr_emit_log. + apply anr_log_iff. +Qed. + +Lemma aul_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ )> \/ + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ )>))). +Proof. + rewrite interp_rr_emit_log. + apply aul_log_iff. +Qed. + +Lemma aur_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ ]> \/ + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ ]>))). +Proof. + rewrite interp_rr_emit_log. + apply aur_log_iff. +Qed. + +Lemma ag_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {log (SPop tag value c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= AG φ )>)). +Proof. + rewrite interp_rr_emit_log. + apply ag_log_iff. +Qed. + +Lemma anl_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ )>)). +Proof. + rewrite interp_nd_source_yield. + apply anl_csl_nd_select. +Qed. + +Lemma anr_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ ]>)). +Proof. + rewrite interp_nd_source_yield. + apply anr_csl_nd_select. +Qed. + +Lemma aul_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ )> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ )>))). +Proof. + rewrite interp_nd_source_yield. + apply aul_csl_nd_select. +Qed. + +Lemma aur_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ ]> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ ]>))). +Proof. + rewrite interp_nd_source_yield. + apply aur_csl_nd_select. +Qed. + +Lemma ag_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_nd (S n) + (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_nd_source_yield. + apply ag_csl_nd_select. +Qed. + +Lemma anl_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite interp_rr_yield. + apply anl_csl_rr_select. +Qed. + +Lemma anr_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite interp_rr_yield. + apply anr_csl_rr_select. +Qed. + +Lemma aul_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite interp_rr_yield. + apply aul_csl_rr_select. +Qed. + +Lemma aur_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite interp_rr_yield. + apply aur_csl_rr_select. +Qed. + +Lemma ag_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_rr_yield. + apply ag_csl_rr_select. +Qed. + +(** ** Finite heaps supply their constructive first-fit witness *) + +Lemma anl_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anr_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aul_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c w + (φ ψ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aur_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma ag_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h c w + (φ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_nd (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_nd (S n) + (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anl_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anr_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aul_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c w + (φ ψ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aur_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma ag_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h c w + (φ : ticllW SObs) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= AG φ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (sh_alloc_finite h size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)). + apply Hall; assumption. +Qed. + +(** ** Total single-cell free through the shared raw heap event *) + +Lemma anl_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> + <( {interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AN ψ )>). +Proof. + rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. +Qed. + +Lemma anr_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> + <[ {interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AN ψ ]>). +Proof. + rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. +Qed. + +Lemma aul_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c w + (φ ψ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> + <( {interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AU ψ )>). +Proof. + rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. +Qed. + +Lemma aur_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> + <[ {interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AU ψ ]>). +Proof. + rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. +Qed. + +Lemma ag_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) h c w + (φ : ticllW SObs) : + (<( {interp_nd (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> + <( {interp_nd (S n) + (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= AG φ )>). +Proof. + rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. +Qed. + +Lemma anl_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AN ψ )>). +Proof. + rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. +Qed. + +Lemma anr_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AN ψ ]>). +Proof. + rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. +Qed. + +Lemma aul_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c w + (φ ψ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AU ψ )>). +Proof. + rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. +Qed. + +Lemma aur_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c w + (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AU ψ ]>). +Proof. + rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. +Qed. + +Lemma ag_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : unit -> thread sE) m h c w + (φ : ticllW SObs) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= AG φ )>). +Proof. + rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. +Qed. diff --git a/theories/Lang/HeapImp.v b/theories/Lang/HeapImp.v index a5b935a..a775768 100644 --- a/theories/Lang/HeapImp.v +++ b/theories/Lang/HeapImp.v @@ -14,6 +14,7 @@ From TICL Require Import ICTree.SBisim ICTree.Equ ICTree.Interp.State.Mod + ICTree.Events.Heap ICTree.Events.State ICTree.Events.Writer ICTree.Logic.Trans @@ -110,6 +111,38 @@ Module HeapImp. | S n' => add base 0 (heap_init (S base) n' h) end. + (** Lower shared heap commands to this backend's existing state effects. *) + Definition h_heapimp : heapE ~> ictree memE := + fun e => + match e return ictree memE (encode e) with + | HRead a => + m <- get ;; + match lookup a (heap m) with + | Some v => Ret v + | None => stuck + end + | HWrite a v => + m <- get ;; + put (update_heap a v m) + | HAlloc n => + m <- get ;; + let base := fresh_addr (heap m) in + put {| store := store m; heap := heap_init base n (heap m) |} ;; + Ret base + | HFree a => + m <- get ;; + put (free_heap a m) + | HCAS a expected desired => + m <- get ;; + match lookup a (heap m) with + | None => stuck + | Some current => + if Nat.eqb current expected + then put (update_heap a desired m) ;; Ret true + else Ret false + end + end. + (** Denotation of expressions to [ictree] *) Fixpoint cdenote_exp(e: CExp): ictree memE nat := match e with @@ -129,18 +162,10 @@ Module HeapImp. Ret (x - y) | CHeapAlloc sz => n <- cdenote_exp sz ;; - m <- get ;; - let base := fresh_addr (heap m) in - let h' := heap_init base n (heap m) in - put {| store := store m; heap := h' |} ;; - Ret base + h_heapimp (HAlloc n) | CHeapRead a => addr <- cdenote_exp a ;; - m <- get ;; - match lookup addr (heap m) with - | Some x => Ret x - | None => stuck - end + h_heapimp (HRead addr) end. (** Denotation of boolean comparison expressions to [ictree] *) @@ -170,12 +195,10 @@ Module HeapImp. | CHeapWrite a v => addr <- cdenote_exp a ;; val <- cdenote_exp v ;; - m <- get ;; - put {| store := store m; heap := add addr val (heap m) |} + h_heapimp (HWrite addr val) | CHeapFree a => addr <- cdenote_exp a ;; - m <- get ;; - put {| store := store m; heap := remove addr (heap m) |} + h_heapimp (HFree addr) | CIf c t e => bv <- cdenote_comp c ;; if bv then diff --git a/theories/Utils/Relations.v b/theories/Utils/Relations.v new file mode 100644 index 0000000..35afd2d --- /dev/null +++ b/theories/Utils/Relations.v @@ -0,0 +1,114 @@ +From Stdlib Require Import Relations Arith.Wf_nat Arith.PeanoNat List Lia. + +(** One natural-number lexicographic layer over an arbitrary relation. *) +Definition lexn {A} (R: relation A) : relation (nat * A) := + fun p q => fst p < fst q \/ (fst p = fst q /\ R (snd p) (snd q)). + +Lemma lexn_wf {A} (R: relation A): well_founded R -> well_founded (lexn R). +Proof. + intros HR [a b]; revert b. + induction a as [a IHa] using (well_founded_induction lt_wf). + intro b. + induction b as [b IHb] using (well_founded_induction HR). + constructor; intros [c d] [Hlt | (Heq & Hlt)]; cbn in *. + - now apply IHa. + - subst c; now apply IHb. +Qed. + +(** Natural pair and triple ranks share the same lexicographic construction. *) +Definition lexnat : relation (nat * nat) := lexn lt. + +Lemma lexnat_wf: well_founded lexnat. +Proof. apply lexn_wf, lt_wf. Qed. + +Definition rank3 : relation (nat * (nat * nat)) := lexn (lexn lt). + +Lemma rank3_wf: well_founded rank3. +Proof. apply lexn_wf, lexn_wf, lt_wf. Qed. + +(** Decrease in the first, second, or third component of a triple. *) +Lemma rank3_bound: forall b b' p p' q q', + b' < b -> rank3 (b', (p', q')) (b, (p, q)). +Proof. intros; left; cbn; assumption. Qed. + +Lemma rank3_pos: forall b p p' q q', + p' < p -> rank3 (b, (p', q')) (b, (p, q)). +Proof. intros; right; cbn; split; [reflexivity | left; cbn; assumption]. Qed. + +Lemma rank3_phase: forall b p q q', + q' < q -> rank3 (b, (p, q')) (b, (p, q)). +Proof. + intros; right; cbn; split; [reflexivity |]. + right; cbn; split; [reflexivity | assumption]. +Qed. + +(** Occurrences arbitrarily far along a sequence, and counts in finite + half-open intervals. *) +Definition infinitely (P : nat -> Prop) : Prop := + forall n, exists k, n <= k /\ P k. + +Definition count_if (p : nat -> bool) (lo len : nat) : nat := + List.length (List.filter p (List.seq lo len)). + +Lemma count_if_zero p lo : count_if p lo 0 = 0. +Proof. reflexivity. Qed. + +Lemma count_if_succ p lo len : + count_if p lo (S len) = (if p lo then 1 else 0) + count_if p (S lo) len. +Proof. + unfold count_if; cbn [List.seq List.filter]; destruct (p lo); reflexivity. +Qed. + +Lemma count_if_add p lo left right : + count_if p lo (left + right) = count_if p lo left + count_if p (lo + left) right. +Proof. + unfold count_if; rewrite List.seq_app, List.filter_app, List.length_app; reflexivity. +Qed. + +Lemma infinitely_count_if (p : nat -> bool) : + infinitely (fun k => p k = true) -> + forall wanted lo, exists len, wanted <= count_if p lo len. +Proof. + intros Hinf wanted; induction wanted as [|wanted IH]; intro lo. + - exists 0; rewrite count_if_zero; lia. + - destruct (Hinf lo) as [k [Hlo Hk]]. + destruct (IH (S k)) as [len Hlen]. + exists ((k - lo) + S len). + rewrite count_if_add. + replace (lo + (k - lo)) with k by lia. + rewrite count_if_succ, Hk; cbn; lia. +Qed. + +(** Constructively find the first satisfying index in a finite interval, + or establish that the whole interval has no satisfying index. *) +Lemma finite_first (P : nat -> Prop) + (dec : forall j, sumbool (P j) (not (P j))) lo len : + (forall j, lo <= j < lo + len -> ~ P j) \/ + exists j, lo <= j < lo + len /\ P j /\ forall i, lo <= i < j -> ~ P i. +Proof. + revert lo; induction len as [|len IH]; intro lo. + - left; intros; lia. + - destruct (dec lo) as [Hyes|Hno]. + + right; exists lo; split; [lia|]; split; [exact Hyes|]. + intros i Hi; lia. + + destruct (IH (S lo)) as [Hnone|(j & Hj & HP & Hfirst)]. + * left; intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; + [exact Hno|apply Hnone; lia]. + * right; exists j; split; [lia|]; split; [exact HP|]. + intros i Hi; destruct (Nat.eq_dec i lo) as [->|Hne]; + [exact Hno|apply Hfirst; lia]. +Qed. + +(** Boolean existence search is a projection of the same first-index search. *) +Lemma finite_bool_search (p : nat -> bool) lo len : + (exists k, lo <= k < lo + len /\ p k = true) \/ + (forall k, lo <= k < lo + len -> p k = false). +Proof. + assert (dec : forall k, sumbool (p k = true) (p k <> true)). + { intro k; destruct (p k); [left; reflexivity|right; discriminate]. } + destruct (finite_first (fun k => p k = true) dec lo len) + as [Hnone|(k & Hk & Hp & _) ]. + - right; intros k Hk. + destruct (p k) eqn:Hp; [exfalso; exact (Hnone k Hk Hp)|reflexivity]. + - left; exists k; split; assumption. +Qed. From 07c5bc0d8abb5a23c52f33c451a27e59eda389c0 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 25 Sep 2026 19:45:50 +0000 Subject: [PATCH 08/14] refactor(csl): reduce example machinery to Logic and Interp laws Move reusable allocator/queue example machinery into canonical ICTree, Utils and Events owners and delete the test, smoke and fixture modules. - Utils: ExtLib Roption / Stdlib RelProd replace local result relations; periodic choices and window list facts move to Utils.Lists. - Events.HeapModel owns stride-two geometry and link initialization; the queue and allocator layouts reuse it. Adds block_pto_overlap_false and hfree_absent_noop. - ICTree.Interp.Yield.Execution: strengthened selected_segment_deterministic, selected_segment_complete, worker guarantees, source_execution_complete, pool_simulation_reachable, source_execution_of_slots_valid, and model_rr_emit_batches. - ICTree.Logic: emit_batches_agaf proved directly by suffix coinduction; model_rr_agaf; singleton scheduler rules reproved from Interp equations. State.Mod no longer imports Logic.Trans. - Lang: HeapImp instruction equations, equ_guard_stuck, productive/silent CUntilNone loop theorems, queue four-pop and empty-heap stuck/no-AG results. - Allocator: turn_proper is the sole congruence; turn_view_complete carries the ownership transition; raw executions use the library Execution and pool_execution_valid; recurrence goes through model_rr_agaf. Starvation and owner-stall counterexamples live in Allocator/Counterexamples.v and ABA safety in Liveness, with section-local witnesses. - Delete GeneralizationSmoke, StructuralTemporalSmoke, HeapEventTests, CSL/{PcmTests,HeapTests,RoundRobinTests,InterpTests,TiclTests,QueueTests, NegativeTests,Layout}, Allocator/{Tests,NegativeTests}. The 130 CSL structural rules are unchanged. All audited results depend only on the inherited eq_rect_eq and functional_extensionality_dep. --- .../{NegativeTests.v => Counterexamples.v} | 664 ++++--- examples/CSL/Allocator/Execution.v | 545 ++---- examples/CSL/Allocator/Layout.v | 191 +- examples/CSL/Allocator/Liveness.v | 1587 ++++++----------- examples/CSL/Allocator/Model.v | 629 ++----- examples/CSL/Allocator/Tests.v | 234 --- examples/CSL/HeapTests.v | 126 -- examples/CSL/InterpTests.v | 297 --- examples/CSL/Layout.v | 105 -- examples/CSL/NegativeTests.v | 109 -- examples/CSL/Overlap.v | 70 +- examples/CSL/PcmTests.v | 30 - examples/CSL/QueueTests.v | 337 ---- examples/CSL/README.md | 138 +- examples/CSL/RoundRobinTests.v | 104 -- examples/CSL/TiclTests.v | 784 -------- examples/HeapEventTests.v | 201 --- examples/Queue.v | 81 +- theories/Events/HeapModel.v | 652 +++++++ theories/Events/WriterE.v | 21 + theories/ICTree/Eq/Bind.v | 7 + theories/ICTree/Equ.v | 66 +- theories/ICTree/Events/Writer.v | 19 +- theories/ICTree/Interp/Core.v | 2 + theories/ICTree/Interp/Heap.v | 397 +++++ theories/ICTree/Interp/Refine.v | 14 +- theories/ICTree/Interp/State/Mod.v | 25 +- theories/ICTree/Interp/Yield/Execution.v | 754 ++++++++ .../ICTree/Interp/Yield/Nondeterministic.v | 204 +++ theories/ICTree/Interp/Yield/SBisim.v | 68 +- theories/ICTree/Interp/Yield/Segments.v | 796 +++++++++ theories/ICTree/Logic/CanStep.v | 16 +- theories/ICTree/Logic/Heap.v | 48 + theories/ICTree/Logic/State.v | 2 + theories/ICTree/Logic/Trace.v | 90 +- theories/ICTree/Logic/Yield.v | 197 +- theories/ICTree/SBisim.v | 12 + theories/ICTree/Trace.v | 101 ++ theories/Lang/CSL.v | 2 +- theories/Lang/CSL/Heap.v | 485 +---- theories/Lang/CSL/Interp.v | 350 ++-- theories/Lang/CSL/Pcm.v | 570 ------ theories/Lang/CSL/Queue/Alternating.v | 40 +- theories/Lang/CSL/Queue/Composition.v | 103 +- theories/Lang/CSL/Queue/Frame.v | 10 +- theories/Lang/CSL/Queue/Layout.v | 72 +- theories/Lang/CSL/Queue/Operations.v | 12 +- theories/Lang/CSL/Queue/Program.v | 132 +- theories/Lang/CSL/Queue/Recurrence.v | 107 +- theories/Lang/CSL/Queue/Representation.v | 307 ++-- theories/Lang/CSL/Queue/Separation.v | 42 +- theories/Lang/CSL/Queue/Sequential.v | 65 +- theories/Lang/CSL/Queue/Ticl.v | 79 +- theories/Lang/CSL/Queue/Trace.v | 17 +- theories/Lang/CSL/Segments.v | 910 +--------- theories/Lang/CSL/Ticl.v | 790 ++++---- theories/Lang/HeapImp.v | 98 +- theories/Utils/Execution.v | 501 ++++++ theories/Utils/Lists.v | 316 ++++ theories/Utils/Pcm.v | 242 +++ theories/Utils/Relations.v | 77 + theories/Utils/Utils.v | 54 - theories/Utils/Vectors.v | 29 +- 63 files changed, 6948 insertions(+), 8185 deletions(-) rename examples/CSL/Allocator/{NegativeTests.v => Counterexamples.v} (50%) delete mode 100644 examples/CSL/Allocator/Tests.v delete mode 100644 examples/CSL/HeapTests.v delete mode 100644 examples/CSL/InterpTests.v delete mode 100644 examples/CSL/Layout.v delete mode 100644 examples/CSL/NegativeTests.v delete mode 100644 examples/CSL/PcmTests.v delete mode 100644 examples/CSL/QueueTests.v delete mode 100644 examples/CSL/RoundRobinTests.v delete mode 100644 examples/CSL/TiclTests.v delete mode 100644 examples/HeapEventTests.v create mode 100644 theories/Events/HeapModel.v create mode 100644 theories/ICTree/Interp/Heap.v create mode 100644 theories/ICTree/Interp/Yield/Execution.v create mode 100644 theories/ICTree/Interp/Yield/Nondeterministic.v create mode 100644 theories/ICTree/Interp/Yield/Segments.v create mode 100644 theories/ICTree/Logic/Heap.v delete mode 100644 theories/Lang/CSL/Pcm.v create mode 100644 theories/Utils/Execution.v create mode 100644 theories/Utils/Lists.v create mode 100644 theories/Utils/Pcm.v diff --git a/examples/CSL/Allocator/NegativeTests.v b/examples/CSL/Allocator/Counterexamples.v similarity index 50% rename from examples/CSL/Allocator/NegativeTests.v rename to examples/CSL/Allocator/Counterexamples.v index eef6e07..e91770b 100644 --- a/examples/CSL/Allocator/NegativeTests.v +++ b/examples/CSL/Allocator/Counterexamples.v @@ -1,175 +1,82 @@ +(** * Constructive counterexamples for the allocator's liveness premises. + + Two infinite executions of the actual model, each realized by the actual + source program: + + - [Starvation]: fair choices under which remote 1 holds block 8 forever + and retries its CAS infinitely often, while block 6 keeps cycling + through retire, reclaim and allocation; + - [OwnerStall]: after turn 5 the owner is never selected, so block 6, + retired at turn 8, is never reclaimed. + + Witness scripts, heaps and observation tables are section [Let]s: they + are discharged into the public statements and leave no global name. The + periodic heaps are pointwise representatives only; every execution state + is the actual result of its preceding turns, never a reset. *) + From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. -From TICL Require Import Utils.Relations. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. +From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Trans ICTree.Trace ICTree.Interp.Yield.Execution. +From TICL Require Import Utils.Relations Utils.Lists Utils.Execution. Import ICtree ICTreeNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope list_scope. Local Open Scope nat_scope. -Definition has_event (kind block : nat) (e : AExecution) (k : nat) : Prop := - exists idx, emitted e k = Some (SPop kind block idx). +Section Starvation. -(** The cycle is nonempty by construction. Every state is still obtained - by executing the preceding turns through [execution_of_choices]. *) -Definition periodic_choices (prefix : list Actor) (first : Actor) (rest : list Actor) - (k : nat) : Actor := - if Nat.ltb k (List.length prefix) - then List.nth k prefix first - else List.nth ((k - List.length prefix) mod (S (List.length rest))) (first :: rest) first. - -Definition starvation_cycle : list Actor := +Let starvation_cycle : list Actor := [Remote1; Remote1; Remote0; Remote0; Remote0; Remote0; Remote1; Owner; Owner; Owner; Owner; Owner; Owner]. -Definition starvation_prefix : list Actor := +Let starvation_prefix : list Actor := [Owner; Owner; Owner; Owner; Owner; Remote1] ++ starvation_cycle. -Definition starvation_choices : nat -> Actor := - periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle). -Definition starvation_execution : AExecution := execution_of_choices 2 0 starvation_choices. - -Definition owner_stall_prefix : list Actor := - List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 4. -Definition owner_stall_cycle : list Actor := [Remote0; Remote1]. -Definition owner_stall_choices : nat -> Actor := - periodic_choices owner_stall_prefix Remote0 [Remote1]. -Definition owner_stall_execution : AExecution := execution_of_choices 2 0 owner_stall_choices. - -Lemma periodic_choices_before prefix first rest k : - k < List.length prefix -> - periodic_choices prefix first rest k = List.nth k prefix first. -Proof. - intro Hk; unfold periodic_choices; apply Nat.ltb_lt in Hk; now rewrite Hk. -Qed. -Lemma periodic_choices_after prefix first rest k : - periodic_choices prefix first rest (List.length prefix + k) = - List.nth (k mod (S (List.length rest))) (first :: rest) first. -Proof. - unfold periodic_choices. - assert (E : Nat.ltb (List.length prefix + k) (List.length prefix) = false) - by (apply Nat.ltb_ge; lia). - rewrite E; f_equal; f_equal; lia. -Qed. -Lemma periodic_choices_nth prefix first rest rounds i : - i < S (List.length rest) -> - periodic_choices prefix first rest - (List.length prefix + rounds * S (List.length rest) + i) = - List.nth i (first :: rest) first. -Proof. - intro Hi. - replace (List.length prefix + rounds * S (List.length rest) + i) - with (List.length prefix + (i + rounds * S (List.length rest))) by lia. - rewrite periodic_choices_after, Nat.Div0.mod_add. - now rewrite Nat.mod_small by exact Hi. -Qed. - -Lemma witness_map_seq_nth {A} len start (f : nat -> A) xs d : - List.length xs = len -> - (forall i, i < len -> f (start+i) = List.nth i xs d) -> - List.map f (List.seq start len) = xs. -Proof. - intros Hlen Hnth; apply List.nth_ext with (d := f start) (d' := d). - - rewrite List.length_map, List.length_seq; symmetry; exact Hlen. - - intros i Hi; rewrite List.length_map, List.length_seq in Hi. - rewrite List.map_nth, List.seq_nth by exact Hi; now apply Hnth. -Qed. -Lemma periodic_prefix_script prefix first rest : - List.map (periodic_choices prefix first rest) (List.seq 0 (List.length prefix)) = prefix. -Proof. - apply (witness_map_seq_nth _ _ _ _ first); [reflexivity|]. - intros i Hi; cbn [Nat.add]; now apply periodic_choices_before. -Qed. -Lemma periodic_cycle_script prefix first rest rounds : - List.map (periodic_choices prefix first rest) - (List.seq (List.length prefix + rounds * S (List.length rest)) - (S (List.length rest))) = first :: rest. -Proof. - apply (witness_map_seq_nth _ _ _ _ first); [reflexivity|]. - intros i Hi; now apply periodic_choices_nth. -Qed. - -Lemma starvation_execution_valid : valid_execution 2 0 starvation_execution. -Proof. apply execution_of_choices_valid. Qed. -Lemma owner_stall_execution_valid : valid_execution 2 0 owner_stall_execution. -Proof. apply execution_of_choices_valid. Qed. -Lemma witness_window_state capacity c e start script s last logs : - valid_execution capacity c e -> state_equiv (states e start) s -> - List.map (selected e) (List.seq start (List.length script)) = script -> - run_turns 1 script s = Some (last,logs) -> - state_equiv (states e (start + List.length script)) last. -Proof. - intros Hvalid Hstate Hchoices Hrun. - destruct (run_turns_respects_heq_some 1 script s (states e start) last logs - (state_equiv_sym _ _ Hstate) Hrun) as (actual & Hactual & Hlast). - pose proof (execution_run_turns capacity c e start (List.length script) Hvalid) as Hexec. - rewrite Hchoices in Hexec; rewrite Hexec in Hactual. - inversion Hactual; subst actual; now apply state_equiv_sym. -Qed. - -Lemma witness_turn_observation capacity c e k s next event : - valid_execution capacity c e -> state_equiv (states e k) s -> - turn 1 (selected e k) s = Some (next,event) -> - emitted e k = event /\ state_equiv (states e (S k)) next. -Proof. - intros Hvalid Hstate Hturn. - destruct (turn_respects_heq_some 1 (selected e k) s (states e k) next event - (state_equiv_sym _ _ Hstate) Hturn) as (actual & Hactual & Hnext). - rewrite (execution_step capacity c e k Hvalid) in Hactual. - inversion Hactual; subst actual event; split; [reflexivity|now apply state_equiv_sym]. -Qed. - -Lemma witness_firstn_seq start n len : - n <= len -> List.firstn n (List.seq start len) = List.seq start n. -Proof. - revert start len; induction n as [|n IH]; intros start len H; [reflexivity|]. - destruct len; [lia|]. cbn [List.firstn List.seq]; now rewrite IH by lia. -Qed. - -Lemma witness_window_prefix e start script n : - n <= List.length script -> - List.map (selected e) (List.seq start (List.length script)) = script -> - List.map (selected e) (List.seq start n) = List.firstn n script. -Proof. - intros Hn Hscript. - rewrite <- (witness_firstn_seq start n (List.length script) Hn), - <- List.firstn_map, Hscript; reflexivity. -Qed. - -From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. -From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program - CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. - -Import ICtree ICTreeNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope list_scope. -Local Open Scope nat_scope. - -Definition starve_prefix_logs (c : nat) : list SObs := - [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); - SPop tag_retire 6 (2+c); SPop tag_retry 8 (3+c); - SPop tag_reclaim 6 (4+c); SPop tag_alloc 6 (5+c)]. -Definition starve_cycle_logs (c : nat) : list SObs := - [SPop tag_retire 6 c; SPop tag_retry 8 (1+c); - SPop tag_reclaim 6 (2+c); SPop tag_alloc 6 (3+c)]. +Let starve_prefix_logs (c : nat) : list (indexed (nat * nat)) := + [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); + stamp (tag_retire,6) (2+c); stamp (tag_retry,8) (3+c); + stamp (tag_reclaim,6) (4+c); stamp (tag_alloc,6) (5+c)]. +Let starve_cycle_logs (c : nat) : list (indexed (nat * nat)) := + [stamp (tag_retire,6) c; stamp (tag_retry,8) (1+c); + stamp (tag_reclaim,6) (2+c); stamp (tag_alloc,6) (3+c)]. (** A pointwise representative only: the infinite witness always retains the actual heap returned by its preceding turn. *) -Definition starve_boundary_heap : Heap := fun x => +Let starve_boundary_heap : Heap := fun x => match x with | 1 => Some 0 | 2 => Some 0 | 3 => Some 0 | 4 => Some 6 | 5 => Some 0 | 6 => Some 0 | 7 => Some 1 | 8 => Some 0 | 9 => Some 2 | _ => None end. -Definition starve_boundary (c : nat) : AState := +Let starve_boundary (c : nat) : AState := {| aheap := starve_boundary_heap; acount := c; owner_state := ORead; remote0_state := RPoll; remote1_state := RRead 8 |}. -Lemma starve_prefix_run c : exists last, - run_turns 1 starvation_prefix (initial_state 2 c) = +(** The observation of each individual turn, including every silent turn. *) +Let starve_prefix_event (c i : nat) : option (indexed (nat * nat)) := + match i with + | 3 => Some (stamp (tag_alloc,6) c) + | 4 => Some (stamp (tag_alloc,8) (1+c)) + | 11 => Some (stamp (tag_retire,6) (2+c)) + | 12 => Some (stamp (tag_retry,8) (3+c)) + | 15 => Some (stamp (tag_reclaim,6) (4+c)) + | 17 => Some (stamp (tag_alloc,6) (5+c)) + | _ => None + end. +Let starve_cycle_event (c i : nat) : option (indexed (nat * nat)) := + match i with + | 5 => Some (stamp (tag_retire,6) c) + | 6 => Some (stamp (tag_retry,8) (1+c)) + | 9 => Some (stamp (tag_reclaim,6) (2+c)) + | 11 => Some (stamp (tag_alloc,6) (3+c)) + | _ => None + end. + +Local Lemma starve_prefix_run c : exists last, + run_turns (turn 1) event_obs starvation_prefix (initial_state 2 c) = Some (last,starve_prefix_logs c) /\ state_equiv last (starve_boundary (6+c)). Proof. @@ -181,8 +88,8 @@ Proof. - vm_compute; repeat split; reflexivity. Qed. -Lemma starve_cycle_run c : exists last, - run_turns 1 starvation_cycle (starve_boundary c) = +Local Lemma starve_cycle_run c : exists last, + run_turns (turn 1) event_obs starvation_cycle (starve_boundary c) = Some (last,starve_cycle_logs c) /\ state_equiv last (starve_boundary (4+c)). Proof. @@ -194,43 +101,23 @@ Proof. - vm_compute; repeat split; reflexivity. Qed. -Lemma starve_cycle_run_actual c s : +Local Lemma starve_cycle_run_actual c s : state_equiv s (starve_boundary c) -> exists last, - run_turns 1 starvation_cycle s = Some (last,starve_cycle_logs c) /\ + run_turns (turn 1) event_obs starvation_cycle s = Some (last,starve_cycle_logs c) /\ state_equiv last (starve_boundary (4+c)). Proof. intro Hs; destruct (starve_cycle_run c) as (last & Hrun & Hlast). - destruct (run_turns_respects_heq_some 1 starvation_cycle - (starve_boundary c) s last (starve_cycle_logs c) + destruct (run_turns_some_compatible (turn 1) event_obs state_equiv (turn_proper 1) + starvation_cycle (starve_boundary c) s last (starve_cycle_logs c) (state_equiv_sym _ _ Hs) Hrun) as (actual & Hactual & Heq). exists actual; split; [exact Hactual|]. eapply state_equiv_trans; [apply state_equiv_sym; exact Heq|exact Hlast]. Qed. -(** The observation of each individual turn, including every silent turn. *) -Definition starve_prefix_event (c i : nat) : option SObs := - match i with - | 3 => Some (SPop tag_alloc 6 c) - | 4 => Some (SPop tag_alloc 8 (1+c)) - | 11 => Some (SPop tag_retire 6 (2+c)) - | 12 => Some (SPop tag_retry 8 (3+c)) - | 15 => Some (SPop tag_reclaim 6 (4+c)) - | 17 => Some (SPop tag_alloc 6 (5+c)) - | _ => None - end. -Definition starve_cycle_event (c i : nat) : option SObs := - match i with - | 5 => Some (SPop tag_retire 6 c) - | 6 => Some (SPop tag_retry 8 (1+c)) - | 9 => Some (SPop tag_reclaim 6 (2+c)) - | 11 => Some (SPop tag_alloc 6 (3+c)) - | _ => None - end. - -Lemma starve_prefix_position c i : i < 19 -> +Local Lemma starve_prefix_position c i : i < 19 -> exists middle logs next, - run_turns 1 (List.firstn i starvation_prefix) (initial_state 2 c) = + run_turns (turn 1) event_obs (List.firstn i starvation_prefix) (initial_state 2 c) = Some (middle,logs) /\ turn 1 (List.nth i starvation_prefix Remote1) middle = Some (next,starve_prefix_event c i). @@ -241,9 +128,9 @@ Proof. lia. Qed. -Lemma starve_cycle_position c i : i < 13 -> +Local Lemma starve_cycle_position c i : i < 13 -> exists middle logs next, - run_turns 1 (List.firstn i starvation_cycle) (starve_boundary c) = + run_turns (turn 1) event_obs (List.firstn i starvation_cycle) (starve_boundary c) = Some (middle,logs) /\ held (remote1_state middle) = [8] /\ turn 1 (List.nth i starvation_cycle Remote1) middle = @@ -257,7 +144,18 @@ Proof. lia. Qed. -Lemma starve_prefix_script : +(** The infinite execution follows the periodic script from the actual + initial state. It is bound only after the finite calculations above, + whose existential witnesses must not range over its closure. *) +Let starvation_choices : nat -> Actor := + periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle). +Let starvation_execution : Execution AState Actor (option (indexed (nat * nat))) := + allocator_execution 2 0 starvation_choices. + +Local Lemma starvation_execution_valid : allocator_valid 2 0 starvation_execution. +Proof. unfold starvation_execution, allocator_execution; apply execution_of_choices_valid. Qed. + +Local Lemma starve_prefix_script : List.map (selected starvation_execution) (List.seq 0 (List.length starvation_prefix)) = starvation_prefix. Proof. @@ -267,14 +165,14 @@ Proof. apply periodic_prefix_script. Qed. -Lemma starve_selected_prefix k : k < 19 -> +Local Lemma starve_selected_prefix k : k < 19 -> selected starvation_execution k = List.nth k starvation_prefix Remote1. Proof. intro Hk; change (starvation_choices k = List.nth k starvation_prefix Remote1). unfold starvation_choices; apply periodic_choices_before; exact Hk. Qed. -Lemma starve_selected_cycle n i : i < 13 -> +Local Lemma starve_selected_cycle n i : i < 13 -> selected starvation_execution (19+13*n+i) = List.nth i starvation_cycle Remote1. Proof. @@ -284,54 +182,55 @@ Proof. replace (19+13*n+i) with (List.length starvation_prefix + n * S (List.length (List.tl starvation_cycle)) + i) by (cbn [starvation_prefix starvation_cycle List.length List.tl List.app]; lia). - apply periodic_choices_nth; exact Hi. + apply periodic_choices_round; exact Hi. Qed. -Lemma starve_cycle_script n : +Local Lemma starve_cycle_script n : List.map (selected starvation_execution) (List.seq (19+13*n) (List.length starvation_cycle)) = starvation_cycle. Proof. - apply (witness_map_seq_nth _ _ _ _ Remote1); [reflexivity|]. + apply (map_seq_eq _ _ _ _ Remote1); [reflexivity|]. intros i Hi; apply starve_selected_cycle; exact Hi. Qed. -Lemma starve_initial_equiv : +Local Lemma starve_initial_equiv : state_equiv (states starvation_execution 0) (initial_state 2 0). Proof. rewrite (proj1 starvation_execution_valid); apply state_equiv_refl. Qed. -Lemma starve_boundaries n : +Local Lemma starve_boundaries n : state_equiv (states starvation_execution (19+13*n)) (starve_boundary (6+4*n)). Proof. induction n as [|n IH]. - destruct (starve_prefix_run 0) as (last & Hrun & Hlast). eapply state_equiv_trans; [|exact Hlast]. - change (state_equiv - (states starvation_execution (0+List.length starvation_prefix)) last). - eapply witness_window_state with (capacity := 2) (c := 0) - (s := initial_state 2 0) (logs := starve_prefix_logs 0). - + exact starvation_execution_valid. - + exact starve_initial_equiv. - + exact starve_prefix_script. - + exact Hrun. + destruct (execution_window_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution 0 (List.length starvation_prefix) (initial_state 2 0) + starvation_execution_valid starve_initial_equiv) as (actual & Hactual & Hstate). + rewrite starve_prefix_script, Hrun in Hactual. + assert (Elast : actual = last) by congruence; subst actual. + replace (19+13*0) with (0 + List.length starvation_prefix) by reflexivity. + exact Hstate. - destruct (starve_cycle_run (6+4*n)) as (last & Hrun & Hlast). replace (6+4*S n) with (4+(6+4*n)) by lia. eapply state_equiv_trans; [|exact Hlast]. replace (19+13*S n) with ((19+13*n)+List.length starvation_cycle) by (cbn [starvation_cycle List.length]; lia). - eapply witness_window_state with (capacity := 2) (c := 0) - (s := starve_boundary (6+4*n)) (logs := starve_cycle_logs (6+4*n)). - + exact starvation_execution_valid. - + exact IH. - + exact (starve_cycle_script n). - + exact Hrun. + destruct (execution_window_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution (19+13*n) (List.length starvation_cycle) + (starve_boundary (6+4*n)) starvation_execution_valid IH) + as (actual & Hactual & Hstate). + rewrite starve_cycle_script, Hrun in Hactual. + assert (Elast : actual = last) by congruence; subst actual; exact Hstate. Qed. -Lemma starve_actual_cycle_run n : exists last, - run_turns 1 starvation_cycle (states starvation_execution (19+13*n)) = +Local Lemma starve_actual_cycle_run n : exists last, + run_turns (turn 1) event_obs starvation_cycle (states starvation_execution (19+13*n)) = Some (last,starve_cycle_logs (6+4*n)) /\ state_equiv last (starve_boundary (6+4*S n)). Proof. @@ -341,9 +240,9 @@ Qed. (** Every intermediate state is the result of a finite fold from the actual returned boundary, not from a periodically reset representative. *) -Lemma starve_actual_cycle_position n i : i < 13 -> +Local Lemma starve_actual_cycle_position n i : i < 13 -> exists logs next, - run_turns 1 (List.firstn i starvation_cycle) + run_turns (turn 1) event_obs (List.firstn i starvation_cycle) (states starvation_execution (19+13*n)) = Some (states starvation_execution (19+13*n+i),logs) /\ held (remote1_state (states starvation_execution (19+13*n+i))) = [8] /\ @@ -354,24 +253,27 @@ Proof. intro Hi. destruct (starve_cycle_position (6+4*n) i Hi) as (middle & logs & next & Hrun & Hheld & Hturn). - destruct (run_turns_respects_heq_some 1 (List.firstn i starvation_cycle) + destruct (run_turns_some_compatible (turn 1) event_obs state_equiv (turn_proper 1) + (List.firstn i starvation_cycle) (starve_boundary (6+4*n)) (states starvation_execution (19+13*n)) middle logs (state_equiv_sym _ _ (starve_boundaries n)) Hrun) as (actual & Hactual & Heq). assert (Hscript : List.map (selected starvation_execution) (List.seq (19+13*n) i) = List.firstn i starvation_cycle). { - eapply witness_window_prefix. - - change (i <= 13); lia. - - exact (starve_cycle_script n). + rewrite <- (map_seq_firstn (selected starvation_execution) (19+13*n) + (List.length starvation_cycle) i ltac:(change (i <= 13); lia)). + rewrite (starve_cycle_script n); reflexivity. } - pose proof (execution_run_turns 2 0 starvation_execution (19+13*n) i + pose proof (execution_run_turns (turn 1) event_obs + (fun s => s = initial_state 2 0) starvation_execution (19+13*n) i starvation_execution_valid) as Hwindow. rewrite Hscript, Hactual in Hwindow. assert (Estate : actual = states starvation_execution (19+13*n+i)) by congruence. subst actual. - destruct (turn_respects_heq_some 1 (List.nth i starvation_cycle Remote1) + destruct (step_some_compatible (turn 1) state_equiv (turn_proper 1) + (List.nth i starvation_cycle Remote1) middle (states starvation_execution (19+13*n+i)) next (starve_cycle_event (6+4*n) i) Heq Hturn) as (actual_next & Hnext & Hnext_eq). @@ -380,48 +282,48 @@ Proof. rewrite <- Hremote1; exact Hheld. Qed. -Lemma starve_cycle_emitted n i : i < 13 -> +Local Lemma starve_cycle_emitted n i : i < 13 -> emitted starvation_execution (19+13*n+i) = starve_cycle_event (6+4*n) i. Proof. intro Hi. destruct (starve_actual_cycle_position n i Hi) as (logs & next & Hrun & Hheld & Hturn). - pose proof (execution_step 2 0 starvation_execution (19+13*n+i) - starvation_execution_valid) as Hstep. + pose proof (execution_step (turn 1) (fun s => s = initial_state 2 0) + starvation_execution (19+13*n+i) starvation_execution_valid) as Hstep. rewrite (starve_selected_cycle n i Hi), Hturn in Hstep; congruence. Qed. -Lemma starve_prefix_emitted i : i < 19 -> +Local Lemma starve_prefix_emitted i : i < 19 -> emitted starvation_execution i = starve_prefix_event 0 i. Proof. intro Hi. destruct (starve_prefix_position 0 i Hi) as (middle & logs & next & Hrun & Hturn). - assert (Hlen : List.length (List.firstn i starvation_prefix) = i). - { - rewrite List.length_firstn; apply Nat.min_l; change (i <= 19); lia. - } - assert (Hscript : List.map (selected starvation_execution) - (List.seq 0 (List.length (List.firstn i starvation_prefix))) = + assert (Hscript : List.map (selected starvation_execution) (List.seq 0 i) = List.firstn i starvation_prefix). { - rewrite Hlen; eapply witness_window_prefix. - - change (i <= 19); lia. - - exact starve_prefix_script. + rewrite <- (map_seq_firstn (selected starvation_execution) 0 + (List.length starvation_prefix) i ltac:(change (i <= 19); lia)). + rewrite starve_prefix_script; reflexivity. } - pose proof (witness_window_state 2 0 starvation_execution 0 - (List.firstn i starvation_prefix) (initial_state 2 0) middle logs - starvation_execution_valid starve_initial_equiv Hscript Hrun) as Heq. - rewrite Hlen, Nat.add_0_l in Heq. + destruct (execution_window_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution 0 i (initial_state 2 0) + starvation_execution_valid starve_initial_equiv) as (actual & Hactual & Heq). + rewrite Hscript, Hrun in Hactual. + assert (Emiddle : actual = middle) by congruence; subst actual. + rewrite Nat.add_0_l in Heq. rewrite <- (starve_selected_prefix i Hi) in Hturn. - exact (proj1 (witness_turn_observation 2 0 starvation_execution i middle next - (starve_prefix_event 0 i) starvation_execution_valid Heq Hturn)). + destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) + state_equiv (turn_proper 1) starvation_execution i middle + starvation_execution_valid Heq) as (next' & Hturn' & _). + rewrite Hturn in Hturn'; congruence. Qed. -Lemma starve_cycle_event_offsets n : - emitted starvation_execution (19+13*n+5) = Some (SPop tag_retire 6 (6+4*n)) /\ - emitted starvation_execution (19+13*n+6) = Some (SPop tag_retry 8 (1+(6+4*n))) /\ - emitted starvation_execution (19+13*n+9) = Some (SPop tag_reclaim 6 (2+(6+4*n))) /\ - emitted starvation_execution (19+13*n+11) = Some (SPop tag_alloc 6 (3+(6+4*n))). +Local Lemma starve_cycle_event_offsets n : + emitted starvation_execution (19+13*n+5) = Some (stamp (tag_retire,6) (6+4*n)) /\ + emitted starvation_execution (19+13*n+6) = Some (stamp (tag_retry,8) (1+(6+4*n))) /\ + emitted starvation_execution (19+13*n+9) = Some (stamp (tag_reclaim,6) (2+(6+4*n))) /\ + emitted starvation_execution (19+13*n+11) = Some (stamp (tag_alloc,6) (3+(6+4*n))). Proof. split; [exact (starve_cycle_emitted n 5 ltac:(lia))|]. split; [exact (starve_cycle_emitted n 6 ltac:(lia))|]. @@ -429,7 +331,7 @@ Proof. exact (starve_cycle_emitted n 11 ltac:(lia)). Qed. -Lemma starve_index k : 19 <= k -> +Local Lemma starve_index k : 19 <= k -> exists n i, i < 13 /\ k = 19+13*n+i. Proof. intro Hk; exists ((k-19)/13), ((k-19) mod 13); split. @@ -437,7 +339,7 @@ Proof. - pose proof (Nat.div_mod (k-19) 13 ltac:(lia)); lia. Qed. -Lemma starve_fair : fair starvation_execution. +Local Lemma starve_fair : fair_choices (selected starvation_execution). Proof. intros actor lo; destruct actor. - exists (19+13*lo+7); split; [lia|]. @@ -448,7 +350,7 @@ Proof. exact (starve_selected_cycle lo 0 ltac:(lia)). Qed. -Lemma starve_held_forever k : 19 <= k -> +Local Lemma starve_held_forever k : 19 <= k -> held (remote1_state (states starvation_execution k)) = [8]. Proof. intro Hk; destruct (starve_index k Hk) as (n & i & Hi & ->). @@ -456,22 +358,23 @@ Proof. as (logs & next & Hrun & Hheld & Hturn); exact Hheld. Qed. -Lemma starve_prefix_never_retire8 c i idx : i < 19 -> - starve_prefix_event c i <> Some (SPop tag_retire 8 idx). +Local Lemma starve_prefix_never_retire8 c i idx : i < 19 -> + starve_prefix_event c i <> Some (stamp (tag_retire,8) idx). Proof. intro Hi. do 19 (destruct i as [|i]; [vm_compute; discriminate|]). lia. Qed. -Lemma starve_cycle_never_retire8 c i idx : i < 13 -> - starve_cycle_event c i <> Some (SPop tag_retire 8 idx). +Local Lemma starve_cycle_never_retire8 c i idx : i < 13 -> + starve_cycle_event c i <> Some (stamp (tag_retire,8) idx). Proof. intro Hi. do 13 (destruct i as [|i]; [vm_compute; discriminate|]). lia. Qed. -Lemma starve_never_retire8 k : ~ has_event tag_retire 8 starvation_execution k. +Local Lemma starve_never_retire8 k : + ~ block_event tag_retire 8 (emitted starvation_execution k). Proof. intros [idx Hevent]; destruct (Nat.lt_ge_cases k 19) as [Hprefix|Hcycle]. - rewrite (starve_prefix_emitted k Hprefix) in Hevent. @@ -481,36 +384,40 @@ Proof. exact (starve_cycle_never_retire8 (6+4*n) i idx Hi Hevent). Qed. -Lemma starve_infinitely_retry8 : infinitely (has_event tag_retry 8 starvation_execution). +Local Lemma starve_infinitely_retry8 : + infinitely (fun k => block_event tag_retry 8 (emitted starvation_execution k)). Proof. intro lo; exists (19+13*lo+6); split; [lia|]. exists (1+(6+4*lo)); exact (starve_cycle_emitted lo 6 ltac:(lia)). Qed. -Lemma starve_infinitely_retire6 : infinitely (has_event tag_retire 6 starvation_execution). +Local Lemma starve_infinitely_retire6 : + infinitely (fun k => block_event tag_retire 6 (emitted starvation_execution k)). Proof. intro lo; exists (19+13*lo+5); split; [lia|]. exists (6+4*lo); exact (starve_cycle_emitted lo 5 ltac:(lia)). Qed. -Lemma starve_infinitely_reclaim6 : infinitely (has_event tag_reclaim 6 starvation_execution). +Local Lemma starve_infinitely_reclaim6 : + infinitely (fun k => block_event tag_reclaim 6 (emitted starvation_execution k)). Proof. intro lo; exists (19+13*lo+9); split; [lia|]. exists (2+(6+4*lo)); exact (starve_cycle_emitted lo 9 ltac:(lia)). Qed. -Lemma starve_infinitely_alloc6 : infinitely (has_event tag_alloc 6 starvation_execution). +Local Lemma starve_infinitely_alloc6 : + infinitely (fun k => block_event tag_alloc 6 (emitted starvation_execution k)). Proof. intro lo; exists (19+13*lo+11); split; [lia|]. exists (3+(6+4*lo)); exact (starve_cycle_emitted lo 11 ltac:(lia)). Qed. Theorem fair_starvation_exists : exists e, - valid_execution 2 0 e /\ fair e /\ + allocator_valid 2 0 e /\ fair_choices (selected e) /\ (forall k, 19 <= k -> held (remote1_state (states e k)) = [8]) /\ - infinitely (has_event tag_retry 8 e) /\ - (forall k, ~ has_event tag_retire 8 e k) /\ - infinitely (has_event tag_retire 6 e) /\ - infinitely (has_event tag_reclaim 6 e) /\ - infinitely (has_event tag_alloc 6 e) /\ - realizes e 0 (run_nd (allocator_program 2) hemp 0). + infinitely (fun k => block_event tag_retry 8 (emitted e k)) /\ + (forall k, ~ block_event tag_retire 8 (emitted e k)) /\ + infinitely (fun k => block_event tag_retire 6 (emitted e k)) /\ + infinitely (fun k => block_event tag_reclaim 6 (emitted e k)) /\ + infinitely (fun k => block_event tag_alloc 6 (emitted e k)) /\ + realizes (fun j => turn_labels (emitted e j)) 0 (run_nd (allocator_program 2) hemp 0). Proof. exists starvation_execution. split; [exact starvation_execution_valid|]. @@ -524,41 +431,64 @@ Proof. apply valid_execution_realizes_source; exact starvation_execution_valid. Qed. -From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans. -From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program - CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. +(** The first cycle, chained from the ACTUAL prefix result, is a finite + source trace with one genuine scheduler tau per turn. *) +Theorem starvation_chained_cycle_actual_source : exists last labels residual, + run_turns (turn 1) event_obs (starvation_prefix ++ starvation_cycle) (initial_state 2 0) = + Some (last,starve_prefix_logs 0 ++ starve_cycle_logs 6) /\ + label_logs labels = starve_prefix_logs 0 ++ starve_cycle_logs 6 /\ + label_taus labels = 32 /\ + finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + destruct (starve_prefix_run 0) as (first & Hprefix & Hfirst). + destruct (starve_cycle_run_actual 6 first Hfirst) as (last & Hcycle & Hlast). + pose proof (run_turns_compose (turn 1) event_obs + starvation_prefix starvation_cycle + (initial_state 2 0) first last (starve_prefix_logs 0) (starve_cycle_logs 6) + Hprefix Hcycle) as Hrun. + destruct (run_turns_realizes_source 2 0 (starvation_prefix ++ starvation_cycle) + last (starve_prefix_logs 0 ++ starve_cycle_logs 6) Hrun) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). + exists last, labels, residual; repeat first [assumption | split]. +Qed. -Import ICtree ICTreeNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope list_scope. -Local Open Scope nat_scope. +End Starvation. + +Section OwnerStall. + +Let owner_stall_prefix : list Actor := + List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 4. +Let owner_stall_cycle : list Actor := [Remote0; Remote1]. +Let owner_stall_choices : nat -> Actor := + periodic_choices owner_stall_prefix Remote0 [Remote1]. -Definition stalled_prefix_logs (c : nat) : list SObs := - [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); - SPop tag_retire 6 (2+c); SPop tag_retire 8 (3+c)]. +Let stalled_prefix_logs (c : nat) : list (indexed (nat * nat)) := + [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); + stamp (tag_retire,6) (2+c); stamp (tag_retire,8) (3+c)]. -Definition stalled_prefix_observations : list (option SObs) := - [None; None; None; Some (SPop tag_alloc 6 0); - Some (SPop tag_alloc 8 1); None; None; None; - Some (SPop tag_retire 6 2); None; None; None; - Some (SPop tag_retire 8 3)]. +Let stalled_prefix_observations : list (option (indexed (nat * nat))) := + [None; None; None; Some (stamp (tag_alloc,6) 0); + Some (stamp (tag_alloc,8) 1); None; None; None; + Some (stamp (tag_retire,6) 2); None; None; None; + Some (stamp (tag_retire,8) 3)]. (** This is only a pointwise representative of the returned heap. The - predefined execution always runs the actual preceding turn. *) -Definition stalled_boundary_heap : Heap := fun x => + execution always runs the actual preceding turn. *) +Let stalled_boundary_heap : Heap := fun x => match x with | 1 => Some 8 | 2 => Some 0 | 3 => Some 0 | 4 => Some 0 | 5 => Some 0 | 6 => Some 0 | 7 => Some 1 | 8 => Some 6 | 9 => Some 2 | _ => None end. -Definition stalled_boundary (c : nat) : AState := +Let stalled_boundary (c : nat) : AState := {| aheap := stalled_boundary_heap; acount := c; owner_state := ORead; remote0_state := RPoll; remote1_state := RPoll |}. -Lemma stalled_prefix_run c : exists last, - run_turns 1 owner_stall_prefix (initial_state 2 c) = +Local Lemma stalled_prefix_run c : exists last, + run_turns (turn 1) event_obs owner_stall_prefix (initial_state 2 c) = Some (last,stalled_prefix_logs c) /\ state_equiv last (stalled_boundary (c+4)). Proof. @@ -571,28 +501,28 @@ Proof. - vm_compute; repeat split; reflexivity. Qed. -Lemma stalled_polling_turn c who : +Local Lemma stalled_polling_turn c who : who = Remote0 \/ who = Remote1 -> turn 1 who (stalled_boundary c) = Some (stalled_boundary c,None). Proof. intros [-> | ->]; vm_compute; reflexivity. Qed. -Lemma stalled_cycle_run c : - run_turns 1 owner_stall_cycle (stalled_boundary c) = +Local Lemma stalled_cycle_run c : + run_turns (turn 1) event_obs owner_stall_cycle (stalled_boundary c) = Some (stalled_boundary c,[]). Proof. reflexivity. Qed. (** Transfer the finite polling calculation to the actual accumulated heap; neither this lemma nor the infinite witness resets that heap. *) -Lemma stalled_cycle_run_actual c s : +Local Lemma stalled_cycle_run_actual c s : state_equiv s (stalled_boundary c) -> - exists last, run_turns 1 owner_stall_cycle s = Some (last,[]) /\ + exists last, run_turns (turn 1) event_obs owner_stall_cycle s = Some (last,[]) /\ state_equiv last s. Proof. intro Hs. - destruct (run_turns_respects_heq_some 1 owner_stall_cycle - (stalled_boundary c) s (stalled_boundary c) [] + destruct (run_turns_some_compatible (turn 1) event_obs state_equiv (turn_proper 1) + owner_stall_cycle (stalled_boundary c) s (stalled_boundary c) [] (state_equiv_sym _ _ Hs) (stalled_cycle_run c)) as (last & Hrun & Hlast). exists last; split; [exact Hrun|]. @@ -600,7 +530,28 @@ Proof. apply state_equiv_sym; exact Hs. Qed. -Lemma stalled_prefix_script : +Local Lemma stalled_prefix_position k : k < 13 -> + exists before after logs, + run_turns (turn 1) event_obs (List.firstn k owner_stall_prefix) (initial_state 2 0) = + Some (before,logs) /\ + turn 1 (owner_stall_choices k) before = + Some (after,List.nth k stalled_prefix_observations None). +Proof. + intro Hk. + do 13 (destruct k as [ | k ]; + [eexists; eexists; eexists; split; vm_compute; reflexivity|]). + lia. +Qed. + +(** The infinite execution follows the periodic script from the actual + initial state; bound after the finite calculations above. *) +Let owner_stall_execution : Execution AState Actor (option (indexed (nat * nat))) := + allocator_execution 2 0 owner_stall_choices. + +Local Lemma owner_stall_execution_valid : allocator_valid 2 0 owner_stall_execution. +Proof. unfold owner_stall_execution, allocator_execution; apply execution_of_choices_valid. Qed. + +Local Lemma stalled_prefix_script : List.map (selected owner_stall_execution) (List.seq 0 (List.length owner_stall_prefix)) = owner_stall_prefix. Proof. @@ -609,93 +560,81 @@ Proof. apply periodic_prefix_script. Qed. -Lemma stalled_initial_equiv : +Local Lemma stalled_initial_equiv : state_equiv (states owner_stall_execution 0) (initial_state 2 0). Proof. rewrite (proj1 owner_stall_execution_valid); apply state_equiv_refl. Qed. -Lemma stalled_prefix_state : +Local Lemma stalled_prefix_state : state_equiv (states owner_stall_execution 13) (stalled_boundary 4). Proof. destruct (stalled_prefix_run 0) as (last & Hrun & Hlast). - pose proof (witness_window_state 2 0 owner_stall_execution 0 - owner_stall_prefix (initial_state 2 0) last (stalled_prefix_logs 0) - owner_stall_execution_valid stalled_initial_equiv - stalled_prefix_script Hrun) as Hstate. - change (state_equiv (states owner_stall_execution 13) last) in Hstate. + destruct (execution_window_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + owner_stall_execution 0 (List.length owner_stall_prefix) (initial_state 2 0) + owner_stall_execution_valid stalled_initial_equiv) as (actual & Hactual & Hstate). + rewrite stalled_prefix_script, Hrun in Hactual. + assert (Elast : actual = last) by congruence; subst actual. + replace (0 + List.length owner_stall_prefix) with 13 in Hstate by reflexivity. eapply state_equiv_trans; [exact Hstate|exact Hlast]. Qed. -Lemma stalled_prefix_observation k : k < 13 -> +Local Lemma stalled_prefix_observation k : k < 13 -> emitted owner_stall_execution k = List.nth k stalled_prefix_observations None. Proof. intro Hk. - assert (Hfinite : exists before after logs, - run_turns 1 (List.firstn k owner_stall_prefix) (initial_state 2 0) = - Some (before,logs) /\ - turn 1 (owner_stall_choices k) before = - Some (after,List.nth k stalled_prefix_observations None)). - { - do 13 (destruct k as [ | k ]; - [eexists; eexists; eexists; split; vm_compute; reflexivity|]). - lia. - } - destruct Hfinite as (before & after & logs & Hrun & Hturn). - assert (Hlen : List.length (List.firstn k owner_stall_prefix) = k). - { - rewrite List.length_firstn. - change (Nat.min k 13 = k). - apply Nat.min_l; lia. - } - assert (Hscript : List.map (selected owner_stall_execution) - (List.seq 0 (List.length (List.firstn k owner_stall_prefix))) = + destruct (stalled_prefix_position k Hk) as (before & after & logs & Hrun & Hturn). + assert (Hscript : List.map (selected owner_stall_execution) (List.seq 0 k) = List.firstn k owner_stall_prefix). { - rewrite Hlen. - apply witness_window_prefix with (script := owner_stall_prefix). - - change (k <= 13); lia. - - exact stalled_prefix_script. + rewrite <- (map_seq_firstn (selected owner_stall_execution) 0 + (List.length owner_stall_prefix) k ltac:(change (k <= 13); lia)). + rewrite stalled_prefix_script; reflexivity. } - pose proof (witness_window_state 2 0 owner_stall_execution 0 - (List.firstn k owner_stall_prefix) (initial_state 2 0) before logs - owner_stall_execution_valid stalled_initial_equiv Hscript Hrun) as Hstate. - cbn [Nat.add] in Hstate; rewrite Hlen in Hstate. + destruct (execution_window_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + owner_stall_execution 0 k (initial_state 2 0) + owner_stall_execution_valid stalled_initial_equiv) as (actual & Hactual & Hstate). + rewrite Hscript, Hrun in Hactual. + assert (Ebefore : actual = before) by congruence; subst actual. + rewrite Nat.add_0_l in Hstate. change (turn 1 (selected owner_stall_execution k) before = Some (after,List.nth k stalled_prefix_observations None)) in Hturn. - exact (proj1 (witness_turn_observation 2 0 owner_stall_execution k - before after (List.nth k stalled_prefix_observations None) - owner_stall_execution_valid Hstate Hturn)). + destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) + state_equiv (turn_proper 1) owner_stall_execution k before + owner_stall_execution_valid Hstate) as (next & Hnext & _). + rewrite Hturn in Hnext; congruence. Qed. -Lemma stalled_prefix_events : +Local Lemma stalled_prefix_events : List.map (emitted owner_stall_execution) (List.seq 0 13) = stalled_prefix_observations. Proof. - apply (witness_map_seq_nth 13 0 _ _ None); [reflexivity|]. + apply (map_seq_eq 0 13 _ _ None); [reflexivity|]. intros i Hi; cbn [Nat.add]; now apply stalled_prefix_observation. Qed. -Lemma stalled_retire6 : - emitted owner_stall_execution 8 = Some (SPop tag_retire 6 2). +Local Lemma stalled_retire6 : + emitted owner_stall_execution 8 = Some (stamp (tag_retire,6) 2). Proof. exact (stalled_prefix_observation 8 ltac:(lia)). Qed. -Lemma stalled_retire8 : - emitted owner_stall_execution 12 = Some (SPop tag_retire 8 3). +Local Lemma stalled_retire8 : + emitted owner_stall_execution 12 = Some (stamp (tag_retire,8) 3). Proof. exact (stalled_prefix_observation 12 ltac:(lia)). Qed. -Lemma stalled_tail_choices n : +Local Lemma stalled_tail_choices n : selected owner_stall_execution (13+n) = List.nth (n mod 2) owner_stall_cycle Remote0. Proof. change (periodic_choices owner_stall_prefix Remote0 [Remote1] (List.length owner_stall_prefix+n) = List.nth (n mod 2) owner_stall_cycle Remote0). - rewrite periodic_choices_after; reflexivity. + rewrite periodic_choices_nth; reflexivity. Qed. -Lemma stalled_tail_client n : +Local Lemma stalled_tail_client n : selected owner_stall_execution (13+n) = Remote0 \/ selected owner_stall_execution (13+n) = Remote1. Proof. @@ -706,7 +645,7 @@ Proof. destruct r as [ | r ]; [right; reflexivity|lia]. Qed. -Lemma stalled_cycle_selection n i : i < 2 -> +Local Lemma stalled_cycle_selection n i : i < 2 -> selected owner_stall_execution (13+n*2+i) = List.nth i owner_stall_cycle Remote0. Proof. @@ -714,10 +653,10 @@ Proof. change (periodic_choices owner_stall_prefix Remote0 [Remote1] (List.length owner_stall_prefix+n*S (List.length [Remote1])+i) = List.nth i (Remote0 :: [Remote1]) Remote0). - apply periodic_choices_nth; exact Hi. + apply periodic_choices_round; exact Hi. Qed. -Lemma stalled_no_owner k : 5 <= k -> +Local Lemma stalled_no_owner k : 5 <= k -> selected owner_stall_execution k <> Owner. Proof. intro Hfive; destruct (Nat.lt_ge_cases k 13) as [Hprefix|Htail]. @@ -728,7 +667,7 @@ Proof. destruct (stalled_tail_client (k-13)) as [-> | ->]; discriminate. Qed. -Lemma stalled_remote0_infinitely : +Local Lemma stalled_remote0_infinitely : infinitely (fun k => selected owner_stall_execution k = Remote0). Proof. intro n; exists (13+n*2); split; [lia|]. @@ -736,34 +675,37 @@ Proof. exact (stalled_cycle_selection n 0 ltac:(lia)). Qed. -Lemma stalled_remote1_infinitely : +Local Lemma stalled_remote1_infinitely : infinitely (fun k => selected owner_stall_execution k = Remote1). Proof. intro n; exists (13+n*2+1); split; [lia|]. exact (stalled_cycle_selection n 1 ltac:(lia)). Qed. -Lemma stalled_suffix_state n : +Local Lemma stalled_suffix_state n : state_equiv (states owner_stall_execution (13+n)) (stalled_boundary 4). Proof. induction n as [ | n IH ]. - exact stalled_prefix_state. - replace (13+S n) with (S (13+n)) by lia. - exact (proj2 (witness_turn_observation 2 0 owner_stall_execution (13+n) - (stalled_boundary 4) (stalled_boundary 4) None - owner_stall_execution_valid IH - (stalled_polling_turn 4 _ (stalled_tail_client n)))). + destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) + state_equiv (turn_proper 1) owner_stall_execution (13+n) (stalled_boundary 4) + owner_stall_execution_valid IH) as (next & Hnext & Hstate). + rewrite (stalled_polling_turn 4 _ (stalled_tail_client n)) in Hnext. + assert (Enext : next = stalled_boundary 4) by congruence; subst next. + exact Hstate. Qed. -Lemma stalled_suffix_silent n : emitted owner_stall_execution (13+n) = None. +Local Lemma stalled_suffix_silent n : emitted owner_stall_execution (13+n) = None. Proof. - exact (proj1 (witness_turn_observation 2 0 owner_stall_execution (13+n) - (stalled_boundary 4) (stalled_boundary 4) None - owner_stall_execution_valid (stalled_suffix_state n) - (stalled_polling_turn 4 _ (stalled_tail_client n)))). + destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) + state_equiv (turn_proper 1) owner_stall_execution (13+n) (stalled_boundary 4) + owner_stall_execution_valid (stalled_suffix_state n)) as (next & Hnext & _). + rewrite (stalled_polling_turn 4 _ (stalled_tail_client n)) in Hnext. + congruence. Qed. -Lemma stalled_suffix_stable n : +Local Lemma stalled_suffix_stable n : state_equiv (states owner_stall_execution (13+n)) (states owner_stall_execution 13) /\ emitted owner_stall_execution (13+n) = None. @@ -773,9 +715,9 @@ Proof. apply state_equiv_sym; exact stalled_prefix_state. Qed. -Lemma stalled_remote_chain n : +Local Lemma stalled_remote_chain n : aheap (states owner_stall_execution (13+n)) (remote_head 1) = Some 8 /\ - free_chain (aheap (states owner_stall_execution (13+n))) [8;6] /\ + linked (fun a next => aheap (states owner_stall_execution (13+n)) a = Some next) [8;6] 0 /\ acount (states owner_stall_execution (13+n)) = 4 /\ owner_state (states owner_stall_execution (13+n)) = ORead /\ remote0_state (states owner_stall_execution (13+n)) = RPoll /\ @@ -784,12 +726,12 @@ Proof. destruct (stalled_suffix_state n) as (Hheap & Hcount & Howner & Hzero & Hone). split; [rewrite Hheap; reflexivity|]. split. - - cbn [free_chain List.hd]; repeat split; rewrite Hheap; reflexivity. + - cbn [linked List.hd]; repeat split; rewrite Hheap; reflexivity. - exact (conj Hcount (conj Howner (conj Hzero Hone))). Qed. -Lemma stalled_no_reclaim k block : - ~ has_event tag_reclaim block owner_stall_execution k. +Local Lemma stalled_no_reclaim k block : + ~ block_event tag_reclaim block (emitted owner_stall_execution k). Proof. intros [idx Hobs]; destruct (Nat.lt_ge_cases k 13) as [Hprefix|Htail]. - rewrite (stalled_prefix_observation k Hprefix) in Hobs. @@ -799,14 +741,15 @@ Proof. rewrite stalled_suffix_silent in Hobs; discriminate. Qed. -Lemma stalled_prefix_source : exists last labels residual, - run_turns 1 owner_stall_prefix (initial_state 2 0) = +Theorem stalled_prefix_source : exists last labels residual, + run_turns (turn 1) event_obs owner_stall_prefix (initial_state 2 0) = Some (last,stalled_prefix_logs 0) /\ state_equiv last (stalled_boundary 4) /\ label_logs labels = stalled_prefix_logs 0 /\ label_taus labels = 13 /\ finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ - residual ~ model_nd 1 last. + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. destruct (stalled_prefix_run 0) as (last & Hrun & Hstate). destruct (run_turns_realizes_source 2 0 owner_stall_prefix last @@ -820,24 +763,25 @@ Proof. Qed. (** Every silent polling choice still consumes one real scheduler tau. *) -Lemma stalled_tail_source_tau n t : - realizes owner_stall_execution (13+n) t -> +Theorem stalled_tail_source_tau n + (t : ictreeW (indexed (nat * nat)) (unit * SSig)) : + realizes (fun j => turn_labels (emitted owner_stall_execution j)) (13+n) t -> exists next, finite_steps t [tau] next /\ - realizes owner_stall_execution (S (13+n)) next. + realizes (fun j => turn_labels (emitted owner_stall_execution j)) (S (13+n)) next. Proof. - intros [next Hsteps Hrest]. + intros [next Hne Hsteps Hrest]. exists next; split; [|exact Hrest]. rewrite stalled_suffix_silent in Hsteps; exact Hsteps. Qed. Theorem owner_stall_prevents_reclamation : exists e, - valid_execution 2 0 e /\ + allocator_valid 2 0 e /\ (forall k, 5 <= k -> selected e k <> Owner) /\ infinitely (fun k => selected e k = Remote0) /\ infinitely (fun k => selected e k = Remote1) /\ - emitted e 8 = Some (SPop tag_retire 6 2) /\ - (forall k, ~ has_event tag_reclaim 6 e k) /\ - realizes e 0 (run_nd (allocator_program 2) hemp 0). + emitted e 8 = Some (stamp (tag_retire,6) 2) /\ + (forall k, ~ block_event tag_reclaim 6 (emitted e k)) /\ + realizes (fun j => turn_labels (emitted e j)) 0 (run_nd (allocator_program 2) hemp 0). Proof. exists owner_stall_execution; split; [exact owner_stall_execution_valid|]. split; [exact stalled_no_owner|]. @@ -847,3 +791,5 @@ Proof. split; [intro k; apply stalled_no_reclaim|]. apply valid_execution_realizes_source; exact owner_stall_execution_valid. Qed. + +End OwnerStall. diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v index 98d6813..f1e2171 100644 --- a/examples/CSL/Allocator/Execution.v +++ b/examples/CSL/Allocator/Execution.v @@ -1,4 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. +From TICL Require Import ICTree.Interp.Yield.Execution. +From TICL Require Import Utils.Execution. From Stdlib Require Import Classes.Morphisms. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod @@ -87,26 +89,6 @@ Definition source_pool0 base : pool sE 3 := Definition state_agrees (sigma : SSig) (s : AState) : Prop := heq (fst sigma) (aheap s) /\ snd sigma = acount s. -Lemma allocator_inv_state_equiv base capacity s t : - state_equiv s t -> allocator_inv base capacity s -> allocator_inv base capacity t. -Proof. - destruct s as [h c op r0 r1], t as [k d oq q0 q1]. - intros [Hh [Hc [Ho [H0 H1]]]]; cbn in Hh, Hc, Ho, H0, H1. - subst d oq q0 q1. - intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & - Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1). - cbn [aheap owner_state remote0_state remote1_state] in *. - unfold allocator_inv; cbn [aheap owner_state remote0_state remote1_state]. - split; [exact Hbase|]; split. - - intro x; rewrite <- Hh; apply Hback. - - exists L, R, D, m0, m1. - repeat split; try assumption; - try solve [rewrite <- Hh; assumption]; - try solve [eapply ai_free_chain_frame; - [eassumption|intros; symmetry; apply Hh]]; - try solve [eapply ai_cached_remote_frame; - [eassumption|intros; symmetry; apply Hh]]. -Qed. Definition source_reheap (sigma : SSig) (s : AState) : AState := {| aheap := fst sigma; acount := snd sigma; @@ -151,9 +133,9 @@ Lemma interp_nd_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) first count (K : option unit -> thread sE) h c : (forall offset, Nat.lt offset (2 * count) -> h (first + offset)%nat <> None) -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some tt)) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (init_links_heap first count h,c). Proof. revert first h; induction count as [|count IH]; intros first h Allocated. @@ -193,10 +175,10 @@ Qed. Lemma interp_nd_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) base capacity (K : option unit -> thread sE) h c : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (init_page base capacity) >>= K)) (Some i) (hunion (hblock base (page_size capacity)) h,c) ~ - interp_nd (S n) (ts @ i := K (Some tt)) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (page_heap base capacity h,c). Proof. unfold init_page, page_heap. @@ -237,9 +219,9 @@ Lemma interp_nd_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) Nat.lt 0 base -> block_free h base (page_size capacity) -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j (page_size capacity)) -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some base)) + interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (page_heap base capacity h,c). Proof. intros Positive Free First. @@ -266,7 +248,7 @@ Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) m (page_heap base capacity h,c). Proof. intro Finite. - destruct (sh_alloc_finite h (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h (page_size capacity) c Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -283,13 +265,13 @@ Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) ~ block_free h j (page_size capacity)) /\ heap_finite (page_heap base capacity h) /\ (forall x, h x <> None -> page_heap base capacity h x = h x) /\ - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some base)) + interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (page_heap base capacity h,c). Proof. intro Finite. - destruct (sh_alloc_finite h (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h (page_size capacity) c Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -299,16 +281,6 @@ Qed. (** Empty heaps accept the very first candidate, even when capacity is zero: the allocation request is always for at least the five metadata cells. *) -Lemma sh_alloc_page_hemp capacity c : - runStateT (sh (inl (HAlloc (page_size capacity)))) (hemp,c) ~ - Ret (1,(hunion (hblock 1 (page_size capacity)) hemp,c)). -Proof. - apply sh_alloc_first. - - apply page_size_positive. - - lia. - - intros offset O; reflexivity. - - intros j Positive Before; lia. -Qed. Lemma interp_rr_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (K : option nat -> thread sE) m c : @@ -325,9 +297,9 @@ Qed. Lemma interp_nd_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (K : option nat -> thread sE) c : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (hemp,c) ~ - interp_nd (S n) (ts @ i := K (Some 1)) + interp_schedule_nd sh (S n) (ts @ i := K (Some 1)) (Some i) (page_heap 1 capacity hemp,c). Proof. apply interp_nd_new_page_first. @@ -356,10 +328,10 @@ Qed. Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (address : nat -> nat) value (K : option nat -> thread sE) c : page_heap 1 capacity hemp (address 1) = Some value -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ - interp_nd (S n) (ts @ i := K (Some value)) + interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (page_heap 1 capacity hemp,c). Proof. intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. @@ -373,7 +345,7 @@ Lemma interp_rr_new_page_read_missing n interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp. apply interp_rr_read_missing; exact Missing. @@ -383,10 +355,10 @@ Lemma interp_nd_new_page_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (address : nat -> nat) (K : option nat -> thread sE) c : page_heap 1 capacity hemp (address 1) = None -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. apply interp_nd_source_read_missing; exact Missing. @@ -429,29 +401,29 @@ Qed. Theorem run_nd_allocator_initialized capacity c : run_nd (allocator_program capacity) hemp c ~ - interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c). + interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c). Proof. unfold run_nd. - change (interp_nd 1 + change (interp_schedule_nd sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) (Some Fin.F1) (hemp,c) ~ - interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). unfold allocator_program; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. rewrite interp_nd_source_bind, interp_nd_source_fork. - change (interp_nd 2 + change (interp_schedule_nd sh 2 ([denote (remote_client 1 false); Ret tt]%vector @ Fin.FS Fin.F1 := (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) (page_heap 1 capacity hemp,c) ~ - interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). rewrite interp_nd_source_bind, interp_nd_source_fork. - change (interp_nd 3 + change (interp_schedule_nd sh 3 ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector @ Fin.FS (Fin.FS Fin.F1) := (denote_flow (owner 1) >>= fun _ => Ret tt)) (Some (Fin.FS (Fin.FS Fin.F1))) (page_heap 1 capacity hemp,c) ~ - interp_nd 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). unfold owner; rewrite interp_nd_source_bind, interp_nd_source_yield; reflexivity. Qed. @@ -524,26 +496,26 @@ Ltac allocator_segment_steps := end | progress (rewrite Nat.eqb_refl) | lazymatch goal with - | |- exact_source_segment_to (denote_flow (CBind _ _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CBind _ _) >>= _) _ _ _ _ => apply exact_source_bind - | |- exact_source_segment_to (denote_flow (CRet _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CRet _) >>= _) _ _ _ _ => apply exact_source_ret - | |- exact_source_segment_to (denote_flow (CUntilNone _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CUntilNone _) >>= _) _ _ _ _ => apply exact_source_until - | |- exact_source_segment_to (denote_flow (CRead _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CRead _) >>= _) _ _ _ _ => eapply exact_source_read; [eassumption|] - | |- exact_source_segment_to (denote_flow (CWrite _ _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CWrite _ _) >>= _) _ _ _ _ => eapply exact_source_write; [allocator_present|] - | |- exact_source_segment_to (denote_flow (CEmit _ _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CEmit _ _) >>= _) _ _ _ _ => apply exact_source_emit - | |- exact_source_segment_to (denote_flow (CCAS _ _ _) >>= _) _ _ _ _ => + | |- (segment_to sh csl_equ) (denote_flow (CCAS _ _ _) >>= _) _ _ _ _ => first [eapply exact_source_cas_success; [congruence|] | eapply exact_source_cas_failure; [eassumption|apply Nat.eqb_neq; eassumption|]] end | progress ( lazymatch goal with - | |- exact_source_segment_to ?src ?sigma ?logs ?target ?sigma' => + | |- (segment_to sh csl_equ) ?src ?sigma ?logs ?target ?sigma' => let src' := eval cbv beta iota zeta delta [remote_residual owner_residual denote remote_client remote_free remote_attempt remote_link_tail remote_cas_tail client_round @@ -551,7 +523,7 @@ Ltac allocator_segment_steps := detach_cas_tail reclaim_step owner_offer_tail offer_block until_tail client_next remote_after_free owner_next owner_after_collect owner_after_detach] in src in - change (exact_source_segment_to src' sigma logs target sigma') + change ((segment_to sh csl_equ) src' sigma logs target sigma') end) ]; apply exact_source_yield; allocator_residual_alignment. @@ -563,7 +535,7 @@ Local Opaque denote_flow ICtree.iter ICtree.bind. Lemma turn_source_exact_segment base who s t event : turn base who s = Some (t,event) -> exists residual, - ExactThreadSegment ((allocator_pool base s) $ slot_of_actor who) + (ThreadSegment sh csl_equ) ((allocator_pool base s) $ slot_of_actor who) (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. @@ -584,28 +556,15 @@ Proof. all: cbn [allocator_pool slot_of_actor Vector.nth aheap acount owner_state remote0_state remote1_state event_obs]. all: lazymatch goal with - | |- exists residual, ExactThreadSegment ?src ?sigma ?logs residual ?sigma' /\ + | |- exists residual, (ThreadSegment sh csl_equ) ?src ?sigma ?logs residual ?sigma' /\ guard_equ residual ?target => - change (exact_source_segment_to src sigma logs target sigma') + change ((segment_to sh csl_equ) src sigma logs target sigma') end. all: allocator_segment_steps. Qed. Local Transparent denote_flow ICtree.iter ICtree.bind. -Lemma turn_source_segment base who s t event : - turn base who s = Some (t,event) -> - exists residual, - ThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who). -Proof. - intro Hturn; destruct (turn_source_exact_segment base who s t event Hturn) - as (residual & Hseg & Htail). - exists residual; split; [now apply ExactThreadSegment_segment|exact Htail]. -Qed. - - Lemma turn_other_slots base who s t event : turn base who s = Some (t,event) -> forall j, j <> slot_of_actor who -> @@ -636,162 +595,47 @@ Proof. unfold allocator_pool; rewrite Ho, H0, H1; apply pool_equ_refl. Qed. -(** The concrete segment is first built with the actual heap function. Only - the model transition and ownership invariant are transported pointwise. *) -Theorem selected_turn_source_segment base capacity (ts : pool sE 3) - sigma s who t event : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - turn base who s = Some (t,event) -> - exists residual sigma', - ThreadSegment (ts $ slot_of_actor who) sigma - (event_obs event) residual sigma' /\ - state_agrees sigma' t /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who). -Proof. - intros Hpool Hagree Hinv Hturn. - pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. - destruct (turn_respects_heq_some base who s (source_reheap sigma s) - t event Hreheap Hturn) as (actual & Hactual & Hnext). - destruct (turn_source_segment base who - (source_reheap sigma s) actual event Hactual) - as (canonical & Hseg & Htail). - change (ThreadSegment ((allocator_pool base s) $ slot_of_actor who) - (fst sigma,snd sigma) (event_obs event) canonical - (aheap actual,acount actual)) in Hseg. - destruct sigma as [h c]; cbn [fst snd] in Hseg. - destruct (guard_equ_segment - ((allocator_pool base s) $ slot_of_actor who) - (ts $ slot_of_actor who) (h,c) (event_obs event) - canonical (aheap actual,acount actual) - (guard_equ_sym _ _ (Hpool (slot_of_actor who))) Hseg) - as (residual & Hraw & Hrawtail). - exists residual, (aheap actual,acount actual); split; [exact Hraw|]; split. - - destruct Hnext as [Hheap [Hcount _]]. - split; cbn; [now apply heq_sym|symmetry; exact Hcount]. - - eapply guard_equ_trans; [apply guard_equ_sym; exact Hrawtail|]. - eapply guard_equ_trans; [exact Htail|]. - apply guard_equ_equ; symmetry. - apply (allocator_pool_state_equiv base t actual Hnext). -Qed. - -Theorem selected_source_segment_exact base capacity (ts : pool sE 3) - sigma s who t event logs residual sigma' : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - turn base who s = Some (t,event) -> - ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> - logs = event_obs event /\ state_agrees sigma' t /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who). -Proof. - intros Hpool Hagree Hinv Hturn Hseg. - destruct (selected_turn_source_segment base capacity ts sigma s who t event - Hpool Hagree Hinv Hturn) as (other & sigma2 & Hother & Hstate & Htail). - destruct (ThreadSegment_deterministic (ts $ slot_of_actor who) sigma - logs residual sigma' (event_obs event) other sigma2 Hseg Hother) - as [Hlogs [Hsigma Hresidual]]. - subst sigma2; split; [exact Hlogs|]; split; [exact Hstate|]. - eapply guard_equ_trans; [apply guard_equ_equ; exact Hresidual|exact Htail]. -Qed. +(** ** The allocator's pool-simulation certificate. -Theorem selected_source_segment_turn base capacity (ts : pool sE 3) - sigma s who logs residual sigma' : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma' -> - exists t event, - turn base who s = Some (t,event) /\ - logs = event_obs event /\ state_agrees sigma' t /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who). -Proof. - intros Hpool Hagree Hinv Hseg. - destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). - exists t, event; split; [exact Hturn|]. - eapply selected_source_segment_exact; eauto. -Qed. - -Lemma selected_source_pool_update base (ts : pool sE 3) s who t event residual : - pool_guard_equ ts (allocator_pool base s) -> - turn base who s = Some (t,event) -> - guard_equ residual ((allocator_pool base t) $ slot_of_actor who) -> - pool_guard_equ (ts @ slot_of_actor who := residual) (allocator_pool base t). + One instantiation of [ICTree.Interp.Yield.Execution.PoolSimulation]; the + scheduling-equivalence theorems it unlocks are the library's, so no + allocator copy of the ND coinduction or the RR guard-alignment proof + remains. The exact segment is built at the ACTUAL heap through + [source_reheap] and the generic step-result congruence, so no heap + function is extracted or equated. *) +Theorem allocator_simulation base capacity : + PoolSimulation 2 sh slot_of_actor (turn base) (allocator_pool base) + state_agrees (allocator_inv base capacity). Proof. - intros Hpool Hturn Htail j. - destruct (Fin.eq_dec j (slot_of_actor who)) as [->|Hne]. - - rewrite Vector.nth_replace_eq; exact Htail. - - rewrite Vector.nth_replace_neq by congruence. - eapply guard_equ_trans; [apply Hpool|]. - apply guard_equ_equ; exact (turn_other_slots base who s t event Hturn j Hne). -Qed. - -(** This is a finite first-yield certificate, not a progress premise about - model runs. Its constructors cannot pass a yield or terminate in a - return, fork, branch, missing-cell fault, or divergent prefix. *) -Theorem initialized_worker_next_yield base capacity (ts : pool sE 3) - sigma s who : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - exists logs residual sigma', - ThreadSegment (ts $ slot_of_actor who) sigma logs residual sigma'. -Proof. - intros Hpool Hagree Hinv. - destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). - destruct (selected_turn_source_segment base capacity ts sigma s who t event - Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & _). - exists (event_obs event), residual, sigma'; exact Hseg. -Qed. - -Theorem initialized_worker_no_terminal_prefix base capacity (ts : pool sE 3) - sigma s who : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - not (guard_equ (ts $ slot_of_actor who) (Ret tt)) /\ - (forall k : bool -> thread sE, - ~ guard_equ (ts $ slot_of_actor who) (Vis (inr (inl Fork)) k)) /\ - (forall n (k : Fin.t (S n) -> thread sE), - ~ guard_equ (ts $ slot_of_actor who) (Br n k)) /\ - not (guard_equ (ts $ slot_of_actor who) (stuck : thread sE)). -Proof. - intros Hpool Hagree Hinv. - destruct (initialized_worker_next_yield base capacity ts sigma s who - Hpool Hagree Hinv) as (logs & residual & sigma' & Hseg). - repeat split. - - intro Hbad. - destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). - exact (ThreadSegment_ret_absurd sigma logs u sigma' Hfalse). - - intros k Hbad. - destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). - exact (ThreadSegment_fork_absurd k sigma logs u sigma' Hfalse). - - intros n k Hbad. - destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). - exact (ThreadSegment_br_absurd n k sigma logs u sigma' Hfalse). - - intro Hbad. - destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). - exact (ThreadSegment_stuck_absurd sigma logs u sigma' Hfalse). -Qed. - -Theorem initialized_worker_no_fault_or_divergence base capacity (ts : pool sE 3) - sigma s who : - pool_guard_equ ts (allocator_pool base s) -> - state_agrees sigma s -> allocator_inv base capacity s -> - not (is_stuck (ts $ slot_of_actor who)) /\ - not (guard_equ (ts $ slot_of_actor who) (spin : thread sE)) /\ - (forall (e : sE) (k : encode e -> thread sE), - guard_equ (ts $ slot_of_actor who) ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) -> - ~ (runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)))). -Proof. - intros Hpool Hagree Hinv. - destruct (initialized_worker_next_yield base capacity ts sigma s who - Hpool Hagree Hinv) as (logs & residual & sigma' & Hseg). split. - - intro Hstuck; apply Hstuck; eapply ThreadSegment_can_step; exact Hseg. - - split. - + intro Hbad. - destruct (guard_equ_segment _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). - exact (ThreadSegment_spin_absurd sigma logs u sigma' Hfalse). - + intros e k Hhead Hfault. - destruct (guard_equ_segment _ _ _ _ _ _ Hhead Hseg) as (u & Hfalse & _). - exact (ThreadSegment_fault_absurd e k sigma logs u sigma' Hfault Hfalse). + - intros who s Hinv. + destruct (turn_total base capacity who s Hinv) as (t & event & Hturn). + exists t, event; split; [exact Hturn | eapply turn_preserves_inv; eauto]. + - intros who s s' event sigma Hinv Hagree Hturn. + pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. + destruct (step_some_compatible (turn base) state_equiv (turn_proper base) + who s (source_reheap sigma s) s' event Hreheap Hturn) as (actual & Hactual & Hnext). + destruct (turn_source_exact_segment base who + (source_reheap sigma s) actual event Hactual) + as (residual & Hseg & Htail). + destruct sigma as [h c]. + cbn [source_reheap aheap acount owner_state remote0_state remote1_state + allocator_pool fst snd] in Hseg, Htail |- *. + exists residual, (aheap actual,acount actual). + split; [exact Hseg |]. + split. + + destruct Hnext as [Hheap [Hcount _]]. + split; cbn; [now apply heq_sym | symmetry; exact Hcount]. + + split. + * eapply guard_equ_trans; [exact Htail |]. + apply guard_equ_equ; symmetry. + exact (allocator_pool_state_equiv base s' actual Hnext + (slot_of_actor who)). + * intros j Hj. + etransitivity; + [exact (turn_other_slots base who (source_reheap (h,c) s) actual event + Hactual j Hj) |]. + symmetry; exact (allocator_pool_state_equiv base s' actual Hnext j). Qed. @@ -809,28 +653,30 @@ Qed. (** Each equation encompasses every branch of the phase table. The result retains the actual residual at None focus: guard_equ is not silently - promoted to an unfocused-pool congruence. *) + promoted to an unfocused-pool congruence. At the canonical state the + handler state after the turn is EXACTLY the model's heap and counter. *) Theorem turn_interp_nd base capacity who s t event : allocator_inv base capacity s -> turn base who s = Some (t,event) -> exists residual, guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ - interp_nd 3 (allocator_pool base s) (Some (slot_of_actor who)) + interp_schedule_nd sh 3 (allocator_pool base s) (Some (slot_of_actor who)) (aheap s,acount s) ~ emit_list (event_obs event) - (interp_nd 3 (allocator_pool base t @ slot_of_actor who := residual) + (interp_schedule_nd sh 3 (allocator_pool base t @ slot_of_actor who := residual) None (aheap t,acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_segment base who s t event Hturn) + destruct (turn_source_exact_segment base who s t event Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - - symmetry; apply equ_sbisim, interp_nd_equ, source_replace_current. + - symmetry; apply equ_sbisim, (interp_schedule_nd_equ sh), pool_replace_current. - etransitivity. - + exact (segment_interp_nd 2 (allocator_pool base s) (slot_of_actor who) + + exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) + 2 (allocator_pool base s) (slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) (aheap s,acount s) (event_obs event) residual (aheap t,acount t) Hseg). - + apply emit_list_sbisim, equ_sbisim, interp_nd_equ. + + apply emit_list_sbisim, equ_sbisim, (interp_schedule_nd_equ sh). exact (source_replace_turn base who s t event residual Hturn). Qed. @@ -846,20 +692,23 @@ Theorem turn_interp_rr base capacity who s t event cursor : None cursor (aheap t,acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_segment base who s t event Hturn) + destruct (turn_source_exact_segment base who s t event Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - symmetry; apply equ_sbisim, interp_schedule_rr_equ, - source_replace_current. + pool_replace_current. - etransitivity. - + exact (segment_interp_rr 2 (allocator_pool base s) (slot_of_actor who) + + exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) + 2 (allocator_pool base s) (slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) cursor (aheap s,acount s) (event_obs event) residual (aheap t,acount t) Hseg). + apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. exact (source_replace_turn base who s t event residual Hturn). Qed. +(** At an arbitrary aligned pool and store the final handler state is only + relationally determined, by the library segment of [allocator_simulation]. *) Theorem selected_turn_interp_nd base capacity (ts : pool sE 3) sigma s who t event : pool_guard_equ ts (allocator_pool base s) -> @@ -868,18 +717,23 @@ Theorem selected_turn_interp_nd base capacity (ts : pool sE 3) exists residual sigma', state_agrees sigma' t /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ - interp_nd 3 ts (Some (slot_of_actor who)) sigma ~ + interp_schedule_nd sh 3 ts (Some (slot_of_actor who)) sigma ~ emit_list (event_obs event) - (interp_nd 3 (ts @ slot_of_actor who := residual) None sigma'). + (interp_schedule_nd sh 3 (ts @ slot_of_actor who := residual) None sigma'). Proof. intros Hpool Hagree Hinv Hturn. - destruct (selected_turn_source_segment base capacity ts sigma s who t event - Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). - exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. - etransitivity. - - symmetry; apply equ_sbisim, interp_nd_equ, source_replace_current. - - exact (segment_interp_nd 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) sigma (event_obs event) residual sigma' Hseg). + destruct (selected_turn_segment 2 sh slot_of_actor (turn base) (allocator_pool base) + state_agrees (allocator_inv base capacity) (allocator_simulation base capacity) + ts s who t event sigma Hinv Hagree Hpool Hturn) + as (residual & sigma' & Hseg & Hstate & Hnext). + exists residual, sigma'; split; [exact Hstate|]; split. + - pose proof (Hnext (slot_of_actor who)) as Htail. + rewrite Vector.nth_replace_eq in Htail; exact Htail. + - etransitivity. + + symmetry; apply equ_sbisim, (interp_schedule_nd_equ sh), pool_replace_current. + + exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) + 2 ts (slot_of_actor who) (ts $ slot_of_actor who) sigma + (event_obs event) residual sigma' Hseg). Qed. Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) @@ -895,14 +749,18 @@ Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) (interp_schedule_rr sh 3 (ts @ slot_of_actor who := residual) None cursor sigma'). Proof. intros Hpool Hagree Hinv Hturn. - destruct (selected_turn_source_segment base capacity ts sigma s who t event - Hpool Hagree Hinv Hturn) as (residual & sigma' & Hseg & Hstate & Htail). - exists residual, sigma'; split; [exact Hstate|]; split; [exact Htail|]. - etransitivity. - - symmetry; apply equ_sbisim, interp_schedule_rr_equ, - source_replace_current. - - exact (segment_interp_rr 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) cursor sigma (event_obs event) residual sigma' Hseg). + destruct (selected_turn_segment 2 sh slot_of_actor (turn base) (allocator_pool base) + state_agrees (allocator_inv base capacity) (allocator_simulation base capacity) + ts s who t event sigma Hinv Hagree Hpool Hturn) + as (residual & sigma' & Hseg & Hstate & Hnext). + exists residual, sigma'; split; [exact Hstate|]; split. + - pose proof (Hnext (slot_of_actor who)) as Htail. + rewrite Vector.nth_replace_eq in Htail; exact Htail. + - etransitivity. + + symmetry; apply equ_sbisim, interp_schedule_rr_equ, pool_replace_current. + + exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) + 2 ts (slot_of_actor who) (ts $ slot_of_actor who) cursor sigma + (event_obs event) residual sigma' Hseg). Qed. From Coinduction Require Import coinduction rel tactics. @@ -911,162 +769,51 @@ Local Open Scope nat_scope. Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event : pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> exists residual, - ExactThreadSegment (ts $ slot_of_actor who) (aheap s,acount s) + (ThreadSegment sh csl_equ) (ts $ slot_of_actor who) (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hturn. destruct (turn_source_exact_segment base who s t event Hturn) as (residual & Hseg & Htail). exists residual; split; [|exact Htail]. - apply (proj2 (guard_equ_exact_segment_iff + apply (proj2 ((guard_equ_segment_iff sh csl_equ) (ts $ slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) (Hpool (slot_of_actor who)) (aheap s,acount s) (event_obs event) residual (aheap t,acount t))); exact Hseg. Qed. -Lemma selected_turn_rr_prefix base (ts : pool sE 3) s who t event cursor : - pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> - exists residual word, - rr_prefix_events word = event_obs event /\ - guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ - interp_schedule_rr sh 3 ts (Some (slot_of_actor who)) cursor (aheap s,acount s) ≅ - rr_prefix word (Guard (interp_schedule_rr sh 3 - (ts @ slot_of_actor who := residual) None cursor (aheap t,acount t))). -Proof. - intros Hpool Hturn. - destruct (selected_turn_exact_segment base ts s who t event Hpool Hturn) - as (residual & Hseg & Htail). - destruct (exact_segment_rr_prefix 2 ts (slot_of_actor who) - (ts $ slot_of_actor who) cursor (aheap s,acount s) (event_obs event) - residual (aheap t,acount t) Hseg) as (word & Ew & Et). - exists residual, word; split; [exact Ew|]; split; [exact Htail|]. - etransitivity; [|exact Et]. - symmetry; apply interp_schedule_rr_equ, source_replace_current. -Qed. - -Lemma allocator_pool_rr_aligned base capacity : forall s ts cursor, - allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> - rr_aligned - (interp_schedule_rr sh 3 ts None cursor (aheap s,acount s)) - (model_rr base s cursor). -Proof. - cofix IH; intros s ts cursor Hinv Hpool. - set (who := actor_of_slot (rr_pick 2 cursor)). - assert (Eslot : slot_of_actor who = rr_pick 2 cursor). - { unfold who; apply slot_of_actor_of_slot. } - destruct (turn_total base capacity who s Hinv) as (next & event & Hturn). - destruct (selected_turn_rr_prefix base ts s who next event (S cursor) Hpool Hturn) - as (residual & word & Ew & Htail & Eprefix). - set (next_tree := interp_schedule_rr sh 3 - (ts @ slot_of_actor who := residual) None (S cursor) (aheap next,acount next)). - set (next_model := model_rr base next (S cursor)). - assert (Hsource : interp_schedule_rr sh 3 ts None cursor (aheap s,acount s) ≅ - rr_guards 3 (rr_prefix word (Guard next_tree))). - { - etransitivity; [exact (segment_rr_select_exact 2 ts cursor (aheap s,acount s))|]. - apply (rr_guards_equ 3); rewrite <- Eslot; exact Eprefix. - } - assert (Hnextinv : allocator_inv base capacity next). - { eapply turn_preserves_inv; eauto. } - assert (Hnextpool : pool_guard_equ (ts @ slot_of_actor who := residual) - (allocator_pool base next)). - { eapply selected_source_pool_update; eauto. } - destruct event as [o|]; cbn [event_obs] in Ew. - - destruct (rr_prefix_one_event word o (Guard next_tree) Ew) as (n & m & Eword). - eapply rr_align_log with (n := 3 + n) (m := 0) (o := o) - (t' := rr_guards m (Guard next_tree)) (u' := Guard next_model). - + etransitivity; [exact Hsource|]. - rewrite (rr_guards_add 3 n - (Vis (Log o) (fun _ => rr_guards m (Guard next_tree)))). - apply rr_guards_equ; exact Eword. - + rewrite (unfold_model_rr base s cursor); fold who; rewrite Hturn; reflexivity. - + eapply rr_align_guard with (n := m) (m := 0) - (t' := next_tree) (u' := next_model). - * rewrite rr_guards_guard; reflexivity. - * reflexivity. - * apply IH; assumption. - - eapply rr_align_guard with (n := 3 + List.length word) (m := 0) - (t' := next_tree) (u' := next_model). - + etransitivity; [exact Hsource|]. - rewrite (rr_prefix_no_events word (Guard next_tree) Ew). - rewrite <- (rr_guards_add 3 (List.length word) (Guard next_tree)). - rewrite rr_guards_guard; reflexivity. - + rewrite (unfold_model_rr base s cursor); fold who; rewrite Hturn; reflexivity. - + apply IH; assumption. -Qed. - -Lemma allocator_pool_rr_bisim base capacity s ts cursor : - allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> - interp_schedule_rr sh 3 ts None cursor (aheap s,acount s) ~ model_rr base s cursor. -Proof. - intros Hinv Hpool; apply rr_aligned_sbisim. - exact (allocator_pool_rr_aligned base capacity s ts cursor Hinv Hpool). -Qed. - Theorem run_rr_allocator_bisim capacity c : - run_rr (allocator_program capacity) hemp c ~ model_rr 1 (initial_state capacity c) 0. + run_rr (allocator_program capacity) hemp c ~ + (model_rr 2 actor_of_slot (turn 1) (initial_state capacity c) 0 + : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_allocator_initialized. - apply (allocator_pool_rr_bisim 1 capacity (initial_state capacity c)). - - apply initial_state_inv. - - apply execution_pool_guard_equ, source_pool0_initial. -Qed. - -From Coinduction Require Import coinduction rel tactics. -Local Notation st L := (coinduction.t (sb L)). - - -Lemma allocator_pool_nd_bisim base capacity : forall s ts, - allocator_inv base capacity s -> pool_guard_equ ts (allocator_pool base s) -> - interp_nd 3 ts None (aheap s,acount s) ~ model_nd base s. -Proof. - unfold sbisim; apply_coinduction; fold_sbisim. - intros R IH s ts Hinv Hpool. - etransitivity; [apply (coinduction.gfp_bt (sb eq) R), interp_nd_select|]. - eapply equ_sbt_closed_goal; [reflexivity|apply unfold_model_nd|]. - apply step_sb_br_id; [reflexivity|intro i]. - destruct (turn_total base capacity (actor_of_slot i) s Hinv) - as (next & event & Hturn). - rewrite Hturn. - destruct (selected_turn_exact_segment base ts s (actor_of_slot i) next event - Hpool Hturn) as (residual & Hseg & Htail). - pose proof (selected_source_pool_update base ts s (actor_of_slot i) - next event residual Hpool Hturn Htail) as Hnextpool. - apply ExactThreadSegment_segment in Hseg. - pose proof (segment_interp_nd 2 ts (slot_of_actor (actor_of_slot i)) - (ts $ slot_of_actor (actor_of_slot i)) (aheap s,acount s) - (event_obs event) residual (aheap next,acount next) Hseg) as Esegment. - rewrite slot_of_actor_of_slot in Esegment, Hnextpool. - assert (Efocus : interp_nd 3 ts (Some i) (aheap s,acount s) ~ - emit_list (event_obs event) - (interp_nd 3 (ts @ i := residual) None (aheap next,acount next))). - { - etransitivity; [|exact Esegment]. - symmetry; apply equ_sbisim, interp_nd_equ, - source_replace_current. - } - assert (Hnextinv : allocator_inv base capacity next). - { eapply turn_preserves_inv; eauto. } - etransitivity; [apply (coinduction.gfp_t (sb eq) R); exact Efocus|]. - assert (Hcontinue : st eq R - (interp_nd 3 (ts @ i := residual) None (aheap next,acount next)) - (Guard (model_nd base next))). - { - etransitivity; [exact (IH next (ts @ i := residual) Hnextinv Hnextpool)|]. - apply (coinduction.gfp_t (sb eq) R); symmetry; exact (sb_guard (model_nd base next)). - } - destruct event as [o|]; cbn [event_obs]. - - eapply equ_clos_st_goal; - [reflexivity|symmetry; exact (emit_list_cons o [] (Guard (model_nd base next)))|]. - apply (emit_list_st R [o]); exact Hcontinue. - - exact Hcontinue. + exact (pool_simulation_rr_bisim 2 sh actor_of_slot slot_of_actor + slot_of_actor_of_slot (turn 1) (allocator_pool 1) state_agrees + (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) 0 + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c))). Qed. Theorem run_nd_allocator_bisim capacity c : - run_nd (allocator_program capacity) hemp c ~ model_nd 1 (initial_state capacity c). + run_nd (allocator_program capacity) hemp c ~ + (model_nd 2 actor_of_slot (turn 1) (initial_state capacity c) + : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_nd_allocator_initialized. - apply (allocator_pool_nd_bisim 1 capacity (initial_state capacity c)). - - apply initial_state_inv. - - apply execution_pool_guard_equ, source_pool0_initial. -Qed. + exact (pool_simulation_nd_bisim 2 sh actor_of_slot slot_of_actor + slot_of_actor_of_slot (turn 1) (allocator_pool 1) state_agrees + (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c))). +Qed. + +(** The one program-specific validity entry point for raw source executions: + the library's pool validity at the allocator handler, slot map, initial + source pool, and initialized page. *) +Definition allocator_source_valid (capacity c : nat) + (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) : Prop := + pool_execution_valid 2 sh slot_of_actor + (source_pool0 1) (page_heap 1 capacity hemp,c) se. diff --git a/examples/CSL/Allocator/Layout.v b/examples/CSL/Allocator/Layout.v index 19236d0..45a188b 100644 --- a/examples/CSL/Allocator/Layout.v +++ b/examples/CSL/Allocator/Layout.v @@ -2,11 +2,11 @@ The five metadata cells precede stride-two blocks. A block's first cell is its free-list link; its successor cell is mutable client payload. - The imported [cells] operation is used only as a two-cell footprint: - none of the queue's ownership or chain predicates is used here. *) + The stride-two geometry ([cells], [node_addrs], [init_links_heap]) is + owned by [Events.HeapModel]; this module only fixes the page layout. *) From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout. +From TICL Require Import Events.HeapModel Utils.Pcm Utils.Lists. Import ListNotations. Local Open Scope list_scope. @@ -55,23 +55,6 @@ Proof. unfold page_size; lia. Qed. -Lemma page_blocks_positive base capacity b : - In b (page_blocks base capacity) -> Nat.lt 0 b. -Proof. intro H; apply page_blocks_bounds in H; lia. Qed. - -Lemma page_blocks_nonnull base capacity : ~ In 0 (page_blocks base capacity). -Proof. intro H; apply page_blocks_positive in H; lia. Qed. - -Lemma node_addrs_link_payload_disjoint first count a b : - In a (node_addrs first count) -> In b (node_addrs first count) -> - a <> S b. -Proof. - intros Ha Hb. - apply node_addrs_in in Ha as (i & Hi & Ha). - apply node_addrs_in in Hb as (j & Hj & Hb). - lia. -Qed. - Lemma page_blocks_link_payload_disjoint base capacity a b : In a (page_blocks base capacity) -> In b (page_blocks base capacity) -> a <> S b. @@ -90,9 +73,6 @@ Proof. repeat constructor; cbn [In]; intuition lia. Qed. -Lemma page_metadata_positive base x : - Nat.lt 0 base -> In x (page_metadata base) -> Nat.lt 0 x. -Proof. intros Hbase Hx; apply page_metadata_range in Hx; lia. Qed. Lemma mailbox_injective base client client' : mailbox base client = mailbox base client' -> client = client'. @@ -132,37 +112,9 @@ Proof. rewrite in_app_iff, in_cells; reflexivity. Qed. -Local Lemma node_addrs_cells_nodup first count : - NoDup (cells (node_addrs first count)). -Proof. - revert first; induction count as [| count IH]; intro first. - - constructor. - - change (NoDup (first :: S first :: cells (node_addrs (first + 2) count))). - constructor. - + intros [H | H]; [lia | apply node_cells_range in H; lia]. - + constructor. - * intro H; apply node_cells_range in H; lia. - * apply IH. -Qed. - -Local Lemma nodup_disjoint_app (xs ys : list nat) : - NoDup xs -> NoDup ys -> - (forall x, In x xs -> ~ In x ys) -> NoDup (xs ++ ys). -Proof. - revert ys; induction xs as [| a xs IH]; intros ys Hxs Hys Hdisj. - - exact Hys. - - apply NoDup_cons_iff in Hxs as [Hnot Hxs]. - cbn [app]; constructor. - + rewrite in_app_iff; intros [Hin | Hin]. - * exact (Hnot Hin). - * exact (Hdisj a (or_introl eq_refl) Hin). - + apply IH; [exact Hxs | exact Hys |]. - intros x Hx; apply Hdisj; now right. -Qed. - Lemma page_cells_nodup base capacity : NoDup (page_cells base capacity). Proof. - unfold page_cells; apply nodup_disjoint_app. + unfold page_cells; apply NoDup_app. - apply page_metadata_nodup. - apply node_addrs_cells_nodup. - intros x Hmeta Hblock. @@ -170,9 +122,6 @@ Proof. apply page_block_cells_range in Hblock; lia. Qed. -Lemma page_cells_positive base capacity x : - Nat.lt 0 base -> In x (page_cells base capacity) -> Nat.lt 0 x. -Proof. intros Hbase Hx; apply page_cells_range in Hx; lia. Qed. (** ** Pure counterparts of the checked initialization writes @@ -180,14 +129,6 @@ Proof. intros Hbase Hx; apply page_cells_range in Hx; lia. Qed. local; then links from low to high. The allocation overlay installs the zero payloads. Initialization never writes a payload cell. *) -Fixpoint init_links_heap (first count : nat) (h : Heap) : Heap := - match count with - | 0 => h - | S rest => - init_links_heap (first + 2) rest - (upd h first (match rest with 0 => 0 | S _ => first + 2 end)) - end. - Definition page_heap (base capacity : nat) (h : Heap) : Heap := init_links_heap (base + 5) capacity (upd @@ -201,116 +142,6 @@ Definition page_heap (base capacity : nat) (h : Heap) : Heap := (mailbox base true) 0) (local_head base) (match capacity with 0 => 0 | S _ => base + 5 end)). -Lemma init_links_heap_lookup_agree first count h f x : - h x = f x -> init_links_heap first count h x = init_links_heap first count f x. -Proof. - revert first h f; induction count as [| count IH]; intros first h f H. - - exact H. - - cbn [init_links_heap]; apply IH, upd_lookup_agree, H. -Qed. - -Lemma init_links_heap_heq first count h f : - heq h f -> heq (init_links_heap first count h) (init_links_heap first count f). -Proof. intros H x; apply init_links_heap_lookup_agree, H. Qed. - -Lemma init_links_heap_frame first count h x : - ~ In x (node_addrs first count) -> init_links_heap first count h x = h x. -Proof. - revert first h; induction count as [| count IH]; intros first h Hout. - - reflexivity. - - cbn [init_links_heap]; rewrite IH. - + apply upd_neq; intro H; apply Hout; cbn [node_addrs]; now left. - + intro Hin; apply Hout; cbn [node_addrs]; now right. -Qed. - -Lemma init_links_heap_out first count h x : - (Nat.lt x first \/ Nat.le (first + 2 * count) x) -> - init_links_heap first count h x = h x. -Proof. - intro Hout; apply init_links_heap_frame. - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. -Qed. - -Lemma init_links_heap_payload first count h b : - In b (node_addrs first count) -> init_links_heap first count h (S b) = h (S b). -Proof. - intro Hb; apply init_links_heap_frame; intro Hin. - exact (node_addrs_link_payload_disjoint first count (S b) b Hin Hb eq_refl). -Qed. - -(** Without a checked-write premise the pure updater can extend a domain. - Its exact domain law makes that possibility explicit. *) -Lemma init_links_heap_dom first count h x : - init_links_heap first count h x <> None <-> - In x (node_addrs first count) \/ h x <> None. -Proof. - revert first h x; induction count as [| count IH]; intros first h x. - - cbn [init_links_heap node_addrs In]; tauto. - - cbn [init_links_heap node_addrs In]; rewrite IH; unfold upd. - destruct (Nat.eqb_spec x first) as [Hx | Hne]. - + subst x; split; intro H. - * left; now left. - * right; discriminate. - + intuition congruence. -Qed. - -Lemma init_links_heap_checked_dom first count h : - (forall b, In b (node_addrs first count) -> h b <> None) -> - forall x, init_links_heap first count h x <> None <-> h x <> None. -Proof. - intro Hchecked; intro x; rewrite init_links_heap_dom. - split; [intros [Hin | Hx]; [now apply Hchecked | exact Hx] | now right]. -Qed. - -(** A list-suffix lookup is independent of the incoming heap. In particular - it supplies exactly the head/tail equations for a later [free_chain] - proof, without defining that ownership predicate in this module. *) -Lemma init_links_heap_link first count h prefix b rest : - node_addrs first count = prefix ++ b :: rest -> - init_links_heap first count h b = Some (hd 0 rest). -Proof. - revert first h prefix b rest; induction count as [| count IH]; - intros first h prefix b rest Hnodes. - - destruct prefix; discriminate. - - destruct prefix as [| a prefix]. - + cbn [node_addrs app] in Hnodes. - injection Hnodes as Hb Hrest; subst b; subst rest. - cbn [init_links_heap]. - rewrite init_links_heap_out by (left; lia). - rewrite upd_eq; destruct count; reflexivity. - + cbn [node_addrs app] in Hnodes. - injection Hnodes as Ha Htail. - cbn [init_links_heap]; eapply IH; exact Htail. -Qed. - -Lemma init_links_heap_link_index first count h j : - Nat.lt j count -> - init_links_heap first count h (first + 2 * j) = - Some (if Nat.ltb (S j) count then first + 2 * S j else 0). -Proof. - revert first h j; induction count as [| count IH]; intros first h j Hj. - - lia. - - destruct j as [| j]. - + replace (first + 2 * 0) with first by lia. - cbn [init_links_heap]. - rewrite init_links_heap_out by (left; lia). - rewrite upd_eq; destruct count; reflexivity. - + cbn [init_links_heap]. - replace (first + 2 * S j) with (first + 2 + 2 * j) by lia. - rewrite IH by lia. - change (Some (if Nat.ltb (S j) count then first + 2 + 2 * S j else 0) = - Some (if Nat.ltb (S j) count then first + 2 * S (S j) else 0)). - destruct (Nat.ltb (S j) count); f_equal; lia. -Qed. - -Lemma init_links_heap_finite first count h : - heap_finite h -> heap_finite (init_links_heap first count h). -Proof. - revert first h; induction count as [| count IH]; intros first h Hh. - - exact Hh. - - cbn [init_links_heap]; apply IH, heap_finite_upd, Hh. -Qed. - (** ** Backing storage, checked cells, and the old frame *) Lemma page_backing_in base capacity h x : @@ -376,13 +207,6 @@ Proof. - intro Hout; rewrite page_heap_frame by exact Hout; reflexivity. Qed. -Lemma page_heap_null base capacity h : - Nat.lt 0 base -> page_heap base capacity h 0 = h 0. -Proof. intro Hbase; apply page_heap_frame; now left. Qed. - -Lemma page_heap_closed_null base capacity : - Nat.lt 0 base -> page_heap base capacity hemp 0 = None. -Proof. intro Hbase; apply page_heap_null; exact Hbase. Qed. Lemma page_heap_old_frame base capacity h : block_free h base (page_size capacity) -> @@ -406,13 +230,6 @@ Proof. rewrite (page_backing_in base capacity f x Hin); reflexivity. Qed. -Lemma page_heap_heq base capacity h f : - heq h f -> heq (page_heap base capacity h) (page_heap base capacity f). -Proof. - intros H x; unfold page_heap; apply init_links_heap_lookup_agree. - repeat apply upd_lookup_agree. - unfold hunion; now rewrite H. -Qed. Lemma page_heap_split base capacity h : heq (page_heap base capacity h) (hunion (page_heap base capacity hemp) h). diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v index 9a4fae2..806f232 100644 --- a/examples/CSL/Allocator/Liveness.v +++ b/examples/CSL/Allocator/Liveness.v @@ -1,4 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import ICTree.Interp.Yield.Execution. +From TICL Require Import Utils.Execution. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield ICTree.Logic.Trace Utils.Relations. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program @@ -9,142 +11,38 @@ Local Open Scope ictree_scope. Local Open Scope list_scope. Local Open Scope nat_scope. -Record AExecution := { - states : nat -> AState; - selected : nat -> Actor; - emitted : nat -> option SObs -}. -Definition valid_execution (capacity c : nat) (e : AExecution) : Prop := - states e 0 = initial_state capacity c /\ - forall k, turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). -Definition event_is (tag : nat) (e : AExecution) (k : nat) : bool := - match emitted e k with None => false | Some o => Nat.eqb (stag o) tag end. -Definition pending_turn (e : AExecution) (k : nat) : bool := - match selected e k with +(** Executions are the library record [Utils.Execution.Execution] at the + allocator's state/actor/output types; validity and construction are the + two [Model.v] instantiations. No example-local execution record, + constructor or replay induction remains. *) +(** One observation's tag, one actor's pending remote phase, and owner + selection: each predicate is stated on the actual turn data, so an idle + turn, an owner turn, and a polling remote are all explicit cases. *) +Definition event_is (tag : nat) (event : option (indexed (nat * nat))) : bool := + match event with None => false + | Some o => Nat.eqb (fst (indexed_value o)) tag end. +Definition remote_pending (who : Actor) (s : AState) : bool := + match who with | Owner => false - | Remote0 => match remote0_state (states e k) with RPoll => false | _ => true end - | Remote1 => match remote1_state (states e k) with RPoll => false | _ => true end - end. -Definition fair (e : AExecution) : Prop := - forall actor, infinitely (fun k => selected e k = actor). -Definition actor_eqb (a b : Actor) : bool := - match a,b with Owner,Owner | Remote0,Remote0 | Remote1,Remote1 => true | _,_ => false end. -Definition owner_turn (e : AExecution) (k : nat) : bool := actor_eqb (selected e k) Owner. - -(** The impossible branch is eliminated in Prop, then by False elimination. - No existential proof is eliminated into state data and there is no fallback. *) -Definition next_valid base capacity who s (Hinv : allocator_inv base capacity s) - : { result : (AState * option SObs)%type | - turn base who s = Some result /\ allocator_inv base capacity (fst result) }. -Proof. - destruct (turn base who s) as [[next event]|] eqn:Hturn. - - exists (next,event); split; [reflexivity|]. - eapply turn_preserves_inv; eauto. - - exfalso; destruct (turn_total base capacity who s Hinv) as (next & event & H). - rewrite Hturn in H; discriminate. -Defined. - -Fixpoint chosen_state (capacity c : nat) (picks : nat -> Actor) (k : nat) - : { s : AState | allocator_inv 1 capacity s } := - match k with - | 0 => exist _ (initial_state capacity c) (initial_state_inv capacity c) - | S j => - let prior := chosen_state capacity c picks j in - let next := next_valid 1 capacity (picks j) (proj1_sig prior) (proj2_sig prior) in - exist _ (fst (proj1_sig next)) (proj2 (proj2_sig next)) + | Remote0 => match remote0_state s with RPoll => false | _ => true end + | Remote1 => match remote1_state s with RPoll => false | _ => true end end. -Definition execution_of_choices (capacity c : nat) (picks : nat -> Actor) : AExecution := - {| states := fun k => proj1_sig (chosen_state capacity c picks k); - selected := picks; - emitted := fun k => - let prior := chosen_state capacity c picks k in - snd (proj1_sig (next_valid 1 capacity (picks k) (proj1_sig prior) (proj2_sig prior))) |}. - -Lemma execution_of_choices_valid capacity c picks : - valid_execution capacity c (execution_of_choices capacity c picks). -Proof. - split; [reflexivity|]; intro k. - unfold execution_of_choices; cbn [states selected emitted chosen_state]. - destruct (next_valid 1 capacity (picks k) - (proj1_sig (chosen_state capacity c picks k)) - (proj2_sig (chosen_state capacity c picks k))) as [[next event] [Hturn Hinv]]. - exact Hturn. -Qed. -Lemma execution_of_choices_selected capacity c picks k : - selected (execution_of_choices capacity c picks) k = picks k. -Proof. reflexivity. Qed. +Definition owner_selected (who : Actor) : bool := + match who with Owner => true | _ => false end. -Lemma execution_inv capacity c e k : - valid_execution capacity c e -> allocator_inv 1 capacity (states e k). +Lemma owner_selected_spec who : owner_selected who = true <-> who = Owner. +Proof. destruct who; cbn [owner_selected]; split; intro H; congruence. Qed. +Lemma event_is_spec tag event : + event_is tag event = true <-> + exists block idx, event = Some (stamp (tag,block) idx). Proof. - intros [Hinit Hstep]; induction k as [|k IH]. - - rewrite Hinit; apply initial_state_inv. - - eapply turn_preserves_inv; [exact IH|apply Hstep]. -Qed. -Lemma execution_step capacity c e k : - valid_execution capacity c e -> - turn 1 (selected e k) (states e k) = Some (states e (S k),emitted e k). -Proof. intros [_ H]; apply H. Qed. - -Lemma actor_eqb_spec a b : actor_eqb a b = true <-> a = b. -Proof. destruct a,b; cbn [actor_eqb]; split; intro H; congruence. Qed. -Lemma owner_turn_spec e k : owner_turn e k = true <-> selected e k = Owner. -Proof. apply actor_eqb_spec. Qed. -Lemma event_is_spec tag e k : - event_is tag e k = true <-> exists block idx, emitted e k = Some (SPop tag block idx). -Proof. - unfold event_is; destruct (emitted e k) as [[kind block idx]|] eqn:E; cbn. + unfold event_is; destruct event as [[[kind block] idx]|]; cbn. - rewrite Nat.eqb_eq; split. + intro H; subst kind; now exists block, idx. + intros (b & i & H); inversion H; reflexivity. - split; [discriminate|intros (b & i & H); discriminate]. Qed. -Lemma execution_event_index capacity c e k o : - valid_execution capacity c e -> emitted e k = Some o -> - acount (states e (S k)) = S (acount (states e k)) /\ sidx o = acount (states e k). -Proof. - intros Hvalid Hobs. - pose proof (turn_counter 1 (selected e k) (states e k) (states e (S k)) - (emitted e k) (execution_step capacity c e k Hvalid)) as H. - now rewrite Hobs in H. -Qed. -Lemma execution_counter_mono capacity c e lo hi : - valid_execution capacity c e -> lo <= hi -> acount (states e lo) <= acount (states e hi). -Proof. - intros Hvalid Hle. - assert (Hstep : forall k, acount (states e k) <= acount (states e (S k))). - { - intro k; pose proof (turn_counter 1 (selected e k) (states e k) (states e (S k)) - (emitted e k) (execution_step capacity c e k Hvalid)) as H. - destruct (emitted e k); cbn in H; intuition lia. - } - induction Hle as [|hi Hle IH]; [lia|specialize (Hstep hi); lia]. -Qed. -Lemma execution_event_order capacity c e k j o p : - valid_execution capacity c e -> k < j -> - emitted e k = Some o -> emitted e j = Some p -> sidx o < sidx p. -Proof. - intros Hvalid Hkj Ho Hp. - pose proof (execution_event_index capacity c e k o Hvalid Ho) as [Hk Hi]. - pose proof (execution_event_index capacity c e j p Hvalid Hp) as [Hj Hjidx]. - pose proof (execution_counter_mono capacity c e (S k) j Hvalid ltac:(lia)); lia. -Qed. - -Lemma execution_run_turns capacity c e lo len : - valid_execution capacity c e -> - run_turns 1 (List.map (selected e) (List.seq lo len)) (states e lo) = - Some (states e (lo + len), - List.flat_map (fun k => event_obs (emitted e k)) (List.seq lo len)). -Proof. - intro Hvalid; revert lo; induction len as [|len IH]; intro lo. - - cbn [List.seq List.map run_turns List.flat_map]; now rewrite Nat.add_0_r. - - cbn [List.seq List.map run_turns List.flat_map]. - rewrite (execution_step capacity c e lo Hvalid), IH. - replace (S lo + len) with (lo + S len) by lia. - destruct (emitted e lo); reflexivity. -Qed. - From Stdlib Require Import List Lia Arith.PeanoNat. From TICL Require Import Lang.CSL. From TICL Require Import Lang.CSL.Queue.Representation. @@ -176,14 +74,6 @@ Definition contention_pending_rank (s : AState) : nat := contention_pending_potential (contention_head s) (remote0_state s) (remote1_state s). Definition contention_failure_rank (s : AState) : nat := contention_failure_potential (contention_head s) (remote0_state s) (remote1_state s). -Definition contention_pending (who : Actor) (s : AState) : bool := - match who with - | Owner => false - | Remote0 => match remote0_state s with RPoll => false | _ => true end - | Remote1 => match remote1_state s with RPoll => false | _ => true end - end. -Definition contention_tag (kind : nat) (event : option SObs) : bool := - match event with None => false | Some o => Nat.eqb (stag o) kind end. Lemma contention_stale_bound current pc : contention_stale current pc <= 1. Proof. @@ -240,7 +130,7 @@ Local Ltac contention_reduce_turn Hturn := cbn [turn aheap acount owner_state remote0_state remote1_state] in Hturn. Local Ltac contention_finish Hturn Hnoret Hr target event := inversion Hturn; subst target event; clear Hturn; - cbn [contention_pending contention_tag stag tag_alloc tag_retire + cbn [remote_pending event_is indexed_value fst tag_alloc tag_retire tag_reclaim tag_retry aheap remote0_state remote1_state] in Hnoret |- *; try discriminate; unfold contention_pending_rank, contention_failure_rank, contention_head; @@ -260,15 +150,15 @@ Local Ltac contention_arithmetic := Lemma turn_contention_ranks capacity who s t event : allocator_inv 1 capacity s -> turn 1 who s = Some (t,event) -> - contention_tag tag_retire event = false -> - (if contention_pending who s then 1 else 0) + contention_pending_rank t <= + event_is tag_retire event = false -> + (if remote_pending who s then 1 else 0) + contention_pending_rank t <= contention_pending_rank s /\ - (if contention_tag tag_retry event then 1 else 0) + contention_failure_rank t <= + (if event_is tag_retry event then 1 else 0) + contention_failure_rank t <= contention_failure_rank s. Proof. destruct s as [h count op p0 p1]. cbn [allocator_inv aheap acount owner_state remote0_state remote1_state]. - intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + intros (L & R & D & Hbase & Hback & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) Hturn Hnoret. cbn [aheap acount owner_state remote0_state remote1_state] in *. destruct who. @@ -283,7 +173,7 @@ Proof. + destruct D as [|b D]. * contention_reduce_turn Hturn; rewrite Hd in Hturn; cbn [hd Nat.eqb] in Hturn. contention_finish Hturn Hnoret Hr t event; contention_arithmetic. - * cbn [free_chain] in CD; destruct CD as [Hnext CD]. + * cbn [linked] in CD; destruct CD as [Hnext CD]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). contention_reduce_turn Hturn; rewrite Hd in Hturn; cbn [hd] in Hturn. rewrite Eb, Hnext, Hl in Hturn. @@ -294,7 +184,7 @@ Proof. ++ contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. rewrite Hl in Hturn; cbn [hd Nat.eqb] in Hturn. contention_finish Hturn Hnoret Hr t event; contention_arithmetic. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + ++ cbn [linked] in CL; destruct CL as [Hnext CL]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). contention_reduce_turn Hturn; rewrite Hm1 in Hturn; cbn [Nat.eqb] in Hturn. rewrite Hl in Hturn; cbn [hd] in Hturn; rewrite Eb, Hnext in Hturn. @@ -306,7 +196,7 @@ Proof. ++ contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. rewrite Hl in Hturn; cbn [hd Nat.eqb] in Hturn. contention_finish Hturn Hnoret Hr t event; contention_arithmetic. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + ++ cbn [linked] in CL; destruct CL as [Hnext CL]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). contention_reduce_turn Hturn; rewrite Hm0 in Hturn; cbn [Nat.eqb] in Hturn. rewrite Hl in Hturn; cbn [hd] in Hturn; rewrite Eb, Hnext in Hturn. @@ -346,42 +236,71 @@ Proof. Qed. Lemma execution_contention_ranks capacity c e k : - valid_execution capacity c e -> event_is tag_retire e k = false -> - (if pending_turn e k then 1 else 0) + contention_pending_rank (states e (S k)) <= + allocator_valid capacity c e -> event_is tag_retire (emitted e k) = false -> + (if remote_pending (selected e k) (states e k) then 1 else 0) + contention_pending_rank (states e (S k)) <= contention_pending_rank (states e k) /\ - (if event_is tag_retry e k then 1 else 0) + contention_failure_rank (states e (S k)) <= + (if event_is tag_retry (emitted e k) then 1 else 0) + contention_failure_rank (states e (S k)) <= contention_failure_rank (states e k). Proof. intros Hvalid Hnone. exact (turn_contention_ranks capacity (selected e k) (states e k) - (states e (S k)) (emitted e k) (execution_inv capacity c e k Hvalid) - (execution_step capacity c e k Hvalid) Hnone). -Qed. - -Lemma no_publication_contention_potential capacity c e lo len : - valid_execution capacity c e -> - (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> - count_if (pending_turn e) lo len + contention_pending_rank (states e (lo + len)) <= + (states e (S k)) (emitted e k) (execution_inv (turn 1) (allocator_inv 1 capacity) + (fun s => s = initial_state capacity c) e (allocator_initial_inv capacity c) + (turn_preserves_inv 1 capacity) k Hvalid) + (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hvalid) Hnone). +Qed. + +(** Both budgets are instances of [Utils.Relations.credit_interval]: the + [Credit] relation is the corresponding rank at the execution's state, + the charge is the pending remote turn (respectively [tag_retry]), and the + goal is publication of [tag_retire]. The interval induction itself is + the library's. *) +Corollary no_publication_contention_potential capacity c e lo len : + allocator_valid capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire (emitted e k) = false) -> + count_if (fun k => remote_pending (selected e k) (states e k)) lo len + contention_pending_rank (states e (lo + len)) <= contention_pending_rank (states e lo) /\ - count_if (event_is tag_retry e) lo len + contention_failure_rank (states e (lo + len)) <= + count_if (fun k => event_is tag_retry (emitted e k)) lo len + contention_failure_rank (states e (lo + len)) <= contention_failure_rank (states e lo). Proof. - intros Hvalid; revert lo; induction len as [|len IH]; intros lo Hnone. - - rewrite !count_if_zero, Nat.add_0_r; cbn; split; lia. - - destruct (execution_contention_ranks capacity c e lo Hvalid - (Hnone lo ltac:(lia))) as [Hpending Hfailure]. - destruct (IH (S lo) ltac:(intros k Hk; apply Hnone; lia)) as [IHpending IHfailure]. - rewrite !count_if_succ. - replace (lo + S len) with (S lo + len) by lia. - split; lia. + intros Hvalid Hnone. + assert (Hbool : forall b : bool, ~ b = true -> b = false) + by (intros [|] H; [exfalso; exact (H eq_refl) | reflexivity]). + split. + - destruct (credit_interval + (fun k r => r = contention_pending_rank (states e k)) + (fun k => remote_pending (selected e k) (states e k)) (fun k => event_is tag_retire (emitted e k) = true)) + with (lo := lo) (len := len) + (credit := contention_pending_rank (states e lo)) + as (r & Hr & Hbound). + + intros k r Hr Hgoal; subst r. + exists (contention_pending_rank (states e (S k))); split; [reflexivity |]. + exact (proj1 (execution_contention_ranks capacity c e k Hvalid + (Hbool _ Hgoal))). + + reflexivity. + + intros k Hk Hgoal; rewrite (Hnone k Hk) in Hgoal; discriminate. + + rewrite <- Hr; exact Hbound. + - destruct (credit_interval + (fun k r => r = contention_failure_rank (states e k)) + (fun k => event_is tag_retry (emitted e k)) (fun k => event_is tag_retire (emitted e k) = true)) + with (lo := lo) (len := len) + (credit := contention_failure_rank (states e lo)) + as (r & Hr & Hbound). + + intros k r Hr Hgoal; subst r. + exists (contention_failure_rank (states e (S k))); split; [reflexivity |]. + exact (proj2 (execution_contention_ranks capacity c e k Hvalid + (Hbool _ Hgoal))). + + reflexivity. + + intros k Hk Hgoal; rewrite (Hnone k Hk) in Hgoal; discriminate. + + rewrite <- Hr; exact Hbound. Qed. (** Only a failed remote CAS emits [tag_retry]. Its unit stale-bit charge proves the four-failure bound independently of the number of idle turns. *) Theorem no_publication_failed_cas_bound capacity c e lo len : - valid_execution capacity c e -> - (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> - count_if (event_is tag_retry e) lo len <= 4. + allocator_valid capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire (emitted e k) = false) -> + count_if (fun k => event_is tag_retry (emitted e k)) lo len <= 4. Proof. intros Hvalid Hnone. destruct (no_publication_contention_potential capacity c e lo len Hvalid Hnone) @@ -390,9 +309,9 @@ Proof. Qed. Theorem no_publication_pending_bound capacity c e lo len : - valid_execution capacity c e -> - (forall k, lo <= k < lo + len -> event_is tag_retire e k = false) -> - count_if (pending_turn e) lo len <= 16. + allocator_valid capacity c e -> + (forall k, lo <= k < lo + len -> event_is tag_retire (emitted e k) = false) -> + count_if (fun k => remote_pending (selected e k) (states e k)) lo len <= 16. Proof. intros Hvalid Hnone. destruct (no_publication_contention_potential capacity c e lo len Hvalid Hnone) @@ -403,13 +322,13 @@ Qed. Theorem remote_free_lockfree capacity c e : - valid_execution capacity c e -> - infinitely (fun k => pending_turn e k = true) -> - infinitely (fun k => event_is tag_retire e k = true). + allocator_valid capacity c e -> + infinitely (fun k => remote_pending (selected e k) (states e k) = true) -> + infinitely (fun k => event_is tag_retire (emitted e k) = true). Proof. intros Hvalid Hpending lo. - destruct (infinitely_count_if (pending_turn e) Hpending 17 lo) as [len Hmany]. - destruct (finite_bool_search (event_is tag_retire e) lo len) + destruct (infinitely_count_if (fun k => remote_pending (selected e k) (states e k)) Hpending 17 lo) as [len Hmany]. + destruct (finite_bool_search (fun k => event_is tag_retire (emitted e k)) lo len) as [[k [Hk Hevent]]|Hnone]. - exists k; split; [lia|exact Hevent]. - pose proof (no_publication_pending_bound capacity c e lo len Hvalid Hnone); lia. @@ -429,140 +348,13 @@ Local Open Scope fin_vector_scope. Local Open Scope list_scope. Local Open Scope nat_scope. -Record SourceExecution := { - source_pools : nat -> pool sE 3; - source_states : nat -> SSig; - source_selected : nat -> Actor; - source_emitted : nat -> list SObs -}. -Definition valid_source_execution (capacity c : nat) (se : SourceExecution) : Prop := - pool_equ (source_pools se 0) (source_pool0 1) /\ - source_states se 0 = (page_heap 1 capacity hemp,c) /\ - forall k, exists residual, - ThreadSegment (source_pools se k $ slot_of_actor (source_selected se k)) - (source_states se k) (source_emitted se k) residual (source_states se (S k)) /\ - pool_equ (source_pools se (S k)) - (source_pools se k @ slot_of_actor (source_selected se k) := residual). - -(** A source scheduler records a physical branch slot, not an observation - guessed to identify its actor. Both inverse laws preserve that witness. *) -Definition source_execution_of_slots - (pools : nat -> pool sE 3) (sigmas : nat -> SSig) - (slots : nat -> Fin.t 3) (logs : nat -> list SObs) : SourceExecution := - {| source_pools := pools; source_states := sigmas; - source_selected := fun k => actor_of_slot (slots k); source_emitted := logs |}. - -Lemma source_execution_of_slots_selected pools sigmas slots logs k : - slot_of_actor (source_selected (source_execution_of_slots pools sigmas slots logs) k) = slots k. -Proof. apply slot_of_actor_of_slot. Qed. - -Theorem source_execution_of_slots_valid capacity c pools sigmas slots logs : - pool_equ (pools 0) (source_pool0 1) -> - sigmas 0 = (page_heap 1 capacity hemp,c) -> - (forall k, exists residual, - ThreadSegment (pools k $ slots k) (sigmas k) (logs k) residual (sigmas (S k)) /\ - pool_equ (pools (S k)) (pools k @ slots k := residual)) -> - valid_source_execution capacity c (source_execution_of_slots pools sigmas slots logs). -Proof. - intros Hpool Hstate Hsteps; split; [exact Hpool|]; split; [exact Hstate|]. - intro k; cbn [source_execution_of_slots source_selected source_pools source_states source_emitted]. - rewrite slot_of_actor_of_slot; apply Hsteps. -Qed. - - -Theorem source_execution_complete capacity c se : - valid_source_execution capacity c se -> - let e := execution_of_choices capacity c (source_selected se) in - valid_execution capacity c e /\ - (forall k, state_agrees (source_states se k) (states e k) /\ - pool_guard_equ (source_pools se k) (allocator_pool 1 (states e k))) /\ - (forall k, source_emitted se k = event_obs (emitted e k)) /\ - (forall k, selected e k = source_selected se k). -Proof. - intros (Hpool0 & Hstate0 & Hsegments) e. - pose proof (execution_of_choices_valid capacity c (source_selected se)) as Hvalid. - change (valid_execution capacity c e) in Hvalid. - assert (Haligned : forall k, - state_agrees (source_states se k) (states e k) /\ - pool_guard_equ (source_pools se k) (allocator_pool 1 (states e k))). - { - intro k; induction k as [|k [Hstate Hpool]]. - - split. - + rewrite Hstate0; split; [apply heq_refl|reflexivity]. - + eapply source_pool_equ_guard_trans; [exact Hpool0|]. - apply execution_pool_guard_equ, source_pool0_initial. - - destruct (Hsegments k) as (residual & Hsegment & Hnextpool). - pose proof (execution_step capacity c e k Hvalid) as Hturn. - change (turn 1 (source_selected se k) (states e k) = - Some (states e (S k),emitted e k)) in Hturn. - destruct (selected_source_segment_exact 1 capacity (source_pools se k) - (source_states se k) (states e k) (source_selected se k) - (states e (S k)) (emitted e k) (source_emitted se k) - residual (source_states se (S k)) Hpool Hstate - (execution_inv capacity c e k Hvalid) Hturn Hsegment) - as (_ & Hstate' & Hresidual). - split; [exact Hstate'|]. - eapply source_pool_equ_guard_trans; [exact Hnextpool|]. - eapply selected_source_pool_update; eassumption. - } - split; [exact Hvalid|]; split; [exact Haligned|]; split. - - intro k; destruct (Haligned k) as [Hstate Hpool]. - destruct (Hsegments k) as (residual & Hsegment & _). - pose proof (execution_step capacity c e k Hvalid) as Hturn. - change (turn 1 (source_selected se k) (states e k) = - Some (states e (S k),emitted e k)) in Hturn. - exact (proj1 (selected_source_segment_exact 1 capacity (source_pools se k) - (source_states se k) (states e k) (source_selected se k) - (states e (S k)) (emitted e k) (source_emitted se k) - residual (source_states se (S k)) Hpool Hstate - (execution_inv capacity c e k Hvalid) Hturn Hsegment)). - - intro k; reflexivity. -Qed. - -(** Finite raw-source reachability has no model premise. It is useful before - an infinite schedule is supplied: every physical slot remains selectable. *) -Inductive ReachableSourcePool (capacity c : nat) : pool sE 3 -> SSig -> Prop := -| source_reachable_initial ts : - pool_equ ts (source_pool0 1) -> - ReachableSourcePool capacity c ts (page_heap 1 capacity hemp,c) -| source_reachable_step ts sigma (i : Fin.t 3) logs residual sigma' ts' : - ReachableSourcePool capacity c ts sigma -> - ThreadSegment (ts $ i) sigma logs residual sigma' -> - pool_equ ts' (ts @ i := residual) -> - ReachableSourcePool capacity c ts' sigma'. - -Lemma reachable_source_alignment capacity c ts sigma : - ReachableSourcePool capacity c ts sigma -> - exists s, allocator_inv 1 capacity s /\ state_agrees sigma s /\ - pool_guard_equ ts (allocator_pool 1 s). -Proof. - intro H; induction H as - [ts E|ts sigma i logs residual sigma' ts' Hreach IH Hseg E]. - - exists (initial_state capacity c); split; [apply initial_state_inv|]; split. - + split; [apply heq_refl|reflexivity]. - + eapply source_pool_equ_guard_trans; [exact E|]. - apply execution_pool_guard_equ, source_pool0_initial. - - destruct IH as (s & Hinv & Hagree & Hpool). - rewrite <- (slot_of_actor_of_slot i) in Hseg, E. - destruct (selected_source_segment_turn 1 capacity ts sigma s (actor_of_slot i) - logs residual sigma' Hpool Hagree Hinv Hseg) - as (next & event & Hturn & Hlogs & Hstate & Htail). - exists next; split; [eapply turn_preserves_inv; eassumption|]; split; - [exact Hstate|]. - eapply source_pool_equ_guard_trans; [exact E|]. - eapply selected_source_pool_update; eassumption. -Qed. - -Lemma source_execution_reachable capacity c se k : - valid_source_execution capacity c se -> - ReachableSourcePool capacity c (source_pools se k) (source_states se k). -Proof. - intros (Hp & Hs & Hsteps); induction k as [|k IH]. - - rewrite Hs; now apply source_reachable_initial. - - destruct (Hsteps k) as (residual & Hseg & E). - eapply source_reachable_step; eassumption. -Qed. +(** ** Raw source executions. + A raw source execution is the library [Execution] at state + [pool sE 3 * SSig], valid by [allocator_source_valid]. Its alignment + with the model execution making the same physical selections is the + library's [source_execution_complete] at [allocator_simulation]; its + finite reachability is the library closure [reachable]. *) Lemma source_pool0_branchfree i : BranchFree (source_pool0 1 $ i). Proof. @@ -570,202 +362,105 @@ Proof. cbn [source_pool0 slot_of_actor Vector.nth]; apply denote_branchfree. Qed. -Lemma reachable_source_branchfree capacity c ts sigma : - ReachableSourcePool capacity c ts sigma -> forall i, BranchFree (ts $ i). -Proof. - intro H; induction H as - [ts E|ts sigma i logs residual sigma' ts' Hreach IH Hseg E]; intro j. - - eapply branchfree_equ_impl; [symmetry; apply E|apply source_pool0_branchfree]. - - eapply branchfree_equ_impl; [symmetry; apply E|]. - destruct (Fin.eq_dec j i) as [->|Hne]. - + rewrite Vector.nth_replace_eq; eapply ThreadSegment_branchfree; eauto. - + rewrite Vector.nth_replace_neq by congruence; apply IH. -Qed. - +(** Finite raw-source reachability has no model premise. It is useful before + an infinite schedule is supplied: every physical slot remains selectable. *) Theorem every_reachable_source_slot_yields capacity c ts sigma (i : Fin.t 3) : - ReachableSourcePool capacity c ts sigma -> + reachable (pool_step 2 sh slot_of_actor) + (fun p => pool_equ (fst p) (source_pool0 1) /\ snd p = (page_heap 1 capacity hemp,c)) + (ts,sigma) -> BranchFree (ts $ i) /\ - (exists logs residual sigma', ThreadSegment (ts $ i) sigma logs residual sigma') /\ + (exists logs residual sigma', (ThreadSegment sh csl_sb) (ts $ i) sigma logs residual sigma') /\ not (guard_equ (ts $ i) (Ret tt)) /\ (forall k : bool -> thread sE, ~ guard_equ (ts $ i) (Vis (inr (inl Fork)) k)) /\ (forall n (k : Fin.t (S n) -> thread sE), ~ guard_equ (ts $ i) (Br n k)) /\ not (guard_equ (ts $ i) (stuck : thread sE)) /\ not (guard_equ (ts $ i) (spin : thread sE)). Proof. - intro Hreach; split; [eapply reachable_source_branchfree; exact Hreach|]. - destruct (reachable_source_alignment capacity c ts sigma Hreach) - as (s & Hinv & Hstate & Hpool). + intro Hreach. + assert (Hbf : forall j, BranchFree (ts $ j)). + { refine (reachable_inv (pool_step 2 sh slot_of_actor) _ + (fun p => forall j, BranchFree (fst p $ j)) _ _ (ts,sigma) Hreach). + - intros [ts0 sigma0] [E _] j; cbn [fst] in *. + eapply branchfree_equ_impl; [symmetry; apply E|apply source_pool0_branchfree]. + - intros who [ts1 sigma1] logs [ts2 sigma2] H Hstep; cbn [fst] in *. + exact (pool_step_branchfree 2 sh slot_of_actor who ts1 sigma1 logs ts2 sigma2 + Hstep H). } + split; [apply Hbf|]. + destruct (pool_simulation_reachable 2 sh slot_of_actor (turn 1) (allocator_pool 1) + state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c)) ts sigma Hreach) + as (s & Hinv & Hagree & Hpool). rewrite <- (slot_of_actor_of_slot i). - split; [eapply initialized_worker_next_yield; eassumption|]. - destruct (initialized_worker_no_terminal_prefix 1 capacity ts sigma s - (actor_of_slot i) Hpool Hstate Hinv) as (Hr & Hf & Hb & Hstuck). - destruct (initialized_worker_no_fault_or_divergence 1 capacity ts sigma s - (actor_of_slot i) Hpool Hstate Hinv) as (_ & Hspin & _). - repeat split; assumption. -Qed. - -(** The raw scheduler presents all three physical choices, including idle - polls. Its scheduling Yield is erased, whereas the following Br contributes - a genuine tau transition. Focus is retained through all source effects. *) - -Lemma source_scheduler_choice_inv (ts : pool sE 3) l next : - trans l (Br 2 (fun i => schedule 3 ts (Some i))) next -> - exists who, l = tau /\ next ≅ schedule 3 ts (Some (slot_of_actor who)). -Proof. - intro H; apply trans_br_inv in H as (i & E & ->). - exists (actor_of_slot i); split; [reflexivity|]. - rewrite slot_of_actor_of_slot; exact E. -Qed. - - - - - - - - -Lemma model_turn_finite_steps base who s next event : - turn base who s = Some (next,event) -> - finite_steps (model_nd base s) (turn_labels event) (Guard (model_nd base next)). -Proof. - intro Hturn; destruct event as [o|]; cbn [turn_labels]. - - eapply finite_steps_cons with - (u := Vis (Log o) (fun _ => Guard (model_nd base next))). - + rewrite (unfold_model_nd base s). - eapply trans_br with (x := slot_of_actor who). - rewrite actor_of_slot_of_actor, Hturn; reflexivity. - + econstructor; - [exact (@trans_vis (writerE SObs) _ (unit * SSig) (Log o) tt - (fun _ => Guard (model_nd base next)))|constructor]. - - econstructor; [|constructor]. - rewrite (unfold_model_nd base s). - eapply trans_br with (x := slot_of_actor who). - rewrite actor_of_slot_of_actor, Hturn; reflexivity. -Qed. - -CoInductive realizes (e : AExecution) (k : nat) - (t : ictreeW SObs (unit * SSig)) : Prop := -| realizes_next next : - finite_steps t (turn_labels (emitted e k)) next -> - realizes e (S k) next -> realizes e k t. - -Lemma valid_execution_realizes_model capacity c e : - valid_execution capacity c e -> - forall k t, t ~ model_nd 1 (states e k) -> realizes e k t. -Proof. - intro Hvalid; cofix CIH; intros k t E. - pose proof (model_turn_finite_steps 1 (selected e k) (states e k) - (states e (S k)) (emitted e k) - (execution_step capacity c e k Hvalid)) as Hmodel. - assert (Esym : model_nd 1 (states e k) ~ t) by (symmetry; exact E). - destruct (finite_steps_sbisim _ _ _ Hmodel t Esym) - as (next & Hsteps & Enext). - eapply realizes_next; [exact Hsteps|]. - apply CIH; transitivity (Guard (model_nd 1 (states e (S k)))); - [symmetry; exact Enext|apply sb_guard]. -Qed. - + split. + - destruct (pool_simulation_worker_segment 2 sh slot_of_actor (turn 1) + (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma + Hinv Hagree Hpool) as (event & residual & sigma' & Hseg). + exists (event_obs event), residual, sigma'; exact Hseg. + - destruct (pool_simulation_no_terminal_prefix 2 sh slot_of_actor (turn 1) + (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma + Hinv Hagree Hpool) as (Hr & Hf & Hb & Hstuck). + destruct (pool_simulation_no_fault_or_divergence 2 sh slot_of_actor (turn 1) + (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma + Hinv Hagree Hpool) as (_ & Hspin & _). + repeat split; assumption. +Qed. + +(** Realization is the library coinductive [ICTree.Trace.realizes] at the + allocator's per-turn chunking; the model application is the library's + [valid_execution_realizes_model] at [step := turn 1]. No allocator-local + cofixpoint remains. *) Theorem valid_execution_realizes_source capacity c e : - valid_execution capacity c e -> - realizes e 0 (run_nd (allocator_program capacity) hemp c). + allocator_valid capacity c e -> + realizes (fun j => turn_labels (emitted e j)) 0 + (run_nd (allocator_program capacity) hemp c). Proof. - intro Hvalid; eapply valid_execution_realizes_model; [exact Hvalid|]. + intro Hvalid. + apply (valid_execution_realizes_model 2 actor_of_slot (turn 1) slot_of_actor + actor_of_slot_of_actor (fun s => s = initial_state capacity c) e Hvalid 0). rewrite (proj1 Hvalid); apply run_nd_allocator_bisim. Qed. (** Labels retain their interleaving: exactly one scheduling tau per actual turn, followed by its zero or one source observation. *) -Fixpoint run_turn_labels (base : nat) (script : list Actor) (s : AState) - : option (list (@label (writerE SObs) _)) := - match script with - | [] => Some [] - | who :: rest => - match turn base who s with - | None => None - | Some (next,event) => - match run_turn_labels base rest next with - | None => None - | Some labels => Some (turn_labels event ++ labels) - end - end - end. - -Lemma run_turns_labels base script : forall s last logs, - run_turns base script s = Some (last,logs) -> - exists labels, run_turn_labels base script s = Some labels /\ - label_logs labels = logs /\ label_taus labels = List.length script /\ - exists residual, finite_steps (model_nd base s) labels residual /\ - residual ~ model_nd base last. -Proof. - induction script as [|who rest IH]; intros s last logs Hrun. - - cbn [run_turns] in Hrun; inversion Hrun; subst last logs. - exists []; repeat split; try reflexivity. - exists (model_nd base s); split; [constructor|reflexivity]. - - cbn [run_turns] in Hrun. - destruct (turn base who s) as [[next event]|] eqn:Hturn; [|discriminate]. - destruct (run_turns base rest next) as [[last' logs']|] eqn:Hrest; [|discriminate]. - inversion Hrun; subst last logs; clear Hrun. - destruct (IH next last' logs' Hrest) - as (labels & Hlabels & Hlogs & Htaus & residual & Hsteps & Eresidual). - exists (turn_labels event ++ labels); split. - + cbn [run_turn_labels]; rewrite Hturn, Hlabels; reflexivity. - + split. - * unfold label_logs in *; rewrite List.flat_map_app, Hlogs. - destruct event; reflexivity. - * split. - -- unfold label_taus in *; rewrite List.filter_app, List.length_app, Htaus. - destruct event; reflexivity. - -- assert (Eguard : model_nd base next ~ Guard (model_nd base next)). - { symmetry; apply sb_guard. } - destruct (finite_steps_sbisim _ _ _ Hsteps _ Eguard) - as (residual' & Hsteps' & Eresidual'). - exists residual'; split. - ++ eapply finite_steps_app; [eapply model_turn_finite_steps; exact Hturn|exact Hsteps']. - ++ transitivity residual; [symmetry; exact Eresidual'|exact Eresidual]. -Qed. - Theorem run_turns_realizes_source capacity c script last logs : - run_turns 1 script (initial_state capacity c) = Some (last,logs) -> + run_turns (turn 1) event_obs script (initial_state capacity c) = Some (last,logs) -> exists labels residual, - run_turn_labels 1 script (initial_state capacity c) = Some labels /\ + option_map snd (run_turns (turn 1) turn_labels script (initial_state capacity c)) = + Some labels /\ label_logs labels = logs /\ label_taus labels = List.length script /\ finite_steps (run_nd (allocator_program capacity) hemp c) labels residual /\ - residual ~ model_nd 1 last. -Proof. - intro Hrun; destruct (run_turns_labels 1 script (initial_state capacity c) - last logs Hrun) as (labels & Hlabels & Hlogs & Htaus & model & Hsteps & Emodel). + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Hrun. + destruct (model_run_turns_labels (X := (unit * SSig)%type) + 2 actor_of_slot (turn 1) slot_of_actor actor_of_slot_of_actor + script (initial_state capacity c) last logs Hrun) + as (labels & model & Hlabels & Hlogs & Htaus & Hsteps & Emodel). pose proof (run_nd_allocator_bisim capacity c) as Esource; symmetry in Esource. destruct (finite_steps_sbisim _ _ _ Hsteps _ Esource) as (residual & Hsource & Eresidual). - exists labels, residual; repeat split; try assumption. + exists labels, residual; split; [rewrite Hlabels; reflexivity|]. + repeat split; try assumption. transitivity model; [symmetry; exact Eresidual|exact Emodel]. Qed. - -Theorem valid_source_execution_scheduler_steps capacity c se k : - valid_source_execution capacity c se -> - exists next, - finite_steps (interp_nd 3 (source_pools se k) None (source_states se k)) - (tau :: List.map (fun o => obs (Log o) tt) (source_emitted se k)) next /\ - next ~ interp_nd 3 (source_pools se (S k)) None (source_states se (S k)). -Proof. - intros (_ & _ & Hsteps); destruct (Hsteps k) as (residual & Hseg & Epool). - eapply source_segment_scheduler_steps; eassumption. -Qed. - -Definition source_pending capacity c se k : bool := - pending_turn (execution_of_choices capacity c (source_selected se)) k. - (** A pending raw remote is one of the actual continuations after mailbox pickup, and before remote_free returns through the successful CAS path. This predicate mentions neither a model execution nor future publication. *) Definition raw_remote_pending base client (t : thread sE) : Prop := exists pc, pc <> RPoll /\ guard_equ t (remote_residual base client pc). -Definition selected_source_pending (se : SourceExecution) k : Prop := - match source_selected se k with +Definition selected_source_pending + (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) k : Prop := + match selected se k with | Owner => False - | Remote0 => raw_remote_pending 1 false (source_pools se k $ slot_of_actor Remote0) - | Remote1 => raw_remote_pending 1 true (source_pools se k $ slot_of_actor Remote1) + | Remote0 => raw_remote_pending 1 false (fst (states se k) $ slot_of_actor Remote0) + | Remote1 => raw_remote_pending 1 true (fst (states se k) $ slot_of_actor Remote1) end. Definition remote_first_event base client pc : sE := @@ -825,67 +520,57 @@ Proof. - split; [reflexivity|intros _; exists (RCAS block old); split; [discriminate|exact E]]. Qed. -Theorem source_pending_raw_spec capacity c se k : - valid_source_execution capacity c se -> - (source_pending capacity c se k = true <-> selected_source_pending se k). -Proof. - intro Hvalid; destruct (source_execution_complete capacity c se Hvalid) - as (_ & Haligned & _). - destruct (Haligned k) as [_ Hpool]. - unfold source_pending, pending_turn; rewrite execution_of_choices_selected. - unfold selected_source_pending; destruct (source_selected se k). - - split; [discriminate|contradiction]. - - symmetry; apply raw_remote_pending_alignment. - exact (Hpool (slot_of_actor Remote0)). - - symmetry; apply raw_remote_pending_alignment. - exact (Hpool (slot_of_actor Remote1)). -Qed. -Lemma execution_of_choices_prefix capacity c picks other k : - (forall j, j < k -> picks j = other j) -> - states (execution_of_choices capacity c picks) k = - states (execution_of_choices capacity c other) k. +(** On a valid raw execution the raw pending predicate is exactly the model's + pending-remote predicate at the model execution of the same selections. *) +Lemma selected_source_pending_alignment capacity c se k : + allocator_source_valid capacity c se -> + (selected_source_pending se k <-> + remote_pending (selected se k) + (states (allocator_execution capacity c (selected se)) k) = true). Proof. - induction k as [|k IH]; intro Hprefix; [reflexivity|]. - assert (E : states (execution_of_choices capacity c picks) k = - states (execution_of_choices capacity c other) k). - { apply IH; intros j Hj; apply Hprefix; lia. } - pose proof (execution_step capacity c (execution_of_choices capacity c picks) k - (execution_of_choices_valid capacity c picks)) as Hp. - pose proof (execution_step capacity c (execution_of_choices capacity c other) k - (execution_of_choices_valid capacity c other)) as Hq. - rewrite execution_of_choices_selected in Hp, Hq. - rewrite E, (Hprefix k ltac:(lia)), Hq in Hp; now inversion Hp. + intro Hvalid. + assert (Hmodel : allocator_valid capacity c (allocator_execution capacity c (selected se))) + by apply execution_of_choices_valid. + destruct (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) + state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se (allocator_execution capacity c (selected se)) + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel + (execution_of_choices_selected _ _ _ _ _ _ (selected se)) k) + as (_ & _ & Hpool & _). + unfold selected_source_pending; destruct (selected se k); cbn [remote_pending]. + - split; [contradiction|discriminate]. + - apply raw_remote_pending_alignment; exact (Hpool (slot_of_actor Remote0)). + - apply raw_remote_pending_alignment; exact (Hpool (slot_of_actor Remote1)). Qed. -Lemma source_pending_finite_history capacity c se other k : - (forall j, j <= k -> source_selected se j = source_selected other j) -> - source_pending capacity c se k = source_pending capacity c other k. -Proof. - intro Hprefix; unfold source_pending, pending_turn. - rewrite !execution_of_choices_selected. - rewrite (Hprefix k ltac:(lia)). - rewrite (execution_of_choices_prefix capacity c (source_selected se) - (source_selected other) k ltac:(intros j Hj; apply Hprefix; lia)). - reflexivity. -Qed. - -Definition source_has_event (kind block : nat) (se : SourceExecution) (k : nat) : Prop := - exists idx, List.In (SPop kind block idx) (source_emitted se k). +Definition source_has_event (kind block : nat) + (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) (k : nat) : Prop := + exists idx, List.In (stamp (kind,block) idx) (emitted se k). Theorem source_remote_free_lockfree capacity c se : - valid_source_execution capacity c se -> - infinitely (fun k => source_pending capacity c se k = true) -> + allocator_source_valid capacity c se -> + infinitely (selected_source_pending se) -> infinitely (fun k => exists block, source_has_event tag_retire block se k). Proof. intros Hvalid Hpending. - destruct (source_execution_complete capacity c se Hvalid) - as (Hmodel & Haligned & Hlogs & Hselected). - pose proof (remote_free_lockfree capacity c - (execution_of_choices capacity c (source_selected se)) Hmodel Hpending) as Hlive. + set (e := allocator_execution capacity c (selected se)). + assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. + pose proof (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) + state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel + (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. + assert (Hpend : infinitely (fun k => remote_pending (selected e k) (states e k) = true)). + { intro n; destruct (Hpending n) as (k & Hnk & Hk); exists k; split; [exact Hnk|]. + exact (proj1 (selected_source_pending_alignment capacity c se k Hvalid) Hk). } + pose proof (remote_free_lockfree capacity c e Hmodel Hpend) as Hlive. intro n; destruct (Hlive n) as (k & Hnk & Hevent). apply event_is_spec in Hevent as (block & idx & Hevent). exists k; split; [exact Hnk|]; exists block, idx. + destruct (Halign k) as (_ & _ & _ & Hlogs). rewrite Hlogs, Hevent; cbn [event_obs]; now left. Qed. @@ -898,41 +583,11 @@ Import ListNotations. Local Open Scope nat_scope. Local Open Scope list_scope. -(* The ghost lists are witnesses of the existing invariant, not additional - executable state. They are used only inside propositions. *) -Definition owner_lists (capacity : nat) (s : AState) (L R D : list nat) : Prop := - 0 < 1 /\ backing 1 capacity (aheap s) /\ - exists m0 m1, - aheap s (remote_head 1) = Some (List.hd 0 R) /\ - aheap s (local_head 1) = Some (List.hd 0 L) /\ - aheap s (drain_head 1) = Some (List.hd 0 D) /\ - free_chain (aheap s) L /\ free_chain (aheap s) R /\ free_chain (aheap s) D /\ - aheap s (mailbox 1 false) = Some m0 /\ - aheap s (mailbox 1 true) = Some m1 /\ - Permutation (L ++ R ++ D ++ mailbox_nodes m0 ++ mailbox_nodes m1 ++ - held (remote0_state s) ++ held (remote1_state s)) (page_blocks 1 capacity) /\ - (match owner_state s with ODrain => True | _ => D = [] end) /\ - (match owner_state s with OCAS old => old = 0 \/ In old (page_blocks 1 capacity) - | _ => True end) /\ - cached_remote 1 capacity (aheap s) (remote0_state s) /\ - cached_remote 1 capacity (aheap s) (remote1_state s). - -Lemma owner_lists_inv capacity s L R D : - owner_lists capacity s L R D -> allocator_inv 1 capacity s. -Proof. - intros (Hb & Hback & m0 & m1 & H). - split; [exact Hb|]; split; [exact Hback|]. - exists L, R, D, m0, m1; exact H. -Qed. -Lemma inv_owner_lists capacity s : - allocator_inv 1 capacity s -> exists L R D, owner_lists capacity s L R D. -Proof. - intros (Hb & Hback & L & R & D & m0 & m1 & H). - exists L, R, D; split; [exact Hb|]; split; [exact Hback|]. - exists m0, m1; exact H. -Qed. +(** The ownership view, its existential closure, and the ownership change + of one turn ([turn_view_step]) are owned by [Model.v]; the ghost lists + are witnesses of the existing invariant, used only inside propositions. *) Lemma owner_lists_lengths capacity s L R D : - owner_lists capacity s L R D -> List.length L + List.length R + List.length D <= capacity. + allocator_view 1 capacity s L R D -> List.length L + List.length R + List.length D <= capacity. Proof. intros (_ & _ & m0 & m1 & _ & _ & _ & _ & _ & _ & _ & _ & Hp & _). apply Permutation_length in Hp. @@ -940,10 +595,15 @@ Proof. rewrite page_blocks_length in Hp; lia. Qed. Lemma owner_lists_disjoint capacity s L R D b : - owner_lists capacity s L R D -> In b (R ++ D) -> ~ In b L. + allocator_view 1 capacity s L R D -> In b (R ++ D) -> ~ In b L. Proof. intros (_ & _ & m0 & m1 & _ & _ & _ & _ & _ & _ & _ & _ & Hp & _) Hrd Hl. - pose proof (ai_partition_count 1 capacity _ Hp b) as Hcount. + assert (Hcount : List.count_occ Nat.eq_dec + (L ++ R ++ D ++ mailbox_nodes m0 ++ mailbox_nodes m1 ++ + held (remote0_state s) ++ held (remote1_state s)) b <= 1) + by (apply (proj1 (List.NoDup_count_occ Nat.eq_dec _)); + eapply Permutation_NoDup; + [apply Permutation_sym, Hp | apply page_blocks_nodup]). repeat rewrite List.count_occ_app in Hcount. apply (proj1 (List.count_occ_In Nat.eq_dec L b)) in Hl. rewrite List.in_app_iff in Hrd; destruct Hrd as [Hr|Hd]. @@ -951,8 +611,6 @@ Proof. - apply (proj1 (List.count_occ_In Nat.eq_dec D b)) in Hd; lia. Qed. -Definition owner_after_offer (client : bool) := if client then ORead else OOffer true. -Definition owner_weight (who : Actor) : nat := match who with Owner => 1 | _ => 0 end. Definition owner_boundary (who : Actor) (pc : owner_pc) : bool := match who, pc with Owner, OOffer true => true | _, _ => false end. Definition collection_phase (pc : owner_pc) : bool := @@ -967,161 +625,8 @@ Definition owner_rank (capacity : nat) (pc : owner_pc) (R D : list nat) : nat := | OOffer true => 1 end. Definition owner_round_bound capacity := 3 * capacity + 5. -Definition block_event (tag block : nat) (event : option SObs) : Prop := - exists idx, event = Some (SPop tag block idx). - -(* Every constructor below is a projection of an actual executable turn. - In particular detach uses the current R, and publication prepends to R. *) -Inductive ownership_transition : - Actor -> owner_pc -> owner_pc -> option SObs -> - list nat -> list nat -> list nat -> list nat -> list nat -> list nat -> Prop := -| ownership_read L R : - ownership_transition Owner ORead (OCAS (List.hd 0 R)) None L R [] L R [] -| ownership_cas_fail old L R : - List.hd 0 R <> old -> - ownership_transition Owner (OCAS old) ORead None L R [] L R [] -| ownership_detach L R : - ownership_transition Owner (OCAS (List.hd 0 R)) ODrain None L R [] L [] R -| ownership_drain_empty L R : - ownership_transition Owner ODrain (OOffer false) None L R [] L R [] -| ownership_drain L R b D idx : - ownership_transition Owner ODrain ODrain (Some (SPop tag_reclaim b idx)) - L R (b :: D) (b :: L) R D -| ownership_offer_empty client L R : - ownership_transition Owner (OOffer client) (owner_after_offer client) None - L R [] L R [] -| ownership_offer client L R b idx : - ownership_transition Owner (OOffer client) (owner_after_offer client) - (Some (SPop tag_alloc b idx)) (b :: L) R [] L R [] -| ownership_remote who pc event L R D : - who <> Owner -> - (event = None \/ exists b idx, event = Some (SPop tag_retry b idx)) -> - ownership_transition who pc pc event L R D L R D -| ownership_publish who pc L R D b idx : - who <> Owner -> - ownership_transition who pc pc (Some (SPop tag_retire b idx)) - L R D L (b :: R) D. - -Local Ltac owner_finish T h L R D m0 m1 := - cbn [aheap acount owner_state remote0_state remote1_state] in *; - try rewrite Nat.eqb_refl in T; - repeat match goal with - | E : Nat.eqb _ _ = _ |- _ => progress rewrite E in T - end; - inversion T; subst; clear T; - exists L, R, D; split; - [ unfold owner_lists; - cbn [aheap acount owner_state remote0_state remote1_state]; - split; [assumption|]; split; [ai_backing|]; - exists m0, m1; cbn [List.hd held]; repeat split; ai_obligation h - | cbn [owner_state]; - first [apply ownership_read | apply ownership_detach | - apply ownership_drain_empty | apply ownership_drain | - apply ownership_offer_empty | apply ownership_offer | - apply ownership_cas_fail; now apply Nat.eqb_neq | - apply ownership_publish; discriminate | - apply ownership_remote; [discriminate|left; reflexivity] | - apply ownership_remote; [discriminate|right; do 2 eexists; reflexivity]] ]. - -Lemma owner_lists_step capacity who s t event L R D : - owner_lists capacity s L R D -> turn 1 who s = Some (t,event) -> - exists L' R' D', owner_lists capacity t L' R' D' /\ - ownership_transition who (owner_state s) (owner_state t) event L R D L' R' D'. -Proof. - destruct s as [h count op p0 p1]. - cbn [owner_lists aheap acount owner_state remote0_state remote1_state]. - intros (Hbase & Hback & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & - Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) T. - cbn [aheap acount owner_state remote0_state remote1_state] in *. - destruct who. - - destruct op as [|old| |client]. - + cbn in Hop; subst D. contention_reduce_turn T; rewrite Hr in T. - owner_finish T h L R (@nil nat) m0 m1. - + cbn in Hop; subst D. contention_reduce_turn T; rewrite Hr in T. - destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. - * apply Nat.eqb_eq in Ecas; subst old. - try rewrite Nat.eqb_refl in T. - rewrite upd_neq in T by ai_distinct; rewrite Hd in T. - owner_finish T h L (@nil nat) R m0 m1. - * try rewrite Ecas in T. owner_finish T h L R (@nil nat) m0 m1. - + destruct D as [|b D]. - * contention_reduce_turn T; rewrite Hd in T; cbn [List.hd Nat.eqb] in T. - owner_finish T h L R (@nil nat) m0 m1. - * cbn [free_chain] in CD; destruct CD as [Hnext CD]. - assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). - contention_reduce_turn T; rewrite Hd in T; cbn [List.hd] in T; - rewrite Eb, Hnext, Hl in T. - owner_finish T h (b :: L) R D m0 m1. - + cbn in Hop; subst D; destruct client. - * destruct m1 as [|m1]. - -- destruct L as [|b L ]. - ++ contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T; - rewrite Hl in T; cbn [List.hd Nat.eqb] in T. - owner_finish T h (@nil nat) R (@nil nat) m0 0. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. - assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). - contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T; - rewrite Hl in T; cbn [List.hd] in T; rewrite Eb, Hnext in T. - owner_finish T h L R (@nil nat) m0 b. - -- contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. - owner_finish T h L R (@nil nat) m0 (S m1). - * destruct m0 as [|m0]. - -- destruct L as [|b L ]. - ++ contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T; - rewrite Hl in T; cbn [List.hd Nat.eqb] in T. - owner_finish T h (@nil nat) R (@nil nat) 0 m1. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. - assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). - contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T; - rewrite Hl in T; cbn [List.hd] in T; rewrite Eb, Hnext in T. - owner_finish T h L R (@nil nat) b m1. - -- contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. - owner_finish T h L R (@nil nat) (S m0) m1. - - destruct p0 as [|b|b old|b old]. - + destruct m0 as [|m0]. - * contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. - owner_finish T h L R D 0 m1. - * assert (Hcell : exists v, h (S (S m0)) = Some v). - { eapply ai_backing_present; [exact Hback|ai_interval]. } - destruct Hcell as [v Hv]. - contention_reduce_turn T; rewrite Hm0 in T; cbn [Nat.eqb] in T. - rewrite upd_neq in T by ai_distinct; rewrite Hv in T. - owner_finish T h L R D 0 m1. - + contention_reduce_turn T; rewrite Hr in T. owner_finish T h L R D m0 m1. - + cbn [cached_remote] in Hc0; destruct Hc0 as [Hbound Hneq]. - assert (Hcell : exists v, h b = Some v). - { eapply ai_backing_present; [exact Hback|ai_interval]. } - destruct Hcell as [v Hv]. contention_reduce_turn T; rewrite Hv in T. - owner_finish T h L R D m0 m1. - + cbn [cached_remote] in Hc0; destruct Hc0 as [Hbound [Hneq Hlink]]. - contention_reduce_turn T; rewrite Hr in T. - destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. - * apply Nat.eqb_eq in Ecas; subst old; try rewrite Nat.eqb_refl in T. - owner_finish T h L (b :: R) D m0 m1. - * try rewrite Ecas in T. owner_finish T h L R D m0 m1. - - destruct p1 as [|b|b old|b old]. - + destruct m1 as [|m1]. - * contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. - owner_finish T h L R D m0 0. - * assert (Hcell : exists v, h (S (S m1)) = Some v). - { eapply ai_backing_present; [exact Hback|ai_interval]. } - destruct Hcell as [v Hv]. - contention_reduce_turn T; rewrite Hm1 in T; cbn [Nat.eqb] in T. - rewrite upd_neq in T by ai_distinct; rewrite Hv in T. - owner_finish T h L R D m0 0. - + contention_reduce_turn T; rewrite Hr in T. owner_finish T h L R D m0 m1. - + cbn [cached_remote] in Hc1; destruct Hc1 as [Hbound Hneq]. - assert (Hcell : exists v, h b = Some v). - { eapply ai_backing_present; [exact Hback|ai_interval]. } - destruct Hcell as [v Hv]. contention_reduce_turn T; rewrite Hv in T. - owner_finish T h L R D m0 m1. - + cbn [cached_remote] in Hc1; destruct Hc1 as [Hbound [Hneq Hlink]]. - contention_reduce_turn T; rewrite Hr in T. - destruct (Nat.eqb (List.hd 0 R) old) eqn:Ecas. - * apply Nat.eqb_eq in Ecas; subst old; try rewrite Nat.eqb_refl in T. - owner_finish T h L (b :: R) D m0 m1. - * try rewrite Ecas in T. owner_finish T h L R D m0 m1. -Qed. +Definition block_event (tag block : nat) (event : option (indexed (nat * nat))) : Prop := + exists idx, event = Some (stamp (tag,block) idx). Lemma ownership_rank_step capacity who pc pc' event L R D L' R' D' : ownership_transition who pc pc' event L R D L' R' D' -> @@ -1129,22 +634,22 @@ Lemma ownership_rank_step capacity who pc pc' event L R D L' R' D' : List.length R' <= capacity -> List.length D' <= capacity -> if owner_boundary who pc then owner_rank capacity pc' R' D' <= owner_round_bound capacity - else owner_weight who + owner_rank capacity pc' R' D' <= owner_rank capacity pc R D. + else (if owner_selected who then 1 else 0) + owner_rank capacity pc' R' D' <= owner_rank capacity pc R D. Proof. intros Hstep Hr Hd Hr' Hd'; destruct Hstep; - cbn [owner_boundary owner_weight owner_rank owner_after_offer List.length List.hd] in *. + cbn [owner_boundary owner_selected owner_rank owner_after_offer List.length List.hd] in *. - rewrite Nat.eqb_refl; lia. - assert (E : Nat.eqb (List.hd 0 R) old = false) by now apply Nat.eqb_neq. rewrite E; lia. - rewrite Nat.eqb_refl; lia. - lia. - lia. - - destruct client; cbn [owner_boundary owner_weight owner_rank owner_after_offer]; + - destruct client; cbn [owner_boundary owner_selected owner_rank owner_after_offer]; unfold owner_round_bound; lia. - - destruct client; cbn [owner_boundary owner_weight owner_rank owner_after_offer]; + - destruct client; cbn [owner_boundary owner_selected owner_rank owner_after_offer]; unfold owner_round_bound; lia. - - destruct who; [contradiction| |]; cbn [owner_boundary owner_weight]; lia. - - destruct who; [contradiction| |]; cbn [owner_boundary owner_weight]; + - destruct who; [contradiction| |]; cbn [owner_boundary owner_selected]; lia. + - destruct who; [contradiction| |]; cbn [owner_boundary owner_selected]; destruct pc; cbn [owner_rank List.length List.hd] in *; repeat match goal with | |- context [if ?b then _ else _] => destruct b eqn:? @@ -1155,20 +660,17 @@ Proof. destruct pc as [|old| |client]; cbn [owner_rank]; repeat match goal with |- context [if ?b then _ else _] => destruct b end; lia. Qed. -Lemma owner_weight_count e k : - (if owner_turn e k then 1 else 0) = owner_weight (selected e k). -Proof. unfold owner_turn; destruct (selected e k); reflexivity. Qed. Lemma owner_lists_step_bounded capacity who s t event L R D : - owner_lists capacity s L R D -> + allocator_view 1 capacity s L R D -> owner_rank capacity (owner_state s) R D <= owner_round_bound capacity -> turn 1 who s = Some (t,event) -> - exists L' R' D', owner_lists capacity t L' R' D' /\ + exists L' R' D', allocator_view 1 capacity t L' R' D' /\ owner_rank capacity (owner_state t) R' D' <= owner_round_bound capacity /\ ownership_transition who (owner_state s) (owner_state t) event L R D L' R' D'. Proof. intros Hview Hbound Hturn. - destruct (owner_lists_step capacity who s t event L R D Hview Hturn) + destruct (turn_view_step 1 capacity who s t event L R D Hview Hturn) as (L' & R' & D' & Hview' & Hstep). pose proof (owner_lists_lengths capacity s L R D Hview) as Hlen. pose proof (owner_lists_lengths capacity t L' R' D' Hview') as Hlen'. @@ -1178,58 +680,70 @@ Proof. destruct (owner_boundary who (owner_state s)); lia. Qed. Lemma execution_owner_rank capacity c e k : - valid_execution capacity c e -> exists L R D, - owner_lists capacity (states e k) L R D /\ + allocator_valid capacity c e -> exists L R D, + allocator_view 1 capacity (states e k) L R D /\ owner_rank capacity (owner_state (states e k)) R D <= owner_round_bound capacity. Proof. intro Hv; induction k as [|k IH]. - - destruct (inv_owner_lists capacity (states e 0) (execution_inv capacity c e 0 Hv)) - as (L & R & D & Hview). + - destruct (execution_inv (turn 1) (allocator_inv 1 capacity) + (fun s => s = initial_state capacity c) e (allocator_initial_inv capacity c) + (turn_preserves_inv 1 capacity) 0 Hv) as (L & R & D & Hview). exists L, R, D; split; [exact Hview|]. rewrite (proj1 Hv); cbn [initial_state owner_state owner_rank]. unfold owner_round_bound; lia. - destruct IH as (L & R & D & Hview & Hrank). destruct (owner_lists_step_bounded capacity (selected e k) (states e k) (states e (S k)) (emitted e k) L R D Hview Hrank - (execution_step capacity c e k Hv)) as (L' & R' & D' & Hview' & Hrank' & _). + (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hv)) as (L' & R' & D' & Hview' & Hrank' & _). now exists L', R', D'. Qed. -Definition round_completion (e : AExecution) k := +Definition round_completion (e : (Execution AState Actor (option (indexed (nat * nat))))) k := owner_boundary (selected e k) (owner_state (states e k)) = true. -Lemma owner_round_interval_descent capacity c e lo len L R D : - valid_execution capacity c e -> owner_lists capacity (states e lo) L R D -> +(** The owner round budget is [credit_interval] at the existentially-bounded + ownership view: [Credit k r] says the view holds at [states e k] with + rank [r]. Keeping the witnesses in [Prop] is what lets a heap-related + ghost list serve as the potential. *) +Corollary owner_round_interval_descent capacity c e lo len L R D : + allocator_valid capacity c e -> allocator_view 1 capacity (states e lo) L R D -> (forall j, lo <= j < lo + len -> ~ round_completion e j) -> - exists L' R' D', owner_lists capacity (states e (lo + len)) L' R' D' /\ - count_if (owner_turn e) lo len + + exists L' R' D', allocator_view 1 capacity (states e (lo + len)) L' R' D' /\ + count_if (fun k => owner_selected (selected e k)) lo len + owner_rank capacity (owner_state (states e (lo + len))) R' D' <= owner_rank capacity (owner_state (states e lo)) R D. Proof. - revert lo L R D; induction len as [|len IH]; intros lo L R D Hv Hview Hnone. - - rewrite Nat.add_0_r, count_if_zero; now exists L, R, D. - - destruct (owner_lists_step capacity (selected e lo) (states e lo) - (states e (S lo)) (emitted e lo) L R D Hview - (execution_step capacity c e lo Hv)) as (L1 & R1 & D1 & Hview1 & Hstep). - destruct (IH (S lo) L1 R1 D1 Hv Hview1 ltac:(intros j Hj; apply Hnone; lia)) - as (L' & R' & D' & Hview' & Hrest). - pose proof (owner_lists_lengths capacity _ _ _ _ Hview) as Hlen. - pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen1. - pose proof (ownership_rank_step capacity _ _ _ _ _ _ _ _ _ _ Hstep - ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia)) as Hrank. - assert (Hnb : owner_boundary (selected e lo) (owner_state (states e lo)) = false). - { destruct (owner_boundary (selected e lo) (owner_state (states e lo))) eqn:E; - [exfalso; apply (Hnone lo ltac:(lia)); exact E|reflexivity]. } - rewrite Hnb in Hrank. - replace (lo + S len) with (S lo + len) by lia. - exists L', R', D'; split; [exact Hview'|]. - rewrite count_if_succ, owner_weight_count; lia. + intros Hv Hview Hnone. + destruct (credit_interval + (fun k r => exists L1 R1 D1, allocator_view 1 capacity (states e k) L1 R1 D1 /\ + r = owner_rank capacity (owner_state (states e k)) R1 D1) + (fun k => owner_selected (selected e k)) (round_completion e)) + with (lo := lo) (len := len) + (credit := owner_rank capacity (owner_state (states e lo)) R D) + as (r & (L' & R' & D' & Hview' & Hr) & Hbound). + - intros k r (L1 & R1 & D1 & Hview1 & ->) Hgoal. + destruct (turn_view_step 1 capacity (selected e k) (states e k) + (states e (S k)) (emitted e k) L1 R1 D1 Hview1 + (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hv)) as (L2 & R2 & D2 & Hview2 & Hstep). + exists (owner_rank capacity (owner_state (states e (S k))) R2 D2); split. + + exists L2, R2, D2; split; [exact Hview2 | reflexivity]. + + pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen. + pose proof (owner_lists_lengths capacity _ _ _ _ Hview2) as Hlen2. + pose proof (ownership_rank_step capacity _ _ _ _ _ _ _ _ _ _ Hstep + ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia)) as Hrank. + assert (Hnb : owner_boundary (selected e k) (owner_state (states e k)) = false). + { destruct (owner_boundary (selected e k) (owner_state (states e k))) eqn:E; + [exfalso; apply Hgoal; exact E | reflexivity]. } + rewrite Hnb in Hrank; cbv beta; lia. + - exists L, R, D; split; [exact Hview | reflexivity]. + - exact Hnone. + - exists L', R', D'; split; [exact Hview' |]; rewrite <- Hr; exact Hbound. Qed. Theorem no_round_completion_owner_bound capacity c e lo len : - valid_execution capacity c e -> + allocator_valid capacity c e -> (forall j, lo <= j < lo + len -> ~ round_completion e j) -> - count_if (owner_turn e) lo len < 3 * capacity + 5. + count_if (fun k => owner_selected (selected e k)) lo len < 3 * capacity + 5. Proof. intros Hv Hnone. destruct (execution_owner_rank capacity c e lo Hv) as (L & R & D & Hview & Hbound). @@ -1247,9 +761,9 @@ Proof. Defined. Theorem owner_round_selection_bound capacity c e lo len : - valid_execution capacity c e -> 3 * capacity + 5 <= count_if (owner_turn e) lo len -> + allocator_valid capacity c e -> 3 * capacity + 5 <= count_if (fun k => owner_selected (selected e k)) lo len -> exists j, lo <= j < lo + len /\ round_completion e j /\ - count_if (owner_turn e) lo (S j - lo) <= 3 * capacity + 5. + count_if (fun k => owner_selected (selected e k)) lo (S j - lo) <= 3 * capacity + 5. Proof. intros Hv Hcount. destruct (finite_first (round_completion e) (round_completion_dec e) lo len) @@ -1260,7 +774,7 @@ Proof. ltac:(intros i Hi; apply Hfirst; lia)) as Hbefore. replace (S j-lo) with ((j-lo)+1) by lia. rewrite count_if_add, count_if_succ, count_if_zero. - destruct (owner_turn e (lo + (j-lo))); lia. + cbv beta; destruct (owner_selected (selected e (lo + (j-lo)))); lia. Qed. Inductive reclaim_credit (capacity block : nat) (pc : owner_pc) (R D : list nat) : nat -> Prop := @@ -1317,64 +831,64 @@ Lemma ownership_reclaim_credit_step capacity who pc pc' event L R D L' R' D' blo reclaim_credit capacity block pc R D credit -> ~ block_event tag_reclaim block event -> exists credit', reclaim_credit capacity block pc' R' D' credit' /\ - owner_weight who + credit' <= credit. + (if owner_selected who then 1 else 0) + credit' <= credit. Proof. intros Hstep Hr Hd Hr' Hd' Hcredit Hno. destruct Hstep. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_remote; eassumption|]. - cbn [owner_weight owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. + cbn [owner_selected owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_remote; eassumption|]. assert (E : Nat.eqb (List.hd 0 R) old = false) by now apply Nat.eqb_neq. - cbn [owner_weight owner_rank collection_phase]; rewrite E; lia. + cbn [owner_selected owner_rank collection_phase]; rewrite E; lia. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_detached; eassumption|]. - cbn [owner_weight owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. + cbn [owner_selected owner_rank collection_phase]; rewrite Nat.eqb_refl; lia. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_remote; eassumption|]. - cbn [owner_weight owner_rank collection_phase]; lia. + cbn [owner_selected owner_rank collection_phase]; lia. - inversion Hcredit; subst. + eexists; split; [apply reclaim_remote; eassumption|]. - cbn [owner_weight owner_rank collection_phase List.length]; lia. + cbn [owner_selected owner_rank collection_phase List.length]; lia. + assert (Htail : In block D). { match goal with Hin : In block (_ :: D) |- _ => destruct Hin as [Heq|Hin] end. - subst; exfalso; apply Hno; eexists; reflexivity. - assumption. } eexists; split; [apply reclaim_detached; exact Htail|]. - cbn [owner_weight List.length]; lia. + cbn [owner_selected List.length]; lia. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_remote; eassumption|]. - destruct client; cbn [owner_weight owner_rank collection_phase owner_after_offer]; + destruct client; cbn [owner_selected owner_rank collection_phase owner_after_offer]; unfold owner_round_bound; lia. - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. eexists; split; [apply reclaim_remote; eassumption|]. - destruct client; cbn [owner_weight owner_rank collection_phase owner_after_offer]; + destruct client; cbn [owner_selected owner_rank collection_phase owner_after_offer]; unfold owner_round_bound; lia. - exists credit; split; [exact Hcredit|]. - destruct who; cbn [owner_weight]; [contradiction|lia|lia]. + destruct who; cbn [owner_selected]; [contradiction|lia|lia]. - inversion Hcredit; subst. + eexists; split; [apply reclaim_remote; now right|]. - destruct who; [contradiction| |]; cbn [owner_weight]; + destruct who; [contradiction| |]; cbn [owner_selected]; destruct pc; cbn [owner_rank collection_phase List.length List.hd] in *; repeat match goal with | |- context [if ?b then _ else _] => destruct b eqn:? end; lia. + eexists; split; [apply reclaim_detached; eassumption|]. - destruct who; cbn [owner_weight]; [contradiction|lia|lia]. + destruct who; cbn [owner_selected]; [contradiction|lia|lia]. Qed. Lemma execution_retired_credit capacity c e k block idx : - valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> + allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> exists L R D credit, - owner_lists capacity (states e (S k)) L R D /\ + allocator_view 1 capacity (states e (S k)) L R D /\ reclaim_credit capacity block (owner_state (states e (S k))) R D credit /\ credit <= 2 * owner_round_bound capacity. Proof. intros Hv Hevent. destruct (execution_owner_rank capacity c e k Hv) as (L & R & D & Hview & Hrank). destruct (owner_lists_step_bounded capacity (selected e k) (states e k) - (states e (S k)) (emitted e k) L R D Hview Hrank (execution_step capacity c e k Hv)) + (states e (S k)) (emitted e k) L R D Hview Hrank (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hv)) as (L' & R' & D' & Hview' & Hrank' & Hstep). pose proof (ownership_retire_member _ _ _ _ _ _ _ _ _ _ block Hstep ltac:(exists idx; exact Hevent)) as Hin. @@ -1386,37 +900,45 @@ Proof. pose proof (owner_lists_lengths capacity _ _ _ _ Hview'); lia. Qed. -Lemma reclaim_interval_descent capacity c e lo len L R D block credit : - valid_execution capacity c e -> owner_lists capacity (states e lo) L R D -> +(** Reclamation is the same interval theorem at the reclaim credit; the + one-step obligation is [ownership_reclaim_credit_step]. *) +Corollary reclaim_interval_descent capacity c e lo len L R D block credit : + allocator_valid capacity c e -> allocator_view 1 capacity (states e lo) L R D -> reclaim_credit capacity block (owner_state (states e lo)) R D credit -> (forall j, lo <= j < lo + len -> ~ block_event tag_reclaim block (emitted e j)) -> exists L' R' D' credit', - owner_lists capacity (states e (lo + len)) L' R' D' /\ + allocator_view 1 capacity (states e (lo + len)) L' R' D' /\ reclaim_credit capacity block (owner_state (states e (lo + len))) R' D' credit' /\ - count_if (owner_turn e) lo len + credit' <= credit. -Proof. - revert lo L R D credit; induction len as [|len IH]; - intros lo L R D credit Hv Hview Hcredit Hnone. - - rewrite Nat.add_0_r, count_if_zero; exists L, R, D, credit; auto. - - destruct (owner_lists_step capacity (selected e lo) (states e lo) - (states e (S lo)) (emitted e lo) L R D Hview (execution_step capacity c e lo Hv)) - as (L1 & R1 & D1 & Hview1 & Hstep). - pose proof (owner_lists_lengths capacity _ _ _ _ Hview) as Hlen. - pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen1. - destruct (ownership_reclaim_credit_step capacity _ _ _ _ _ _ _ _ _ _ block credit Hstep - ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia) Hcredit (Hnone lo ltac:(lia))) - as [credit1 [Hcredit1 Hrank]]. - destruct (IH (S lo) L1 R1 D1 credit1 Hv Hview1 Hcredit1 - ltac:(intros j Hj; apply Hnone; lia)) as (L' & R' & D' & credit' & Hview' & Hcredit' & Hrest). - replace (lo + S len) with (S lo + len) by lia. - exists L', R', D', credit'; split; [exact Hview'|]; split; [exact Hcredit'|]. - rewrite count_if_succ, owner_weight_count; lia. + count_if (fun k => owner_selected (selected e k)) lo len + credit' <= credit. +Proof. + intros Hv Hview Hcredit Hnone. + destruct (credit_interval + (fun k r => exists L1 R1 D1, allocator_view 1 capacity (states e k) L1 R1 D1 /\ + reclaim_credit capacity block (owner_state (states e k)) R1 D1 r) + (fun k => owner_selected (selected e k)) (fun j => block_event tag_reclaim block (emitted e j))) + with (lo := lo) (len := len) (credit := credit) + as (r & (L' & R' & D' & Hview' & Hcredit') & Hbound). + - intros k r (L1 & R1 & D1 & Hview1 & Hr) Hgoal. + destruct (turn_view_step 1 capacity (selected e k) (states e k) + (states e (S k)) (emitted e k) L1 R1 D1 Hview1 + (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hv)) as (L2 & R2 & D2 & Hview2 & Hstep). + pose proof (owner_lists_lengths capacity _ _ _ _ Hview1) as Hlen. + pose proof (owner_lists_lengths capacity _ _ _ _ Hview2) as Hlen2. + destruct (ownership_reclaim_credit_step capacity _ _ _ _ _ _ _ _ _ _ block r + Hstep ltac:(lia) ltac:(lia) ltac:(lia) ltac:(lia) Hr Hgoal) + as (r1 & Hcredit1 & Hrank). + exists r1; split. + + exists L2, R2, D2; split; [exact Hview2 | exact Hcredit1]. + + cbv beta; lia. + - exists L, R, D; split; [exact Hview | exact Hcredit]. + - exact Hnone. + - exists L', R', D', r; split; [exact Hview' |]; split; [exact Hcredit' | exact Hbound]. Qed. Definition block_event_dec tag block event : sumbool (block_event tag block event) (not (block_event tag block event)). Proof. - destruct event as [[kind b idx]|]. + destruct event as [[[kind b] idx]|]. - destruct (Nat.eq_dec kind tag) as [->|Hkind]; destruct (Nat.eq_dec b block) as [->|Hb]. + left; exists idx; reflexivity. @@ -1427,9 +949,9 @@ Proof. Defined. Theorem no_reclaim_owner_bound capacity c e k block idx len : - valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> + allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> (forall j, S k <= j < S k + len -> ~ block_event tag_reclaim block (emitted e j)) -> - count_if (owner_turn e) (S k) len < 6 * capacity + 10. + count_if (fun k => owner_selected (selected e k)) (S k) len < 6 * capacity + 10. Proof. intros Hv Hevent Hnone. destruct (execution_retired_credit capacity c e k block idx Hv Hevent) @@ -1441,11 +963,11 @@ Proof. Qed. Theorem retired_reclaimed_owner_selection_bound capacity c e k block idx len : - valid_execution capacity c e -> emitted e k = Some (SPop tag_retire block idx) -> - 6 * capacity + 10 <= count_if (owner_turn e) (S k) len -> + allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> + 6 * capacity + 10 <= count_if (fun k => owner_selected (selected e k)) (S k) len -> exists j idx', k < j /\ j < S k + len /\ idx < idx' /\ - emitted e j = Some (SPop tag_reclaim block idx') /\ - count_if (owner_turn e) (S k) (j-k) <= 6 * capacity + 10. + emitted e j = Some (stamp (tag_reclaim,block) idx') /\ + count_if (fun k => owner_selected (selected e k)) (S k) (j-k) <= 6 * capacity + 10. Proof. intros Hv Hret Hcount. destruct (finite_first (fun j => block_event tag_reclaim block (emitted e j)) @@ -1453,34 +975,35 @@ Proof. as [Hnone|(j & Hj & [idx' Hreclaim] & Hfirst)]. - pose proof (no_reclaim_owner_bound capacity c e k block idx len Hv Hret Hnone); lia. - exists j, idx'; split; [lia|]; split; [lia|]; split. - + exact (execution_event_order capacity c e k j _ _ Hv ltac:(lia) Hret Hreclaim). + + exact (execution_event_order (turn 1) + (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e k j _ _ Hv ltac:(lia) Hret Hreclaim). + split; [exact Hreclaim|]. pose proof (no_reclaim_owner_bound capacity c e k block idx (j-S k) Hv Hret ltac:(intros q Hq; apply Hfirst; lia)) as Hbefore. replace (j-k) with ((j-S k)+1) by lia. rewrite count_if_add, count_if_succ, count_if_zero. - destruct (owner_turn e (S k + (j-S k))); lia. + cbv beta; destruct (owner_selected (selected e (S k + (j-S k)))); lia. Qed. -Lemma infinitely_owner_count e : +Lemma infinitely_owner_count (e : Execution AState Actor (option (indexed (nat * nat)))) : infinitely (fun k => selected e k = Owner) -> - forall lo n, exists len, n <= count_if (owner_turn e) lo len. + forall lo n, exists len, n <= count_if (fun k => owner_selected (selected e k)) lo len. Proof. intros Hinf lo n. apply infinitely_count_if. intro start. destruct (Hinf start) as (k & Hk & Howner). exists k; split; [exact Hk|]. - apply owner_turn_spec; exact Howner. + apply owner_selected_spec; exact Howner. Qed. Theorem retired_eventually_reclaimed capacity c e : - valid_execution capacity c e -> + allocator_valid capacity c e -> infinitely (fun k => selected e k = Owner) -> forall k block idx, - emitted e k = Some (SPop tag_retire block idx) -> + emitted e k = Some (stamp (tag_retire,block) idx) -> exists j idx', k < j /\ idx < idx' /\ - emitted e j = Some (SPop tag_reclaim block idx'). + emitted e j = Some (stamp (tag_reclaim,block) idx'). Proof. intros Hv Howner k block idx Hret. destruct (infinitely_owner_count e Howner (S k) (6*capacity+10)) as [len Hlen]. @@ -1490,10 +1013,10 @@ Proof. Qed. Theorem retired_not_reallocated_before_reclaim capacity c e k block idx j : - valid_execution capacity c e -> - emitted e k = Some (SPop tag_retire block idx) -> k < j -> - (forall q idx', k < q < j -> emitted e q <> Some (SPop tag_reclaim block idx')) -> - forall idx', emitted e j <> Some (SPop tag_alloc block idx'). + allocator_valid capacity c e -> + emitted e k = Some (stamp (tag_retire,block) idx) -> k < j -> + (forall q idx', k < q < j -> emitted e q <> Some (stamp (tag_reclaim,block) idx')) -> + forall idx', emitted e j <> Some (stamp (tag_alloc,block) idx'). Proof. intros Hv Hret Hkj Hnone idx' Halloc. destruct (execution_retired_credit capacity c e k block idx Hv Hret) @@ -1504,19 +1027,19 @@ Proof. replace (S k + (j-S k)) with j in Hviewj, Hcreditj by lia. pose proof (reclaim_credit_member _ _ _ _ _ _ Hcreditj) as Hin. pose proof (owner_lists_disjoint capacity (states e j) Lj Rj Dj block Hviewj Hin) as Hnot. - destruct (owner_lists_step capacity (selected e j) (states e j) - (states e (S j)) (emitted e j) Lj Rj Dj Hviewj (execution_step capacity c e j Hv)) + destruct (turn_view_step 1 capacity (selected e j) (states e j) + (states e (S j)) (emitted e j) Lj Rj Dj Hviewj (execution_step (turn 1) (fun s => s = initial_state capacity c) e j Hv)) as (L' & R' & D' & _ & Hstep). eapply (ownership_no_premature_alloc _ _ _ _ _ _ _ _ _ _ block Hstep Hnot). exists idx'; exact Halloc. Qed. Theorem retired_reallocation_requires_reclaim capacity c e k j block idx alloc_idx : - valid_execution capacity c e -> k < j -> - emitted e k = Some (SPop tag_retire block idx) -> - emitted e j = Some (SPop tag_alloc block alloc_idx) -> + allocator_valid capacity c e -> k < j -> + emitted e k = Some (stamp (tag_retire,block) idx) -> + emitted e j = Some (stamp (tag_alloc,block) alloc_idx) -> exists q reclaim_idx, k < q /\ q < j /\ idx < reclaim_idx /\ - reclaim_idx < alloc_idx /\ emitted e q = Some (SPop tag_reclaim block reclaim_idx). + reclaim_idx < alloc_idx /\ emitted e q = Some (stamp (tag_reclaim,block) reclaim_idx). Proof. intros Hv Hkj Hret Halloc. destruct (finite_first (fun q => block_event tag_reclaim block (emitted e q)) @@ -1526,37 +1049,41 @@ Proof. [exact Hv|exact Hret|exact Hkj| |exact Halloc]. intros q qi Hq Hreclaim; apply (Hnone q ltac:(lia)); now exists qi. - exists q, qi; split; [lia|]; split; [lia|]; split. - + exact (execution_event_order capacity c e k q _ _ Hv ltac:(lia) Hret Hreclaim). + + exact (execution_event_order (turn 1) + (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e k q _ _ Hv ltac:(lia) Hret Hreclaim). + split; [|exact Hreclaim]. - exact (execution_event_order capacity c e q j _ _ Hv ltac:(lia) Hreclaim Halloc). + exact (execution_event_order (turn 1) + (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e q j _ _ Hv ltac:(lia) Hreclaim Halloc). Qed. Theorem source_retired_eventually_reclaimed capacity c se : - valid_source_execution capacity c se -> - infinitely (fun k => source_selected se k = Owner) -> + allocator_source_valid capacity c se -> + infinitely (fun k => selected se k = Owner) -> forall k block idx, - List.In (SPop tag_retire block idx) (source_emitted se k) -> + List.In (stamp (tag_retire,block) idx) (emitted se k) -> exists j idx', k < j /\ idx < idx' /\ - List.In (SPop tag_reclaim block idx') (source_emitted se j). + List.In (stamp (tag_reclaim,block) idx') (emitted se j). Proof. intros Hvalid Howner k block idx Hretire. - destruct (source_execution_complete capacity c se Hvalid) - as (Hmodel & Haligned & Hlogs & Hselected). - set (e := execution_of_choices capacity c (source_selected se)) in *. - assert (Howner' : infinitely (fun j => selected e j = Owner)). + set (e := allocator_execution capacity c (selected se)). + assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. + pose proof (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) + state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e + (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) + (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel + (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. + assert (Howner' : infinitely (fun j => selected e j = Owner)) by exact Howner. + assert (Eretire : emitted e k = Some (stamp (tag_retire,block) idx)). { - intro n; destruct (Howner n) as (j & Hnj & Hwho). - exists j; split; [exact Hnj|now rewrite Hselected]. - } - assert (Eretire : emitted e k = Some (SPop tag_retire block idx)). - { - rewrite Hlogs in Hretire. + destruct (Halign k) as (_ & _ & _ & Hlogs); rewrite Hlogs in Hretire. destruct (emitted e k) as [o|] eqn:E; cbn [event_obs] in Hretire; [destruct Hretire as [<-|[]]; reflexivity|contradiction]. } destruct (retired_eventually_reclaimed capacity c e Hmodel Howner' k block idx Eretire) as (j & idx' & Hkj & Hij & Ereclaim). exists j, idx'; repeat split; try assumption. + destruct (Halign j) as (_ & _ & _ & Hlogs). rewrite Hlogs, Ereclaim; cbn [event_obs]; now left. Qed. @@ -1564,7 +1091,8 @@ From Stdlib Require Import List Lia Arith.PeanoNat. From Coinduction Require Import coinduction rel tactics. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Eq.Bind ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.AX ICTree.Logic.Bind ICTree.Logic.Iter ICTree.Logic.State Logic.Core. + ICTree.Logic.AX ICTree.Logic.Bind ICTree.Logic.Iter ICTree.Logic.State + ICTree.Logic.Trace ICTree.Logic.Yield Logic.Core. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution. @@ -1575,38 +1103,42 @@ Local Open Scope list_scope. Local Open Scope nat_scope. Local Typeclasses Transparent equ sbisim. +(** ** Round-robin recurrence of the two-client demo. + + The prefix of 57 turns and the repeating 42-turn cycle are executable + certificates for [model_rr_emit_batches] / [model_rr_agaf]; the logs, + boundary heap and boundary state are section-local witnesses. *) +Section AllocatorRecurrence. + (** These lists use left numerals so that symbolic counters compute without inspecting the counter. [n+c] is, of course, the prescribed [c+n]. *) -Definition demo_prefix (c : nat) : list SObs := - [SPop tag_alloc 6 c; SPop tag_alloc 8 (1+c); - SPop tag_retire 6 (2+c); SPop tag_retry 8 (3+c); - SPop tag_retire 8 (4+c); SPop tag_reclaim 8 (5+c); - SPop tag_reclaim 6 (6+c); SPop tag_alloc 6 (7+c); - SPop tag_alloc 8 (8+c)]. - -Definition demo_cycle_logs (c : nat) : list SObs := - [SPop tag_retire 6 c; SPop tag_retry 8 (1+c); - SPop tag_retire 8 (2+c); SPop tag_reclaim 8 (3+c); - SPop tag_reclaim 6 (4+c); SPop tag_alloc 6 (5+c); - SPop tag_alloc 8 (6+c)]. - -Definition demo_rr_script (cursor len : nat) : list Actor := - List.map (fun k => actor_of_slot (rr_pick 2 k)) (List.seq cursor len). +Let demo_prefix (c : nat) : list (indexed (nat * nat)) := + [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); + stamp (tag_retire,6) (2+c); stamp (tag_retry,8) (3+c); + stamp (tag_retire,8) (4+c); stamp (tag_reclaim,8) (5+c); + stamp (tag_reclaim,6) (6+c); stamp (tag_alloc,6) (7+c); + stamp (tag_alloc,8) (8+c)]. + +Let demo_cycle_logs (c : nat) : list (indexed (nat * nat)) := + [stamp (tag_retire,6) c; stamp (tag_retry,8) (1+c); + stamp (tag_retire,8) (2+c); stamp (tag_reclaim,8) (3+c); + stamp (tag_reclaim,6) (4+c); stamp (tag_alloc,6) (5+c); + stamp (tag_alloc,8) (6+c)]. (** Only a pointwise representative; no execution ever resets its heap to it. *) -Definition demo_boundary_heap : Heap := fun x => +Let demo_boundary_heap : Heap := fun x => match x with | 1 => Some 0 | 2 => Some 0 | 3 => Some 0 | 4 => Some 0 | 5 => Some 8 | 6 => Some 8 | 7 => Some 1 | 8 => Some 0 | 9 => Some 2 | _ => None end. -Definition demo_boundary (c : nat) : AState := +Let demo_boundary (c : nat) : AState := {| aheap := demo_boundary_heap; acount := c; owner_state := ORead; remote0_state := RRead 6; remote1_state := RPoll |}. -Lemma demo_prefix_run c : exists last, - run_turns 1 (demo_rr_script 0 57) (initial_state 2 c) = +Local Lemma demo_prefix_run c : exists last, + run_turns (turn 1) event_obs (rr_script 2 actor_of_slot 0 57) (initial_state 2 c) = Some (last,demo_prefix c) /\ state_equiv last (demo_boundary (c+9)). Proof. @@ -1619,8 +1151,8 @@ Proof. - vm_compute; repeat split; reflexivity. Qed. -Lemma demo_cycle_run c : exists last, - run_turns 1 (demo_rr_script 0 42) (demo_boundary c) = +Local Lemma demo_cycle_run c : exists last, + run_turns (turn 1) event_obs (rr_script 2 actor_of_slot 0 42) (demo_boundary c) = Some (last,demo_cycle_logs c) /\ state_equiv last (demo_boundary (c+7)). Proof. @@ -1633,245 +1165,140 @@ Proof. - vm_compute; repeat split; reflexivity. Qed. -(** The actual returned heap is passed to the following cycle. *) -Lemma demo_cycle_run_actual c s : - state_equiv s (demo_boundary c) -> - exists last, - run_turns 1 (demo_rr_script 0 42) s = Some (last,demo_cycle_logs c) /\ - state_equiv last (demo_boundary (c+7)). -Proof. - intro Hs; destruct (demo_cycle_run c) as (last & Hrun & Hlast). - destruct (run_turns_respects_heq_some 1 (demo_rr_script 0 42) - (demo_boundary c) s last (demo_cycle_logs c) - (state_equiv_sym _ _ Hs) Hrun) as (actual & Hactual & Heq). - exists actual; split; [exact Hactual|]. - eapply state_equiv_trans; [apply state_equiv_sym; exact Heq|exact Hlast]. -Qed. - -Lemma demo_cycle_cursor cursor : (cursor+42) mod 3 = cursor mod 3. -Proof. - rewrite Nat.Div0.add_mod. - change ((cursor mod 3 + 0) mod 3 = cursor mod 3). - rewrite Nat.add_0_r, Nat.Div0.mod_mod; reflexivity. -Qed. - -Lemma demo_rr_run_turns base len cursor s last logs : - run_turns base (demo_rr_script cursor len) s = Some (last,logs) -> - model_rr base s cursor ~ emit_list logs (model_rr base last (cursor+len)). -Proof. - revert cursor s last logs. - induction len as [|len IH]; intros cursor s last logs Hrun. - - cbn [demo_rr_script List.seq List.map run_turns] in Hrun. - inversion Hrun; subst; rewrite Nat.add_0_r; reflexivity. - - cbn [demo_rr_script List.seq List.map run_turns] in Hrun. - destruct (turn base (actor_of_slot (rr_pick 2 cursor)) s) - as [[next event]|] eqn:Hturn; [|discriminate]. - destruct (run_turns base - (List.map (fun k => actor_of_slot (rr_pick 2 k)) (List.seq (S cursor) len)) next) - as [[last' suffix]|] eqn:Hrest; [|discriminate]. - inversion Hrun; subst last' logs. - replace (cursor+S len) with (S cursor+len) by lia. - rewrite unfold_model_rr, Hturn. - destruct event as [o|]. - + rewrite emit_list_cons; apply sb_vis; intros []. - rewrite sb_guard; eapply IH; exact Hrest. - + rewrite sb_guard; eapply IH; exact Hrest. -Qed. - -Lemma demo_rr_period c : - model_rr 1 (demo_boundary c) 0 ~ - emit_list (demo_cycle_logs c) (model_rr 1 (demo_boundary (c+7)) 0). -Proof. - destruct (demo_cycle_run c) as (last & Hrun & Hlast). - etransitivity; [exact (demo_rr_run_turns 1 42 0 _ _ _ Hrun)|]. - apply emit_list_sbisim, model_rr_respects_heq; [exact Hlast|reflexivity]. -Qed. - -Definition demo_cycle (c : nat) : ictreeW SObs (unit * SSig) := - ICtree.iter (fun n => emit_list (demo_cycle_logs n) - (Ret (@inl nat (unit * SSig) (n+7)))) c. - -Lemma demo_cycle_unfold c : - demo_cycle c ~ emit_list (demo_cycle_logs c) (demo_cycle (c+7)). -Proof. - unfold demo_cycle at 1; rewrite sb_unfold_iter. - rewrite emit_list_ret_bind; reflexivity. -Qed. - -Lemma demo_rr_cycle_bisim : forall c, - model_rr 1 (demo_boundary c) 0 ~ demo_cycle c. -Proof. - unfold sbisim; apply_coinduction; fold_sbisim; intros R IH c. - etransitivity; [apply (coinduction.gfp_bt (sb eq) R), demo_rr_period|]. - etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; - apply demo_cycle_unfold]. - change (coinduction.bt (sb eq) R - (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) - (model_rr 1 (demo_boundary (c+7)) 0)) - (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) - (demo_cycle (c+7)))). - eapply equ_sbt_closed_goal; [apply emit_list_cons|apply emit_list_cons|]. - apply step_sb_vis. - - intros []; exists tt; split; [|reflexivity]. - apply emit_list_st; apply IH. - - intros []; exists tt; split; [|reflexivity]. - apply emit_list_st; apply IH. -Qed. - -Theorem run_rr_allocator_demo_bisim c : - run_rr (allocator_program 2) hemp c ~ - emit_list (demo_prefix c) (demo_cycle (c+9)). -Proof. - rewrite run_rr_allocator_bisim. - destruct (demo_prefix_run c) as (last & Hrun & Hlast). - etransitivity; [exact (demo_rr_run_turns 1 57 0 _ _ _ Hrun)|]. - apply emit_list_sbisim. - etransitivity; [apply (model_rr_respects_heq 1 last (demo_boundary (c+9)) 57 0); - [exact Hlast|reflexivity]|]. - apply demo_rr_cycle_bisim. -Qed. - - - - - - -Lemma demo_cycle_fresh_member c kind : +Local Lemma demo_cycle_fresh_member c kind : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> - exists o, List.In o (demo_cycle_logs c) /\ stag o = kind /\ c <= sidx o. + exists o, List.In o (demo_cycle_logs c) /\ (fst (indexed_value o)) = kind /\ c <= indexed_index o. Proof. intros [<-|[<-|[<-|[]]]]. - - exists (SPop tag_alloc 6 (5+c)); cbn [demo_cycle_logs List.In stag sidx]; + - exists (stamp (tag_alloc,6) (5+c)); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; repeat split; intuition lia. - - exists (SPop tag_retire 6 c); cbn [demo_cycle_logs List.In stag sidx]; + - exists (stamp (tag_retire,6) c); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; repeat split; intuition lia. - - exists (SPop tag_reclaim 8 (3+c)); cbn [demo_cycle_logs List.In stag sidx]; + - exists (stamp (tag_reclaim,8) (3+c)); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; repeat split; intuition lia. Qed. -Lemma demo_cycle_af c kind kb w : - List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> - <( {demo_cycle c}, w |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. -Proof. - intros Hkind Hd; unfold demo_cycle. - eapply aul_iter_nat with (Ri := fun (_ : nat) (_ : WorldW SObs) => True) - (f := fun n (_ : WorldW SObs) => kb-n). - - exact Hd. - - exact I. - - intros n v Hv _; destruct (Nat.le_gt_cases kb n) as [Hle|Hlt]. - + left; destruct (demo_cycle_fresh_member n kind Hkind) as (o & Hin & Htag & Hidx). - eapply af_emit_list_member; [exact Hv|exact Hin|]. - split; [exact Htag|lia]. - + right; apply af_emit_list_ret; [exact Hv|]. - exists (n+7); split; [reflexivity|]. - split; [apply after_logs_not_done; exact Hv|]. - split; [exact I|lia]. -Qed. - -(** A proof-only presentation which exposes a single observation per body. - [ag_iter] requires its invariant at *finite-body* residuals. Splitting the - body at logs allows their eventuality proof to use the next complete cycle, - instead of incorrectly asking the finite seven-log body to publish again. *) -Definition demo_log_body (p : list SObs * nat) - : ictreeW SObs ((list SObs * nat) + (unit * SSig)) := - let '(xs,c) := p in - match xs with - | [] => log (SPop tag_retire 6 c);; - Ret (inl (List.tl (demo_cycle_logs c),c+7)) - | o :: rest => log o;; Ret (inl (rest,c)) - end. -Definition demo_log_loop (xs : list SObs) (c : nat) - : ictreeW SObs (unit * SSig) := ICtree.iter demo_log_body (xs,c). - -Lemma demo_log_loop_unfold xs c : - demo_log_loop xs c ~ - match xs with - | [] => log (SPop tag_retire 6 c);; - demo_log_loop (List.tl (demo_cycle_logs c)) (c+7) - | o :: rest => log o;; demo_log_loop rest c - end. -Proof. - unfold demo_log_loop at 1; rewrite sb_unfold_iter. - unfold demo_log_body; destruct xs as [|o rest]; cbn beta iota zeta. - all: rewrite bind_bind; apply sbisim_clo_bind_eq; [reflexivity|]. - all: intros []; rewrite bind_ret_l; reflexivity. -Qed. - -Lemma demo_log_loop_bisim : forall xs c, - demo_log_loop xs c ~ emit_list xs (demo_cycle c). -Proof. - unfold sbisim; apply_coinduction; fold_sbisim; intros R IH xs c. - etransitivity; [apply (coinduction.gfp_bt (sb eq) R), demo_log_loop_unfold|]. - destruct xs as [|o rest]. - - cbn [emit_list List.fold_right]. - etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; - apply demo_cycle_unfold]. - change (coinduction.bt (sb eq) R - (log (SPop tag_retire 6 c);; - demo_log_loop (List.tl (demo_cycle_logs c)) (c+7)) - (emit_list (SPop tag_retire 6 c :: List.tl (demo_cycle_logs c)) - (demo_cycle (c+7)))). - eapply equ_sbt_closed_goal; - [apply (emit_list_cons (SPop tag_retire 6 c) [] _)|apply emit_list_cons|]. - apply step_sb_vis. - + intros []; exists tt; split; [apply IH|reflexivity]. - + intros []; exists tt; split; [apply IH|reflexivity]. - - eapply equ_sbt_closed_goal; - [apply (emit_list_cons o [] _)|apply emit_list_cons|]. - apply step_sb_vis. - + intros []; exists tt; split; [apply IH|reflexivity]. - + intros []; exists tt; split; [apply IH|reflexivity]. -Qed. - -Lemma demo_log_loop_af xs c kind kb w : - List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> - <( {demo_log_loop xs c}, w |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. -Proof. - intros Hkind Hd; rewrite demo_log_loop_bisim. - apply af_emit_list; [exact Hd|]. - apply demo_cycle_af; [exact Hkind|]. - apply after_logs_not_done; exact Hd. -Qed. - -Lemma demo_log_loop_agaf xs c kind kb w : - List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> - <( {demo_log_loop xs c}, w |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. -Proof. - intros Hkind Hd; unfold demo_log_loop. - eapply ag_iter with (R := fun (_ : list SObs * nat) v => not_done v). - - exact Hd. - - intros [ys n] v Hv; split. - + change <( {demo_log_loop ys n}, v - |= AF visW {fun o => stag o = kind /\ kb <= sidx o} )>. - apply demo_log_loop_af; assumption. - + unfold demo_log_body; cbn beta iota zeta. - destruct ys as [|o rest]. - * apply axr_log; [exact Hv|]. - cleft; apply axr_ret; [constructor|]. - exists (List.tl (demo_cycle_logs n),n+7); split; [reflexivity|constructor]. - * apply axr_log; [exact Hv|]. - cleft; apply axr_ret; [constructor|]. - exists (rest,n); split; [reflexivity|constructor]. -Qed. +Local Lemma demo_cycle_logs_nonempty : forall n : nat, True -> demo_cycle_logs n <> []. +Proof. intros n _; unfold demo_cycle_logs; discriminate. Qed. -Lemma demo_cycle_agaf c kind kb w : - List.In kind [tag_alloc;tag_retire;tag_reclaim] -> not_done w -> - <( {demo_cycle c}, w |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. +(** The actual source is the 57-turn prefix followed by the repeating cycle, + each cycle a genuine 42-turn round-robin run from the actual state. *) +Theorem run_rr_allocator_demo_bisim c : + run_rr (allocator_program 2) hemp c ~ + emit_list (demo_prefix c) + (emit_batches demo_cycle_logs (fun n => n+7) (c+9) + : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. - intros Hkind Hd. - change <( {emit_list [] (demo_cycle c)}, w - |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. - rewrite <- (demo_log_loop_bisim [] c). - apply demo_log_loop_agaf; assumption. + rewrite run_rr_allocator_bisim. + destruct (demo_prefix_run c) as (last & Hrun & Hlast). + etransitivity; + [exact (model_rr_run_turns 2 actor_of_slot (turn 1) 57 0 _ _ _ Hrun)|]. + apply emit_list_sbisim. + etransitivity; [apply equ_sbisim; exact (model_rr_equ 2 actor_of_slot (turn 1) + state_equiv (turn_proper 1) last (demo_boundary (c+9)) (0+57) 0 Hlast eq_refl)|]. + exact (model_rr_emit_batches 2 actor_of_slot (turn 1) state_equiv (turn_proper 1) + demo_boundary demo_cycle_logs (fun n => n+7) (fun _ => True) 0 42 eq_refl + (fun _ _ => I) demo_cycle_logs_nonempty (fun n _ => demo_cycle_run n) (c+9) I). Qed. +(** Recurrence is [model_rr_agaf] at [rank := fun c => kb - c] and + [P o := fst (indexed_value o) = kind /\ kb <= indexed_index o]. The + concrete tag premise is retained: the generic rule accepts arbitrary + predicates, but this proof must not claim recurrence of arbitrary tags. *) Theorem allocator_demo_agaf_fresh c kind kb : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> <( {run_rr (allocator_program 2) hemp c}, Pure - |= AG (AF visW {fun o => stag o = kind /\ kb <= sidx o}) )>. -Proof. - intro Hkind; rewrite run_rr_allocator_demo_bisim. + |= AG (AF visW {fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o}) )>. +Proof. + intro Hkind. + assert (Hprogress : forall n : nat, True -> + (exists o, List.In o (demo_cycle_logs n) /\ + ((fst (indexed_value o)) = kind /\ kb <= indexed_index o)) + \/ kb - (n+7) < kb - n). + { intros n _; destruct (Nat.le_gt_cases kb n) as [Hle|Hlt]. + - left; destruct (demo_cycle_fresh_member n kind Hkind) as (o & Hin & Htag & Hidx). + exists o; split; [exact Hin |]; split; [exact Htag | lia]. + - right; lia. } + rewrite run_rr_allocator_bisim. + destruct (demo_prefix_run c) as (last & Hrun & Hlast). + rewrite (model_rr_run_turns 2 actor_of_slot (turn 1) 57 0 _ _ _ Hrun). apply agaf_emit_list; [constructor|]. - apply demo_cycle_agaf; [exact Hkind|]. + rewrite (model_rr_equ 2 actor_of_slot (turn 1) state_equiv (turn_proper 1) + last (demo_boundary (c+9)) (0+57) 0 Hlast eq_refl). + apply (model_rr_agaf 2 actor_of_slot (turn 1) state_equiv (turn_proper 1) + demo_boundary demo_cycle_logs (fun n => n+7) (fun _ => True) 0 42 eq_refl + (fun _ _ => I) demo_cycle_logs_nonempty (fun n _ => demo_cycle_run n) + (fun n => kb - n) (fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o) + Hprogress (c+9)); [exact I|]. apply after_logs_not_done; constructor. Qed. + +End AllocatorRecurrence. + +(** ** ABA robustness. + + Remote 1 snapshots head 6 and prepares to publish block 8 with link 6; + before its CAS commits, block 6 is reclaimed, reallocated and retired + again, so the head is once more 6. The stale snapshot still matches, and + the successful CAS loses nothing: the remote list is exactly [8;6]. *) +Section ABASafety. + +Let aba_before_reuse := + List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 3. +Let aba_before_commit := + aba_before_reuse ++ List.repeat Owner 6 ++ List.repeat Remote0 4. +Let aba_script := aba_before_commit ++ [Remote1]. +Let aba_logs : list (indexed (nat * nat)) := + [stamp (0,6) 0; stamp (0,8) 1; stamp (1,6) 2; stamp (2,6) 3; + stamp (0,6) 4; stamp (1,6) 5; stamp (1,8) 6]. + +Theorem aba_snapshot_survives_reuse : + option_map (fun result => (owner_state (fst result), remote0_state (fst result), + remote1_state (fst result))) + (run_turns (turn 1) event_obs aba_before_reuse (initial_state 2 0)) = + Some (ORead,RPoll,RCAS 8 6) /\ + option_map (fun result => (owner_state (fst result), remote0_state (fst result), + remote1_state (fst result))) + (run_turns (turn 1) event_obs aba_before_commit (initial_state 2 0)) = + Some (ORead,RPoll,RCAS 8 6) /\ + option_map (fun result => [aheap (fst result) 1]) + (run_turns (turn 1) event_obs aba_before_reuse (initial_state 2 0)) = Some [Some 6] /\ + option_map (fun result => [aheap (fst result) 1]) + (run_turns (turn 1) event_obs aba_before_commit (initial_state 2 0)) = Some [Some 6]. +Proof. vm_compute; repeat split; reflexivity. Qed. + +Lemma aba_run_no_loss : exists last, + run_turns (turn 1) event_obs aba_script (initial_state 2 0) = Some (last,aba_logs) /\ + allocator_inv 1 2 last /\ + aheap last (remote_head 1) = Some 8 /\ linked (fun a next => aheap last a = Some next) [8;6] 0 /\ + NoDup [8;6] /\ Permutation [8;6] (page_blocks 1 2). +Proof. + assert (Hrun : exists last, + run_turns (turn 1) event_obs aba_script (initial_state 2 0) = Some (last,aba_logs)). + { eexists; vm_compute; reflexivity. } + destruct Hrun as [last Hrun]; exists last; split; [exact Hrun|]; split. + - exact (run_turns_preserves_inv (turn 1) event_obs + (allocator_inv 1 2) (turn_preserves_inv 1 2) aba_script (initial_state 2 0) + last aba_logs (initial_state_inv 2 0) Hrun). + - vm_compute in Hrun; inversion Hrun; subst last. + split; [reflexivity|]; split; [repeat split; reflexivity|]; split. + + repeat constructor; cbn; intuition congruence. + + change (Permutation [8;6] [6;8]); apply perm_swap. +Qed. + +Theorem aba_actual_source_no_loss : exists last labels residual, + run_turns (turn 1) event_obs aba_script (initial_state 2 0) = Some (last,aba_logs) /\ + allocator_inv 1 2 last /\ + aheap last (remote_head 1) = Some 8 /\ linked (fun a next => aheap last a = Some next) [8;6] 0 /\ + label_logs labels = aba_logs /\ label_taus labels = 23 /\ + finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + destruct aba_run_no_loss as (last & Hrun & Hinv & Hhead & Hchain & Hnd & Hp). + destruct (run_turns_realizes_source 2 0 aba_script last aba_logs Hrun) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). + exists last, labels, residual; repeat first [assumption | split]. +Qed. + +End ABASafety. diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v index 8e4e023..e34e493 100644 --- a/examples/CSL/Allocator/Model.v +++ b/examples/CSL/Allocator/Model.v @@ -1,4 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Sorting.Permutation. +From TICL Require Import Utils.Execution. +From TICL Require Import ICTree.Interp.Yield.Execution. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.Refine. From TICL Require Import Lang.CSL.Queue.Representation. @@ -23,14 +25,14 @@ Record AState := { (** One selected source segment, ending at its first yield. The helpers below only assemble this example's result; missing checked cells fault. *) Definition turn (base : nat) (who : Actor) (s : AState) - : option (AState * option SObs) := + : option (AState * option (indexed (nat * nat))) := let finish (h : Heap) (op : owner_pc) (r0 r1 : remote_pc) (event : option (nat * nat)) := Some ({| aheap := h; acount := match event with None => acount s | Some _ => S (acount s) end; owner_state := op; remote0_state := r0; remote1_state := r1 |}, match event with None => None - | Some (tag,block) => Some (SPop tag block (acount s)) end) in + | Some (tag,block) => Some (stamp (tag,block) (acount s)) end) in let own pc h event := finish h pc (remote0_state s) (remote1_state s) event in let remote (client : bool) := let pc := if client then remote1_state s else remote0_state s in @@ -137,12 +139,6 @@ Definition initial_state (capacity c : nat) : AState := {| aheap := page_heap 1 capacity hemp; acount := c; owner_state := ORead; remote0_state := RPoll; remote1_state := RPoll |}. -Fixpoint free_chain (h : Heap) (nodes : list nat) : Prop := - match nodes with - | [] => True - | block :: rest => h block = Some (hd 0 rest) /\ free_chain h rest - end. - Definition held (pc : remote_pc) : list nat := match pc with RPoll => [] | RRead block | RLink block _ | RCAS block _ => [block] end. Definition mailbox_nodes (block : nat) : list nat := @@ -159,13 +155,21 @@ Definition cached_remote (base capacity : nat) (h : Heap) (pc : remote_pc) : Pro Definition backing (base capacity : nat) (h : Heap) : Prop := forall x, h x <> None <-> base <= x /\ x < base + page_size capacity. -Definition allocator_inv (base capacity : nat) (s : AState) : Prop := +(** The ownership VIEW: the invariant body with its ghost lists exposed. + [allocator_inv] is exactly its existential closure -- a regrouping of the + existing invariant, not a stronger ownership premise. The ghost lists + are proposition-level witnesses; nothing is added to [AState] or + extracted into executable state. *) +Definition allocator_view (base capacity : nat) (s : AState) (L R D : list nat) + : Prop := 0 < base /\ backing base capacity (aheap s) /\ - exists (L R D : list nat) (m0 m1 : nat), + exists (m0 m1 : nat), aheap s (remote_head base) = Some (hd 0 R) /\ aheap s (local_head base) = Some (hd 0 L) /\ aheap s (drain_head base) = Some (hd 0 D) /\ - free_chain (aheap s) L /\ free_chain (aheap s) R /\ free_chain (aheap s) D /\ + linked (fun a next => aheap s a = Some next) L 0 /\ + linked (fun a next => aheap s a = Some next) R 0 /\ + linked (fun a next => aheap s a = Some next) D 0 /\ aheap s (mailbox base false) = Some m0 /\ aheap s (mailbox base true) = Some m1 /\ Permutation (L ++ R ++ D ++ mailbox_nodes m0 ++ mailbox_nodes m1 ++ @@ -177,50 +181,28 @@ Definition allocator_inv (base capacity : nat) (s : AState) : Prop := cached_remote base capacity (aheap s) (remote0_state s) /\ cached_remote base capacity (aheap s) (remote1_state s). +Definition allocator_inv (base capacity : nat) (s : AState) : Prop := + exists L R D, allocator_view base capacity s L R D. + Definition state_equiv (s t : AState) : Prop := heq (aheap s) (aheap t) /\ acount s = acount t /\ owner_state s = owner_state t /\ remote0_state s = remote0_state t /\ remote1_state s = remote1_state t. -Fixpoint run_turns (base : nat) (script : list Actor) (s : AState) - : option (AState * list SObs) := - match script with - | [] => Some (s,[]) - | who :: rest => - match turn base who s with - | None => None - | Some (next,event) => - match run_turns base rest next with - | None => None - | Some (last,logs) => - Some (last,match event with None => logs | Some o => o :: logs end) - end - end - end. - -Lemma init_chain_links h nodes : - (forall prefix block rest, nodes = prefix ++ block :: rest -> - h block = Some (hd 0 rest)) -> free_chain h nodes. -Proof. - induction nodes as [|block rest IH]; intro Links; [exact I|]. - split. - - exact (Links [] block rest eq_refl). - - apply IH; intros prefix next tail E. - apply (Links (block :: prefix) next tail); cbn; now rewrite E. -Qed. - Lemma initial_state_inv capacity c : allocator_inv 1 capacity (initial_state capacity c). Proof. - unfold allocator_inv, initial_state; cbn [aheap owner_state remote0_state remote1_state]. + unfold allocator_inv, allocator_view, initial_state; + cbn [aheap owner_state remote0_state remote1_state]. + exists (page_blocks 1 capacity), [], []. split; [lia|]; split. - intro x; apply page_heap_closed_dom. - - exists (page_blocks 1 capacity), [], [], 0, 0. + - exists 0, 0. split; [apply page_heap_remote|]. split; [apply page_heap_local_blocks|]. split; [apply page_heap_drain|]. split. - + apply init_chain_links; intros prefix block rest E. + + apply linked_of_splits; intros prefix block rest E. eapply page_heap_link; exact E. + split; [exact I|]; split; [exact I|]. split; [apply page_heap_mailbox|]. @@ -234,7 +216,7 @@ Lemma turn_counter base who s t event : turn base who s = Some (t,event) -> match event with | None => acount t = acount s - | Some o => acount t = S (acount s) /\ sidx o = acount s + | Some o => acount t = S (acount s) /\ indexed_index o = acount s end. Proof. destruct s as [h c op r0 r1]; destruct who; @@ -248,7 +230,8 @@ Proof. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Fin - Classes.RelationClasses Program.Equality. + Classes.RelationClasses Classes.RelationPairs Program.Equality. +From ExtLib Require Import Data.Option. From Coinduction Require Import coinduction rel tactics. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.Refine. @@ -288,17 +271,12 @@ Qed. (** Both faults and successful turns are preserved. In particular this statement does not assume the ownership invariant or heap finiteness. *) -Lemma turn_respects_heq base who s t : - state_equiv s t -> - match turn base who s, turn base who t with - | None, None => True - | Some (s',event), Some (t',event') => - state_equiv s' t' /\ event = event' - | _, _ => False - end. +#[global] Instance turn_proper base : + Proper (eq ==> state_equiv ==> Roption (RelProd state_equiv eq)) (turn base). Proof. + intros who who' <- s t Hst. destruct s as [h c op r0 r1], t as [k d oq q0 q1]. - intros [Hh [Hc [Ho [H0 H1]]]]. + destruct Hst as [Hh [Hc [Ho [H0 H1]]]]. cbn in Hh, Hc, Ho, H0, H1. subst d oq q0 q1. destruct who; [destruct op | destruct r0 | destruct r1]; @@ -313,8 +291,8 @@ Proof. | |- context [if ?b then _ else _] => let Hb := fresh "Htest" in destruct b eqn:Hb end ]. - all: try exact I. - all: split; [|reflexivity]. + all: constructor. + all: split; unfold RelCompFun; cbn [fst snd]; [|reflexivity]. all: unfold state_equiv; cbn [aheap acount owner_state remote0_state remote1_state]. all: split; @@ -322,29 +300,6 @@ Proof. | repeat split; reflexivity ]. Qed. -Corollary turn_respects_heq_some base who s t s' event : - state_equiv s t -> turn base who s = Some (s',event) -> - exists t', turn base who t = Some (t',event) /\ state_equiv s' t'. -Proof. - intros Hst Hstep. - pose proof (turn_respects_heq base who s t Hst) as H. - rewrite Hstep in H. - destruct (turn base who t) as [[t' event']|] eqn:Ht; - cbn in H; [|contradiction]. - destruct H as [Hnext Hevent]; subst event'. - exists t'; split; [assumption || reflexivity | exact Hnext]. -Qed. - -Corollary turn_respects_heq_none base who s t : - state_equiv s t -> (turn base who s = None <-> turn base who t = None). -Proof. - intro Hst; pose proof (turn_respects_heq base who s t Hst) as H. - destruct (turn base who s) as [[s' event]|]; - destruct (turn base who t) as [[t' event']|]; - cbn in H; try contradiction; split; intro Hnone; - try discriminate; reflexivity. -Qed. - (** Physical source-pool order is [client1; client0; owner]. *) Definition actor_of_slot (i : Fin.t 3) : Actor := match i with @@ -378,244 +333,13 @@ Proof. * intro impossible; inversion impossible. Qed. -(** Every nondeterministic turn begins with exactly one real branch node. - The post-effect guards are invisible, not additional scheduling choices. *) -CoFixpoint model_nd (base : nat) (s : AState) - : ictreeW SObs (unit * SSig) := - Br 2 (fun i => - match turn base (actor_of_slot i) s with - | None => stuck - | Some (next,None) => Guard (model_nd base next) - | Some (next,Some event) => - Vis (Log event) (fun _ => Guard (model_nd base next)) - end). - -CoFixpoint model_rr (base : nat) (s : AState) (cursor : nat) - : ictreeW SObs (unit * SSig) := - match turn base (actor_of_slot (rr_pick 2 cursor)) s with - | None => stuck - | Some (next,None) => Guard (model_rr base next (S cursor)) - | Some (next,Some event) => - Vis (Log event) (fun _ => Guard (model_rr base next (S cursor))) - end. - -Lemma unfold_model_nd base s : - model_nd base s ≅ - Br 2 (fun i => - match turn base (actor_of_slot i) s with - | None => stuck - | Some (next,None) => Guard (model_nd base next) - | Some (next,Some event) => - Vis (Log event) (fun _ => Guard (model_nd base next)) - end). -Proof. step; now cbn. Qed. - -Lemma unfold_model_rr base s cursor : - model_rr base s cursor ≅ - match turn base (actor_of_slot (rr_pick 2 cursor)) s with - | None => stuck - | Some (next,None) => Guard (model_rr base next (S cursor)) - | Some (next,Some event) => - Vis (Log event) (fun _ => Guard (model_rr base next (S cursor))) - end. -Proof. step; now cbn. Qed. - -Lemma model_nd_respects_heq_equ base : forall s t, - state_equiv s t -> model_nd base s ≅ model_nd base t. +Lemma turn_event_counter base who s s' event : + turn base who s = Some (s',event) -> + acount s' = (acount s + List.length (event_obs event))%nat. Proof. - coinduction R IH; intros s t Hst. - rewrite !unfold_model_nd. - constructor; intro i. - pose proof (turn_respects_heq base (actor_of_slot i) s t Hst) as Hturn. - destruct (turn base (actor_of_slot i) s) as [[s' event]|]; - destruct (turn base (actor_of_slot i) t) as [[t' event']|]; - cbn in Hturn; try contradiction. - - destruct Hturn as [Hnext Hevent]; subst event'. - destruct event as [o|]. - + step; cbn; constructor; intros []. - step; cbn; constructor; apply IH; exact Hnext. - + step; cbn; constructor; apply IH; exact Hnext. - - reflexivity. -Qed. - -Lemma model_nd_respects_heq base s t : - state_equiv s t -> model_nd base s ~ model_nd base t. -Proof. - intro Hst. - eapply equ_clos_sbisim_goal; - [apply model_nd_respects_heq_equ; exact Hst | reflexivity | reflexivity]. -Qed. - -(** The proof compares finite indices through their numeric values, never - through equality of proof fields in [Fin.of_nat_lt]. *) -Local Lemma trees_rr_pick_three_congr cursor cursor' : - cursor mod 3 = cursor' mod 3 -> rr_pick 2 cursor = rr_pick 2 cursor'. -Proof. - intro Hmod; apply Fin.to_nat_inj; unfold rr_pick. - rewrite !Fin.to_nat_of_nat; exact Hmod. -Qed. - -Local Lemma trees_succ_mod_three cursor cursor' : - cursor mod 3 = cursor' mod 3 -> S cursor mod 3 = S cursor' mod 3. -Proof. - intro Hmod. - replace (S cursor) with (cursor + 1)%nat by lia. - replace (S cursor') with (cursor' + 1)%nat by lia. - rewrite (Nat.Div0.add_mod cursor 1 3), (Nat.Div0.add_mod cursor' 1 3). - now rewrite Hmod. -Qed. - -Lemma model_rr_respects_heq_equ base : forall s t cursor cursor', - state_equiv s t -> cursor mod 3 = cursor' mod 3 -> - model_rr base s cursor ≅ model_rr base t cursor'. -Proof. - coinduction R IH; intros s t cursor cursor' Hst Hmod. - rewrite !unfold_model_rr. - rewrite <- (trees_rr_pick_three_congr cursor cursor' Hmod). - pose proof (turn_respects_heq base - (actor_of_slot (rr_pick 2 cursor)) s t Hst) as Hturn. - destruct (turn base (actor_of_slot (rr_pick 2 cursor)) s) - as [[s' event]|]; - destruct (turn base (actor_of_slot (rr_pick 2 cursor)) t) - as [[t' event']|]; - cbn in Hturn; try contradiction. - - destruct Hturn as [Hnext Hevent]; subst event'. - destruct event as [o|]; cbn. - + constructor; intros []. - step; cbn; constructor; apply IH; - [exact Hnext | now apply trees_succ_mod_three]. - + constructor; apply IH; - [exact Hnext | now apply trees_succ_mod_three]. - - reflexivity. -Qed. - -Lemma model_rr_respects_heq base s t cursor cursor' : - state_equiv s t -> cursor mod 3 = cursor' mod 3 -> - model_rr base s cursor ~ model_rr base t cursor'. -Proof. - intros Hst Hmod. - eapply equ_clos_sbisim_goal; - [exact (model_rr_respects_heq_equ base s t cursor cursor' Hst Hmod) - | reflexivity | reflexivity]. -Qed. - -(** The finite fold uses the actual result of each turn; faults propagate. *) -Lemma run_turns_append base left right s : - run_turns base (left ++ right) s = - match run_turns base left s with - | None => None - | Some (middle,first) => - match run_turns base right middle with - | None => None - | Some (last,second) => Some (last,first ++ second) - end - end. -Proof. - revert s; induction left as [|who left IH]; intro s. - - cbn [run_turns app]. - destruct (run_turns base right s) as [[last logs]|]; reflexivity. - - cbn [run_turns app]. - destruct (turn base who s) as [[next event]|]; [|reflexivity]. - rewrite IH. - destruct (run_turns base left next) as [[middle first]|]; [|reflexivity]. - destruct (run_turns base right middle) as [[last second]|]; [|reflexivity]. - destruct event; reflexivity. -Qed. - -Corollary run_turns_compose base left right s middle last first second : - run_turns base left s = Some (middle,first) -> - run_turns base right middle = Some (last,second) -> - run_turns base (left ++ right) s = Some (last,first ++ second). -Proof. - intros Hleft Hright; rewrite run_turns_append, Hleft, Hright; reflexivity. -Qed. - -Lemma run_turns_append_inv base left right s last logs : - run_turns base (left ++ right) s = Some (last,logs) -> - exists middle first second, - run_turns base left s = Some (middle,first) /\ - run_turns base right middle = Some (last,second) /\ - logs = first ++ second. -Proof. - rewrite run_turns_append; intro Hrun. - destruct (run_turns base left s) as [[middle first]|] eqn:Hleft; - [|discriminate]. - destruct (run_turns base right middle) as [[last' second]|] eqn:Hright; - [|discriminate]. - inversion Hrun; subst. - exists middle, first, second; repeat split; assumption || reflexivity. -Qed. - -Lemma run_turns_counter base script s last logs : - run_turns base script s = Some (last,logs) -> - acount last = (acount s + length logs)%nat. -Proof. - revert s last logs; induction script as [|who rest IH]; - intros s last logs Hrun. - - cbn [run_turns] in Hrun; inversion Hrun; subst; cbn; lia. - - cbn [run_turns] in Hrun. - destruct (turn base who s) as [[next event]|] eqn:Hstep; - [|discriminate]. - destruct (run_turns base rest next) as [[last' suffix]|] eqn:Hrest; - [|discriminate]. - pose proof (IH next last' suffix Hrest) as Hsuffix. - pose proof (turn_counter base who s next event Hstep) as Hcounter. - destruct event as [o|]; cbn in Hrun, Hcounter. - + destruct Hcounter as [Hcount Hindex]. - inversion Hrun; subst; cbn; lia. - + inversion Hrun; subst; cbn; lia. -Qed. - -Lemma run_turns_respects_heq base script s t : - state_equiv s t -> - match run_turns base script s, run_turns base script t with - | None, None => True - | Some (s',logs), Some (t',logs') => - state_equiv s' t' /\ logs = logs' - | _, _ => False - end. -Proof. - revert s t; induction script as [|who rest IH]; intros s t Hst. - - cbn [run_turns]; split; [exact Hst | reflexivity]. - - cbn [run_turns]. - pose proof (turn_respects_heq base who s t Hst) as Hturn. - destruct (turn base who s) as [[next event]|]; - destruct (turn base who t) as [[next' event']|]; - cbn in Hturn; try contradiction. - + destruct Hturn as [Hnext Hevent]; subst event'. - specialize (IH next next' Hnext). - destruct (run_turns base rest next) as [[last logs]|]; - destruct (run_turns base rest next') as [[last' logs']|]; - cbn in IH; try contradiction. - * destruct IH as [Hlast Hlogs]; subst logs'. - split; [exact Hlast | reflexivity]. - * exact I. - + exact I. -Qed. - -Corollary run_turns_respects_heq_some base script s t last logs : - state_equiv s t -> run_turns base script s = Some (last,logs) -> - exists last', run_turns base script t = Some (last',logs) /\ - state_equiv last last'. -Proof. - intros Hst Hrun. - pose proof (run_turns_respects_heq base script s t Hst) as H. - rewrite Hrun in H. - destruct (run_turns base script t) as [[last' logs']|] eqn:Ht; - cbn in H; [|contradiction]. - destruct H as [Hlast Hlogs]; subst logs'. - exists last'; split; [assumption || reflexivity | exact Hlast]. -Qed. - -Corollary run_turns_respects_heq_none base script s t : - state_equiv s t -> - (run_turns base script s = None <-> run_turns base script t = None). -Proof. - intro Hst; pose proof (run_turns_respects_heq base script s t Hst) as H. - destruct (run_turns base script s) as [[last logs]|]; - destruct (run_turns base script t) as [[last' logs']|]; - cbn in H; try contradiction; split; intro Hnone; - try discriminate; reflexivity. + intro Hstep; pose proof (turn_counter base who s s' event Hstep) as H. + destruct event as [o|]; cbn [event_obs List.length] in H |- *; + [destruct H as [Hcount _]; lia | lia]. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. @@ -627,27 +351,6 @@ Import ListNotations. Local Open Scope list_scope. Local Open Scope nat_scope. -Lemma ai_free_chain_frame h h' xs : - free_chain h xs -> - (forall b, In b xs -> h' b = h b) -> - free_chain h' xs. -Proof. - revert h h'; induction xs as [|b xs IH]; intros h h' Hchain Hframe. - - exact I. - - cbn [free_chain] in *; destruct Hchain as [Hb Hxs]; split. - + rewrite Hframe; [exact Hb | now left]. - + eapply IH; [exact Hxs | intros x Hx; apply Hframe; now right]. -Qed. - -Lemma ai_free_chain_upd h xs a v : - free_chain h xs -> - (forall b, In b xs -> b <> a) -> - free_chain (upd h a v) xs. -Proof. - intros Hchain Haway; eapply ai_free_chain_frame; [exact Hchain |]. - intros b Hb; apply upd_neq, Haway, Hb. -Qed. - Lemma ai_cached_remote_frame base capacity h h' pc : cached_remote base capacity h pc -> (forall b, In b (held pc) -> h' b = h b) -> @@ -658,52 +361,6 @@ Proof. rewrite Hframe; [exact Hlink | now left]. Qed. -Lemma ai_partition_member base capacity xs x : - Permutation xs (page_blocks base capacity) -> - In x xs -> In x (page_blocks base capacity). -Proof. intros Hp Hx; eapply Permutation_in; eauto. Qed. - -Lemma ai_partition_nodup base capacity xs : - Permutation xs (page_blocks base capacity) -> NoDup xs. -Proof. - intro Hp; eapply Permutation_NoDup; [apply Permutation_sym, Hp |]. - apply page_blocks_nodup. -Qed. - -Lemma ai_partition_count base capacity xs : - Permutation xs (page_blocks base capacity) -> - forall x, count_occ Nat.eq_dec xs x <= 1. -Proof. - intro Hp; apply (proj1 (NoDup_count_occ Nat.eq_dec xs)). - now apply (ai_partition_nodup base capacity). -Qed. - -Lemma ai_partition_disjoint base capacity xs ys zs : - Permutation (xs ++ ys ++ zs) (page_blocks base capacity) -> - forall b, In b xs -> ~ In b ys. -Proof. - intros Hp b Hx Hy. - pose proof (ai_partition_count base capacity _ Hp b) as Hcount. - repeat rewrite count_occ_app in Hcount. - apply (proj1 (count_occ_In Nat.eq_dec xs b)) in Hx. - apply (proj1 (count_occ_In Nat.eq_dec ys b)) in Hy. - lia. -Qed. - -Lemma ai_head_bound base capacity xs : - (forall b, In b xs -> In b (page_blocks base capacity)) -> - hd 0 xs = 0 \/ In (hd 0 xs) (page_blocks base capacity). -Proof. - destruct xs as [|b xs]; cbn; intro H; [now left | right; apply H; now left]. -Qed. - -Lemma ai_head_distinct xs b : - ~ In b xs -> 0 <> b -> hd 0 xs <> b. -Proof. - destruct xs as [|a xs]; cbn; intros Hnot Hzero; [exact Hzero |]. - intro E; apply Hnot; now left. -Qed. - Lemma ai_backing_present base capacity h x : backing base capacity h -> base <= x /\ x < base + page_size capacity -> @@ -725,12 +382,12 @@ Qed. Lemma allocator_inv_backing base capacity s : allocator_inv base capacity s -> backing base capacity (aheap s). -Proof. intros [_ [H _]]; exact H. Qed. +Proof. intros (_ & _ & _ & _ & H & _); exact H. Qed. Lemma allocator_inv_null base capacity s : allocator_inv base capacity s -> aheap s 0 = None. Proof. - intros [Hbase [Hback _]]. + intros (_ & _ & _ & Hbase & Hback & _). destruct (aheap s 0) as [v|] eqn:E; [|reflexivity]. assert (Hpresent : aheap s 0 <> None) by (rewrite E; discriminate). apply Hback in Hpresent; lia. @@ -740,7 +397,7 @@ Lemma allocator_inv_outside base capacity s x : allocator_inv base capacity s -> (x < base \/ base + page_size capacity <= x) -> aheap s x = None. Proof. - intros [_ [Hback _]] Hout. + intros (_ & _ & _ & _ & Hback & _) Hout. destruct (aheap s x) as [v|] eqn:E; [|reflexivity]. assert (Hpresent : aheap s x <> None) by (rewrite E; discriminate). apply Hback in Hpresent; lia. @@ -751,9 +408,9 @@ Lemma allocator_inv_held_member base capacity s (client : bool) b : In b (held (if client then remote1_state s else remote0_state s)) -> In b (page_blocks base capacity). Proof. - intros (_ & _ & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + intros (L & R & D & _ & _ & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) Hin. - eapply ai_partition_member; [exact Hp |]. + eapply Permutation_in; [exact Hp |]. repeat rewrite in_app_iff; destruct client; tauto. Qed. @@ -763,7 +420,7 @@ Ltac ai_member := match goal with | Hp : Permutation ?xs (page_blocks ?base ?capacity) |- In ?x (page_blocks _ _) => - apply (ai_partition_member base capacity xs x Hp); + eapply Permutation_in; [exact Hp |]; repeat rewrite in_app_iff; cbn [held mailbox_nodes Nat.eqb In]; intuition congruence end. @@ -789,7 +446,10 @@ Ltac ai_count_contradiction x := match goal with | Hp : Permutation ?xs (page_blocks ?base ?capacity) |- _ => let Hcount := fresh "Hcount" in - pose proof (ai_partition_count base capacity xs Hp x) as Hcount; + assert (Hcount : count_occ Nat.eq_dec xs x <= 1) by + (apply (proj1 (NoDup_count_occ Nat.eq_dec xs)); + eapply Permutation_NoDup; + [apply Permutation_sym, Hp | apply page_blocks_nodup]); repeat rewrite count_occ_app in Hcount; try unfold mailbox_nodes in Hcount; repeat match goal with @@ -841,7 +501,11 @@ Ltac ai_heap := Ltac ai_chain := first [assumption | exact I | - eapply ai_free_chain_upd; [ai_chain | intros; ai_distinct]]. + eapply linked_mono; + [ let a := fresh "a" in let b := fresh "b" in + let Hin := fresh "Hin" in let Hab := fresh "Hab" in + intros a b Hin Hab; rewrite upd_neq by ai_distinct; exact Hab + | ai_chain ]]. Ltac ai_backing := first [assumption | @@ -877,10 +541,14 @@ Ltac ai_obligation h := | solve [ai_cached h] | solve [ai_permutation] | solve [ai_member] - | solve [apply ai_head_bound; intros; ai_member] + | match goal with + | |- hd 0 ?xs = 0 \/ In (hd 0 ?xs) (page_blocks _ _) => + solve [destruct (head_in_or_default 0 xs) as [Hzero | Hhead]; + [now left | right; ai_member]] + end | match goal with | |- hd 0 ?xs <> ?b => - solve [apply ai_head_distinct; + solve [apply head_not_in; [intro; ai_count_contradiction b | ai_distinct]] end | solve [ai_distinct] ]. @@ -888,27 +556,79 @@ Ltac ai_obligation h := Local Ltac ai_reduce_turn := cbn [turn aheap acount owner_state remote0_state remote1_state]. +(** ** Ownership change of one turn. + + Every constructor below is a projection of an actual executable turn. + In particular detach uses the current R, and publication prepends to R. *) +Definition owner_after_offer (client : bool) := if client then ORead else OOffer true. + +Inductive ownership_transition : + Actor -> owner_pc -> owner_pc -> option (indexed (nat * nat)) -> + list nat -> list nat -> list nat -> list nat -> list nat -> list nat -> Prop := +| ownership_read L R : + ownership_transition Owner ORead (OCAS (List.hd 0 R)) None L R [] L R [] +| ownership_cas_fail old L R : + List.hd 0 R <> old -> + ownership_transition Owner (OCAS old) ORead None L R [] L R [] +| ownership_detach L R : + ownership_transition Owner (OCAS (List.hd 0 R)) ODrain None L R [] L [] R +| ownership_drain_empty L R : + ownership_transition Owner ODrain (OOffer false) None L R [] L R [] +| ownership_drain L R b D idx : + ownership_transition Owner ODrain ODrain (Some (stamp (tag_reclaim,b) idx)) + L R (b :: D) (b :: L) R D +| ownership_offer_empty client L R : + ownership_transition Owner (OOffer client) (owner_after_offer client) None + L R [] L R [] +| ownership_offer client L R b idx : + ownership_transition Owner (OOffer client) (owner_after_offer client) + (Some (stamp (tag_alloc,b) idx)) (b :: L) R [] L R [] +| ownership_remote who pc event L R D : + who <> Owner -> + (event = None \/ exists b idx, event = Some (stamp (tag_retry,b) idx)) -> + ownership_transition who pc pc event L R D L R D +| ownership_publish who pc L R D b idx : + who <> Owner -> + ownership_transition who pc pc (Some (stamp (tag_retire,b) idx)) + L R D L (b :: R) D. + +(** Finish one branch: the computed result, its ownership view at the new + ghost lists, and the ownership constructor of the branch. *) Ltac ai_finish h L R D m0 m1 := cbn [aheap acount owner_state remote0_state remote1_state]; try rewrite Nat.eqb_refl; repeat match goal with | E : Nat.eqb _ _ = _ |- _ => progress rewrite E end; - do 2 eexists; split; [reflexivity |]; - unfold allocator_inv; cbn [aheap acount owner_state remote0_state remote1_state]; - split; [assumption |]; split; [ai_backing |]; - exists L, R, D, m0, m1; - cbn [hd held]; - repeat split; ai_obligation h. - -Lemma ai_turn_complete base capacity who s : - allocator_inv base capacity s -> - exists t event, turn base who s = Some (t,event) /\ - allocator_inv base capacity t. + do 2 eexists; exists L, R, D; split; [reflexivity |]; split; + [ unfold allocator_view; + cbn [aheap acount owner_state remote0_state remote1_state]; + split; [assumption |]; split; [ai_backing |]; + exists m0, m1; + cbn [hd held]; + repeat split; ai_obligation h + | cbn [owner_state]; + first [apply ownership_read | apply ownership_detach | + apply ownership_drain_empty | apply ownership_drain | + apply ownership_offer_empty | apply ownership_offer | + apply ownership_cas_fail; now apply Nat.eqb_neq | + apply ownership_publish; discriminate | + apply ownership_remote; [discriminate|left; reflexivity] | + apply ownership_remote; [discriminate|right; do 2 eexists; reflexivity]] ]. + +(** Transition completeness: on the ownership view every turn succeeds, + re-establishes the view, and changes ownership by one constructor. *) +Lemma turn_view_complete base capacity who s L R D : + allocator_view base capacity s L R D -> + exists t event L' R' D', + turn base who s = Some (t,event) /\ + allocator_view base capacity t L' R' D' /\ + ownership_transition who (owner_state s) (owner_state t) + event L R D L' R' D'. Proof. destruct s as [h count op p0 p1]. - cbn [allocator_inv aheap acount owner_state remote0_state remote1_state]. - intros (Hbase & Hback & L & R & D & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & + cbn [allocator_view aheap acount owner_state remote0_state remote1_state]. + intros (Hbase & Hback & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1). cbn [aheap acount owner_state remote0_state remote1_state] in *. destruct who. @@ -926,7 +646,7 @@ Proof. + destruct D as [|b D]. * ai_reduce_turn; rewrite Hd; cbn [hd Nat.eqb]. ai_finish h L R (@nil nat) m0 m1. - * cbn [free_chain] in CD; destruct CD as [Hnext CD]. + * cbn [linked] in CD; destruct CD as [Hnext CD]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). ai_reduce_turn; rewrite Hd; cbn [hd]; rewrite Eb, Hnext, Hl. @@ -937,7 +657,7 @@ Proof. ++ ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]; rewrite Hl; cbn [hd Nat.eqb]. ai_finish h (@nil nat) R (@nil nat) m0 0. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + ++ cbn [linked] in CL; destruct CL as [Hnext CL]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). ai_reduce_turn; rewrite Hm1; cbn [Nat.eqb]; rewrite Hl; @@ -950,7 +670,7 @@ Proof. ++ ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]; rewrite Hl; cbn [hd Nat.eqb]. ai_finish h (@nil nat) R (@nil nat) 0 m1. - ++ cbn [free_chain] in CL; destruct CL as [Hnext CL]. + ++ cbn [linked] in CL; destruct CL as [Hnext CL]. assert (Eb : Nat.eqb b 0 = false) by (apply Nat.eqb_neq; ai_distinct). ai_reduce_turn; rewrite Hm0; cbn [Nat.eqb]; rewrite Hl; @@ -1010,12 +730,27 @@ Proof. * ai_finish h L R D m0 m1. Qed. +Lemma turn_view_step base capacity who s t event L R D : + allocator_view base capacity s L R D -> + turn base who s = Some (t,event) -> + exists L' R' D', allocator_view base capacity t L' R' D' /\ + ownership_transition who (owner_state s) (owner_state t) + event L R D L' R' D'. +Proof. + intros Hview Hturn. + destruct (turn_view_complete base capacity who s L R D Hview) + as (t' & event' & L' & R' & D' & Hturn' & Hview' & Hstep). + rewrite Hturn in Hturn'; injection Hturn' as <- <-. + exists L', R', D'; split; assumption. +Qed. + Lemma turn_total base capacity who s : allocator_inv base capacity s -> exists t event, turn base who s = Some (t,event). Proof. - intro Hinv; destruct (ai_turn_complete base capacity who s Hinv) - as (t & event & Hturn & Hnext). + intros (L & R & D & Hview). + destruct (turn_view_complete base capacity who s L R D Hview) + as (t & event & _ & _ & _ & Hturn & _). now exists t, event. Qed. @@ -1023,51 +758,31 @@ Lemma turn_preserves_inv base capacity who s t event : allocator_inv base capacity s -> turn base who s = Some (t,event) -> allocator_inv base capacity t. Proof. - intros Hinv Hturn. - destruct (ai_turn_complete base capacity who s Hinv) - as (t' & event' & Hturn' & Hnext). - rewrite Hturn in Hturn'; inversion Hturn'; subst; exact Hnext. -Qed. - -Lemma turn_preserves_backing base capacity who s t event : - allocator_inv base capacity s -> - turn base who s = Some (t,event) -> - forall x, aheap t x <> None <-> aheap s x <> None. -Proof. - intros Hinv Hturn x. - pose proof (turn_preserves_inv base capacity who s t event Hinv Hturn) as Hnext. - pose proof (allocator_inv_backing base capacity s Hinv) as Hbefore. - pose proof (allocator_inv_backing base capacity t Hnext) as Hafter. - rewrite (Hbefore x), (Hafter x); reflexivity. -Qed. - -Lemma run_turns_preserves_inv base capacity script s last logs : - allocator_inv base capacity s -> - run_turns base script s = Some (last,logs) -> - allocator_inv base capacity last. -Proof. - revert s last logs; induction script as [|who rest IH]; - intros s last logs Hinv Hrun. - - cbn [run_turns] in Hrun; inversion Hrun; subst; exact Hinv. - - cbn [run_turns] in Hrun. - destruct (turn base who s) as [[next event]|] eqn:Hstep; - [|discriminate]. - destruct (run_turns base rest next) as [[last' suffix]|] eqn:Hrest; - [|discriminate]. - inversion Hrun; subst. - eapply IH; [eapply turn_preserves_inv; eauto | exact Hrest]. -Qed. - -Lemma run_turns_total base capacity script s : - allocator_inv base capacity s -> - exists last logs, run_turns base script s = Some (last,logs). -Proof. - revert s; induction script as [|who rest IH]; intros s Hinv. - - exists s, []; reflexivity. - - destruct (turn_total base capacity who s Hinv) as (next & event & Hstep). - assert (Hnext : allocator_inv base capacity next). - { eapply turn_preserves_inv; eauto. } - destruct (IH next Hnext) as (last & logs & Hrest). - exists last, (match event with None => logs | Some o => o :: logs end). - cbn [run_turns]; rewrite Hstep, Hrest; reflexivity. -Qed. + intros (L & R & D & Hview) Hturn. + destruct (turn_view_step base capacity who s t event L R D Hview Hturn) + as (L' & R' & D' & Hview' & _). + now exists L', R', D'. +Qed. + +Lemma allocator_initial_inv capacity c s : + s = initial_state capacity c -> allocator_inv 1 capacity s. +Proof. intros ->; apply initial_state_inv. Qed. + +(** ** The allocator's validity and construction interface. + + Exactly two instantiations of [Utils.Execution]; no example-local + execution record, constructor or replay proof remains. *) +Definition allocator_valid (capacity c : nat) + (e : Execution AState Actor (option (indexed (nat * nat)))) : Prop := + execution_valid (fun who s o s' => turn 1 who s = Some (s',o)) + (fun s => s = initial_state capacity c) e. + +Definition allocator_execution (capacity c : nat) (picks : nat -> Actor) + : Execution AState Actor (option (indexed (nat * nat))) := + execution_of_choices (turn 1) (allocator_inv 1 capacity) + (fun who s Hs => + match turn_total 1 capacity who s Hs with + | ex_intro _ t (ex_intro _ ev H) => ex_intro _ (t,ev) H + end) + (fun who s s' o Hs Hstep => turn_preserves_inv 1 capacity who s s' o Hs Hstep) + (initial_state capacity c) (initial_state_inv capacity c) picks. diff --git a/examples/CSL/Allocator/Tests.v b/examples/CSL/Allocator/Tests.v deleted file mode 100644 index d7f6675..0000000 --- a/examples/CSL/Allocator/Tests.v +++ /dev/null @@ -1,234 +0,0 @@ -From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Sorting.Permutation. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.Yield.RoundRobin - ICTree.Logic.State Logic.Core Utils.Vectors. -From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program - CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness - CSL.Allocator.NegativeTests. - -Import ICtree ICTreeNotations TiclNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. -Local Open Scope list_scope. -Local Open Scope ticl_scope. -Local Open Scope nat_scope. - -(** These probes execute allocation and checked initialization before reading. - The arbitrary continuation observes the returned base/value, exact heap, - unchanged counter, and unchanged scheduling focus/cursor. *) -Example new_page_two_source n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) cursor c : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page 2) >>= K)) (Some i) cursor (hemp,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) (Some i) cursor - (page_heap 1 2 hemp,c). -Proof. apply interp_rr_new_page_hemp. Qed. - -Example new_page_two_source_reads n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) cursor c : - List.Forall (fun '(offset,value) => - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind (new_page 2) - (fun base => CRead (base+offset))) >>= K)) (Some i) cursor (hemp,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) cursor - (page_heap 1 2 hemp,c)) - [(0,0);(1,6);(2,0);(3,0);(4,0);(5,8);(6,0);(7,0);(8,0)]. -Proof. - repeat constructor; apply interp_rr_new_page_read; reflexivity. -Qed. - -Example new_page_two_exact_domain x : - page_heap 1 2 hemp x <> None <-> 1 <= x /\ x <= 9. -Proof. rewrite page_heap_closed_dom; unfold page_size; lia. Qed. - -Example new_page_two_source_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) cursor c : - List.Forall (fun address => - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind (new_page 2) - (fun _ => CRead address)) >>= K)) (Some i) cursor (hemp,c) ~ - (stuck : ictreeW SObs (unit * SSig))) [0;10]. -Proof. - repeat constructor; apply interp_rr_new_page_read_missing; reflexivity. -Qed. - -Example new_page_zero_source n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) c : - interp_nd (S n) - (ts @ i := (denote_flow (new_page 0) >>= K)) (Some i) (hemp,c) ~ - interp_nd (S n) (ts @ i := K (Some 1)) (Some i) (page_heap 1 0 hemp,c). -Proof. apply interp_nd_new_page_hemp. Qed. - -Example new_page_zero_source_reads n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) c : - List.Forall (fun offset => - interp_nd (S n) - (ts @ i := (denote_flow (CBind (new_page 0) - (fun base => CRead (base+offset))) >>= K)) (Some i) (hemp,c) ~ - interp_nd (S n) (ts @ i := K (Some 0)) (Some i) (page_heap 1 0 hemp,c)) - [0;1;2;3;4]. -Proof. - repeat constructor; apply interp_nd_new_page_read; reflexivity. -Qed. - -Example new_page_zero_exact_domain x : - page_heap 1 0 hemp x <> None <-> 1 <= x /\ x <= 5. -Proof. rewrite page_heap_closed_dom; unfold page_size; lia. Qed. - -Definition fixture_events (result : option (AState * list SObs)) : option (list SObs) := - match result with None => None | Some (_,logs) => Some logs end. -Definition fixture_cells (addresses : list nat) (result : option (AState * list SObs)) - : option (list (option nat)) := - match result with None => None | Some (s,_) => Some (List.map (aheap s) addresses) end. -Definition fixture_counter (result : option (AState * list SObs)) : option nat := - match result with None => None | Some (s,_) => Some (acount s) end. -Definition fixture_controls (result : option (AState * list SObs)) - : option (owner_pc * remote_pc * remote_pc) := - match result with None => None - | Some (s,_) => Some (owner_state s,remote0_state s,remote1_state s) end. - -Definition rr_prefix_fixture := - run_turns 1 (demo_rr_script 0 57) (initial_state 2 0). -Definition rr_cycle_fixture := - match rr_prefix_fixture with None => None | Some (s,_) => - run_turns 1 (demo_rr_script 57 42) s end. -Definition aba_before_reuse := - List.repeat Owner 5 ++ List.repeat Remote0 4 ++ List.repeat Remote1 3. -Definition aba_before_commit := - aba_before_reuse ++ List.repeat Owner 6 ++ List.repeat Remote0 4. -Definition aba_script := aba_before_commit ++ [Remote1]. -Definition aba_fixture := run_turns 1 aba_script (initial_state 2 0). -Definition starvation_prefix_fixture := - run_turns 1 starvation_prefix (initial_state 2 0). -Definition starvation_cycle_fixture := - match starvation_prefix_fixture with None => None | Some (s,_) => - run_turns 1 starvation_cycle s end. -Definition owner_stall_prefix_fixture := - run_turns 1 owner_stall_prefix (initial_state 2 0). -Definition owner_stall_polling_fixture := - match owner_stall_prefix_fixture with None => None | Some (s,_) => - run_turns 1 owner_stall_cycle s end. - -Example rr_prefix_events : fixture_events rr_prefix_fixture = Some - [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 3 8 3; SPop 1 8 4; - SPop 2 8 5; SPop 2 6 6; SPop 0 6 7; SPop 0 8 8]. -Proof. vm_compute; reflexivity. Qed. -Example rr_prefix_state : - fixture_cells (List.seq 1 9) rr_prefix_fixture = - Some (List.map (@Some nat) [0;0;0;0;8;8;1;0;2]) /\ - fixture_counter rr_prefix_fixture = Some 9 /\ - fixture_controls rr_prefix_fixture = Some (ORead,RRead 6,RPoll). -Proof. vm_compute; repeat split; reflexivity. Qed. -Example rr_next_cycle_events : fixture_events rr_cycle_fixture = Some - [SPop 1 6 9; SPop 3 8 10; SPop 1 8 11; SPop 2 8 12; - SPop 2 6 13; SPop 0 6 14; SPop 0 8 15]. -Proof. vm_compute; reflexivity. Qed. -Example rr_next_cycle_state : - fixture_cells (List.seq 1 9) rr_cycle_fixture = fixture_cells (List.seq 1 9) rr_prefix_fixture /\ - fixture_controls rr_cycle_fixture = fixture_controls rr_prefix_fixture /\ - fixture_counter rr_cycle_fixture = Some 16. -Proof. vm_compute; repeat split; reflexivity. Qed. -Example rr_actual_source : - run_rr (allocator_program 2) hemp 0 ~ emit_list (demo_prefix 0) (demo_cycle 9). -Proof. exact (run_rr_allocator_demo_bisim 0). Qed. - -Definition aba_logs : list SObs := - [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 2 6 3; - SPop 0 6 4; SPop 1 6 5; SPop 1 8 6]. -Example aba_snapshot_survives_reuse : - fixture_controls (run_turns 1 aba_before_reuse (initial_state 2 0)) = - Some (ORead,RPoll,RCAS 8 6) /\ - fixture_controls (run_turns 1 aba_before_commit (initial_state 2 0)) = - Some (ORead,RPoll,RCAS 8 6) /\ - fixture_cells [1] (run_turns 1 aba_before_reuse (initial_state 2 0)) = Some [Some 6] /\ - fixture_cells [1] (run_turns 1 aba_before_commit (initial_state 2 0)) = Some [Some 6]. -Proof. vm_compute; repeat split; reflexivity. Qed. -Example aba_events : fixture_events aba_fixture = Some aba_logs. -Proof. vm_compute; reflexivity. Qed. -Example aba_links_and_counter : - fixture_cells [1;8;6] aba_fixture = Some [Some 8;Some 6;Some 0] /\ - fixture_counter aba_fixture = Some 7. -Proof. vm_compute; split; reflexivity. Qed. -Lemma aba_run_no_loss : exists last, - aba_fixture = Some (last,aba_logs) /\ - allocator_inv 1 2 last /\ - aheap last (remote_head 1) = Some 8 /\ free_chain (aheap last) [8;6] /\ - NoDup [8;6] /\ Permutation [8;6] (page_blocks 1 2). -Proof. - assert (Hrun : exists last, aba_fixture = Some (last,aba_logs)). - { eexists; vm_compute; reflexivity. } - destruct Hrun as [last Hrun]; exists last; split; [exact Hrun|]; split. - - eapply run_turns_preserves_inv; [apply initial_state_inv|exact Hrun]. - - vm_compute in Hrun; inversion Hrun; subst last. - split; [reflexivity|]; split; [repeat split; reflexivity|]; split. - + repeat constructor; cbn; intuition congruence. - + change (Permutation [8;6] [6;8]); apply perm_swap. -Qed. -Theorem aba_actual_source_no_loss : exists last labels residual, - aba_fixture = Some (last,aba_logs) /\ allocator_inv 1 2 last /\ - aheap last (remote_head 1) = Some 8 /\ free_chain (aheap last) [8;6] /\ - label_logs labels = aba_logs /\ label_taus labels = 23 /\ - finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ - residual ~ model_nd 1 last. -Proof. - destruct aba_run_no_loss as (last & Hrun & Hinv & Hhead & Hchain & Hnd & Hp). - destruct (run_turns_realizes_source 2 0 aba_script last aba_logs Hrun) - as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). - exists last, labels, residual; repeat first [assumption | split]. -Qed. - -Example starvation_prefix_events : fixture_events starvation_prefix_fixture = Some - [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 3 8 3; SPop 2 6 4; SPop 0 6 5]. -Proof. vm_compute; reflexivity. Qed. -Example starvation_cycle_events : fixture_events starvation_cycle_fixture = Some - [SPop 1 6 6; SPop 3 8 7; SPop 2 6 8; SPop 0 6 9]. -Proof. vm_compute; reflexivity. Qed. -Example starvation_chained_cycle_state : - fixture_cells (List.seq 1 9) starvation_prefix_fixture = - Some (List.map (@Some nat) [0;0;0;6;0;0;1;0;2]) /\ - fixture_cells (List.seq 1 9) starvation_cycle_fixture = - fixture_cells (List.seq 1 9) starvation_prefix_fixture /\ - fixture_controls starvation_cycle_fixture = Some (ORead,RPoll,RRead 8) /\ - fixture_counter starvation_cycle_fixture = Some 10. -Proof. vm_compute; repeat split; reflexivity. Qed. -Theorem starvation_chained_cycle_actual_source : exists last labels residual, - run_turns 1 (starvation_prefix ++ starvation_cycle) (initial_state 2 0) = - Some (last,starve_prefix_logs 0 ++ starve_cycle_logs 6) /\ - label_logs labels = starve_prefix_logs 0 ++ starve_cycle_logs 6 /\ - label_taus labels = 32 /\ - finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ - residual ~ model_nd 1 last. -Proof. - destruct (starve_prefix_run 0) as (first & Hprefix & Hfirst). - destruct (starve_cycle_run_actual 6 first Hfirst) as (last & Hcycle & Hlast). - pose proof (run_turns_compose 1 starvation_prefix starvation_cycle - (initial_state 2 0) first last (starve_prefix_logs 0) (starve_cycle_logs 6) - Hprefix Hcycle) as Hrun. - destruct (run_turns_realizes_source 2 0 (starvation_prefix ++ starvation_cycle) - last (starve_prefix_logs 0 ++ starve_cycle_logs 6) Hrun) - as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). - exists last, labels, residual; repeat first [assumption | split]. -Qed. - -Example owner_stall_prefix_events : fixture_events owner_stall_prefix_fixture = Some - [SPop 0 6 0; SPop 0 8 1; SPop 1 6 2; SPop 1 8 3]. -Proof. vm_compute; reflexivity. Qed. -Example owner_stall_polling_retains_remote_list : - fixture_events owner_stall_polling_fixture = Some [] /\ - fixture_cells [1;8;6] owner_stall_polling_fixture = Some [Some 8;Some 6;Some 0] /\ - fixture_counter owner_stall_polling_fixture = Some 4 /\ - fixture_controls owner_stall_polling_fixture = Some (ORead,RPoll,RPoll). -Proof. vm_compute; repeat split; reflexivity. Qed. - -Example allocator_allocation_recurs_fresh : - <( {run_rr (allocator_program 2) hemp 0}, Pure - |= AG (AF visW {fun o => stag o = tag_alloc /\ 100 <= sidx o}) )>. -Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. -Example allocator_remote_free_recurs_fresh : - <( {run_rr (allocator_program 2) hemp 0}, Pure - |= AG (AF visW {fun o => stag o = tag_retire /\ 100 <= sidx o}) )>. -Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. -Example allocator_reclamation_recurs_fresh : - <( {run_rr (allocator_program 2) hemp 0}, Pure - |= AG (AF visW {fun o => stag o = tag_reclaim /\ 100 <= sidx o}) )>. -Proof. apply allocator_demo_agaf_fresh; cbn; auto. Qed. diff --git a/examples/CSL/HeapTests.v b/examples/CSL/HeapTests.v deleted file mode 100644 index 1a7bde4..0000000 --- a/examples/CSL/HeapTests.v +++ /dev/null @@ -1,126 +0,0 @@ -From Stdlib Require Import Lia Arith.PeanoNat. -From ExtLib Require Import Data.Monads.StateMonad. -From TICL Require Import - ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer - ICTree.Interp.State.Mod Lang.CSL.Heap. - -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. - -Lemma allocated_read_returns a h c v : - h a = Some v -> - runStateT (sh (inl (HRead a))) (h,c) ≅ Ret (v,(h,c)). -Proof. apply sh_rd_some. Qed. - -Lemma empty_read_faults a c : - interp_state sh (heap_read (E:=sE) a) (hemp,c) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. apply sinterp_srd_stuck; reflexivity. Qed. - -Lemma empty_write_faults a v c : - interp_state sh (heap_write (E:=sE) a v) (hemp,c) ≅ - (stuck : ictreeW SObs (unit * SSig)). -Proof. apply sinterp_swr_stuck; reflexivity. Qed. - -Lemma allocated_write_updates a h c v old : - h a = Some old -> - runStateT (sh (inl (HWrite a v))) (h,c) ≅ Ret (tt,(upd h a v,c)). -Proof. apply sh_wr_some. Qed. - -Lemma emit_records_current_index q v h c : - runStateT (sh (inr (Log (q,v)))) (h,c) ≅ - (log (SPop q v c);; Ret (tt,(h,S c))). -Proof. apply sh_emit. Qed. - -Lemma alloc_empty_two : - runStateT (sh (inl (HAlloc 2))) (hemp,5) ~ - Ret (1,(hunion (hblock 1 2) hemp,5)). -Proof. - apply sh_alloc_first; try lia. - - apply block_freeb_spec; reflexivity. -Qed. - -Lemma alloc_skips_partial_overlap : - runStateT (sh (inl (HAlloc 2))) (Pcm.hsingle 2 99,5) ~ - Ret (3,(hunion (hblock 3 2) (Pcm.hsingle 2 99),5)). -Proof. - apply sh_alloc_first; try lia. - - apply block_freeb_spec; reflexivity. - - intros j J L F; assert (j = 1 \/ j = 2) by lia. - destruct H; subst j. - + specialize (F 1 ltac:(lia)); discriminate F. - + specialize (F 0 ltac:(lia)); discriminate F. -Qed. - -Lemma alloc_zero_stuck c : - interp_state sh (heap_alloc (E:=sE) 0) (hemp,c) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. apply sinterp_salloc_zero. Qed. - -Definition full_heap : Heap := fun _ : nat => Some 7. - -Lemma alloc_full_heap_stuck size c : - Nat.lt 0 size -> - runStateT (sh (inl (HAlloc size))) (full_heap,c) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. - intro Pos; apply (alloc_search_no_space (W:=SObs)); [exact Pos |]. - intros j J Free; specialize (Free 0 Pos); discriminate Free. -Qed. - -Example cas_replacement_preserves_frame frame c : - frame <> 2 -> - interp_state sh - (b <- heap_cas (E:=sE) 2 7 9 ;; - current <- heap_read (E:=sE) 2 ;; - framed <- heap_read (E:=sE) frame ;; - Ret (b,current,framed)) (full_heap,c) ~ - Ret ((true,9,7),(upd full_heap 2 9,c)). -Proof. - intro Frame. - etransitivity; [apply sinterp_cas_success; reflexivity |]. - etransitivity; [eapply sinterp_rd with (v := 9); reflexivity |]. - etransitivity. - - eapply sinterp_rd with (v := 7). - unfold upd; destruct (Nat.eqb_spec frame 2); [contradiction | reflexivity]. - - rewrite interp_state_ret; reflexivity. -Qed. - -Example cas_mismatch_preserves_entire_state frame c : - interp_state sh - (b <- heap_cas (E:=sE) 2 8 9 ;; - current <- heap_read (E:=sE) 2 ;; - framed <- heap_read (E:=sE) frame ;; - Ret (b,current,framed)) (full_heap,c) ~ - Ret ((false,7,7),(full_heap,c)). -Proof. - etransitivity. - - eapply sinterp_cas_failure with (current := 7); [reflexivity | discriminate]. - - etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. - etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. - rewrite interp_state_ret; reflexivity. -Qed. - -Example cas_same_value_still_succeeds frame c : - interp_state sh - (b <- heap_cas (E:=sE) 2 7 7 ;; - current <- heap_read (E:=sE) 2 ;; - framed <- heap_read (E:=sE) frame ;; - Ret (b,current,framed)) (full_heap,c) ~ - Ret ((true,7,7),(upd full_heap 2 7,c)). -Proof. - etransitivity; [apply sinterp_cas_success; reflexivity |]. - etransitivity; [eapply sinterp_rd with (v := 7); reflexivity |]. - etransitivity. - - eapply sinterp_rd with (v := 7). - unfold upd; destruct (Nat.eqb frame 2); reflexivity. - - rewrite interp_state_ret; reflexivity. -Qed. - -Example cas_missing_faults_before_continuation c : - interp_state sh - (b <- heap_cas (E:=sE) 1 0 9 ;; - semit 10 (if b then 1 else 0) ;; - Ret b) (Pcm.hsingle 2 99,c) ~ - (stuck : ictreeW SObs (bool * SSig)). -Proof. apply sinterp_cas_missing; reflexivity. Qed. diff --git a/examples/CSL/InterpTests.v b/examples/CSL/InterpTests.v deleted file mode 100644 index 20a9997..0000000 --- a/examples/CSL/InterpTests.v +++ /dev/null @@ -1,297 +0,0 @@ -From Stdlib Require Import Arith.PeanoNat Fin Vector Lia. -From ExtLib Require Import Data.Monads.StateMonad. -From TICL Require Import - Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod - ICTree.Interp.Yield.RoundRobin Utils.Vectors. - -Import ICtree ICTreeNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. - - -Definition shared_write_program : CProg unit := - CBind (CFork (CBind (CRead 4) (fun v => CEmit 2 v))) - (fun _ => CBind (CWrite 4 9) (fun _ => CYield)). - -Lemma shared_write_seen : - run_rr shared_write_program (Pcm.hsingle 4 0) 0 ~ - (log (SPop 2 9 0);; - Ret (tt, (upd (Pcm.hsingle 4 0) 4 9, 1))). -Proof. - unfold shared_write_program; rewrite run_rr_fork_bind. - change (interp_schedule_rr sh 2 - ([denote (CBind (CRead 4) (fun v => CEmit 2 v)); Ret tt]%vector - @ Fin.FS Fin.F1 := - (denote_flow (CBind (CWrite 4 9) (fun _ => CYield)) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (Pcm.hsingle 4 0,0) ~ - (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). - rewrite interp_rr_bind. - rewrite interp_rr_write_present by discriminate. - rewrite interp_rr_yield, interp_schedule_rr_select. - change (interp_schedule_rr sh 2 - ([Ret tt; Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CRead 4) (fun v => CEmit 2 v)) >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (upd (Pcm.hsingle 4 0) 4 9,0) ~ - (log (SPop 2 9 0);; Ret (tt,(upd (Pcm.hsingle 4 0) 4 9,1)))). - rewrite interp_rr_bind. - rewrite interp_rr_read_value with (value:=9) by reflexivity. - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. - -Definition scoped_child_program : CProg unit := - CBind - (CUntilNone - (CBind (CFork (CEmit 2 20)) - (fun _ => CBind (CEmit 1 10) - (fun _ => CRet (None : option unit))))) - (fun _ => CEmit 1 11). - -Lemma scoped_child_halts : - run_rr scoped_child_program hemp 0 ~ - (log (SPop 1 10 0);; - log (SPop 1 11 1);; - log (SPop 2 20 2);; - Ret (tt,(hemp,3))). -Proof. - set (body := CBind (CFork (CEmit 2 20)) - (fun _ => CBind (CEmit 1 10) (fun _ => CRet (None : option unit)))). - set (done := fun _ : option unit => (Ret tt : thread sE)). - set (after := fun r : option unit => - match r with None => done None | Some _ => denote_flow (CEmit 1 11) >>= done end). - set (next := fun r : option (option unit) => - match r with - | None => after None - | Some None => after (Some tt) - | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= after) - end). - unfold run_rr, scoped_child_program. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CUntilNone body) (fun _ => CEmit 1 11)) >>= done)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_bind, interp_rr_until_none. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := (denote_flow body >>= next)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - unfold body at 1; rewrite interp_rr_bind, interp_rr_fork. - change (interp_schedule_rr sh 2 - ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CBind (CEmit 1 10) (fun _ => CRet (None : option unit))) >>= next)) - (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ - (log (SPop 1 10 0);; log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_ret. - change (interp_schedule_rr sh 2 - ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CEmit 1 11) >>= done)) - (Some (Fin.FS Fin.F1)) 0 (hemp,1) ~ - (log (SPop 1 11 1);; log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - erewrite interp_schedule_rr_ret by source_observe. - pool_simpl; rewrite vector_remove_tail, vector_remove_head. - rewrite interp_schedule_rr_select. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 20) >>= done)) - (Some Fin.F1) 1 (hemp,2) ~ - (log (SPop 2 20 2);; Ret (tt,(hemp,3)))). - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - unfold done; finish_pool. -Qed. - -Definition finite_tagged_program : CProg unit := - CBind - (CFork (CBind (CEmit 2 9) (fun _ => - CBind CYield (fun _ => CEmit 2 10)))) - (fun _ => CBind (CEmit 1 7) (fun _ => - CBind CYield (fun _ => CEmit 1 8))). - -Lemma finite_tagged_round_robin : - run_rr finite_tagged_program hemp 0 ~ - (log (SPop 1 7 0);; log (SPop 2 9 1);; - log (SPop 1 8 2);; log (SPop 2 10 3);; - Ret (tt,(hemp,4))). -Proof. - unfold finite_tagged_program; rewrite run_rr_fork_bind. - change (interp_schedule_rr sh 2 - ([denote (CBind (CEmit 2 9) (fun _ => CBind CYield (fun _ => CEmit 2 10))); Ret tt]%vector - @ Fin.FS Fin.F1 := - (denote_flow (CBind (CEmit 1 7) (fun _ => CBind CYield (fun _ => CEmit 1 8))) - >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ - (log (SPop 1 7 0);; log (SPop 2 9 1);; log (SPop 1 8 2);; - log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. - change (interp_schedule_rr sh 2 - ([Ret tt; denote (CEmit 1 8)]%vector @ Fin.F1 := - (denote_flow (CBind (CEmit 2 9) (fun _ => CBind CYield (fun _ => CEmit 2 10))) - >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (hemp,1) ~ - (log (SPop 2 9 1);; log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_bind, interp_rr_yield, interp_schedule_rr_select. - change (interp_schedule_rr sh 2 - ([denote (CEmit 2 10); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CEmit 1 8) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 2 (hemp,2) ~ - (log (SPop 1 8 2);; log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - erewrite interp_schedule_rr_ret by source_observe. - pool_simpl; rewrite vector_remove_tail, vector_remove_head. - rewrite interp_schedule_rr_select. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 10) >>= fun _ => Ret tt)) - (Some Fin.F1) 3 (hemp,3) ~ - (log (SPop 2 10 3);; Ret (tt,(hemp,4)))). - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. - -Definition allocation_zero_read : CProg unit := - CBind (CAlloc 2) (fun base => - CBind (CRead (S base)) (fun value => CEmit 9 value)). - -Lemma allocation_zero_read_seen : - run_rr allocation_zero_read hemp 0 ~ - (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1))). -Proof. - unfold run_rr, allocation_zero_read. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 2) (fun base => - CBind (CRead (S base)) (fun value => CEmit 9 value))) >>= - fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 9 0 0);; Ret (tt,(hunion (hblock 1 2) hemp,1)))). - rewrite interp_rr_bind. - rewrite interp_rr_alloc_first with (base:=1) by - (try lia; apply block_freeb_spec; reflexivity). - rewrite interp_rr_bind. - rewrite interp_rr_read_value with (value:=0) by reflexivity. - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. - -Definition allocating_thread (tag : nat) : CProg unit := - CBind (CAlloc 2) (fun base => - CBind (CWrite base tag) (fun _ => - CBind (CEmit tag base) (fun _ => CYield))). - -Definition shared_alloc_program : CProg unit := - CBind (CFork (allocating_thread 2)) (fun _ => allocating_thread 1). - -Definition alloc_parent_heap := upd (hunion (hblock 1 2) hemp) 1 1. -Definition alloc_both_heap := upd (hunion (hblock 3 2) alloc_parent_heap) 3 2. - -Lemma shared_alloc_seen : - run_rr shared_alloc_program hemp 0 ~ - (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2))). -Proof. - assert (First : forall j, Nat.lt 0 j -> Nat.lt j 3 -> - ~ block_free alloc_parent_heap j 2). - { intros j J L F; assert (j = 1 \/ j = 2) as Cases by lia. - destruct Cases as [-> | ->]; - specialize (F 0 ltac:(lia)); discriminate F. } - unfold shared_alloc_program; rewrite run_rr_fork_bind. - change (interp_schedule_rr sh 2 - ([denote (allocating_thread 2); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CBind (CAlloc 2) (fun base => - CBind (CWrite base 1) (fun _ => - CBind (CEmit 1 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (hemp,0) ~ - (log (SPop 1 1 0);; log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). - rewrite interp_rr_bind. - rewrite interp_rr_alloc_first with (base:=1) by - (try lia; apply block_freeb_spec; reflexivity). - rewrite interp_rr_bind. - rewrite interp_rr_write_present by discriminate. - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_yield, interp_schedule_rr_select. - change (interp_schedule_rr sh 2 - ([Ret tt; Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 2) (fun base => - CBind (CWrite base 2) (fun _ => - CBind (CEmit 2 base) (fun _ => CYield)))) >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (alloc_parent_heap,1) ~ - (log (SPop 2 3 1);; Ret (tt,(alloc_both_heap,2)))). - rewrite interp_rr_bind. - rewrite interp_rr_alloc_first with (base:=3) by - (try lia; first [apply block_freeb_spec; reflexivity | exact First]). - rewrite interp_rr_bind. - rewrite interp_rr_write_present by discriminate. - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_yield. - finish_pool. -Qed. - -Definition shared_cas_program : CProg unit := - CBind (CAlloc 1) (fun cell => - CBind (CFork (CBind (CCAS cell 0 20) (fun won => - CEmit 20 (if won then 1 else 0)))) - (fun _ => CBind (CCAS cell 0 10) (fun won => - CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield)))). - -Lemma shared_cas_seen : - run_rr shared_cas_program hemp 0 ~ - (log (SPop 10 1 0);; log (SPop 20 0 1);; - Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2))). -Proof. - unfold run_rr, shared_cas_program. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 1) (fun cell => - CBind (CFork (CBind (CCAS cell 0 20) (fun won => - CEmit 20 (if won then 1 else 0)))) - (fun _ => CBind (CCAS cell 0 10) (fun won => - CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))))) >>= - fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 10 1 0);; log (SPop 20 0 1);; - Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind. - rewrite interp_rr_alloc_first with (base:=1) by - (try lia; apply block_freeb_spec; reflexivity). - rewrite interp_rr_bind, interp_rr_fork. - change (interp_schedule_rr sh 2 - ([denote (CBind (CCAS 1 0 20) (fun won => - CEmit 20 (if won then 1 else 0))); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CBind (CCAS 1 0 10) (fun won => - CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))) >>= - fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (hunion (hblock 1 1) hemp,0) ~ - (log (SPop 10 1 0);; log (SPop 20 0 1);; - Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind. - rewrite interp_rr_cas_value with (current:=0) by reflexivity. - cbn [Nat.eqb]. - rewrite interp_rr_bind, interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite interp_rr_yield, interp_schedule_rr_select. - change (interp_schedule_rr sh 2 - ([Ret tt; Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CCAS 1 0 20) (fun won => - CEmit 20 (if won then 1 else 0))) >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (upd (hunion (hblock 1 1) hemp) 1 10,1) ~ - (log (SPop 20 0 1);; Ret (tt,(upd (hunion (hblock 1 1) hemp) 1 10,2)))). - rewrite interp_rr_bind. - rewrite interp_rr_cas_value with (current:=10) by apply upd_eq. - cbn [Nat.eqb]. - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. diff --git a/examples/CSL/Layout.v b/examples/CSL/Layout.v deleted file mode 100644 index a71b147..0000000 --- a/examples/CSL/Layout.v +++ /dev/null @@ -1,105 +0,0 @@ -(** Concrete queue layout and address-bound frame fixtures. *) - -From Stdlib Require Import - List - Lia - Arith.PeanoNat. - -From TICL Require Import - Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame. - -Import ListNotations. -Local Open Scope list_scope. -Local Open Scope nat_scope. - - - -(** ** The concrete rotating queue, frozen across every frame variant. - - Addresses are even and below 8; every frame variant below allocates only - addresses at least 8. That single numeric separation is what both proof - families use, and it is stated once, here. *) - -Definition hdr1 : nat := 2. -Definition ns1 : list nat := [4; 6]. -Definition vs1 : list nat := [7; 9]. -Definition nl : nat := 7. - -Definition h1 : Heap := qheap hdr1 ns1 vs1. - -Lemma qwf1: qwf hdr1 ns1. -Proof. - unfold hdr1, ns1; split; [| split]. - - repeat (apply NoDup_cons; [cbn; intuition congruence |]); apply NoDup_nil. - - cbn; intuition congruence. - - cbn; intros x y Hx Hy; intuition lia. -Qed. - -Lemma qrep1: qrep hdr1 ns1 vs1 h1. -Proof. apply qheap_qrep; [apply qwf1 | reflexivity | discriminate]. Qed. - -Lemma qex1: qex hdr1 ns1 h1. -Proof. apply qheap_qex. Qed. - -Lemma ns1_nonnil: ns1 <> []. -Proof. discriminate. Qed. - -Lemma find_nl_vs1: find nl vs1 = Some 0. -Proof. reflexivity. Qed. - -(** The queue's footprint is exactly the addresses below 8. *) -Lemma qcells1_low: forall x, In x (qcells hdr1 ns1) -> x < 8. -Proof. unfold hdr1, ns1, qcells; cbn; intros x H; intuition lia. Qed. - -Lemma h1_low: forall x, h1 x <> None -> x < 8. -Proof. intros x H; apply qcells1_low, qex1, H. Qed. - -(** [high] and [HighHeap] are the SHARED vocabulary in which every frame - variant describes itself: "I allocate only addresses at or above 8". - They are defined here, in a file that does not import the [Coinduction] - library, because inside TICL's scopes [<=] resolves to a lattice order - rather than to [Nat.le]. *) -Definition high (x: nat) : Prop := 8 <= x. - -Definition HighHeap (f: Heap) : Prop := forall x, f x <> None -> high x. - -Lemma high_not_low: forall x, high x -> x < 8 -> False. -Proof. unfold high; intros x H1 H2; lia. Qed. - -Lemma high_nonzero: forall x, high x -> x <> 0. -Proof. unfold high; intros x H; lia. Qed. - - -(** The two compatibility conditions, derived once from the address bound. - Every frame variant states only [HighHeap fv]; both proof families read - the conditions off from here. *) - -Lemma disj_of_high: forall f, HighHeap f -> hdisj h1 f. -Proof. - intros f Hhigh x; destruct (h1 x) eqn:E; [| now left]. - right; destruct (f x) eqn:F; [| reflexivity]. - exfalso; apply (high_not_low x); [apply Hhigh; congruence |]. - apply h1_low; congruence. -Qed. - -Lemma null_of_high: forall f, HighHeap f -> f 0 = None. -Proof. - intros f Hhigh; destruct (f 0) eqn:E; [| reflexivity]. - exfalso; apply (high_nonzero 0); [apply Hhigh; congruence | reflexivity]. -Qed. - -(** Rotation permutes the node list, so every node reachable from the initial - layout still lies below 8. Both families need this to know that the four - addresses a rotation writes are inside the queue. *) -Lemma ns1_low: forall x, In x ns1 -> x < 7. -Proof. unfold ns1; cbn; intros x H; intuition lia. Qed. - -(** ** Instantiating the compatibility conditions from an address bound. - - Every frame variant is described by "I allocate only addresses at least - 8"; the owned queue lives below 8 ([Layout.h1_low]). These two lemmas turn - that numeric statement into the two compatibility conditions, once. *) - -Lemma qrepX1: qrepX hdr1 ns1 vs1 h1. -Proof. split; [apply qrep1 | apply qex1]. Qed. - diff --git a/examples/CSL/NegativeTests.v b/examples/CSL/NegativeTests.v deleted file mode 100644 index d56877b..0000000 --- a/examples/CSL/NegativeTests.v +++ /dev/null @@ -1,109 +0,0 @@ -From Stdlib Require Import List. -From TICL Require Import - Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer - ICTree.Interp.State.Mod ICTree.Interp.Yield.RoundRobin - ICTree.Logic.AG ICTree.Logic.Trans Logic.Core. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Recurrence - Lang.CSL.Queue.Alternating Lang.CSL.Queue.Program Lang.CSL.Queue.Ticl - Lang.CSL.Queue.Operations. -From examples Require Import CSL.Layout CSL.Overlap. - -Import ICtree ICTreeNotations TiclNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope ticl_scope. -Local Open Scope list_scope. - -(* Ownership controls retain their original statements in CSL.Overlap: - overlap_rejected, overlap_frame_not_preserved, null_frame_disjoint_but_bad. - Sequential controls live in Lang.CSL.Queue.Recurrence and do not quantify - over concurrent pools. Lang.CSL.Queue.Alternating.sfresh_excludes_retained - rules out reusing an old tagged observation. *) - -Lemma empty_heap_parallel_stuck : - run_rr (parallel_queues 2 10) hemp 0 ~ - (stuck : ictreeW SObs (unit * SSig)). -Proof. - unfold parallel_queues; rewrite run_rr_fork_bind. - change (interp_schedule_rr sh 2 (queue_workers 2 10 false false) - (Some (queue_slot 0)) 0 (hemp,0) ~ - (stuck : ictreeW SObs (unit * SSig))). - etransitivity; [apply queue_pool_turn|]. - assert (Hfault : interp_state sh (turn 1 2) (hemp,0) ≅ - (stuck : ictreeW SObs (unit * SSig))). - { - unfold turn, turnk, queue_turn. - etransitivity; [apply interp_state_bind|]. - lazymatch goal with - | |- (interp_state sh (heap_read (E:=sE) 3) (hemp,0) >>= ?next) ≅ _ => - etransitivity; - [ apply equ_clo_bind with (S := eq) (k2 := next); - [exact (sinterp_srd_stuck 3 hemp 0 eq_refl) | intros x y <-; reflexivity] - | apply bind_stuck_equ ] - end. - } - lazymatch goal with - | |- (interp_state sh ?p ?s >>= ?kont) ~ _ => - let Hwhole := fresh "Hwhole" in - assert (Hwhole : (interp_state sh p s >>= kont) ≅ - (stuck : ictreeW SObs (unit * SSig))) by - (etransitivity; - [apply equ_clo_bind with (S := eq) (k2 := kont); - [exact Hfault | intros x y <-; reflexivity] - | apply bind_stuck_equ]); - eapply equ_clos_sbisim_goal; [exact Hwhole | reflexivity | reflexivity] - end. -Qed. - -Local Typeclasses Transparent equ sbisim. - -Lemma empty_heap_parallel_no_recurrence : - ~ <( {run_rr (parallel_queues 2 10) hemp 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. - rewrite empty_heap_parallel_stuck. - apply ag_stuck. -Qed. - -Lemma allocated_empty_queue_stuck : - run_rr (allocated_parallel_queues [] [8]) hemp 0 ~ - (stuck : ictreeW SObs (unit * SSig)). -Proof. - destruct (run_rr_allocated_parallel [] [8] 0) - as (u & v & h & Finite & Owned & Run). - destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). - destruct H1 as (_ & Hhead & _ & _ & Hnull & _). - change (h (S u) = Some 0) in Hhead. - rewrite Run; unfold parallel_queues; rewrite run_rr_fork_bind. - change (interp_schedule_rr sh 2 (queue_workers u v false false) - (Some (queue_slot 0)) 0 (h,0) ~ - (stuck : ictreeW SObs (unit * SSig))). - etransitivity; [apply queue_pool_turn |]. - assert (Hfault : interp_state sh (turn 1 u) (h,0) ~ - (stuck : ictreeW SObs (unit * SSig))). - { unfold turn, turnk, queue_turn. - etransitivity; [eapply sinterp_rd; exact Hhead |]. - eapply equ_clos_sbisim_goal; [apply interp_state_bind | reflexivity |]. - lazymatch goal with - | |- (interp_state sh (heap_read (E:=sE) 0) (h,0) >>= ?next) ~ _ => - eapply equ_clos_sbisim_goal; - [ etransitivity; - [ apply equ_clo_bind with (S := eq) (k2 := next); - [exact (sinterp_srd_stuck 0 h 0 Hnull) | intros x y <-; reflexivity] - | apply bind_stuck_equ ] - | reflexivity | reflexivity ] - end. } - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hfault | intro result; reflexivity] |] - end. - eapply equ_clos_sbisim_goal; [apply bind_stuck_equ | reflexivity | reflexivity]. -Qed. - -Lemma allocated_empty_queue_no_recurrence : - ~ <( {run_rr (allocated_parallel_queues [] [8]) hemp 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. - rewrite allocated_empty_queue_stuck; apply ag_stuck. -Qed. diff --git a/examples/CSL/Overlap.v b/examples/CSL/Overlap.v index 2a03ac8..cd43d45 100644 --- a/examples/CSL/Overlap.v +++ b/examples/CSL/Overlap.v @@ -12,6 +12,8 @@ showing that the conclusion the frame rule would license is actually false. + The witness queue (header 2, nodes [4;6], payloads [7;9]) and the two + candidate frames are section [Let]s, discharged into the statements. This file is frame-variant independent. *) From Stdlib Require Import @@ -20,27 +22,41 @@ From Stdlib Require Import Arith.PeanoNat. From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace - Lang.CSL.Queue.Frame. -From examples Require Import CSL.Layout. + Lang.CSL.Queue.Frame Lang.CSL.Queue.Layout. Import ListNotations. Local Open Scope list_scope. -(** ** C1: overlap *) +Section Overlap. +Let h1 : Heap := qheap 2 [4;6] [7;9]. (** The candidate frame claims address 3, which is the queue's HEAD POINTER - cell -- squarely inside [qcells hdr1 ns1]. *) -Definition fbad : Heap := Pcm.hsingle 3 42. + cell -- squarely inside [qcells 2 [4;6]]. *) +Let fbad : Heap := hsingle 3 42. +(** The candidate frame allocates address 0, which the language's + representation uses as the end-of-list terminator. *) +Let fnull : Heap := hsingle 0 1. + +Local Lemma qwf1 : qwf 2 [4;6]. +Proof. + split; [| split]. + - repeat (apply NoDup_cons; [cbn; intuition congruence |]); apply NoDup_nil. + - cbn; intuition congruence. + - cbn; intros x y Hx Hy; intuition lia. +Qed. -Lemma three_in_footprint: In 3 (qcells hdr1 ns1). -Proof. unfold hdr1, ns1, qcells; cbn; tauto. Qed. +Local Lemma qrep1 : qrep 2 [4;6] [7;9] h1. +Proof. apply qheap_qrep; [apply qwf1 | reflexivity | discriminate]. Qed. + +(** ** C1: overlap *) (** (a) The compatibility check rejects it. *) Theorem overlap_rejected: ~ hdisj h1 fbad. Proof. intro Hd; destruct (Hd 3) as [H | H]. - - apply (qrep_fp hdr1 ns1 vs1 h1 qrep1 3 three_in_footprint); exact H. - - unfold fbad, Pcm.hsingle in H; cbn in H; discriminate. + - assert (Hin : In 3 (qcells 2 [4;6])) by (unfold qcells; cbn; tauto). + apply (qrep_fp 2 [4;6] [7;9] h1 qrep1 3 Hin); exact H. + - unfold fbad, hsingle in H; cbn in H; discriminate. Qed. (** (b) ...and the conclusion it would license is FALSE. The cell the @@ -48,56 +64,40 @@ Qed. assertion about it can be carried across the queue's execution. This is what makes [hdisj] a genuine hypothesis rather than a convenience: the failure is semantic, not a stuck proof. *) -Lemma rot_changes_head_pointer: qstep hdr1 ns1 h1 3 = Some 6 /\ h1 3 = Some 4. +Local Lemma rot_changes_head_pointer : qstep 2 [4;6] h1 3 = Some 6 /\ h1 3 = Some 4. Proof. split; reflexivity. Qed. Theorem overlap_frame_not_preserved: - cellsat [(3, 4)] h1 /\ ~ cellsat [(3, 4)] (qstep hdr1 ns1 h1). + cellsat [(3, 4)] h1 /\ ~ cellsat [(3, 4)] (qstep 2 [4;6] h1). Proof. split. - unfold cellsat; repeat constructor. - intro H; unfold cellsat in H; rewrite Forall_forall in H. - specialize (H (3, 4) (in_eq _ _)); cbn in H; discriminate. -Qed. - -(** For contrast, the SAME shape of assertion about a cell outside the - footprint is preserved -- so the refutation above is about overlap and not - about [cellsat] being unpreservable in general. *) -Theorem disjoint_cell_is_preserved: forall n a v, - high a -> - cellsat [(a, v)] h1 -> cellsat [(a, v)] (qstepN hdr1 n ns1 h1). -Proof. - intros n a v Ha H; eapply cellsat_agree; [| exact H]. - intros p Hp; cbn in Hp; destruct Hp as [E | []]; rewrite <- E; cbn. - apply (qstepN_agree n hdr1 ns1 vs1 h1 qrep1 ns1_nonnil). - intro C; apply (high_not_low a); [exact Ha | now apply qcells1_low]. + specialize (H (3, 4) (in_eq _ _)); cbn [fst snd] in H. + rewrite (proj1 rot_changes_head_pointer) in H; discriminate. Qed. (** ** C2: the null address *) -(** The candidate frame allocates address 0, which the language's - representation uses as the end-of-list terminator. *) -Definition fnull : Heap := Pcm.hsingle 0 1. - (** (a) The compatibility check rejects it. *) Theorem null_frame_rejected: fnull 0 <> None. -Proof. unfold fnull, Pcm.hsingle; cbn; discriminate. Qed. +Proof. unfold fnull, hsingle; cbn; discriminate. Qed. (** (b) ...and the conclusion it would license is FALSE: the extended heap is not a representation of the queue at all, so the frozen recurrence theorem does not even apply to it. [hdisj h1 fnull] DOES hold, so this is a condition that disjointness alone does not supply. *) Theorem null_frame_disjoint_but_bad: - hdisj h1 fnull /\ ~ qrep hdr1 ns1 vs1 (hunion h1 fnull). + hdisj h1 fnull /\ ~ qrep 2 [4;6] [7;9] (hunion h1 fnull). Proof. split. - intro x; destruct (h1 x) eqn:E; [| now left]. - right; unfold fnull, Pcm.hsingle. + right; unfold fnull, hsingle. destruct (Nat.eq_dec 0 x) as [Ex | Hne]; [| reflexivity]. exfalso; rewrite <- Ex in E. - pose proof (qrep_null hdr1 ns1 vs1 h1 qrep1) as H0; congruence. + pose proof (qrep_null 2 [4;6] [7;9] h1 qrep1) as H0; congruence. - intro Hq; pose proof (qrep_null _ _ _ _ Hq) as H0. - unfold hunion, fnull, Pcm.hsingle in H0; cbn in H0; discriminate. + unfold hunion, fnull, hsingle in H0; cbn in H0; discriminate. Qed. (** ** The two conditions are independent @@ -113,3 +113,5 @@ Proof. - split; [reflexivity | apply overlap_rejected]. - split; [apply (proj1 null_frame_disjoint_but_bad) | apply null_frame_rejected]. Qed. + +End Overlap. diff --git a/examples/CSL/PcmTests.v b/examples/CSL/PcmTests.v deleted file mode 100644 index b3be599..0000000 --- a/examples/CSL/PcmTests.v +++ /dev/null @@ -1,30 +0,0 @@ -From Stdlib Require Import Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL.Pcm. - -Lemma same_cell_cannot_separate a v w h : - ~ asep (pto a v) (pto a w) h. -Proof. apply Pcm.pto_sep_same_false. Qed. - -Lemma distinct_cells_separate : - asep (pto 2 7) (pto 4 9) - (hunion (Pcm.hsingle 2 7) (Pcm.hsingle 4 9)). -Proof. apply Pcm.pto_sep_distinct; discriminate. Qed. - -Lemma block_overlap_rejected : - forall h, ~ asep (block_pto 1 2) (pto 2 9) h. -Proof. - intros h (b & p & D & E & B & P). - pose proof (B 2) as B2; change (b 2 = Some 0) in B2. - pose proof (pto_lookup 2 9 p P) as P2. - destruct (D 2); congruence. -Qed. - -Lemma allocated_block_frame : - asep (block_pto 3 2) (pto 2 9) - (hunion (hblock 3 2) (Pcm.hsingle 2 9)). -Proof. - apply allocated_block_sep. - - intros offset O; unfold Pcm.hsingle; destruct (Nat.eq_dec 2 (3 + offset)); - [lia | reflexivity]. - - apply heq_refl. -Qed. diff --git a/examples/CSL/QueueTests.v b/examples/CSL/QueueTests.v deleted file mode 100644 index 70909d2..0000000 --- a/examples/CSL/QueueTests.v +++ /dev/null @@ -1,337 +0,0 @@ -From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. -From TICL Require Import - Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer - ICTree.Interp.State.Mod ICTree.Logic.Trans Logic.Core - ICTree.Events.Yield ICTree.Interp.Yield.RoundRobin Utils.Vectors. -From TICL Require Import Lang.CSL.Queue. -From examples Require Import CSL.Layout. - -Import ICtree ICTreeNotations TiclNotations VectorNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope ticl_scope. -Local Open Scope list_scope. -Local Open Scope fin_vector_scope. -Local Typeclasses Opaque equ sbisim. - -Definition demo_h1 := qheap 2 [4;6] [7;9]. -Definition demo_h2 := qheap 10 [12] [8]. -Definition demo_heap := hunion demo_h1 demo_h2. -Definition duplicate_heap := - hunion (qheap 2 [4;6] [7;7]) (qheap 10 [12] [7]). - -Lemma demo_queue2_aligned : qwf 10 [12]. -Proof. - apply qwf_aligned. - - repeat (apply NoDup_cons; [cbn; intuition congruence |]); apply NoDup_nil. - - cbn; intuition congruence. - - repeat constructor; [exists 5 | exists 6]; reflexivity. -Qed. - -Lemma demo_h1_owned : qrepX 2 [4;6] [7;9] demo_h1. -Proof. exact Layout.qrepX1. Qed. - -Lemma demo_h2_owned : qrepX 10 [12] [8] demo_h2. -Proof. - split; [apply qheap_qrep; [apply demo_queue2_aligned | reflexivity | discriminate] - | apply qheap_qex]. -Qed. - -Lemma demo_disjoint xs ys : hdisj (qheap 2 [4;6] xs) (qheap 10 [12] ys). -Proof. - intro x. - destruct (qheap 2 [4;6] xs x) eqn:H1; [| now left]. - destruct (qheap 10 [12] ys x) eqn:H2; [| now right]. - exfalso. - pose proof (qheap_qex 2 [4;6] xs x ltac:(congruence)) as F1. - pose proof (qheap_qex 10 [12] ys x ltac:(congruence)) as F2. - cbn in F1, F2; intuition congruence. -Qed. - -Lemma demo_owned : owned_queues 2 [4;6] [7;9] 10 [12] [8] demo_heap. -Proof. - exists demo_h1, demo_h2. - split; [apply demo_disjoint |]. - split; [intro x; reflexivity |]. - split; [apply demo_h1_owned | apply demo_h2_owned]. -Qed. - -Lemma duplicate_owned : - owned_queues 2 [4;6] [7;7] 10 [12] [7] duplicate_heap. -Proof. - exists (qheap 2 [4;6] [7;7]), (qheap 10 [12] [7]). - split; [apply demo_disjoint |]. - split; [intro x; reflexivity |]. - split; split; try apply qheap_qex. - - apply qheap_qrep; [exact Layout.qwf1 | reflexivity | discriminate]. - - apply qheap_qrep; [apply demo_queue2_aligned | reflexivity | discriminate]. -Qed. - -Local Ltac reference_turn Hq := - lazymatch type of Hq with - | qrep ?hdr (?a :: ?ns) (?pv :: ?vs) ?h => - lazymatch goal with - | |- srun ?u ?v ?n h ?c ~ ?rhs => - let Hbody := constr:(sbody_spec u v n a ns pv vs h c Hq) in - unfold srun, sched at 1; - rewrite interp_state_unfold_iter; - cbv beta; - match goal with - | |- sbisim _ (ICtree.bind _ ?k) _ => - eapply Transitive_sbisim; - [ eapply sbisim_clo_bind_eq with (k2 := k); - [ exact Hbody | intros ?; reflexivity ] - | ] - end; - rewrite bind_bind; - apply sbisim_clo_bind_eq; [reflexivity | intros []]; - rewrite bind_ret_l, sb_guard; - lazymatch goal with - | |- _ ~ ?tail => - change (srun u v (S n) (qstep hdr (a :: ns) h) (S c) ~ tail) - end - end - end. - -Local Lemma fixed_layout_four_pop u a b v d h x y z : - qrep u [a;b] [x;y] h -> qrep v [d] [z] h -> Disj u [a;b] v [d] -> - exists rest : ictreeW SObs (unit * SSig), - run_rr (parallel_queues u v) h 0 ~ - (log (SPop 1 x 0);; log (SPop 2 z 1);; - log (SPop 1 y 2);; log (SPop 2 z 3);; rest). -Proof. - intros H1 H2 Hd. - assert (F1 : find x [x;y] = Some 0) by (cbn [find]; now rewrite Nat.eqb_refl). - assert (F2 : find z [z] = Some 0) by (cbn [find]; now rewrite Nat.eqb_refl). - pose proof (qstep_qrep u [a;b] [x;y] h H1 ltac:(discriminate)) as H1a. - change (qrep u [b;a] [y;x] (qstep u [a;b] h)) in H1a. - pose proof (foreign_pres u [a;b] [x;y] v [d] [z] h - H1 ltac:(discriminate) H2 Hd) as H2a. - pose proof (Disj_rotl_l u [a;b] v [d] ltac:(discriminate) Hd) as Hda. - change (Disj u [b;a] v [d]) in Hda. - pose proof (foreign_pres v [d] [z] u [b;a] [y;x] - (qstep u [a;b] h) H2a ltac:(discriminate) H1a - (Disj_sym u [b;a] v [d] Hda)) as H1b. - pose proof (qstep_qrep v [d] [z] (qstep u [a;b] h) - H2a ltac:(discriminate)) as H2b. - change (qrep v [d] [z] (qstep v [d] (qstep u [a;b] h))) in H2b. - pose proof (foreign_pres u [b;a] [y;x] v [d] [z] - (qstep v [d] (qstep u [a;b] h)) H1b ltac:(discriminate) H2b Hda) as H2c. - exists (srun u v 4 - (qstep v [d] (qstep u [b;a] - (qstep v [d] (qstep u [a;b] h)))) 4). - etransitivity. - - exact (run_rr_parallel_bisim u v h 0). - - reference_turn H1. - reference_turn H2a. - reference_turn H1b. - reference_turn H2c. - reflexivity. -Qed. - -Lemma demo_four_pop_prefix : exists rest : ictreeW SObs (unit * SSig), - run_rr (parallel_queues 2 10) demo_heap 0 ~ - (log (SPop 1 7 0);; log (SPop 2 8 1);; - log (SPop 1 9 2);; log (SPop 2 8 3);; rest). -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). - apply (fixed_layout_four_pop 2 4 6 10 12); assumption. -Qed. - -Lemma duplicate_four_pop_prefix : exists rest : ictreeW SObs (unit * SSig), - run_rr (parallel_queues 2 10) duplicate_heap 0 ~ - (log (SPop 1 7 0);; log (SPop 2 7 1);; - log (SPop 1 7 2);; log (SPop 2 7 3);; rest). -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). - apply (fixed_layout_four_pop 2 4 6 10 12); assumption. -Qed. - -Lemma demo_queue1_recurs : - <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr 2 10 7 8 demo_heap 0 - [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma demo_queue2_recurs : - <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure - |= AG (AF visW {spopped 2 8}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_q2 2 10 7 8 demo_heap 0 - [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma demo_queue1_fresh k : - <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure - |= AG (AF visW {spopped_after 1 7 k}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_fresh 2 10 7 8 k demo_heap 0 - [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma demo_queue2_fresh k : - <( {run_rr (parallel_queues 2 10) demo_heap 0}, Pure - |= AG (AF visW {spopped_after 2 8 k}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ demo_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_q2_fresh 2 10 7 8 k demo_heap 0 - [4;6] [7;9] [12] [8] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma duplicate_queue1_recurs : - <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr 2 10 7 7 duplicate_heap 0 - [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma duplicate_queue2_recurs : - <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure - |= AG (AF visW {spopped 2 7}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_q2 2 10 7 7 duplicate_heap 0 - [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma duplicate_queue1_fresh k : - <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure - |= AG (AF visW {spopped_after 1 7 k}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_fresh 2 10 7 7 k duplicate_heap 0 - [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma duplicate_queue2_fresh k : - <( {run_rr (parallel_queues 2 10) duplicate_heap 0}, Pure - |= AG (AF visW {spopped_after 2 7 k}) )>. -Proof. - destruct (owned_queues_sound _ _ _ _ _ _ _ duplicate_owned) as (H1 & H2 & Hd). - exact (rotate_agaf_pop_rr_q2_fresh 2 10 7 7 k duplicate_heap 0 - [4;6] [7;7] [12] [7] 0 0 H1 H2 Hd eq_refl eq_refl). -Qed. - -Lemma allocated_demo_four_pop_prefix : - exists rest : ictreeW SObs (unit * SSig), - run_rr (allocated_parallel_queues [7;9] [8]) hemp 0 ~ - (log (SPop 1 7 0);; log (SPop 2 8 1);; - log (SPop 1 9 2);; log (SPop 2 8 3);; rest). -Proof. - destruct (run_rr_allocated_parallel [7;9] [8] 0) - as (u & v & h & Finite & Owned & Run). - destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). - destruct (fixed_layout_four_pop _ _ _ _ _ _ _ _ _ H1 H2 Hd) as (rest & Prefix). - exists rest; etransitivity; [exact Run | exact Prefix]. -Qed. - -Lemma allocated_duplicate_four_pop_prefix : - exists rest : ictreeW SObs (unit * SSig), - run_rr (allocated_parallel_queues [7;7] [7]) hemp 0 ~ - (log (SPop 1 7 0);; log (SPop 2 7 1);; - log (SPop 1 7 2);; log (SPop 2 7 3);; rest). -Proof. - destruct (run_rr_allocated_parallel [7;7] [7] 0) - as (u & v & h & Finite & Owned & Run). - destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). - destruct (fixed_layout_four_pop _ _ _ _ _ _ _ _ _ H1 H2 Hd) as (rest & Prefix). - exists rest; etransitivity; [exact Run | exact Prefix]. -Qed. - -Lemma allocated_demo_queue1_recurs : - <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. exact (rotate_agaf_pop_alloc [7;9] [8] 7 8 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_demo_queue2_recurs : - <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure - |= AG (AF visW {spopped 2 8}) )>. -Proof. exact (rotate_agaf_pop_alloc_q2 [7;9] [8] 7 8 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_demo_queue1_fresh k : - <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure - |= AG (AF visW {spopped_after 1 7 k}) )>. -Proof. exact (rotate_agaf_pop_alloc_fresh [7;9] [8] 7 8 k 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_demo_queue2_fresh k : - <( {run_rr (allocated_parallel_queues [7;9] [8]) hemp 0}, Pure - |= AG (AF visW {spopped_after 2 8 k}) )>. -Proof. exact (rotate_agaf_pop_alloc_q2_fresh [7;9] [8] 7 8 k 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_duplicate_queue1_recurs : - <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure - |= AG (AF visW {spopped 1 7}) )>. -Proof. exact (rotate_agaf_pop_alloc [7;7] [7] 7 7 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_duplicate_queue2_recurs : - <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure - |= AG (AF visW {spopped 2 7}) )>. -Proof. exact (rotate_agaf_pop_alloc_q2 [7;7] [7] 7 7 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_duplicate_queue1_fresh k : - <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure - |= AG (AF visW {spopped_after 1 7 k}) )>. -Proof. exact (rotate_agaf_pop_alloc_fresh [7;7] [7] 7 7 k 0 0 0 eq_refl eq_refl). Qed. - -Lemma allocated_duplicate_queue2_fresh k : - <( {run_rr (allocated_parallel_queues [7;7] [7]) hemp 0}, Pure - |= AG (AF visW {spopped_after 2 7 k}) )>. -Proof. exact (rotate_agaf_pop_alloc_q2_fresh [7;7] [7] 7 7 k 0 0 0 eq_refl eq_refl). Qed. - - -Definition initialized_queue_probe : CProg unit := - CBind (new_queue [7;9]) (fun hdr => - CBind (CRead (S hdr)) (fun head => - CBind (CRead head) (fun value => CEmit hdr value))). - -Lemma initialized_queue_probe_seen : - run_rr initialized_queue_probe hemp 0 ~ - (log (SPop 1 7 0);; Ret (tt,(new_queue_heap 1 [7;9] hemp,1))). -Proof. - unfold run_rr, initialized_queue_probe. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (new_queue [7;9]) (fun hdr => - CBind (CRead (S hdr)) (fun head => - CBind (CRead head) (fun value => CEmit hdr value)))) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 1 7 0);; Ret (tt,(new_queue_heap 1 [7;9] hemp,1)))). - rewrite interp_rr_bind, interp_rr_new_queue_empty. - rewrite interp_rr_bind, interp_rr_read_value with (value:=3) by reflexivity. - rewrite interp_rr_bind, interp_rr_read_value with (value:=7) by reflexivity. - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. - -Definition empty_queue_probe : CProg unit := - CBind (new_queue []) (fun hdr => - CBind (CRead hdr) (fun tail => - CBind (CRead (S hdr)) (fun head => CEmit tail head))). - -Lemma empty_queue_probe_seen : - run_rr empty_queue_probe hemp 0 ~ - (log (SPop 0 0 0);; Ret (tt,(new_queue_heap 1 [] hemp,1))). -Proof. - unfold run_rr, empty_queue_probe. - change (interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (new_queue []) (fun hdr => - CBind (CRead hdr) (fun tail => - CBind (CRead (S hdr)) (fun head => CEmit tail head)))) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ - (log (SPop 0 0 0);; Ret (tt,(new_queue_heap 1 [] hemp,1)))). - rewrite interp_rr_bind, interp_rr_new_queue_empty. - rewrite interp_rr_bind, interp_rr_read_value with (value:=0) by reflexivity. - rewrite interp_rr_bind, interp_rr_read_value with (value:=0) by reflexivity. - rewrite interp_rr_emit_log. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - finish_pool. -Qed. - diff --git a/examples/CSL/README.md b/examples/CSL/README.md index 488ec4e..410a9f1 100644 --- a/examples/CSL/README.md +++ b/examples/CSL/README.md @@ -21,7 +21,9 @@ re-export files. | `ICTree.Logic.Bind` | Five exact `*_log_iff` rules, shared by the CSL emit matrix | | `ICTree.Logic.State` | Ghost-ranked `aul_state_iter_ghost` over arbitrary handlers | | `ICTree.Interp.State.Mod` | Generic `interp_state_trigger_bind` normalization | -| `Utils.Relations` | One lexicographic construction, finite first-index search, interval counts, and infinite-occurrence facts | +| `Utils.Relations` | Lexicographic ranks, bounded predicate search, interval counts, and infinite-occurrence facts | +| `Utils.Lists` | Comparator-parametric first-match search and shared list-rotation lemmas | +| `Utils.Vectors` | Pointwise update/removal/cons laws shared by pool equivalence and bisimulation | | `Lang.CSL.Heap` | Checked heap laws shared by both observation alphabets | | `Lang.CSL.Segments` | Exact and bisimilar first-yield segments, guard transport, arbitrary-pool ND/RR equations | | `Lang.CSL.Queue` | Queue representation/layout, one polymorphic rotation implementation and proof, framing, composition, source programs, and recurrence | @@ -38,6 +40,22 @@ matrix, log-prefix rules, and state-iteration rules. Queue recurrence shares the same ghost-ranked rule with active queue composition; it does not reprove the underlying fixed point. +The abstract and heap-backed queues use the same `find_index` implementation. +Natural payloads pass `Nat.eqb`; the abstract queue passes its existing +`@rel_dec T eq HDec`. Equality-dependent search lemmas take comparator +correctness explicitly. Repeated payloads select their **first** occurrence; +rotation preserves existence without claiming that duplicate payloads have a +unique position. `List.hd default list` replaces the old `hdf list default`. + +Duplicate vector inversion and unused triple-projection well-foundedness +helpers were removed in favor of `inversion_0` and Stdlib's `wf_inverse_image`. +Scheduler parity and allocator cursor proofs share `rr_pick_mod_congr`. +Obsolete allocator transport/specialization helpers were removed, but unused +public structural rules and substantive verification goals remain intentional +proof roots. In particular, the 130 CSL rules, `aur_schedule_update`, +`free_local_disj`, `free_local_frame`, and allocator safety/liveness results are +not classified as dead merely because no other theorem references them. + ## Actual execution and proof boundary The source execution is: @@ -96,7 +114,7 @@ It also covers empty input lists. No initialized heap is assumed. - `rotate_agaf_pop_alloc_fresh`: queue 1 recurrence at every inclusive index bound. - `rotate_agaf_pop_alloc_q2_fresh`: queue 2 recurrence at every inclusive index bound. -These four theorems require only one successful `find` premise for each payload +These four theorems require one successful `find_index Nat.eqb` premise per payload list, not representation, disjointness, or preallocated-heap premises. They transport the existing worker recurrence through the proved initialization bisimulation. The lower-level statements remain: @@ -228,13 +246,13 @@ S = /home/eioannidis/ticl-sl/spark_submission/experiments/separate-active-compos | Source | Current owner | | --- | --- | -| `P/Pcm.v`, complete | `theories/Lang/CSL/Pcm.v` | +| `P/Pcm.v`, complete | `theories/Utils/Pcm.v` (interface), `theories/Events/HeapModel.v` (heap model) | | `S/SLang.v`, heap prefix | `theories/Lang/CSL/Heap.v` | | `Q/HeapQ.v` | `theories/Lang/CSL/Queue/Representation.v` | | `Q/QLang.v` | `theories/Lang/CSL/Queue/Sequential.v`, shared `Operations.v` | | `Q/Recurrence.v` | `theories/Lang/CSL/Queue/Recurrence.v`, `ICTree/Logic/State.v`, `Utils/Relations.v` | | `Q/Trace.v` | `theories/Lang/CSL/Queue/Trace.v` | -| `Q/Layout.v` | `theories/Lang/CSL/Queue/Layout.v`; concrete fixtures in `examples/CSL/Layout.v` | +| `Q/Layout.v` | `theories/Lang/CSL/Queue/Layout.v`; stride-two node geometry in `theories/Events/HeapModel.v` | | `Q/Frame.v` | `theories/Lang/CSL/Queue/Frame.v` | | `S/Sep2.v` | `theories/Lang/CSL/Queue/Separation.v` | | `S/SLang.v`, turn/scheduler suffix | `theories/Lang/CSL/Queue/Alternating.v`, shared `Operations.v` | @@ -266,76 +284,31 @@ donor dependency and changes no generic scheduler or refiner API. ## Behavioral verification -The existing operational regression modules and the shared-event/temporal suites compile: - -- `PcmTests`: same-cell and overlapping-block ownership exclusion, distinct-cell - separation, and the actual fresh-block split beside an unchanged points-to frame. -- `HeapTests`: checked access/fault behavior, exact emit observation/counter, - zero-initialized allocation, whole-block first-fit rejection of partial overlap, - zero-size faults, and silent divergence on a saturated infinite heap. -- `RoundRobinTests`: modulo choices, returned cursors, singleton-branch cursor - advance, actual scheduler selection, and a language-independent shared state - counter with complete trace `1,11,12,22` and final state 22. -- `InterpTests`: a child sees the parent's write, a scoped child skips both - remaining loop body and post-loop continuation, and the finite alternating - tagged trace. Allocation tests read a fresh zero cell and allocate across two - active threads: parent base 1, child base 3, emit indices 0 and 1. All contracts - include the final returned shared state. -- `QueueTests`: both literal preallocated fixtures and dynamically initialized - programs on `hemp`, with both tags' ordinary/fresh recurrence and four-pop - prefixes. The demo prefix is `(1,7,0),(2,8,1),(1,9,2),(2,8,3)`. Duplicate - payloads still produce tags `1,2,1,2` at indices `0,1,2,3`. Source probes read - the newly initialized `[7;9]` queue and both zero pointers of an empty queue. -- `NegativeTests`: retains the ownership/sequential/freshness controls. The - low-level `parallel_queues` still faults on `hemp`. Dynamically initializing - `[]` and `[8]` succeeds, but the first worker then faults on its null payload - read; that execution is `stuck` and fails queue-1 recurrence. Sequential - controls are not claims about arbitrary concurrent pools. -- `examples/HeapEventTests`: allocation/free/reallocation through shared triggers, - single-cell deletion with a surviving block cell and frame, absent free, - checked read-after-free, all 15 trigger embeddings, and the distinct HeapImp - zero-allocation/write/free/CAS instrumentation policies. -- `TiclTests`: 23 temporal consumers using the new structural cells, including - first-fit and finite allocation, shared write/CAS ordering, scoped child halt, - universal ND versus cursor-dependent RR selection, productive and silent loops, - strong termination/fault controls, immediate AU matching, and one-step raw free - completion. Final heap postconditions use pointwise `heq`. - -The shared-event and structural-rule extension passed its event-only, backend, -interpreter/helper, temporal-interface, and consumer compilation gates, followed -by `dune build`. All 130 public names were individually checked after importing -only the `Lang.CSL` umbrella. The current focused checks are: - -```sh -dune build _build/default/examples/HeapEventTests.vo \ - _build/default/examples/CSL/TiclTests.vo -dune build -``` - -The initial baseline, every dependency gate, and the final `make build` passed. -The allocation extension rejected both requested temporary mutations with -nonzero proof compilation status: - -1. Replacing `block_freeb`'s recursive `None` branch with `true` failed in - `Heap.block_freeb_spec`, before the heap/source regression modules. -2. Replacing only `new_queue`'s `CAlloc` prefix with `CRet 1` failed in - `Program.interp_rr_new_queue` at the source allocation equation, before - `QueueTests`. - -Both correct bodies were restored immediately. Afterwards: - -```sh -dune build examples/CSL/PcmTests.vo examples/CSL/HeapTests.vo \ - examples/CSL/RoundRobinTests.vo examples/CSL/InterpTests.vo \ - examples/CSL/QueueTests.vo examples/CSL/NegativeTests.vo -make build -``` - -Both commands exited zero. No commit or index modification was performed. - -The earlier scheduler migration separately recorded rejection of `rr_pick` -returning `Fin.F1` in `rr_pick_even`, and per-thread `run_rr` interpretation in -`run_rr_unfold`. Those generic mechanisms were not mutated for this extension. +Verification uses the actual proof development and its source programs; there +are no separate test, smoke, or fixture modules. The former regression +consumers were reduced to general statements in their semantic owners: + +- `Events.HeapModel`: `block_pto_overlap_false` (a block and an overlapping + points-to cannot separate) and `hfree_absent_noop` (freeing an absent cell is + pointwise the identity). +- `Lang.HeapImp.HeapImp`: the five `instr_heapimp_*` equations for zero + allocation, free, write, and successful/failed CAS. Same-value CAS still logs; + a mismatching CAS does not. +- `ICTree.Eq.Bind.equ_guard_stuck`: a tree raw-equivalent to its own guard is + raw-equivalent to `stuck`. +- `Lang.CSL.Ticl`: `run_{nd,rr}_emit_loop_ag` (a productive `CUntilNone` loop + satisfies `AG ⊤` in every not-done world) and `run_{nd,rr}_silent_loop_no_ag` + (a silent loop is `stuck`, hence fails `AG ⊤`), beside the unchanged 130 rules. +- `Lang.CSL.Queue.Program`: `parallel_queues_four_pop_bisim` (the exact first + four pops of any two represented, disjoint queues, then the reference loop; + payloads may repeat), `parallel_queues_hemp_stuck`, and + `allocated_parallel_queues_empty_stuck`; `Lang.CSL.Queue.Ticl` derives the two + corresponding `*_no_ag` results for an arbitrary formula. +- `examples/CSL/Overlap.v` and `examples/CSL/Allocator/Counterexamples.v` keep + their witness queue, heaps, scripts, and observation tables as section-local + `Let`s, discharged into the public statements. + +`dune build` compiles all of them. ## Trust-base audit @@ -350,8 +323,8 @@ paths, HQ dependencies, donor runtime paths, and layer violations. The structural-rule audit separately checked `anl_csl_nd_yield`, `anr_csl_rr_emit`, `aul_csl_nd_until_none`, `aur_csl_rr_cas`, `ag_csl_rr_until_none`, `aur_csl_nd_alloc_finite`, `ag_csl_rr_alloc_finite`, -`anr_csl_nd_heap_free`, `ag_csl_rr_heap_free`, `nd_emit_loop_ag`, and -`rr_emit_loop_ag` through `rocq_assumptions`. Each reports only the inherited +`anr_csl_nd_heap_free`, `ag_csl_rr_heap_free`, `run_nd_emit_loop_ag`, and +`run_rr_emit_loop_ag` through `rocq_assumptions`. Each reports only the inherited `FunctionalExtensionality.functional_extensionality_dep` and `Eqdep.Eq_rect_eq.eq_rect_eq`. No new axiom or unfinished proof command was introduced; the new heap postconditions do not identify functions by @@ -360,9 +333,12 @@ functional extensionality. The library extraction audit found `Utils.Relations.finite_first` closed under the global context. `ICTree.Logic.State.aul_state_iter_ghost` and `ICTree.Trace.rr_aligned_sbisim` use only inherited UIP. The generalized -`Lang.CSL.Segments.source_segment_scheduler_steps` uses inherited UIP and -dependent functional extensionality. Boolean-observation smoke proofs exercise -the promoted trace and AF-return rules independently of `SObs`. +`ICTree.Interp.Yield.Segments.segment_scheduler_steps` uses inherited UIP and +dependent functional extensionality. + +The list-search deduplication audit found `find_index_rotl_pres`, +`vector_replace_pointwise`, and `rr_pick_mod_congr` closed under the global +context. The previously recorded baseline `examples.Queue.Queue.rotate_agaf_pop` prints: @@ -405,8 +381,8 @@ The functional-extensionality dependency is inherited from the **pre-existing** `ICTree.Interp.Yield.SBisim.schedule_pool_proper`, whose `Print Assumptions` reports those same two axioms. That scheduler proof was not changed. `interp_schedule_rr_equ` consumes it as required by the pool-congruence API. -This is not an added heap-extensionality axiom: `Heap.upd_pcm` and -`Queue.owned_queues_sound` each print `Closed under the global context`. +This is not an added heap-extensionality axiom: `HeapModel.HeapCancellative` and +`Queue.Separation.owned_queues_sound` each print `Closed under the global context`. There is no new admitted constant, allocator-choice or finite-support oracle, assumed initialization correctness, fairness or recurrence axiom, or assumed program bisimulation. diff --git a/examples/CSL/RoundRobinTests.v b/examples/CSL/RoundRobinTests.v deleted file mode 100644 index 84a773b..0000000 --- a/examples/CSL/RoundRobinTests.v +++ /dev/null @@ -1,104 +0,0 @@ -From Stdlib Require Import Fin Vector. -From ExtLib Require Import Data.Monads.StateMonad. -From TICL Require Import - ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Events.Yield ICTree.Events.State ICTree.Events.Writer - ICTree.Interp.Refine ICTree.Interp.Yield.Mod - ICTree.Interp.Yield.RoundRobin Utils.Vectors. - -Import ICtree ICTreeNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. - -Lemma modulo_picks : - rr_pick 1 0 = Fin.F1 /\ - rr_pick 1 1 = Fin.FS Fin.F1 /\ - rr_pick 1 2 = Fin.F1 /\ - rr_pick 0 3 = Fin.F1. -Proof. repeat split; reflexivity. Qed. - -Lemma guard_retains_cursor : - runStateT (round_robin (Guard (Ret tt) : ictreeW nat unit)) 4 ≅ - Guard (Ret (tt,4)). -Proof. - change (refine_rr (Guard (Ret tt) : ictreeW nat unit) 4 ≅ Guard (Ret (tt,4))). - rewrite unfold_refine_rr; cbn [observe]. - apply guard_equ_node; rewrite unfold_refine_rr; reflexivity. -Qed. - -Lemma event_retains_cursor : - runStateT (round_robin (Vis (Log 7) (fun _ => Ret tt))) 4 ≅ - Vis (Log 7) (fun _ => Ret (tt,4)). -Proof. - change (refine_rr (Vis (Log 7) (fun _ => Ret tt)) 4 ≅ - Vis (Log 7) (fun _ => Ret (tt,4))). - rewrite unfold_refine_rr; cbn [observe]. - apply vis_equ_node; intros []; rewrite unfold_refine_rr; reflexivity. -Qed. - -Lemma singleton_branch_advances_cursor : - runStateT (round_robin (Br 0 (fun _ => Ret tt) : ictreeW nat unit)) 4 ≅ - Guard (Ret (tt,5)). -Proof. - change (refine_rr (Br 0 (fun _ => Ret tt) : ictreeW nat unit) 4 ≅ - Guard (Ret (tt,5))). - rewrite unfold_refine_rr; cbn [observe]. - apply guard_equ_node; rewrite unfold_refine_rr; reflexivity. -Qed. - -Lemma scheduled_two_selects {E : Type} {HE : Encode E} (ts : pool E 2) m : - refine_rr (schedule 2 ts None) m ≅ - Vis (inl Yield) (fun _ => - Guard (refine_rr (schedule 2 ts (Some (rr_pick 1 m))) (S m))). -Proof. - rewrite unfold_refine_rr, schedule_no_focus_nonempty. - apply vis_equ_node; intros []; rewrite unfold_refine_rr; reflexivity. -Qed. - -Definition raw_add (delta : nat) : thread (stateE nat) := - Vis (inr (inr Get)) (fun x => - Vis (inr (inr (Put ((x + delta)%nat)))) (fun _ => Ret tt)). -Definition counter_thread (delta : nat) : thread (stateE nat) := - raw_add delta;; Vis (inl Yield) (fun _ => raw_add delta). -Definition counter_fork : thread (stateE nat) := - Vis (inr (inl Fork)) - (fun child : bool => counter_thread (if child then 10 else 1)). - -Local Ltac counter_observe := - lazy [observe _observe Vector.nth Vector.replace Vector.caseS' raw_add - counter_thread ICtree.bind ICtree.subst' rr_pick]; reflexivity. - -Local Ltac counter_get := - erewrite interp_schedule_rr_user with (e := Get) by counter_observe; - cbn [h_stateW runStateT]; rewrite bind_ret_l. - -Local Ltac counter_put := - erewrite interp_schedule_rr_user by counter_observe; - cbn [h_stateW runStateT]; rewrite bind_bind; - apply sbisim_clo_bind_eq; [reflexivity|]; - intros []; rewrite bind_ret_l. - -Lemma shared_counter_round_robin : - interp_schedule_rr h_stateW 1 [counter_fork]%vector (Some Fin.F1) 0 0 ~ - (log 1;; log 11;; log 12;; log 22;; Ret (tt,22)). -Proof. - erewrite interp_schedule_rr_fork by reflexivity. - counter_get; counter_put. - erewrite interp_schedule_rr_yield by counter_observe. - rewrite interp_schedule_rr_select. - counter_get; counter_put. - erewrite interp_schedule_rr_yield by counter_observe. - rewrite interp_schedule_rr_select. - counter_get; counter_put. - erewrite interp_schedule_rr_ret by counter_observe. - change (interp_schedule_rr h_stateW 1 - ([raw_add 10; Ret tt]%vector -- Fin.FS Fin.F1) None 2 12 ~ - (log 22;; Ret (tt,22))). - rewrite vector_remove_tail, vector_remove_head. - rewrite interp_schedule_rr_select. - counter_get; counter_put. - erewrite interp_schedule_rr_ret by counter_observe. - change (interp_schedule_rr h_stateW 0 - ([Ret tt]%vector -- Fin.F1) None 3 22 ~ Ret (tt,22)). - rewrite vector_remove_head, interp_schedule_rr_empty; reflexivity. -Qed. diff --git a/examples/CSL/TiclTests.v b/examples/CSL/TiclTests.v deleted file mode 100644 index 79a6f0a..0000000 --- a/examples/CSL/TiclTests.v +++ /dev/null @@ -1,784 +0,0 @@ -From Stdlib Require Import Arith.PeanoNat Lia Fin Vector Program.Equality. -From Coinduction Require Import coinduction rel tactics. -From TICL Require Import - Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Events.Writer ICTree.Events.Yield ICTree.Events.Heap - ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin - ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep - Logic.Core Utils.Vectors. -From examples Require Import CSL.InterpTests. - -Import ICtree ICTreeNotations TiclNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. -Local Open Scope ticl_scope. - -Local Definition allocate_then_emit : CProg unit := - CBind (CAlloc 2) (fun base => CEmit 9 base). - -(** Allocation is silent; its emission and final return are distinct steps. *) - -Lemma rr_alloc_first_fit_ticl : - <[ {run_rr allocate_then_emit (Pcm.hsingle 2 99) 5}, Pure |= - AX (AX done {fun result w => - heq (fst (snd result)) (hunion (hblock 3 2) (Pcm.hsingle 2 99)) /\ - snd (snd result) = 6 /\ w = Obs (Log (SPop 9 3 5)) tt}) ]>. -Proof. - assert (Free : block_free (Pcm.hsingle 2 99) 3 2) - by (apply block_freeb_spec; reflexivity). - assert (First : forall j, Nat.lt 0 j -> Nat.lt j 3 -> - ~ block_free (Pcm.hsingle 2 99) j 2). - { intros j J L F; assert (j = 1 \/ j = 2) by lia. - destruct H; subst j; - [specialize (F 1 ltac:(lia)) | specialize (F 0 ltac:(lia))]; discriminate F. } - unfold run_rr. - change [denote allocate_then_emit]%vector with - ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). - unfold allocate_then_emit. - rewrite anr_csl_rr_bind. - rewrite anr_csl_rr_alloc with (base:=3) by (try lia; assumption). - rewrite anr_csl_rr_emit. - split. - - apply ticll_top; constructor. - - cbn beta iota. - erewrite interp_schedule_rr_ret by source_observe. - pool_simpl; rewrite vector_remove_head, interp_schedule_rr_empty. - apply axr_ret; [constructor |]. - cbn; split; [intro address; reflexivity | split; reflexivity]. -Qed. - -Lemma nd_alloc_finite_observed h c : heap_finite h -> - <( {run_nd allocate_then_emit h c}, Pure |= - AF (visW {fun o => stag o = 9 /\ sidx o = c /\ Nat.lt 0 (sval o)}) )>. -Proof. - intro Finite; unfold run_nd. - change [denote allocate_then_emit]%vector with - ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). - unfold allocate_then_emit. - rewrite aul_csl_nd_bind. - rewrite aul_csl_nd_alloc_finite by (try assumption; lia). - intros base Base Free First. - rewrite aul_csl_nd_emit. - right; split. - - apply ticll_top; constructor. - - cleft; apply ticll_vis; constructor; cbn; repeat split; auto. -Qed. - -Lemma rr_alloc_finite_observed h c : heap_finite h -> - <( {run_rr allocate_then_emit h c}, Pure |= - AF (visW {fun o => stag o = 9 /\ sidx o = c /\ Nat.lt 0 (sval o)}) )>. -Proof. - intro Finite; unfold run_rr. - change [denote allocate_then_emit]%vector with - ([Ret tt]%vector @ Fin.F1 := (denote_flow allocate_then_emit >>= fun _ => Ret tt)). - unfold allocate_then_emit. - rewrite aul_csl_rr_bind. - rewrite aul_csl_rr_alloc_finite by (try assumption; lia). - intros base Base Free First. - rewrite aul_csl_rr_emit. - right; split. - - apply ticll_top; constructor. - - cleft; apply ticll_vis; constructor; cbn; repeat split; auto. -Qed. - -(** Shared-state scheduling and scoped source continuations. *) - -Lemma rr_shared_write_ticl : - <[ {run_rr shared_write_program (Pcm.hsingle 4 0) 0}, Pure |= - AF (AX done {fun result w => - heq (fst (snd result)) (upd (Pcm.hsingle 4 0) 4 9) /\ - snd (snd result) = 1 /\ w = Obs (Log (SPop 2 9 0)) tt}) ]>. -Proof. - unfold run_rr. - change [denote shared_write_program]%vector with - ([Ret tt]%vector @ Fin.F1 := (denote_flow shared_write_program >>= fun _ => Ret tt)). - unfold shared_write_program. - rewrite aur_csl_rr_bind, aur_csl_rr_fork. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([denote (CBind (CRead 4) (fun v => CEmit 2 v)); Ret tt]%vector - @ Fin.FS Fin.F1 := - (denote_flow (CBind (CWrite 4 9) (fun _ => CYield)) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (Pcm.hsingle 4 0,0)}, Pure |= {formula} ]>) end. - rewrite aur_csl_rr_bind. - rewrite aur_csl_rr_write by discriminate. - rewrite aur_csl_rr_yield. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([Ret tt; Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CRead 4) (fun v => CEmit 2 v)) >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (upd (Pcm.hsingle 4 0) 4 9,0)}, Pure |= {formula} ]>) end. - rewrite aur_csl_rr_bind. - rewrite aur_csl_rr_read with (value:=9) by apply upd_eq. - rewrite aur_csl_rr_emit. - right; split. - - apply ticll_top; constructor. - - cleft. - repeat first - [ progress pool_simpl - | rewrite vector_remove_head - | rewrite vector_remove_tail - | erewrite interp_schedule_rr_ret by source_observe - | rewrite interp_schedule_rr_select - | rewrite interp_schedule_rr_empty ]. - apply axr_ret; [constructor |]. - cbn; split; [intro address; reflexivity | split; reflexivity]. -Qed. - -Lemma rr_shared_cas_ticl : - <[ {run_rr shared_cas_program hemp 0}, Pure |= - AX ({<( visW {fun o => o = SPop 10 1 0} )>} AN - (AX done {fun result w => - heq (fst (snd result)) (upd (hunion (hblock 1 1) hemp) 1 10) /\ - snd (snd result) = 2 /\ w = Obs (Log (SPop 20 0 1)) tt})) ]>. -Proof. - unfold run_rr. - change [denote shared_cas_program]%vector with - ([Ret tt]%vector @ Fin.F1 := (denote_flow shared_cas_program >>= fun _ => Ret tt)). - unfold shared_cas_program. - rewrite anr_csl_rr_bind. - rewrite anr_csl_rr_alloc with (base:=1) by - (try lia; apply block_freeb_spec; reflexivity). - rewrite anr_csl_rr_bind, anr_csl_rr_fork. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([denote (CBind (CCAS 1 0 20) (fun won => CEmit 20 (if won then 1 else 0))); Ret tt]%vector - @ Fin.FS Fin.F1 := - (denote_flow (CBind (CCAS 1 0 10) (fun won => - CBind (CEmit 10 (if won then 1 else 0)) (fun _ => CYield))) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (hunion (hblock 1 1) hemp,0)}, Pure |= {formula} ]>) end. - rewrite anr_csl_rr_bind. - rewrite anr_csl_rr_cas with (current:=0) by reflexivity. - cbn [Nat.eqb]. - rewrite anr_csl_rr_bind, anr_csl_rr_emit. - split. - - apply ticll_top; constructor. - - rewrite anr_csl_rr_yield. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([Ret tt; Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CCAS 1 0 20) (fun won => - CEmit 20 (if won then 1 else 0))) >>= fun _ => Ret tt)) - (Some Fin.F1) 1 (upd (hunion (hblock 1 1) hemp) 1 10,1)}, - {Obs (Log (SPop 10 1 0)) tt} |= {formula} ]>) end. - rewrite anr_csl_rr_bind. - rewrite anr_csl_rr_cas with (current:=10) by apply upd_eq. - cbn [Nat.eqb]. - rewrite anr_csl_rr_emit. - split. - + apply ticll_vis; constructor; reflexivity. - + repeat first - [ progress pool_simpl - | rewrite vector_remove_head - | rewrite vector_remove_tail - | erewrite interp_schedule_rr_ret by source_observe - | rewrite interp_schedule_rr_select - | rewrite interp_schedule_rr_empty ]. - apply axr_ret; [constructor |]. - cbn; split; [intro address; reflexivity | split; reflexivity]. -Qed. - -Lemma rr_scoped_child_ticl : - <[ {run_rr scoped_child_program hemp 0}, Pure |= - AX ({<( visW {fun o => o = SPop 1 10 0} )>} AN - ({<( visW {fun o => o = SPop 1 11 1} )>} AN - (AX done {fun result w => heq (fst (snd result)) hemp /\ - snd (snd result) = 3 /\ w = Obs (Log (SPop 2 20 2)) tt}))) ]>. -Proof. - set (body := CBind (CFork (CEmit 2 20)) - (fun _ => CBind (CEmit 1 10) (fun _ => CRet (None : option unit)))). - set (haltk := fun _ : option unit => (Ret tt : thread sE)). - set (after := fun r : option unit => - match r with None => haltk None | Some _ => denote_flow (CEmit 1 11) >>= haltk end). - set (next := until_tail body after). - unfold run_rr, scoped_child_program. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CUntilNone body) (fun _ => CEmit 1 11)) >>= haltk)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= {formula} ]>) end. - rewrite anr_csl_rr_bind, anr_csl_rr_until_none. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := (denote_flow body >>= next)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= {formula} ]>) end. - unfold body at 1; rewrite anr_csl_rr_bind, anr_csl_rr_fork. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CBind (CEmit 1 10) (fun _ => CRet (None : option unit))) >>= next)) - (Some (Fin.FS Fin.F1)) 0 (hemp,0)}, Pure |= {formula} ]>) end. - rewrite anr_csl_rr_bind, anr_csl_rr_emit. - split. - - apply ticll_top; constructor. - - rewrite anr_csl_rr_ret. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 2 - ([denote (CEmit 2 20); Ret tt]%vector @ Fin.FS Fin.F1 := - (denote_flow (CEmit 1 11) >>= haltk)) - (Some (Fin.FS Fin.F1)) 0 (hemp,1)}, - {Obs (Log (SPop 1 10 0)) tt} |= {formula} ]>) end. - rewrite anr_csl_rr_emit. - split. - + apply ticll_vis; constructor; reflexivity. - + erewrite interp_schedule_rr_ret by source_observe. - pool_simpl; rewrite vector_remove_tail, vector_remove_head. - rewrite anr_csl_rr_select. - lazymatch goal with |- @entailsR _ _ _ _ _ ?formula _ _ => - change (<[ {interp_schedule_rr sh 1 - ([Ret tt]%vector @ Fin.F1 := (denote_flow (CEmit 2 20) >>= haltk)) - (Some Fin.F1) 1 (hemp,2)}, - {Obs (Log (SPop 1 11 1)) tt} |= {formula} ]>) end. - rewrite anr_csl_rr_emit. - split. - * apply ticll_vis; constructor; reflexivity. - * erewrite interp_schedule_rr_ret by source_observe. - pool_simpl; rewrite vector_remove_head, interp_schedule_rr_empty. - apply axr_ret; [constructor |]. - cbn; split; [intro address; reflexivity | split; reflexivity]. -Qed. - -(** Universal ND choices versus cursor-dependent round-robin choices. *) - -Local Definition choice_good : CProg unit := CEmit 1 7. -Local Definition choice_bad : CProg unit := - CBind (CRead 99) (fun _ => CEmit 2 9). - -Lemma nd_yield_bad_successor : - ~ <( {interp_nd 2 - ([Ret tt; denote choice_bad] @ Fin.F1 := - (denote_flow CYield >>= fun _ => denote choice_good)) - (Some Fin.F1) (hemp,0)}, - Pure |= AX (AF (visW {fun _ => True})) )>. -Proof. - intro H. - apply anl_csl_nd_yield in H. - destruct H as [_ Hnext]. - specialize (Hnext (Fin.FS Fin.F1)). - change <( {interp_nd 2 - ([denote choice_good; Ret tt] @ Fin.FS Fin.F1 := - (denote_flow (CBind (CRead 99) (fun _ => CEmit 2 9)) >>= - fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) (hemp,0)}, - Pure |= AF (visW {fun _ => True}) )> in Hnext. - apply (proj1 (aul_csl_nd_bind 1 [denote choice_good; Ret tt] - (Fin.FS Fin.F1) (CRead 99) (fun _ => CEmit 2 9) - (fun _ => Ret tt) hemp 0 Pure - <( ⊤ )> <( visW {fun _ => True} )>)) in Hnext. - pose proof (interp_nd_source_read_missing 1 [denote choice_good; Ret tt] - (Fin.FS Fin.F1) 99 - (fun flow => match flow with - | None => Ret tt - | Some _ => denote_flow (CEmit 2 9);; Ret tt - end) - hemp 0 eq_refl) as Hmissing. - rewrite Hmissing in Hnext. - apply aul_stuck in Hnext. - apply ticll_vis in Hnext. - inversion Hnext. -Qed. - -Lemma nd_yield_all_emit : - <( {interp_nd 2 - ([Ret tt; denote (CEmit 2 9)] @ Fin.F1 := - (denote_flow CYield >>= fun _ => denote choice_good)) - (Some Fin.F1) (hemp,0)}, - Pure |= AX (AF (visW {fun _ => True})) )>. -Proof. - apply (proj2 (anl_csl_nd_yield 1 [Ret tt; denote (CEmit 2 9)] Fin.F1 - (fun _ => denote choice_good) hemp 0 Pure - <( ⊤ )> <( AF (visW {fun _ => True}) )>)). - split. - - apply ticll_top; constructor. - - intro j; dependent destruction j. - + apply (proj2 (aul_csl_nd_emit 1 [Ret tt; denote (CEmit 2 9)] Fin.F1 - 1 7 (fun _ => Ret tt) hemp 0 Pure - <( ⊤ )> <( visW {fun _ => True} )>)). - right; split. - * apply ticll_top; constructor. - * cleft. apply ticll_vis; constructor; exact I. - + dependent destruction j. - * apply (proj2 (aul_csl_nd_emit 1 [denote choice_good; Ret tt] - (Fin.FS Fin.F1) 2 9 (fun _ => Ret tt) hemp 0 Pure - <( ⊤ )> <( visW {fun _ => True} )>)). - right; split. - -- apply ticll_top; constructor. - -- cleft. apply ticll_vis; constructor; exact I. - * inversion j. -Qed. - -Lemma rr_yield_cursor0_observed : - <( {interp_schedule_rr sh 2 - ([Ret tt; denote choice_bad] @ Fin.F1 := - (denote_flow CYield >>= fun _ => denote choice_good)) - (Some Fin.F1) 0 (hemp,0)}, - Pure |= AX (visW {fun o => o = SPop 1 7 0}) )>. -Proof. - apply (proj2 (anl_csl_rr_yield 1 [Ret tt; denote choice_bad] Fin.F1 - (fun _ => denote choice_good) 0 hemp 0 Pure - <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)). - apply (proj2 (anl_csl_rr_emit 1 [Ret tt; denote choice_bad] Fin.F1 - 1 7 (fun _ => Ret tt) 1 hemp 0 Pure - <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)). - split. - - apply ticll_top; constructor. - - apply ticll_vis; constructor; reflexivity. -Qed. - -Lemma rr_yield_cursor1_blocked : - ~ <( {interp_schedule_rr sh 2 - ([Ret tt; denote choice_bad] @ Fin.F1 := - (denote_flow CYield >>= fun _ => denote choice_good)) - (Some Fin.F1) 1 (hemp,0)}, - Pure |= AX (visW {fun o => o = SPop 1 7 0}) )>. -Proof. - intro H. - apply (proj1 (anl_csl_rr_yield 1 [Ret tt; denote choice_bad] Fin.F1 - (fun _ => denote choice_good) 1 hemp 0 Pure - <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)) in H. - apply (proj1 (anl_csl_rr_bind 1 [denote choice_good; Ret tt] - (Fin.FS Fin.F1) (CRead 99) (fun _ => CEmit 2 9) - (fun _ => Ret tt) 2 hemp 0 Pure - <( ⊤ )> <( visW {fun o => o = SPop 1 7 0} )>)) in H. - pose proof (interp_rr_read_missing 1 [denote choice_good; Ret tt] - (Fin.FS Fin.F1) 99 - (fun flow => match flow with - | None => Ret tt - | Some _ => denote_flow (CEmit 2 9);; Ret tt - end) - 2 hemp 0 eq_refl) as Hmissing. - rewrite Hmissing in H. - exact (anl_stuck H). -Qed. - -(** Actual observations sustain AG; guard-only divergence does not. *) - -Theorem nd_emit_loop_ag : - <( {run_nd - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - hemp 0}, Pure |= AG ⊤ )>. -Proof. - assert (Hproductive : forall c w, not_done w -> - <( {run_nd - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - hemp c}, {w} |= AG ⊤ )>). - { - coinduction R CIH; intros c w Hw. - unfold run_nd, denote. - change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R - (interp_nd 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,c)) w). - rewrite interp_nd_source_until_none, interp_nd_source_bind, - interp_nd_source_emit_log. - unfold log, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - split; [split; [exact I | exact Hw] |]. - split. - - apply can_step_vis; [exact tt | exact Hw]. - - intros t' w' Htr. - apply ktrans_vis in Htr as ([] & -> & <- & Hnd). - rewrite interp_nd_source_ret. - erewrite interp_nd_guard by reflexivity. - cbn [Vector.replace]. - apply CIH. - constructor. - } - unfold run_nd, denote. - change <( {interp_nd 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,0)}, Pure |= AG ⊤ )>. - rewrite ag_csl_nd_until_none, ag_csl_nd_bind, ag_csl_nd_emit. - split. - - split; constructor. - - rewrite ag_csl_nd_ret. - erewrite interp_nd_guard by reflexivity. - cbn [Vector.replace]. - apply Hproductive. - constructor. -Qed. - -Theorem rr_emit_loop_ag : - <( {run_rr - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - hemp 0}, Pure |= AG ⊤ )>. -Proof. - assert (Hproductive : forall c w, not_done w -> - <( {run_rr - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - hemp c}, {w} |= AG ⊤ )>). - { - coinduction R CIH; intros c w Hw. - unfold run_rr, denote. - change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R - (interp_schedule_rr sh 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,c)) w). - rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. - unfold log, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - split; [split; [exact I | exact Hw] |]. - split. - - apply can_step_vis; [exact tt | exact Hw]. - - intros t' w' Htr. - apply ktrans_vis in Htr as ([] & -> & <- & Hnd). - rewrite interp_rr_ret. - erewrite interp_schedule_rr_guard by reflexivity. - cbn [Vector.replace]. - apply CIH. - constructor. - } - unfold run_rr, denote. - change <( {interp_schedule_rr sh 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit 7 9) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= AG ⊤ )>. - rewrite ag_csl_rr_until_none, ag_csl_rr_bind, ag_csl_rr_emit. - split. - - split; constructor. - - rewrite ag_csl_rr_ret. - erewrite interp_schedule_rr_guard by reflexivity. - cbn [Vector.replace]. - apply Hproductive. - constructor. -Qed. - -Theorem nd_silent_loop_no_ag : - ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) hemp 0}, - Pure |= AG ⊤ )>. -Proof. - set (p := CUntilNone (CRet (Some tt : option unit))). - assert (Hraw : denote p ≅ Guard (denote p)). - { - unfold p, denote. - etransitivity; [apply source_raw_until |]. - etransitivity; [apply source_raw_ret |]. - reflexivity. - } - assert (Hguard : run_nd p hemp 0 ≅ Guard (run_nd p hemp 0)). - { - unfold run_nd. - etransitivity. - - apply (interp_nd_equ 1 _ [Guard (denote p)]). - apply SBisim.cons_pool_equ; - [exact Hraw | apply SBisim.pool_equ_refl]. - - unfold interp_nd. - rewrite (SBisim.trans_schedule_focused_guard - 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). - rewrite interp_erase_guard, Mod.interp_state_tau. - reflexivity. - } - assert (Hstuck : run_nd p hemp 0 ≅ - (stuck : ictreeW SObs (unit * SSig))). - { - unfold equ. - coinduction R CIH. - rewrite Hguard, unfold_stuck. - constructor. - exact CIH. - } - rewrite Hstuck. - apply ag_stuck. -Qed. - -Theorem rr_silent_loop_no_ag : - ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) hemp 0}, - Pure |= AG ⊤ )>. -Proof. - set (p := CUntilNone (CRet (Some tt : option unit))). - assert (Hraw : denote p ≅ Guard (denote p)). - { - unfold p, denote. - etransitivity; [apply source_raw_until |]. - etransitivity; [apply source_raw_ret |]. - reflexivity. - } - assert (Hguard : run_rr p hemp 0 ≅ Guard (run_rr p hemp 0)). - { - unfold run_rr. - etransitivity. - - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). - apply SBisim.cons_pool_equ; - [exact Hraw | apply SBisim.pool_equ_refl]. - - unfold interp_schedule_rr. - rewrite unfold_run_round_robin, - (schedule_focused_guard - 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). - rewrite interp_erase_guard, Mod.interp_state_tau. - reflexivity. - } - assert (Hstuck : run_rr p hemp 0 ≅ - (stuck : ictreeW SObs (unit * SSig))). - { - unfold equ. - coinduction R CIH. - rewrite Hguard, unfold_stuck. - constructor. - exact CIH. - } - rewrite Hstuck. - apply ag_stuck. -Qed. - -(** Termination, faults, immediate until matching, and physical deletion. *) - -Lemma rr_ret_next_done : - <[ {run_rr (CRet tt) hemp 0}, Pure |= AX done {fun _ _ => True} ]>. -Proof. - unfold run_rr, denote. - change (<[ {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CRet tt) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= AX done {fun _ _ => True} ]>). - apply (proj2 (anr_csl_rr_ret 0 [Ret tt]%vector Fin.F1 tt - (fun _ => Ret tt) 0 hemp 0 Pure _ _)). - pose proof (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 - (hemp,0) eq_refl) as Hret. - cbn in Hret. - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ Hret _ _ eq_refl)). - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ - (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). - apply axr_ret; [constructor | exact I]. -Qed. - -Lemma rr_ret_no_prefix_next : - ~ <( {run_rr (CRet tt) hemp 0}, Pure |= AX ⊤ )>. -Proof. - unfold run_rr, denote. - change (not <( {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CRet tt) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= AX ⊤ )>). - rewrite anl_csl_rr_ret. - intro H. - apply (@anl_ret (writerE SObs) _ (unit * SSig) (tt,(hemp,0)) - Pure <[⊤]> <[⊤]>). - eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ - (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). - eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ - (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 - (hemp,0) eq_refl) _ _ eq_refl)). - exact H. -Qed. - -Lemma rr_ret_no_ag : - ~ <( {run_rr (CRet tt) hemp 0}, Pure |= AG ⊤ )>. -Proof. - unfold run_rr, denote. - change (not <( {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CRet tt) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0)}, Pure |= AG ⊤ )>). - rewrite ag_csl_rr_ret. - intro H. - apply (@ag_ret (writerE SObs) _ (unit * SSig) (tt,(hemp,0)) Pure <(⊤)>). - eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ - (interp_schedule_rr_empty sh 0 (hemp,0)) _ _ eq_refl)). - eapply (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ - (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 - (hemp,0) eq_refl) _ _ eq_refl)). - exact H. -Qed. - - -Lemma nd_fault_controls : - (not <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_nd (CWrite 1 9) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_nd (CWrite 1 9) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_nd (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_nd (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_nd (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_nd (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_nd (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AX ⊤ )> /\ - not <( {run_nd (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AG ⊤ )>). -Proof. - assert (Hcontrol : forall t : ictreeW SObs (unit * SSig), t ~ (stuck : ictreeW SObs (unit * SSig)) -> - (not <( {t}, Pure |= AX ⊤ )> /\ not <( {t}, Pure |= AG ⊤ )>)). - { intros t Hstuck; split; intro H. - - apply (@anl_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)> <(⊤)>). - exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ Hstuck _ _ eq_refl) H). - - apply (@ag_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)>). - exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ Hstuck _ _ eq_refl) H). } - split; [apply Hcontrol |]. - - unfold run_nd, denote. - change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CRead 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_nd_source_bind. - apply interp_nd_source_read_missing; reflexivity. - - split; [apply Hcontrol |]. - + unfold run_nd, denote. - change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CWrite 1 9) >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - apply interp_nd_source_write_missing; reflexivity. - + split; [apply Hcontrol |]. - * unfold run_nd, denote. - change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CCAS 1 0 9) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_nd_source_bind. - apply interp_nd_source_cas_missing; reflexivity. - * split; apply Hcontrol. - -- unfold run_nd, denote. - change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 0) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_nd_source_bind. - apply interp_nd_source_alloc_zero. - -- unfold run_nd, denote. - change (interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) ((fun _ => Some 7),0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_nd_source_bind. - apply interp_nd_source_alloc_no_space; [lia |]. - intros base Positive Free. - specialize (Free 0 ltac:(lia)); discriminate. -Qed. - -Lemma rr_fault_controls : - (not <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_rr (CWrite 1 9) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_rr (CWrite 1 9) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_rr (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_rr (CBind (CCAS 1 0 9) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_rr (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AX ⊤ )> /\ - not <( {run_rr (CBind (CAlloc 0) (fun _ => CRet tt)) hemp 0}, Pure |= AG ⊤ )>) /\ - (not <( {run_rr (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AX ⊤ )> /\ - not <( {run_rr (CBind (CAlloc 1) (fun _ => CRet tt)) (fun _ => Some 7) 0}, Pure |= AG ⊤ )>). -Proof. - assert (Hcontrol : forall t : ictreeW SObs (unit * SSig), t ~ (stuck : ictreeW SObs (unit * SSig)) -> - (not <( {t}, Pure |= AX ⊤ )> /\ not <( {t}, Pure |= AG ⊤ )>)). - { intros t Hstuck; split; intro H. - - apply (@anl_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)> <(⊤)>). - exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AX ⊤)> _ _ Hstuck _ _ eq_refl) H). - - apply (@ag_stuck (writerE SObs) _ (unit * SSig) Pure <(⊤)>). - exact (proj1 (@proper_entailsL_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) <(AG ⊤)> _ _ Hstuck _ _ eq_refl) H). } - split; [apply Hcontrol |]. - - unfold run_rr, denote. - change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CRead 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_rr_bind. - apply interp_rr_read_missing; reflexivity. - - split; [apply Hcontrol |]. - + unfold run_rr, denote. - change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CWrite 1 9) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - apply interp_rr_write_missing; reflexivity. - + split; [apply Hcontrol |]. - * unfold run_rr, denote. - change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CCAS 1 0 9) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_rr_bind. - apply interp_rr_cas_missing; reflexivity. - * split; apply Hcontrol. - -- unfold run_rr, denote. - change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 0) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_rr_bind. - apply interp_rr_alloc_zero. - -- unfold run_rr, denote. - change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (denote_flow (CBind (CAlloc 1) (fun _ => CRet tt)) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 ((fun _ => Some 7),0) ~ (stuck : ictreeW SObs (unit * SSig))). - rewrite interp_rr_bind. - apply interp_rr_alloc_no_space; [lia |]. - intros base Positive Free. - specialize (Free 0 ltac:(lia)); discriminate. -Qed. - -Lemma nd_stuck_until_now : - <( {run_nd (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= ⊤ AU pure )>. -Proof. - cleft. apply ticll_pure; reflexivity. -Qed. - -Lemma rr_stuck_until_now : - <( {run_rr (CBind (CRead 1) (fun _ => CRet tt)) hemp 0}, Pure |= ⊤ AU pure )>. -Proof. - cleft. apply ticll_pure; reflexivity. -Qed. - - -Lemma nd_heap_free_next_done : - <[ {interp_nd 1 [heap_free (E:=CEff) 1;; Ret tt]%vector - (Some Fin.F1) (Pcm.hsingle 1 9,7)}, Pure |= - AX done {fun r w => snd (snd r) = 7 /\ - heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>. -Proof. - change (<[ {interp_nd 1 ([Ret tt]%vector @ Fin.F1 := - (heap_free (E:=CEff) 1 >>= fun _ => Ret tt)) - (Some Fin.F1) (Pcm.hsingle 1 9,7)}, Pure |= - AX done {fun r w => snd (snd r) = 7 /\ - heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>). - apply (proj2 (anr_csl_nd_heap_free 0 [Ret tt]%vector Fin.F1 1 - (fun _ => Ret tt) (Pcm.hsingle 1 9) 7 Pure _ _)). - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ - (interp_nd_ret 0 [Ret tt]%vector Fin.F1 - (Pcm.hfree 1 (Pcm.hsingle 1 9),7) eq_refl) _ _ eq_refl)). - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ - (interp_nd_empty (Pcm.hfree 1 (Pcm.hsingle 1 9),7)) _ _ eq_refl)). - apply axr_ret; [constructor |]. - split; [reflexivity |]. split; [apply heq_refl | reflexivity]. -Qed. - -Lemma rr_heap_free_next_done : - <[ {interp_schedule_rr sh 1 [heap_free (E:=CEff) 1;; Ret tt]%vector - (Some Fin.F1) 0 (Pcm.hsingle 1 9,7)}, Pure |= - AX done {fun r w => snd (snd r) = 7 /\ - heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>. -Proof. - change (<[ {interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := - (heap_free (E:=CEff) 1 >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (Pcm.hsingle 1 9,7)}, Pure |= - AX done {fun r w => snd (snd r) = 7 /\ - heq (fst (snd r)) (Pcm.hfree 1 (Pcm.hsingle 1 9)) /\ w = Pure} ]>). - apply (proj2 (anr_csl_rr_heap_free 0 [Ret tt]%vector Fin.F1 1 - (fun _ => Ret tt) 0 (Pcm.hsingle 1 9) 7 Pure _ _)). - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ - (interp_schedule_rr_ret sh 0 [Ret tt]%vector Fin.F1 0 - (Pcm.hfree 1 (Pcm.hsingle 1 9),7) eq_refl) _ _ eq_refl)). - eapply (proj2 (@proper_entailsR_meq _ _ _ _ _ (sbisim eq) _ - (@KripkeSetoidSBisim _ _ _) _ _ _ - (interp_schedule_rr_empty sh 0 (Pcm.hfree 1 (Pcm.hsingle 1 9),7)) _ _ eq_refl)). - apply axr_ret; [constructor |]. - split; [reflexivity |]. split; [apply heq_refl | reflexivity]. -Qed. diff --git a/examples/HeapEventTests.v b/examples/HeapEventTests.v deleted file mode 100644 index df1b5b2..0000000 --- a/examples/HeapEventTests.v +++ /dev/null @@ -1,201 +0,0 @@ -From TICL Require Import ICTree.Events.Heap. - -(* Raw command clients require no language-specific module. *) -Check (heap_read (E:=heapE)). -Check (heap_write (E:=heapE)). -Check (heap_alloc (E:=heapE)). -Check (heap_free (E:=heapE)). -Check (heap_cas (E:=heapE)). - -From Stdlib Require Import Arith.PeanoNat Lia List. -From ExtLib Require Import Data.Monads.StateMonad. -From TICL Require Import - ICTree.Core ICTree.Equ ICTree.SBisim - ICTree.Events.Heap ICTree.Events.Writer ICTree.Interp.State.Mod - Lang.CSL.Heap Lang.CSL.Denote Lang.HeapImp. -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. -Module HI := TICL.Lang.HeapImp.HeapImp. - -Check (heap_read (E:=(heapE + writerE nat)%type) : - nat -> ictree (heapE + writerE nat) nat). -Check (heap_write (E:=(heapE + writerE nat)%type) : - nat -> nat -> ictree (heapE + writerE nat) unit). -Check (heap_alloc (E:=(heapE + writerE nat)%type) : - nat -> ictree (heapE + writerE nat) nat). -Check (heap_free (E:=(heapE + writerE nat)%type) : - nat -> ictree (heapE + writerE nat) unit). -Check (heap_cas (E:=(heapE + writerE nat)%type) : - nat -> nat -> nat -> ictree (heapE + writerE nat) bool). - -Check (heap_read (E:=CEff) : nat -> ictree CEff nat). -Check (heap_write (E:=CEff) : nat -> nat -> ictree CEff unit). -Check (heap_alloc (E:=CEff) : nat -> ictree CEff nat). -Check (heap_free (E:=CEff) : nat -> ictree CEff unit). -Check (heap_cas (E:=CEff) : nat -> nat -> nat -> ictree CEff bool). - -Local Definition heapimp_empty : HI.Mem := - {| HI.store := nil; HI.heap := nil |}. -Local Definition alloc_free_alloc : ictree sE (nat * nat) := - a <- heap_alloc 1;; heap_free a;; b <- heap_alloc 1;; Ret (a,b). -Local Definition two_cell_frame : Pcm.Heap := - hunion (hblock 1 2) (Pcm.hsingle 9 42). - -Lemma shared_heap_alloc_free_reuses_cell : - interp_state sh alloc_free_alloc (hemp,7) ~ - Ret ((1,1), - (hunion (hblock 1 1) (Pcm.hfree 1 (hunion (hblock 1 1) hemp)),7)). -Proof. - unfold alloc_free_alloc. - etransitivity. - - eapply sinterp_alloc_first with (base:=1); try lia. - apply block_freeb_spec; reflexivity. - - etransitivity; [apply sinterp_free |]. - etransitivity. - + eapply sinterp_alloc_first with (base:=1); try lia. - apply block_freeb_spec; reflexivity. - + eapply equ_clos_sbisim_goal; - [apply interp_state_ret | reflexivity | reflexivity]. -Qed. - -Lemma shared_heap_free_preserves_other_cells : - (interp_state sh - (heap_free 1;; - other <- heap_read 2;; - framed <- heap_read 9;; - Ret (other,framed)) (two_cell_frame,7) ~ - Ret ((0,42),(Pcm.hfree 1 two_cell_frame,7))) /\ - Pcm.hfree 1 two_cell_frame 1 = None. -Proof. - split. - - etransitivity; [apply sinterp_free |]. - etransitivity; [eapply sinterp_rd with (v:=0); reflexivity |]. - etransitivity; [eapply sinterp_rd with (v:=42); reflexivity |]. - eapply equ_clos_sbisim_goal; - [apply interp_state_ret | reflexivity | reflexivity]. - - reflexivity. -Qed. - -Lemma shared_heap_free_absent_succeeds : - (interp_state sh (heap_free (E:=sE) 42) (hemp,7) ~ - Ret (tt,(Pcm.hfree 42 hemp,7))) /\ - heq (Pcm.hfree 42 hemp) hemp. -Proof. - split. - - pose proof (sinterp_free 42 hemp 7 - (fun x : unit => (Ret x : ictree sE unit))) as Hfree. - rewrite bind_ret_r, interp_state_ret in Hfree. - exact Hfree. - - intro a; unfold Pcm.hfree, hemp. - destruct (Nat.eq_dec 42 a); reflexivity. -Qed. - -Lemma shared_heap_read_after_free_stuck : - interp_state sh (heap_free 1;; heap_read 1) (Pcm.hsingle 1 9,7) ~ - (stuck : ictreeW SObs (nat * SSig)). -Proof. - etransitivity; [apply sinterp_free |]. - eapply equ_clos_sbisim_goal; - [apply sinterp_srd_stuck; reflexivity | reflexivity | reflexivity]. -Qed. - -Lemma heapimp_alloc_zero_preserved : - (instr_stateE (HI.h_heapimp (HAlloc 0)) heapimp_empty ~ - (log heapimp_empty;; Ret (0,heapimp_empty))) /\ - interp_state sh (heap_alloc (E:=sE) 0) (hemp,7) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. - split. - - unfold HI.h_heapimp, instr_stateE. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_get | intro result; reflexivity] |] - end. - rewrite bind_ret_l. - cbn [HI.fresh_addr HI.heap_init HI.heap HI.store heapimp_empty]. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_put | intro result; reflexivity] |] - end. - rewrite bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l, interp_state_ret; reflexivity. - - apply sinterp_salloc_zero. -Qed. - -Lemma heapimp_free_absent_still_logs : - instr_stateE (HI.h_heapimp (HFree 42)) heapimp_empty ~ - (log (HI.free_heap 42 heapimp_empty);; - Ret (tt,HI.free_heap 42 heapimp_empty)). -Proof. - unfold HI.h_heapimp, instr_stateE. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_get | intro result; reflexivity] |] - end. - rewrite bind_ret_l. - apply interp_state_put. -Qed. - -Lemma heapimp_write_absent_still_allocates : - (instr_stateE (HI.h_heapimp (HWrite 1 9)) heapimp_empty ~ - (log (HI.update_heap 1 9 heapimp_empty);; - Ret (tt,HI.update_heap 1 9 heapimp_empty))) /\ - interp_state sh (heap_write (E:=sE) 1 9) (hemp,7) ≅ - (stuck : ictreeW SObs (unit * SSig)). -Proof. - split. - - unfold HI.h_heapimp, instr_stateE. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_get | intro result; reflexivity] |] - end. - rewrite bind_ret_l. - apply interp_state_put. - - apply sinterp_swr_stuck; reflexivity. -Qed. - -Lemma heapimp_cas_same_value_logs : - let m := HI.update_heap 1 7 heapimp_empty in - (instr_stateE (HI.h_heapimp (HCAS 1 7 7)) m ~ - (log (HI.update_heap 1 7 m);; Ret (true,HI.update_heap 1 7 m))) /\ - (instr_stateE (HI.h_heapimp (HCAS 1 8 9)) m ~ Ret (false,m)). -Proof. - cbn zeta. - assert (Lookup : ExtLib.Structures.Maps.lookup 1 - (HI.heap (HI.update_heap 1 7 heapimp_empty)) = Some 7). - { unfold HI.update_heap; cbn. - pose proof (ExtLib.Structures.Maps.mapsto_add_eq (R:=@eq nat) (V:=nat) - (HI.heap heapimp_empty) 1 7) as Hlookup. - now apply ExtLib.Structures.Maps.mapsto_lookup in Hlookup. } - split. - - unfold HI.h_heapimp, instr_stateE. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_get | intro result; reflexivity] |] - end. - rewrite bind_ret_l. - rewrite Lookup; cbn [Nat.eqb]. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_put | intro result; reflexivity] |] - end. - rewrite bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l, interp_state_ret; reflexivity. - - unfold HI.h_heapimp, instr_stateE. - rewrite interp_state_bind. - lazymatch goal with |- (?t >>= ?k) ~ _ => - etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); - [apply interp_state_get | intro result; reflexivity] |] - end. - rewrite bind_ret_l. - rewrite Lookup; cbn [Nat.eqb]. - rewrite interp_state_ret; reflexivity. -Qed. diff --git a/examples/Queue.v b/examples/Queue.v index dd4312b..3eb49e7 100644 --- a/examples/Queue.v +++ b/examples/Queue.v @@ -12,7 +12,8 @@ From TICL Require Import ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Lang.MeQ. + Lang.MeQ + Utils.Lists. From ExtLib Require Export Structures.MonadState @@ -44,78 +45,26 @@ Module Queue. (CIfSome opt (fun x => CPush x)) (fun 'tt => CRet (Some tt)))). - (* Element [t] appears unique in [l] in some position *) - Fixpoint find(t: T) (l: list T): option nat := - match l with - | nil => None - | h :: ts => if h =? t then - Some 0 - else - option_map S (find t ts) - end. - - Lemma unfold_find_hd: forall t h ts, - find t (h :: ts) = - (if h =? t then - Some 0 - else - option_map S (find t ts)). - Proof. reflexivity. Qed. - - Lemma find_last_ex: forall nl ts, - exists i0 : nat, find nl (ts ++ [nl]) = Some i0. - Proof with eauto with ticl. - induction ts. - - exists 0; cbn. - rewrite rel_dec_eq_true... - typeclasses eauto. - - destruct IHts. - destruct (a =? nl) eqn:Hnl. - + rewrite rel_dec_correct in Hnl; subst. - exists 0; cbn. - rewrite rel_dec_eq_true... - typeclasses eauto. - + exists (S x); cbn. - rewrite Hnl, H. - reflexivity. - Qed. - - Lemma find_app_l: forall nl ts n l, - find nl ts = Some n -> - find nl (ts ++ l) = Some n. - Proof with eauto. - induction ts; intros. - - inv H. - - cbn. - rewrite unfold_find_hd in H. - destruct (a =? nl) eqn:Hnl... - destruct (find nl ts); inv H. - rewrite IHts with (n:=n0)... - Qed. - - Lemma nat_eqb_S: forall n, - Nat.eqb n (S n) = false. - Proof. induction n; auto. Qed. Local Typeclasses Transparent equ. Local Typeclasses Transparent sbisim. Theorem rotate_agaf_pop: forall q i (nl: T), - find nl q = Some i -> + find_index (@rel_dec T eq HDec) nl q = Some i -> <( {instr_prog rotate q}, Pure |= AG AF visW {fun h => h = nl} )>. Proof with eauto with ticl. intros. unfold rotate; cbn. apply ag_qprog_invariance with - (R:= fun q w => exists h ts, q = h :: ts /\ (h = nl \/ (h <> nl /\ exists i, find nl ts = Some i)))... + (R:= fun q w => exists h ts, q = h :: ts /\ (h = nl \/ (h <> nl /\ exists i, find_index (@rel_dec T eq HDec) nl ts = Some i)))... - destruct q; try solve [ inv H ]. exists t, q; intuition. - rewrite unfold_find_hd in H. + rewrite find_index_cons in H. destruct (t =? nl) eqn:Hnl; inv H. + rewrite rel_dec_correct in Hnl. left... + right. - destruct (find nl q) eqn:Hq, i; inv H1. + destruct (find_index (@rel_dec T eq HDec) nl q) eqn:Hq, i; inv H1. apply neg_rel_dec_correct in Hnl; split... - clear H q. intros q w (h & ts & -> & [-> | (Hnl & Hi)]) Hd. @@ -148,16 +97,16 @@ Module Queue. now apply rel_dec_correct. --- right. apply neg_rel_dec_correct in Hnl; split... - apply find_last_ex. + apply (find_index_last_ex (@rel_dec T eq HDec) rel_dec_correct). + (* h <> nl *) clear i. destruct Hi as (i & Hi). split. * eapply aul_qprog_eventually with (Ri:=fun q _ => - exists h ts, q = h :: ts /\ (h = nl \/ (h <> nl /\ exists i, find nl ts = Some i))) + exists h ts, q = h :: ts /\ (h = nl \/ (h <> nl /\ exists i, find_index (@rel_dec T eq HDec) nl ts = Some i))) (f:=fun q => - match find nl q with + match find_index (@rel_dec T eq HDec) nl q with | None => length q | Some v => v end)... @@ -189,19 +138,19 @@ Module Queue. split. +++ destruct ts'; cbn; try solve [inv Hi']. exists t, (ts' ++ [h']); split... - rewrite unfold_find_hd in Hi'. + rewrite find_index_cons in Hi'. destruct (t =? nl) eqn:Hnl''; inv Hi'. *** rewrite rel_dec_correct in Hnl''; subst. now left. *** right; split. ---- now apply neg_rel_dec_correct in Hnl''. - ---- destruct (find nl ts') eqn:Hts'; inv H0. + ---- destruct (find_index (@rel_dec T eq HDec) nl ts') eqn:Hts'; inv H0. exists n. - now apply find_app_l. + now apply find_index_app_l. +++ (* variant *) apply rel_dec_neq_false with (r:=HDec) in Hnl'; [|typeclasses eauto]. rewrite Hnl', Hi'; cbn. - erewrite find_app_l... + erewrite find_index_app_l... * eapply anr_qprog_bind_l. -- apply anr_pop_cons... csplit... @@ -219,11 +168,11 @@ Module Queue. ** rewrite rel_dec_correct in Hnl'; subst... ** right. rewrite Hnl' in H0. - destruct (find nl ts) eqn:Hts; inv H0. + destruct (find_index (@rel_dec T eq HDec) nl ts) eqn:Hts; inv H0. split. --- now apply neg_rel_dec_correct. --- exists n. - now apply find_app_l. + now apply find_index_app_l. Qed. End Queue. diff --git a/theories/Events/HeapModel.v b/theories/Events/HeapModel.v new file mode 100644 index 0000000..c5e8f80 --- /dev/null +++ b/theories/Events/HeapModel.v @@ -0,0 +1,652 @@ +(** * The concrete heap model. + + Representation: [nat -> option nat]. Equivalence: pointwise equality. + Composition: union, defined exactly on disjoint pairs. This is the + "justified map representation / equivalence" the PCM interface asks for; it + is not an association list under list equality, for which commutativity is + false. + + This module owns the *pure* heap: its PCM instance, its points-to and + framing laws, the single update primitive [upd], the finite-block algebra + used by allocation, and the stride-two node geometry shared by the queue + and the allocator. It is deliberately distinct from [ICTree.Events.Heap], + which only builds [heapE] triggers. + + Heap equality stays POINTWISE ([heq]). Nothing here converts it to + function equality or assumes extensionality. *) + +From Stdlib Require Import + Basics + Arith.PeanoNat + Lia + List + Relations + Sorting.Permutation. + +From TICL Require Export Utils.Pcm. + +Import ListNotations. +Local Open Scope pcm_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** ** Carrier and primitive operations *) +Definition Heap := nat -> option nat. + +Definition hemp : Heap := fun _ => None. +Definition heq (h1 h2: Heap) : Prop := forall a, h1 a = h2 a. +Definition hdisj (h1 h2: Heap) : Prop := forall a, h1 a = None \/ h2 a = None. +Definition hunion (h1 h2: Heap) : Heap := + fun a => match h1 a with Some v => Some v | None => h2 a end. + +Definition hsingle (a v: nat) : Heap := + fun b => if Nat.eq_dec a b then Some v else None. +Definition hfree (a: nat) (h: Heap) : Heap := + fun b => if Nat.eq_dec a b then None else h b. + +(** The single update primitive. Its decision procedure is [Nat.eqb] on the + LOOKED-UP address, which is the computational convention every allocator + and queue computation already uses. *) +Definition upd (h : Heap) (a v : nat) : Heap := + fun x => if Nat.eqb x a then Some v else h x. + +(** The empty heap has no allocated cell. *) +Lemma hemp_dom: forall x, hemp x <> None -> False. +Proof. intros x H; apply H; reflexivity. Qed. + +(** Pointwise contents of a finite collection of heap cells. *) +Definition cellsat (W: list (nat * nat)) (h: Heap) : Prop := + Forall (fun p => h (fst p) = Some (snd p)) W. + +Lemma cellsat_heq: forall W h1 h2, heq h1 h2 -> cellsat W h1 -> cellsat W h2. +Proof. + intros W k1 k2 Heq H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite <- Heq; now apply H. +Qed. + +Lemma cellsat_agree: forall W h h', + (forall p, In p W -> h' (fst p) = h (fst p)) -> cellsat W h -> cellsat W h'. +Proof. + intros W h h' Hag H; unfold cellsat in *. + rewrite Forall_forall in *; intros p Hp; rewrite Hag by exact Hp; now apply H. +Qed. + +Ltac hcase a := unfold hunion, hfree, hsingle, hemp in *; + intros; repeat (destruct (Nat.eq_dec _ _)); subst; auto. + +Lemma hdisj_none: forall h1 h2 a v, hdisj h1 h2 -> h1 a = Some v -> h2 a = None. +Proof. intros h1 h2 a v Hd Hs; destruct (Hd a) as [Hn | Hn]; congruence. Qed. + +(** ** The algebra of [upd]. + + Elementary lookup facts about the primitive defined above. Stated with + explicit binders: they are applied positionally. *) + +Lemma upd_unfold: forall h a v x, upd h a v x = if Nat.eqb x a then Some v else h x. +Proof. reflexivity. Qed. + +Lemma upd_eq: forall h a v, upd h a v a = Some v. +Proof. intros; unfold upd; now rewrite Nat.eqb_refl. Qed. + +Lemma upd_neq: forall h a v x, x <> a -> upd h a v x = h x. +Proof. intros; unfold upd; now apply Nat.eqb_neq in H as ->. Qed. + +Lemma upd_mono: forall h a v x, h x <> None -> upd h a v x <> None. +Proof. intros h a v x H; unfold upd; destruct (Nat.eqb x a); [discriminate | exact H]. Qed. + +Lemma upd_dom: forall h a v x, h a <> None -> (upd h a v x <> None <-> h x <> None). +Proof. + intros h a v x Ha; unfold upd; destruct (Nat.eqb_spec x a) as [-> | Hne]. + - split; [intros _; exact Ha | intros _; discriminate]. + - reflexivity. +Qed. + +Lemma upd_lookup_agree: forall h f a v x, h x = f x -> upd h a v x = upd f a v x. +Proof. + intros h f a v x H; destruct (Nat.eq_dec x a) as [-> | Hne]. + - now rewrite !upd_eq. + - now rewrite !upd_neq by exact Hne. +Qed. + +Lemma upd_heq: forall h k a v, heq h k -> heq (upd h a v) (upd k a v). +Proof. + intros h k a v H x; unfold upd; destruct (Nat.eqb x a); [reflexivity | apply H]. +Qed. + +(** Elementary lookup consequences of [hunion]/[hdisj]. These read a single + address out of a union; the monoid laws below are stated pointwise on top + of them. *) + +Lemma hunion_some: forall h f x v, h x = Some v -> hunion h f x = Some v. +Proof. intros h f x v H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_eq: forall h f x, h x <> None -> hunion h f x = h x. +Proof. + intros h f x H; destruct (h x) as [v |] eqn:E; [| congruence]. + now apply hunion_some. +Qed. + +Lemma hunion_none: forall h f x, h x = None -> hunion h f x = f x. +Proof. intros h f x H; unfold hunion; now rewrite H. Qed. + +Lemma hunion_dom: forall h f x, h x <> None -> hunion h f x <> None. +Proof. intros h f x H; now rewrite hunion_eq. Qed. + +Lemma hunion_null: forall h f, h 0 = None -> f 0 = None -> hunion h f 0 = None. +Proof. intros h f Hh Hf; unfold hunion; now rewrite Hh. Qed. + +Lemma hdisj_union: forall h1 h2 f, + hdisj h1 h2 -> hdisj h1 f -> hdisj h1 (hunion h2 f). +Proof. + intros h1 h2 f H12 H1f x. + destruct (h1 x) eqn:E1; [| now left]. + right; unfold hunion. + destruct (H12 x) as [C | E2]; [congruence |]; rewrite E2. + destruct (H1f x) as [C | Ef]; [congruence | exact Ef]. +Qed. + +(** Every law is proved as a standalone lemma first, so that the instance is a + list of [exact]s and its field order cannot silently drift. *) +Lemma heq_refl: forall a, heq a a. +Proof. intros a x; reflexivity. Qed. + +Lemma heq_sym: forall a b, heq a b -> heq b a. +Proof. intros a b Hab x; now rewrite Hab. Qed. + +Lemma heq_trans: forall a b c, heq a b -> heq b c -> heq a c. +Proof. intros a b c Hab Hbc x; now rewrite Hab, Hbc. Qed. + +Lemma hdisj_resp: forall a a' b b', heq a a' -> heq b b' -> hdisj a b -> hdisj a' b'. +Proof. intros a a' b b' Ha Hb Hd x; rewrite <- Ha, <- Hb; apply Hd. Qed. + +Lemma hunion_resp: forall a a' b b', heq a a' -> heq b b' -> heq (hunion a b) (hunion a' b'). +Proof. intros a a' b b' Ha Hb x; unfold hunion; rewrite Ha, Hb; reflexivity. Qed. + +Lemma hdisj_sym: forall a b, hdisj a b -> hdisj b a. +Proof. intros a b Hd x; destruct (Hd x); auto. Qed. + +Lemma hunion_comm: forall a b, hdisj a b -> heq (hunion a b) (hunion b a). +Proof. + intros a b Hd x; unfold hunion; destruct (Hd x) as [Hx | Hx]; rewrite Hx. + - destruct (b x); reflexivity. + - destruct (a x); reflexivity. +Qed. + +Lemma hdisj_hemp: forall a, hdisj hemp a. +Proof. intros a x; left; reflexivity. Qed. + +Lemma hunion_hemp: forall a, heq (hunion hemp a) a. +Proof. intros a x; reflexivity. Qed. + +Lemma hdisj_assocL: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj a b. +Proof. + intros a b c Hbc Ha x; specialize (Ha x); unfold hunion in Ha. + destruct (b x) eqn:Hb; auto. +Qed. + +Lemma hdisj_assocR: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj (hunion a b) c. +Proof. + intros a b c Hbc Ha x; specialize (Ha x); specialize (Hbc x); unfold hunion in *. + destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; + intuition (try discriminate); auto. +Qed. + +Lemma hdisj_assocI: forall a b c, + hdisj b c -> hdisj a b -> hdisj (hunion a b) c -> hdisj a (hunion b c). +Proof. + intros a b c Hbc Hab Habc x. + specialize (Hbc x); specialize (Hab x); specialize (Habc x); unfold hunion in *. + destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; + intuition (try discriminate); auto. +Qed. + +Lemma hunion_assoc: forall a b c, + hdisj b c -> hdisj a (hunion b c) -> heq (hunion a (hunion b c)) (hunion (hunion a b) c). +Proof. intros a b c _ _ x; unfold hunion; destruct (a x); reflexivity. Qed. + +#[global] Instance HeapPCM : PCM Heap. +Proof. + refine {| peq := heq; pdef := hdisj; pop := hunion; pemp := hemp |}. + - exact heq_refl. + - exact heq_sym. + - exact heq_trans. + - exact hdisj_resp. + - exact hunion_resp. + - exact hdisj_sym. + - exact hunion_comm. + - exact hdisj_hemp. + - exact hunion_hemp. + - exact hdisj_assocL. + - exact hdisj_assocR. + - exact hdisj_assocI. + - exact hunion_assoc. +Defined. + +(** Heaps are cancellative -- recorded to show the class is not weakened by + leaving cancellativity out. *) +Lemma HeapCancellative: Cancellative Heap. +Proof. + intros a b c Hab Hac Heq x; cbn in *. + unfold heq, hunion, hdisj in *. + specialize (Heq x); specialize (Hab x); specialize (Hac x). + destruct (a x) eqn:Ha; auto. + destruct Hab as [? | Hb]; [congruence |]. + destruct Hac as [? | Hc]; [congruence |]. + congruence. +Qed. + +(** ** Points-to, and the separation it buys. + + [pto a v] is an assertion about the *owned* resource. [CNow] is + tree-blind, so this can never be a TICL base predicate on its own: it is a + predicate on the resource, lifted into the temporal layer only through an + owned projection. *) +Definition pto (a v: nat) : assn Heap := fun h => heq h (hsingle a v). + +Lemma pto_proper: forall a v, AProper (pto a v). +Proof. intros a v h1 h2 Heq Hp x; rewrite <- Heq; apply Hp. Qed. + +Lemma pto_lookup: forall a v h, pto a v h -> h a = Some v. +Proof. intros a v h Hp; rewrite Hp; hcase a; congruence. Qed. + +(** Two points-to on the same address cannot be separated: the hallmark + consequence of a disjointness-based PCM. *) +Theorem pto_sep_same_false: forall a v v' h, ~ (pto a v ⋆ pto a v')%pcm h. +Proof. + intros a v v' h (h1 & h2 & Hd & Heq & H1 & H2). + apply pto_lookup in H1; apply pto_lookup in H2. + destruct (Hd a); congruence. +Qed. + +(** Distinct addresses do separate. *) +Theorem pto_sep_distinct: forall a b v v', + a <> b -> (pto a v ⋆ pto b v')%pcm (hunion (hsingle a v) (hsingle b v')). +Proof. + intros a b v v' Hab. + exists (hsingle a v), (hsingle b v'). + split; [| split; [| split]]. + - intro x; unfold hsingle; destruct (Nat.eq_dec a x); destruct (Nat.eq_dec b x); + subst; auto. + exfalso; auto. + - intro x; reflexivity. + - intro x; reflexivity. + - intro x; reflexivity. +Qed. + +(** ** Safe-access locality on the concrete heap. + + Each of the three laws is stated with the footprint hypothesis it needs. *) + +(** A read inside the owned footprint returns the owned value, under every + compatible frame. *) +Theorem read_local: forall h f a v, + hdisj h f -> h a = Some v -> hunion h f a = Some v. +Proof. intros h f a v Hd Ha; unfold hunion; now rewrite Ha. Qed. + +(** A write inside the owned footprint keeps the frame disjoint ... *) +Theorem write_local_disj: forall h f a v v0, + hdisj h f -> h a = Some v0 -> hdisj (upd h a v) f. +Proof. + intros h f a v v0 Hd Ha x; destruct (Nat.eq_dec x a) as [-> | Hne]. + - right; eapply hdisj_none; eauto. + - rewrite upd_neq by exact Hne; apply Hd. +Qed. + +(** ... and commutes with framing. *) +Theorem write_local_frame: forall h f a v, + heq (upd (hunion h f) a v) (hunion (upd h a v) f). +Proof. + intros h f a v x; destruct (Nat.eq_dec x a) as [-> | Hne]. + - rewrite !upd_eq; unfold hunion; now rewrite upd_eq. + - rewrite !upd_neq by exact Hne; unfold hunion; now rewrite upd_neq by exact Hne. +Qed. + +(** A free inside the owned footprint keeps the frame disjoint ... *) +Theorem free_local_disj: forall h f a, + hdisj h f -> hdisj (hfree a h) f. +Proof. intros h f a Hd x; unfold hfree; destruct (Nat.eq_dec a x); auto. Qed. + +(** ... and commutes with framing, provided the address is owned. *) +Theorem free_local_frame: forall h f a v0, + hdisj h f -> h a = Some v0 -> + heq (hfree a (hunion h f)) (hunion (hfree a h) f). +Proof. + intros h f a v0 Hd Ha x; unfold hfree, hunion; destruct (Nat.eq_dec a x); auto. + subst; erewrite hdisj_none; eauto. +Qed. + +(** Freeing an absent address leaves the heap pointwise unchanged. *) +Lemma hfree_absent_noop (h : Heap) a : + h a = None -> heq (hfree a h) h. +Proof. + intros Ha x; unfold hfree; destruct (Nat.eq_dec a x) as [<- | _]; auto. +Qed. + +(** ** Finite blocks over the unrestricted function heap. + Bounds are proof witnesses only; allocation searches in its handler. + Fresh ownership preserves the old resource, not literal frame-stable bases. *) + +Definition heap_bounded (bound : nat) (h : Heap) : Prop := + forall x, Nat.le bound x -> h x = None. +Definition heap_finite (h : Heap) : Prop := + exists bound, heap_bounded bound h. +Definition hblock (base size : nat) : Heap := + fun x => if andb (Nat.leb base x) (Nat.ltb x (base + size)) + then Some 0 else None. +Definition block_free (h : Heap) (base size : nat) : Prop := + forall offset, Nat.lt offset size -> h (base + offset) = None. +Definition block_pto (base size : nat) : Heap -> Prop := + fun h => heq h (hblock base size). + +Lemma hblock_in base size offset : + Nat.lt offset size -> hblock base size (base + offset) = Some 0. +Proof. + intro H; unfold hblock. + assert (L : Nat.leb base (base + offset) = true) + by (apply Nat.leb_le; lia). + assert (R : Nat.ltb (base + offset) (base + size) = true) + by (apply Nat.ltb_lt; lia). + now rewrite L, R. +Qed. + +Lemma hblock_out base size x : + (Nat.lt x base \/ Nat.le (base + size) x) -> + hblock base size x = None. +Proof. + intro H; unfold hblock. + destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); + cbn; try reflexivity; lia. +Qed. + +Lemma block_free_disjoint h base size : + block_free h base size <-> hdisj (hblock base size) h. +Proof. + split. + - intros H x. + destruct (Nat.le_gt_cases base x) as [L | L]; + [destruct (Nat.lt_ge_cases x (base + size)) as [R | R] |]. + + right; replace x with (base + (x - base)) by lia; apply H; lia. + + left; apply hblock_out; auto. + + left; apply hblock_out; auto. + - intros H offset O; specialize (H (base + offset)). + rewrite (hblock_in base size offset O) in H; destruct H; congruence. +Qed. + +Lemma heap_finite_hemp : heap_finite hemp. +Proof. exists 0; intros x H; reflexivity. Qed. + +Lemma heap_finite_hblock base size : heap_finite (hblock base size). +Proof. + exists (base + size); intros x H; apply hblock_out; auto. +Qed. + +Lemma heap_finite_hunion h f : + heap_finite h -> heap_finite f -> heap_finite (hunion h f). +Proof. + intros [B HB] [C HC]; exists (Nat.max B C); intros x H. + unfold hunion; rewrite HB, HC; try reflexivity; lia. +Qed. + +Lemma heap_finite_upd h a v : heap_finite h -> heap_finite (upd h a v). +Proof. + intros [B Bound]; exists (Nat.max B (S a)); intros x X. + unfold upd; destruct (Nat.eqb_spec x a); [lia | apply Bound; lia]. +Qed. + +Lemma heap_bounded_block_free bound h base size : + heap_bounded bound h -> Nat.le bound base -> block_free h base size. +Proof. intros H B offset O; apply H; lia. Qed. + +Lemma allocated_block_sep base size h (P : Heap -> Prop) : + block_free h base size -> P h -> + asep (block_pto base size) P (hunion (hblock base size) h). +Proof. + intros F H; exists (hblock base size), h. + split; [apply block_free_disjoint; exact F |]. + split; [apply heq_refl |]. + split; [apply heq_refl | exact H]. +Qed. + +(** An owned block cannot be separated from a points-to on one of its cells. *) +Lemma block_pto_overlap_false base size a v h : + base <= a < base + size -> + ~ asep (block_pto base size) (pto a v) h. +Proof. + intros Ha (b & p & D & _ & B & P). + assert (Hb : b a = Some 0). + { rewrite (B a); replace a with (base + (a - base)) by lia; apply hblock_in; lia. } + apply pto_lookup in P; destruct (D a); congruence. +Qed. + +(** The immutable snapshot is searched without fuel or heap instrumentation. *) +Fixpoint block_freeb (h : Heap) (base size : nat) : bool := + match size with + | 0 => true + | S rest => + match h base with + | None => block_freeb h (S base) rest + | Some _ => false + end + end. + +Lemma block_freeb_spec h base size : + block_freeb h base size = true <-> block_free h base size. +Proof. + revert base; induction size as [|size IH]; intro base. + - split; [intros _ offset O; lia | reflexivity]. + - cbn [block_freeb]; destruct (h base) as [v|] eqn:E. + + split; [discriminate | intro F]. + specialize (F 0 ltac:(lia)); rewrite Nat.add_0_r, E in F; discriminate. + + rewrite IH; split. + * intros F [|offset] O. + -- now rewrite Nat.add_0_r. + -- replace (base + S offset)%nat with (S base + offset)%nat by lia; apply F; lia. + * intros F offset O. + replace (S base + offset)%nat with (base + S offset)%nat by lia; apply F; lia. +Qed. + +(** ** Stride-two node geometry. + + A node named [a] owns exactly two cells: [a] and [S a]. Stride two, null + terminator zero, and low-to-high initialization order are fixed; this is a + concrete layout, not a configurable memory-layout framework. Both the + queue representation and the allocator page share it. *) + +(** The two cells of a node named [a]: the payload cell [a] and the link cell + [S a]. *) +Definition cells (l: list nat) : list nat := flat_map (fun a => [a; S a]) l. + +Lemma in_cells: forall x l, In x (cells l) <-> exists a, In a l /\ (x = a \/ x = S a). +Proof. + intros x l; unfold cells; rewrite in_flat_map; split. + - intros (a & Ha & Hx); exists a; split; [assumption |]. + cbn in Hx; destruct Hx as [Heq | [Heq | []]]; [left | right]; congruence. + - intros (a & Ha & Hx); exists a; split; [assumption |]. + cbn; destruct Hx as [-> | ->]; auto. +Qed. + +Fixpoint node_addrs (first count : nat) : list nat := + match count with + | 0 => [] + | S rest => first :: node_addrs (first + 2) rest + end. + +Lemma node_addrs_in first count x : + In x (node_addrs first count) <-> + exists j, Nat.lt j count /\ x = first + 2*j. +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs]; split; [contradiction | intros (j & Hj & _); lia]. + - cbn [node_addrs In]; rewrite IH; split. + + intros [Hx | (j & Hj & Hx)]. + * exists 0; split; lia. + * exists (S j); split; lia. + + intros (j & Hj & Hx); destruct j as [| j]. + * left; lia. + * right; exists j; split; lia. +Qed. + +Lemma node_addrs_length first count : length (node_addrs first count) = count. +Proof. + revert first; induction count as [| count IH]; intro first; + cbn [node_addrs length]; [reflexivity | now rewrite IH]. +Qed. + +Lemma node_addrs_nodup first count : NoDup (node_addrs first count). +Proof. + revert first; induction count as [| count IH]; intro first; cbn [node_addrs]. + - constructor. + - constructor; [| apply IH]. + intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. +Qed. + +Lemma node_cells_range first count x : + In x (cells (node_addrs first count)) <-> + Nat.le first x /\ Nat.lt x (first + 2 * count). +Proof. + revert first x; induction count as [| count IH]; intros first x. + - cbn [node_addrs cells]; split; [contradiction | lia]. + - change ((first = x \/ S first = x \/ + In x (cells (node_addrs (first + 2) count))) <-> + Nat.le first x /\ Nat.lt x (first + 2 * S count)). + rewrite IH; split. + + intros [Hx | [Hx | Hx]]; lia. + + intros [Hlo Hhi]. + destruct (Nat.eq_dec first x) as [Hx | Hx]; [now left |]. + destruct (Nat.eq_dec (S first) x) as [Hsx | Hsx]; [now right; left |]. + right; right; split; lia. +Qed. + +Lemma node_addrs_link_payload_disjoint first count a b : + In a (node_addrs first count) -> In b (node_addrs first count) -> + a <> S b. +Proof. + intros Ha Hb. + apply node_addrs_in in Ha as (i & Hi & Ha). + apply node_addrs_in in Hb as (j & Hj & Hb). + lia. +Qed. + +Lemma node_addrs_cells_nodup first count : + NoDup (cells (node_addrs first count)). +Proof. + revert first; induction count as [| count IH]; intro first. + - constructor. + - change (NoDup (first :: S first :: cells (node_addrs (first + 2) count))). + constructor. + + intros [H | H]; [lia | apply node_cells_range in H; lia]. + + constructor. + * intro H; apply node_cells_range in H; lia. + * apply IH. +Qed. + +(** ** Pure link initialization over a stride-two node list. + + Links run low to high; the last node's link is the null terminator zero. + [count = 0] leaves the heap unchanged. Without a checked-write premise the + pure initializer may EXTEND a domain; the exact domain law below makes that + explicit. Checked source writes still require allocated cells. *) + +Fixpoint init_links_heap (first count : nat) (h : Heap) : Heap := + match count with + | 0 => h + | S rest => + init_links_heap (first + 2) rest + (upd h first (match rest with 0 => 0 | S _ => first + 2 end)) + end. + +Lemma init_links_heap_lookup_agree first count h f x : + h x = f x -> init_links_heap first count h x = init_links_heap first count f x. +Proof. + revert first h f; induction count as [| count IH]; intros first h f H. + - exact H. + - cbn [init_links_heap]; apply IH, upd_lookup_agree, H. +Qed. + +Lemma init_links_heap_frame first count h x : + ~ In x (node_addrs first count) -> init_links_heap first count h x = h x. +Proof. + revert first h; induction count as [| count IH]; intros first h Hout. + - reflexivity. + - cbn [init_links_heap]; rewrite IH. + + apply upd_neq; intro H; apply Hout; cbn [node_addrs]; now left. + + intro Hin; apply Hout; cbn [node_addrs]; now right. +Qed. + +Lemma init_links_heap_out first count h x : + (Nat.lt x first \/ Nat.le (first + 2 * count) x) -> + init_links_heap first count h x = h x. +Proof. + intro Hout; apply init_links_heap_frame. + intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. +Qed. + +Lemma init_links_heap_payload first count h b : + In b (node_addrs first count) -> init_links_heap first count h (S b) = h (S b). +Proof. + intro Hb; apply init_links_heap_frame; intro Hin. + exact (node_addrs_link_payload_disjoint first count (S b) b Hin Hb eq_refl). +Qed. + +Lemma init_links_heap_dom first count h x : + init_links_heap first count h x <> None <-> + In x (node_addrs first count) \/ h x <> None. +Proof. + revert first h x; induction count as [| count IH]; intros first h x. + - cbn [init_links_heap node_addrs In]; tauto. + - cbn [init_links_heap node_addrs In]; rewrite IH; unfold upd. + destruct (Nat.eqb_spec x first) as [Hx | Hne]. + + subst x; split; intro H. + * left; now left. + * right; discriminate. + + intuition congruence. +Qed. + +(** A list-suffix lookup is independent of the incoming heap. In particular + it supplies exactly the head/tail equations a free-list ownership proof + needs, without defining that ownership predicate here. *) +Lemma init_links_heap_link first count h prefix b rest : + node_addrs first count = prefix ++ b :: rest -> + init_links_heap first count h b = Some (hd 0 rest). +Proof. + revert first h prefix b rest; induction count as [| count IH]; + intros first h prefix b rest Hnodes. + - destruct prefix; discriminate. + - destruct prefix as [| a prefix]. + + cbn [node_addrs app] in Hnodes. + injection Hnodes as Hb Hrest; subst b; subst rest. + cbn [init_links_heap]. + rewrite init_links_heap_out by (left; lia). + rewrite upd_eq; destruct count; reflexivity. + + cbn [node_addrs app] in Hnodes. + injection Hnodes as Ha Htail. + cbn [init_links_heap]; eapply IH; exact Htail. +Qed. + +Lemma init_links_heap_link_index first count h j : + Nat.lt j count -> + init_links_heap first count h (first + 2 * j) = + Some (if Nat.ltb (S j) count then first + 2 * S j else 0). +Proof. + revert first h j; induction count as [| count IH]; intros first h j Hj. + - lia. + - destruct j as [| j]. + + replace (first + 2 * 0) with first by lia. + cbn [init_links_heap]. + rewrite init_links_heap_out by (left; lia). + rewrite upd_eq; destruct count; reflexivity. + + cbn [init_links_heap]. + replace (first + 2 * S j) with (first + 2 + 2 * j) by lia. + rewrite IH by lia. + change (Some (if Nat.ltb (S j) count then first + 2 + 2 * S j else 0) = + Some (if Nat.ltb (S j) count then first + 2 * S (S j) else 0)). + destruct (Nat.ltb (S j) count); f_equal; lia. +Qed. + +Lemma init_links_heap_finite first count h : + heap_finite h -> heap_finite (init_links_heap first count h). +Proof. + revert first h; induction count as [| count IH]; intros first h Hh. + - exact Hh. + - cbn [init_links_heap]; apply IH, heap_finite_upd, Hh. +Qed. diff --git a/theories/Events/WriterE.v b/theories/Events/WriterE.v index a91a1db..3a2123c 100644 --- a/theories/Events/WriterE.v +++ b/theories/Events/WriterE.v @@ -22,3 +22,24 @@ End Writer. Arguments Log {S}. +(** * Indexed observations. + + Instrumentation that wants to distinguish *occurrences* of the same + payload logs the payload together with the count of observations that + preceded it. The payload is arbitrary, so the same representation serves + a queue's popped value and a tagged allocator event. *) +Record indexed (A : Type) := stamp { + indexed_value : A; + indexed_index : nat +}. + +Arguments stamp {A} _ _. +Arguments indexed_value {A} _. +Arguments indexed_index {A} _. + +(** [P] holds of the payload AND the occurrence is not older than [lower]. + A retained world therefore cannot satisfy a strictly later bound. *) +Definition indexed_after {A} (P : A -> Prop) (lower : nat) + (o : indexed A) : Prop := + P (indexed_value o) /\ lower <= indexed_index o. + diff --git a/theories/ICTree/Eq/Bind.v b/theories/ICTree/Eq/Bind.v index 1a723bb..1c7c24a 100644 --- a/theories/ICTree/Eq/Bind.v +++ b/theories/ICTree/Eq/Bind.v @@ -308,6 +308,13 @@ Proof. step; now cbn. Qed. Lemma unfold_stuck {E R} {HE: Encode E}: @stuck E _ R ≅ Guard stuck. Proof. exact (ictree_eta stuck). Qed. +(** A tree that is raw-equivalent to its own guard is the guarded divergence. *) +Lemma equ_guard_stuck {E X} {HE : Encode E} (t : ictree E X) : t ≅ Guard t -> t ≅ stuck. +Proof. + intros Hguard; unfold equ; coinduction R CIH. + rewrite Hguard, unfold_stuck; constructor; exact CIH. +Qed. + Lemma unfold_spin {E R} {HE: Encode E}: @spin E _ R ≅ step spin. Proof. exact (ictree_eta spin). Qed. diff --git a/theories/ICTree/Equ.v b/theories/ICTree/Equ.v index 6d7ea6d..70b427b 100644 --- a/theories/ICTree/Equ.v +++ b/theories/ICTree/Equ.v @@ -6,7 +6,9 @@ From TICL Require Import ICTree.Core. From Stdlib Require Import - Classes.Morphisms. + Relations + Classes.RelationClasses + Classes.Morphisms. Import ICTreeNotations. Local Open Scope ictree_scope. @@ -45,3 +47,65 @@ Ltac observe_equ_all := observe_equ_all | _ => idtac end. + +(** * Forgetting finitely many leading guards. + + [guard_equ] is the equivalence closure of "raw-equivalent, or one leading + guard away". It forgets ONLY finitely many leading guards and raw + equivalence: it never erases a [Br] node, and it never equates a + divergent prefix with a productive one. The closure is Stdlib's + [clos_refl_sym_trans], not a second hand-written equivalence closure; the + five constructor-shaped facts below are derived so that source-alignment + tactics remain usable. *) + +Definition guard_step {E} {HE : Encode E} {X} (t u : ictree E X) : Prop := + t ≅ u \/ t ≅ Guard u. + +Definition guard_equ {E} {HE : Encode E} {X} : ictree E X -> ictree E X -> Prop := + clos_refl_sym_trans _ guard_step. + +Section GuardEqu. + Context {E : Type} {HE : Encode E} {X : Type}. + + Lemma guard_equ_equ (t u : ictree E X) : t ≅ u -> guard_equ t u. + Proof. intro H; apply rst_step; now left. Qed. + + Lemma guard_equ_left (t u : ictree E X) : + guard_equ t u -> guard_equ (Guard t) u. + Proof. + intro H; eapply rst_trans; [| exact H]. + apply rst_step; right; reflexivity. + Qed. + + Lemma guard_equ_right (t u : ictree E X) : + guard_equ t u -> guard_equ t (Guard u). + Proof. + intro H; eapply rst_trans; [exact H |]. + apply rst_sym, rst_step; right; reflexivity. + Qed. + + Lemma guard_equ_sym (t u : ictree E X) : guard_equ t u -> guard_equ u t. + Proof. apply rst_sym. Qed. + + Lemma guard_equ_trans (t u v : ictree E X) : + guard_equ t u -> guard_equ u v -> guard_equ t v. + Proof. apply rst_trans. Qed. + + #[global] Instance guard_equ_Equivalence : Equivalence (@guard_equ E HE X). + Proof. + split. + - intro t; apply rst_refl. + - intros t u; apply rst_sym. + - intros t u v; apply rst_trans. + Qed. + + #[global] Instance guard_equ_proper : + Proper (equ eq ==> equ eq ==> iff) (@guard_equ E HE X). + Proof. + intros t t' Ht u u' Hu; split; intro H. + - eapply guard_equ_trans; [apply guard_equ_equ; symmetry; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; exact Hu]. + - eapply guard_equ_trans; [apply guard_equ_equ; exact Ht|]. + eapply guard_equ_trans; [exact H|apply guard_equ_equ; symmetry; exact Hu]. + Qed. +End GuardEqu. diff --git a/theories/ICTree/Events/Writer.v b/theories/ICTree/Events/Writer.v index b92cad0..0d61fa4 100644 --- a/theories/ICTree/Events/Writer.v +++ b/theories/ICTree/Events/Writer.v @@ -8,7 +8,8 @@ From TICL Require Import Logic.World Events.Core ICTree.Events.State - ICTree.Core. + ICTree.Core + ICTree.Equ. From TICL Require Export Events.WriterE. @@ -51,6 +52,22 @@ Definition h_stateW{S}: stateE S ~> InstrM S S := | Put s' => log s' ;; Ret (tt, s') end). +(** The one shared indexing handler: every [Log a] emits exactly one indexed + observation and increments the shared counter once. The untouched + auxiliary state [Sigma] is passed through unchanged, so the same handler + serves a heap-and-counter signature and a bare counter. *) +Definition h_indexed {A Sigma : Type} : + writerE A ~> stateT (Sigma * nat) (ictreeW (indexed A)) := + fun '(Log a) => mkStateT (fun '(s,c) => + log (stamp a c);; Ret (tt,(s,S c))). + +(** The canonical RAW response certificate of an emitting segment. It is a + handler equation, not an interpreter equation. *) +Lemma h_indexed_log {A Sigma} (a : A) (s : Sigma) (c : nat) : + runStateT (h_indexed (Sigma:=Sigma) (Log a)) (s,c) + ≅ (log (stamp a c);; Ret (tt,(s,S c))). +Proof. reflexivity. Qed. + #[global] Instance ReSum_inlW {A B} : ReSum (writerE A) (writerE (A + B)) := fun '(Log a) => Log (inl a). diff --git a/theories/ICTree/Interp/Core.v b/theories/ICTree/Interp/Core.v index 3f7a834..68d83f6 100644 --- a/theories/ICTree/Interp/Core.v +++ b/theories/ICTree/Interp/Core.v @@ -58,6 +58,8 @@ Proof. rewrite ?bind_ret_l. reflexivity. - reflexivity. + +From Coinduction Require Import coinduction. - setoid_rewrite bind_ret_l. reflexivity. Qed. diff --git a/theories/ICTree/Interp/Heap.v b/theories/ICTree/Interp/Heap.v new file mode 100644 index 0000000..20bc194 --- /dev/null +++ b/theories/ICTree/Interp/Heap.v @@ -0,0 +1,397 @@ +(** * Checked heap accesses and constructive allocation, in one handler. + + The handler is polymorphic in its OUTPUT effect [F] and in an untouched + auxiliary state [Sigma]; the heap itself is the first component of the + interpretation state. Instrumented interpreters instantiate [F] with a + writer effect and [Sigma] with their own bookkeeping; a pure client may + instantiate [F := void] and [Sigma := unit]. + + The algorithm is fixed: allocation starts at address 1, rejects size 0, + searches the immutable snapshot for the first free positive block, keeps + rejected candidates silent, preserves [aux], propagates a missing + read/write/CAS as [stuck], leaves the whole state unchanged on a failed + CAS, and lets a free of an absent cell succeed. There is no least-address + axiom, no fuel, and no failure fallback. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From Coinduction Require Import coinduction. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Events.Heap + Events.Core. + +From TICL Require Export Events.HeapModel. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +(** Setoid rewriting through [≅] and [~] needs [equ]/[sbisim] to be + typeclass-transparent, exactly as elsewhere in this development. Both + unfold to the Coinduction companion [t], which that library keeps + typeclass-opaque -- but only as an [#[export]] setting, so it is in + effect solely in modules that IMPORT [coinduction], not in modules that + merely require it transitively. Without that import the transparency + below lets resolution unfold past [t] into the lattice machinery, and at + the generic effect type [F] of this module a single [reflexivity] costs + tens of seconds instead of milliseconds. That is why [coinduction] is + imported explicitly above. *) +Local Typeclasses Transparent equ. +Local Typeclasses Transparent sbisim. + +(** The immutable snapshot is searched without fuel or heap instrumentation. + Every rejected candidate is silent; only success changes the heap. *) +CoFixpoint alloc_search {F : Type} {HF : Encode F} {Sigma : Type} + (h : Heap) (size candidate : nat) (aux : Sigma) + : ictree F (nat * (Heap * Sigma)) := + match size with + | 0 => stuck + | S _ => + if block_freeb h candidate size + then Ret (candidate, (hunion (hblock candidate size) h, aux)) + else Guard (alloc_search h size (S candidate) aux) + end. + +Definition heap_handler {F : Type} {HF : Encode F} {Sigma : Type} + : heapE ~> stateT (Heap * Sigma) (ictree F) := + fun e => + mkStateT (fun s => + match e return ictree F (encode e * (Heap * Sigma)) with + | HRead a => match fst s a with + | Some v => Ret (v,s) + | None => stuck + end + | HWrite a v => match fst s a with + | Some _ => Ret (tt,(upd (fst s) a v,snd s)) + | None => stuck + end + | HAlloc size => alloc_search (fst s) size 1 (snd s) + | HFree a => Ret (tt,(hfree a (fst s),snd s)) + | HCAS a expected desired => + match fst s a with + | None => stuck + | Some current => + if Nat.eqb current expected + then Ret (true,(upd (fst s) a desired,snd s)) + else Ret (false,s) + end + end). + +(** ** Raw handler equations. + + These are the canonical response certificates a first-yield segment + discharges; they are handler equations, not interpreter equations. *) +Section HandlerEquations. + Context {F : Type} {HF : Encode F} {Sigma : Type}. + + Lemma heap_handler_rd_some : forall a h (aux : Sigma) v, + h a = Some v -> + runStateT (heap_handler (F:=F) (HRead a)) (h,aux) ≅ Ret (v,(h,aux)). + Proof. intros a h aux v H; cbn; rewrite H; reflexivity. Qed. + + Lemma heap_handler_rd_none : forall a h (aux : Sigma), + h a = None -> + runStateT (heap_handler (F:=F) (HRead a)) (h,aux) ≅ stuck. + Proof. intros a h aux H; cbn; rewrite H; reflexivity. Qed. + + Lemma heap_handler_wr_some : forall a h (aux : Sigma) v w, + h a = Some w -> + runStateT (heap_handler (F:=F) (HWrite a v)) (h,aux) ≅ + Ret (tt,(upd h a v,aux)). + Proof. intros a h aux v w H; cbn; rewrite H; reflexivity. Qed. + + Lemma heap_handler_wr_none : forall a h (aux : Sigma) v, + h a = None -> + runStateT (heap_handler (F:=F) (HWrite a v)) (h,aux) ≅ stuck. + Proof. intros a h aux v H; cbn; rewrite H; reflexivity. Qed. + + Lemma heap_handler_cas_success a expected desired h (aux : Sigma) : + h a = Some expected -> + runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ + Ret (true,(upd h a desired,aux)). + Proof. intro H; cbn; rewrite H, Nat.eqb_refl; reflexivity. Qed. + + Lemma heap_handler_cas_failure a expected desired current h (aux : Sigma) : + h a = Some current -> current <> expected -> + runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ + Ret (false,(h,aux)). + Proof. + intros H N; cbn; rewrite H. + apply Nat.eqb_neq in N; rewrite N; reflexivity. + Qed. + + Lemma heap_handler_cas_missing a expected desired h (aux : Sigma) : + h a = None -> + runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ + (stuck : ictree F (bool * (Heap * Sigma))). + Proof. intro H; cbn; rewrite H; reflexivity. Qed. + + Lemma heap_handler_free a h (aux : Sigma) : + runStateT (heap_handler (F:=F) (HFree a)) (h,aux) ≅ + Ret (tt,(hfree a h,aux)). + Proof. reflexivity. Qed. +End HandlerEquations. + +(** ** Allocation search *) +Section AllocSearch. + Context {F : Type} {HF : Encode F} {Sigma : Type}. + + Lemma unfold_alloc_search h size candidate (aux : Sigma) : + alloc_search (F:=F) h size candidate aux ≅ + match size with + | 0 => stuck + | S _ => if block_freeb h candidate size + then Ret (candidate, (hunion (hblock candidate size) h, aux)) + else Guard (alloc_search (F:=F) h size (S candidate) aux) + end. + Proof. step; cbn; unfold observe; cbn; reflexivity. Qed. + + Lemma alloc_search_first h size start base (aux : Sigma) : + Nat.lt 0 size -> Nat.le start base -> block_free h base size -> + (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size) -> + alloc_search (F:=F) h size start aux ~ + Ret (base, (hunion (hblock base size) h, aux)). + Proof. + intros Pos L Free First; destruct size as [|size]; [lia |]. + remember (base - start) as distance eqn:D. + revert start L First D. + induction distance as [|distance IH]; intros start L First D. + - assert (start = base) by lia; subst start. + rewrite unfold_alloc_search. + apply block_freeb_spec in Free; rewrite Free; reflexivity. + - assert (Test : block_freeb h start (S size) = false). + { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. + exfalso; apply (First start); try lia; apply block_freeb_spec; exact T. } + rewrite unfold_alloc_search, Test. + etransitivity; [apply sb_guard |]. + apply IH; [lia | |lia]. + intros j J B; apply First; lia. + Qed. + + Lemma alloc_search_no_space h size start (aux : Sigma) : + Nat.lt 0 size -> + (forall j, Nat.le start j -> ~ block_free h j size) -> + alloc_search (F:=F) h size start aux ≅ + (stuck : ictree F (nat * (Heap * Sigma))). + Proof. + intros Pos Full; destruct size as [|size]; [lia |]. + revert start Full; __coinduction_equ R CIH; intros start Full. + assert (Test : block_freeb h start (S size) = false). + { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. + exfalso; apply (Full start); [lia | apply block_freeb_spec; exact T]. } + rewrite unfold_alloc_search, Test, unfold_stuck. + constructor; apply CIH; intros j J; apply Full; lia. + Qed. + + Lemma heap_handler_alloc_zero h (aux : Sigma) : + runStateT (heap_handler (F:=F) (HAlloc 0)) (h,aux) ≅ + (stuck : ictree F (nat * (Heap * Sigma))). + Proof. exact (unfold_alloc_search h 0 1 aux). Qed. + + Lemma heap_handler_alloc_first h size base (aux : Sigma) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + runStateT (heap_handler (F:=F) (HAlloc size)) (h,aux) ~ + Ret (base, (hunion (hblock base size) h, aux)). + Proof. + intros Pos B Free First. + apply (alloc_search_first h size 1 base aux); try assumption; try lia. + Qed. + + (** A finite heap always admits a first-fit witness. *) + Lemma heap_handler_alloc_finite h size (aux : Sigma) : + heap_finite h -> Nat.lt 0 size -> + exists base, + Nat.lt 0 base /\ block_free h base size /\ + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) /\ + runStateT (heap_handler (F:=F) (HAlloc size)) (h,aux) ~ + Ret (base, (hunion (hblock base size) h, aux)). + Proof. + intros [B Bound] Pos. + assert (Search : forall distance start, + Nat.max 1 B = (start + distance)%nat -> + exists base, Nat.le start base /\ block_free h base size /\ + (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size)). + { induction distance as [|distance IH]; intros start D. + - exists start; split; [lia |]; split. + + eapply heap_bounded_block_free; [exact Bound |lia]. + + intros j J L; lia. + - destruct (block_freeb h start size) eqn:T. + + exists start; split; [lia |]; split. + * apply block_freeb_spec; exact T. + * intros j J L; lia. + + destruct (IH (S start) ltac:(lia)) as (base & L & F0 & First). + exists base; split; [lia |]; split; [exact F0 |]. + intros j J Lt Free; destruct (Nat.eq_dec j start) as [E|E]. + * subst j; apply block_freeb_spec in Free; congruence. + * apply (First j); try lia; exact Free. } + destruct (Search (Nat.max 1 B - 1) 1 ltac:(lia)) + as (base & L & F0 & First). + exists base; split; [lia |]; split; [exact F0 |]; split. + - intros j J Lt; apply First; lia. + - apply heap_handler_alloc_first; try assumption; try lia. + Qed. +End AllocSearch. + +(** ** Lifting through [interp_state]. + + Adding another effect handler leaves the checked memory paths unchanged; + [other] is arbitrary. *) +Section HeapInterp. + Context {F G : Type} {HF : Encode F} {HG : Encode G} {Sigma : Type} + (other : G ~> stateT (Heap * Sigma) (ictree F)). + + Lemma interp_heap_rd {X} : forall a h (aux : Sigma) v + (k : nat -> ictree (heapE + G) X), + h a = Some v -> + interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,aux) ~ + interp_state (h_sum heap_handler other) (k v) (h,aux). + Proof. + intros a h aux v k H. + unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_rd_some (F:=F) a h aux v H), bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_wr {X} : forall a h (aux : Sigma) v w + (k : unit -> ictree (heapE + G) X), + h a = Some w -> + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,aux) ~ + interp_state (h_sum heap_handler other) (k tt) (upd h a v,aux). + Proof. + intros a h aux v w k H. + unfold heap_write, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_wr_some (F:=F) a h aux v w H), bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_wr_present {X} : forall a h (aux : Sigma) v + (k : unit -> ictree (heapE + G) X), + h a <> None -> + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,aux) ~ + interp_state (h_sum heap_handler other) (k tt) (upd h a v,aux). + Proof. + intros a h aux v k H; destruct (h a) as [w |] eqn:Ha; [| contradiction]. + eapply interp_heap_wr; eauto. + Qed. + + Lemma interp_heap_rd_stuck a h (aux : Sigma) : + h a = None -> + interp_state (h_sum heap_handler other) (heap_read (E:=heapE + G) a) (h,aux) + ≅ (stuck : ictree F (nat * (Heap * Sigma))). + Proof. + intro H; unfold heap_read, ICtree.trigger. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_rd_none (F:=F) a h aux H). + apply bind_stuck_equ. + Qed. + + Lemma interp_heap_wr_stuck a v h (aux : Sigma) : + h a = None -> + interp_state (h_sum heap_handler other) (heap_write (E:=heapE + G) a v) (h,aux) + ≅ (stuck : ictree F (unit * (Heap * Sigma))). + Proof. + intro H; unfold heap_write, ICtree.trigger. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_wr_none (F:=F) a h aux v H). + apply bind_stuck_equ. + Qed. + + Lemma interp_heap_cas_success {X} a expected desired h (aux : Sigma) + (k : bool -> ictree (heapE + G) X) : + h a = Some expected -> + interp_state (h_sum heap_handler other) + (b <- heap_cas a expected desired;; k b) (h,aux) ~ + interp_state (h_sum heap_handler other) (k true) (upd h a desired,aux). + Proof. + intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; + setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_cas_success (F:=F) a expected desired h aux H), + bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_cas_failure {X} a expected desired current h (aux : Sigma) + (k : bool -> ictree (heapE + G) X) : + h a = Some current -> current <> expected -> + interp_state (h_sum heap_handler other) + (b <- heap_cas a expected desired;; k b) (h,aux) ~ + interp_state (h_sum heap_handler other) (k false) (h,aux). + Proof. + intros H N; unfold heap_cas, ICtree.trigger; rewrite bind_vis; + setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_cas_failure (F:=F) a expected desired current h aux H N), + bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_cas_missing {X} a expected desired h (aux : Sigma) + (k : bool -> ictree (heapE + G) X) : + h a = None -> + interp_state (h_sum heap_handler other) + (b <- heap_cas a expected desired;; k b) (h,aux) ~ + (stuck : ictree F (X * (Heap * Sigma))). + Proof. + intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; + setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_cas_missing (F:=F) a expected desired h aux H). + rewrite bind_stuck_equ; reflexivity. + Qed. + + Lemma interp_heap_free {X} a h (aux : Sigma) + (k : unit -> ictree (heapE + G) X) : + interp_state (h_sum heap_handler other) (heap_free a >>= k) (h,aux) ~ + interp_state (h_sum heap_handler other) (k tt) (hfree a h,aux). + Proof. + unfold heap_free, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl; + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_free (F:=F) a h aux), bind_ret_l. + apply sb_guard. + Qed. + + Lemma interp_heap_alloc_zero h (aux : Sigma) : + interp_state (h_sum heap_handler other) (heap_alloc (E:=heapE + G) 0) (h,aux) + ≅ (stuck : ictree F (nat * (Heap * Sigma))). + Proof. + unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_alloc_zero (F:=F) h aux). + apply bind_stuck_equ. + Qed. + + Lemma interp_heap_alloc_first {X} h size base (aux : Sigma) + (k : nat -> ictree (heapE + G) X) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_state (h_sum heap_handler other) (a <- heap_alloc size;; k a) (h,aux) ~ + interp_state (h_sum heap_handler other) (k base) + (hunion (hblock base size) h,aux). + Proof. + intros Pos B Free First. + unfold heap_alloc, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl; + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_alloc_first (F:=F) h size base aux Pos B Free First), + bind_ret_l. + apply sb_guard. + Qed. +End HeapInterp. diff --git a/theories/ICTree/Interp/Refine.v b/theories/ICTree/Interp/Refine.v index 9a9ccbd..2eb5709 100644 --- a/theories/ICTree/Interp/Refine.v +++ b/theories/ICTree/Interp/Refine.v @@ -11,6 +11,14 @@ Definition rr_pick (n cursor : nat) : Fin.t (S n) := @Fin.of_nat_lt (cursor mod S n) (S n) (Nat.mod_upper_bound cursor (S n) (Nat.neq_succ_0 n)). +(** Compare numeric choices, not the proof arguments of finite indices. *) +Lemma rr_pick_mod_congr n cursor cursor' : + cursor mod S n = cursor' mod S n -> rr_pick n cursor = rr_pick n cursor'. +Proof. + intro Hmod; apply Fin.to_nat_inj; unfold rr_pick. + rewrite !Fin.to_nat_of_nat; exact Hmod. +Qed. + CoFixpoint refine_rr {E : Type} `{Encode E} {A : Type} (t : ictree E A) (cursor : nat) : ictree E (A * nat) := match observe t with @@ -224,7 +232,7 @@ End BranchFreeLaws. Lemma rr_pick_even n : Nat.even n = true -> rr_pick 1 n = Fin.F1. Proof. intro Hn; apply Nat.even_spec in Hn; destruct Hn as [k ->]. - apply Fin.to_nat_inj; unfold rr_pick; rewrite Fin.to_nat_of_nat. + transitivity (rr_pick 1 0); [apply rr_pick_mod_congr|reflexivity]. change ((2 * k) mod 2 = 0). rewrite Nat.mul_comm; apply Nat.mod_mul; discriminate. Qed. @@ -234,9 +242,9 @@ Proof. intro Hn. assert (Ho : Nat.odd n = true) by (unfold Nat.odd; now rewrite Hn). apply Nat.odd_spec in Ho; destruct Ho as [k ->]. - apply Fin.to_nat_inj; unfold rr_pick; rewrite Fin.to_nat_of_nat. + transitivity (rr_pick 1 1); [apply rr_pick_mod_congr|reflexivity]. change ((2 * k + 1) mod 2 = 1). - rewrite Nat.add_mod by discriminate. + rewrite Nat.Div0.add_mod. rewrite (Nat.mul_comm 2 k), Nat.mod_mul by discriminate. reflexivity. Qed. diff --git a/theories/ICTree/Interp/State/Mod.v b/theories/ICTree/Interp/State/Mod.v index 45ee669..eceb1af 100644 --- a/theories/ICTree/Interp/State/Mod.v +++ b/theories/ICTree/Interp/State/Mod.v @@ -9,7 +9,6 @@ From TICL Require Import ICTree.Interp.Core Events.Core ICTree.Events.Writer - ICTree.Logic.Trans ICTree.Events.State ICTree.Equ ICTree.SBisim. @@ -340,3 +339,27 @@ Proof with eauto. unfold instr_stateE. apply interp_state_put. Qed. + +(** * Interpreting one indexed emission. + + [h_indexed] leaves exactly one observation and advances the shared + occurrence counter once; the untouched auxiliary state and the other + handler are arbitrary. This is the interpretation-level companion of the + raw equation [h_indexed_log]. *) +Local Typeclasses Transparent equ. +Lemma interp_indexed_emit {A Sigma E X} {HE : Encode E} + (other : E ~> stateT (Sigma * nat) (ictreeW (indexed A))) + (a : A) (s : Sigma) (c : nat) + (k : unit -> ictree (E + writerE A) X) : + interp_state (h_sum other h_indexed) + ((ICtree.trigger (Log a) : ictree (E + writerE A) unit) >>= k) (s,c) ~ + (log (stamp a c);; interp_state (h_sum other h_indexed) (k tt) (s,S c)). +Proof. + unfold ICtree.trigger, resum, resum_ret, ReSum_inr, ReSumRet_inr; + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (h_indexed_log (Sigma:=Sigma) a s c), bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; apply sb_guard. +Qed. +Local Typeclasses Opaque equ. diff --git a/theories/ICTree/Interp/Yield/Execution.v b/theories/ICTree/Interp/Yield/Execution.v new file mode 100644 index 0000000..3d3ee96 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Execution.v @@ -0,0 +1,754 @@ +(** * Abstract turn models and pool simulation. + + The bridge between an ABSTRACT stepping model (a partial transition on an + opaque state, emitting at most one observation per turn) and the CONCRETE + scheduled interpretation of a thread pool. + + Nothing here mentions a particular source language. [Execution] and + [ThreadSegment] stay output/list polymorphic; only these two models fix + the zero-or-one-observation turn shape. *) + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector + Classes.Morphisms Classes.RelationClasses Classes.RelationPairs. +From ExtLib Require Import Data.Option. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Yield.Segments + Utils.Vectors Utils.Execution. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** ** The two models *) +Section Models. + Context {St Act W X : Type} (n : nat) + (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)). + + (** Every nondeterministic turn begins with exactly one real branch node. + The post-effect guards are invisible, not additional choices. *) + CoFixpoint model_nd (s : St) : ictreeW W X := + Br n (fun i => + match step (actor i) s with + | None => stuck + | Some (next,None) => Guard (model_nd next) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_nd next)) + end). + + CoFixpoint model_rr (s : St) (cursor : nat) : ictreeW W X := + match step (actor (rr_pick n cursor)) s with + | None => stuck + | Some (next,None) => Guard (model_rr next (S cursor)) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_rr next (S cursor))) + end. + + Lemma unfold_model_nd s : + (model_nd s : ictreeW W X) ≅ + Br n (fun i => + match step (actor i) s with + | None => stuck + | Some (next,None) => Guard (model_nd next) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_nd next)) + end). + Proof. step; now cbn. Qed. + + Lemma unfold_model_rr s cursor : + (model_rr s cursor : ictreeW W X) ≅ + match step (actor (rr_pick n cursor)) s with + | None => stuck + | Some (next,None) => Guard (model_rr next (S cursor)) + | Some (next,Some event) => + Vis (Log event) (fun _ => Guard (model_rr next (S cursor))) + end. + Proof. step; now cbn. Qed. + + (** Index-first: no assumption that every abstract action occurs in + [actor]. *) + Lemma model_turn_finite_steps (i : Fin.t (S n)) s next event : + step (actor i) s = Some (next,event) -> + finite_steps (model_nd s : ictreeW W X) (turn_labels event) + (Guard (model_nd next)). + Proof. + intro Hstep; destruct event as [o|]; cbn [turn_labels]. + - eapply finite_steps_cons with + (u := Vis (Log o) (fun _ => Guard (model_nd next))). + + rewrite (unfold_model_nd s). + eapply trans_br with (x := i); rewrite Hstep; reflexivity. + + econstructor; + [exact (@trans_vis (writerE W) _ X (Log o) tt + (fun _ => Guard (model_nd next)))|constructor]. + - econstructor; [|constructor]. + rewrite (unfold_model_nd s). + eapply trans_br with (x := i); rewrite Hstep; reflexivity. + Qed. +End Models. + +Arguments model_nd {St Act W X} n actor step s. +Arguments model_rr {St Act W X} n actor step s cursor. + +(** ** Round-robin model congruence in the state and the cursor. *) +Section ModelRRCongruence. + Context {St Act W X : Type} (n : nat) + (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)) + (R : St -> St -> Prop) + (Requiv : Equivalence R) + (Hstep : Proper (eq ==> R ==> Roption (RelProd R eq)) step). + + Lemma model_rr_equ : forall s t cursor cursor', + R s t -> cursor mod (S n) = cursor' mod (S n) -> + (model_rr n actor step s cursor : ictreeW W X) ≅ + model_rr n actor step t cursor'. + Proof. + coinduction Rc IH; intros s t cursor cursor' Hst Hmod. + assert (Hnextmod : S cursor mod (S n) = S cursor' mod (S n)). + { replace (S cursor) with (cursor + 1) by lia. + replace (S cursor') with (cursor' + 1) by lia. + rewrite (Nat.Div0.add_mod cursor 1 (S n)), + (Nat.Div0.add_mod cursor' 1 (S n)), Hmod. + reflexivity. } + rewrite !unfold_model_rr. + rewrite <- (rr_pick_mod_congr n cursor cursor' Hmod). + pose proof (Hstep (actor (rr_pick n cursor)) _ eq_refl s t Hst) as Hturn. + destruct (step (actor (rr_pick n cursor)) s) as [[s' event]|]; + destruct (step (actor (rr_pick n cursor)) t) as [[t' event']|]; + inversion Hturn as [|p q Hpair]; subst. + - unfold RelProd, RelCompFun in Hpair. + destruct Hpair as [Hnext Hevent]; cbn in Hnext, Hevent; subst event'. + destruct event as [o|]; cbn. + + constructor; intros []. + step; cbn; constructor; apply IH; [exact Hnext|exact Hnextmod]. + + constructor; apply IH; [exact Hnext|exact Hnextmod]. + - reflexivity. + Qed. +End ModelRRCongruence. + +(** ** Finite replay against the models. *) +Definition rr_script {Act} (n : nat) (actor : Fin.t (S n) -> Act) + (cursor len : nat) : list Act := + List.map (fun k => actor (rr_pick n k)) (List.seq cursor len). + +Section ModelReplay. + Context {St Act W X : Type} (n : nat) + (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)). + + Lemma model_rr_run_turns : forall len cursor s last logs, + run_turns step event_obs (rr_script n actor cursor len) s = Some (last,logs) -> + (model_rr n actor step s cursor : ictreeW W X) ~ + emit_list logs (model_rr n actor step last (cursor + len) : ictreeW W X). + Proof. + induction len as [|len IH]; intros cursor s last logs Hrun. + - cbn [rr_script List.seq List.map run_turns] in Hrun. + inversion Hrun; subst; cbn [emit_list]. + now rewrite Nat.add_0_r. + - unfold rr_script in Hrun; cbn [List.seq List.map run_turns] in Hrun. + destruct (step (actor (rr_pick n cursor)) s) as [[next event]|] eqn:Hstep; + [|discriminate]. + destruct (run_turns step event_obs + (List.map (fun k => actor (rr_pick n k)) (List.seq (S cursor) len)) next) + as [[last' tail]|] eqn:Hrest; [|discriminate]. + inversion Hrun; subst last logs; clear Hrun. + specialize (IH (S cursor) next last' tail Hrest). + rewrite (unfold_model_rr n actor step s cursor), Hstep. + replace (cursor + S len) with (S cursor + len) by lia. + destruct event as [o|]; cbn [event_obs emit_list app]. + + rewrite emit_list_cons. + apply sb_vis; intros []; rewrite sb_guard; exact IH. + + rewrite sb_guard; exact IH. + Qed. + + (** Realizing every abstract action needs the two inverse slot laws. *) + Context (slot : Act -> Fin.t (S n)) + (actor_slot : forall who, actor (slot who) = who). + + Lemma model_run_turns_labels : forall script s last logs, + run_turns step event_obs script s = Some (last,logs) -> + exists labels residual, + run_turns step turn_labels script s = Some (last,labels) /\ + label_logs labels = logs /\ + label_taus labels = List.length script /\ + finite_steps (model_nd n actor step s : ictreeW W X) labels residual /\ + residual ~ (model_nd n actor step last : ictreeW W X). + Proof. + induction script as [|who rest IH]; intros s last logs Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst last logs. + exists [], (model_nd n actor step s); repeat split; + try reflexivity; constructor. + - cbn [run_turns] in Hrun. + destruct (step who s) as [[next event]|] eqn:Hstep; [|discriminate]. + destruct (run_turns step event_obs rest next) as [[last' logs']|] eqn:Hrest; + [|discriminate]. + inversion Hrun; subst last logs; clear Hrun. + destruct (IH next last' logs' Hrest) + as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Eresidual). + exists (turn_labels event ++ labels). + assert (Eguard : (model_nd n actor step next : ictreeW W X) ~ + Guard (model_nd n actor step next)) by (symmetry; apply sb_guard). + destruct (finite_steps_sbisim _ _ _ Hsteps _ Eguard) + as (residual' & Hsteps' & Eresidual'). + exists residual'; split. + + cbn [run_turns]; rewrite Hstep, Hlabels; reflexivity. + + split. + * unfold label_logs in *; rewrite List.flat_map_app, Hlogs. + destruct event; reflexivity. + * split. + -- unfold label_taus in *; + rewrite List.filter_app, List.length_app, Htaus. + destruct event; reflexivity. + -- split. + ++ eapply finite_steps_app; [|exact Hsteps']. + rewrite <- (actor_slot who) in Hstep. + eapply model_turn_finite_steps; exact Hstep. + ++ transitivity residual; + [symmetry; exact Eresidual'|exact Eresidual]. + Qed. +End ModelReplay. + +(** ** Round-robin recurrence from finite cycle certificates. + + A family of boundaries, each of whose RR cycle actually runs to a state + related to the next boundary while emitting a nonempty batch, makes the + RR model bisimilar to the library batch loop [emit_batches]. A failed + turn cannot supply a certificate, and the batch comes from the actual + run; no observation is synthesized and no state is reset. *) +Section ModelRRBatches. + Context {St Act W X I : Type} + (n : nat) (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)) + (R : St -> St -> Prop) + (Hstep : Proper (eq ==> R ==> Roption (RelProd R eq)) step) + (boundary : I -> St) (batch : I -> list W) (next : I -> I) + (Inv : I -> Prop) (cursor period : nat) + (Hcursor : (cursor + period) mod (S n) = cursor mod (S n)) + (Hnext : forall i, Inv i -> Inv (next i)) + (Hnonempty : forall i, Inv i -> batch i <> []) + (Hcycle : forall i, Inv i -> exists last, + run_turns step event_obs (rr_script n actor cursor period) (boundary i) = + Some (last,batch i) /\ R last (boundary (next i))). + + Lemma model_rr_emit_batches : forall i, Inv i -> + (model_rr n actor step (boundary i) cursor : ictreeW W X) ~ + (emit_batches batch next i : ictreeW W X). + Proof. + apply (emit_batches_bisim batch next Inv + (fun i => model_rr n actor step (boundary i) cursor : ictreeW W X) + Hnext Hnonempty). + intros i Hi. + destruct (Hcycle i Hi) as (last & Hrun & Hlast). + etransitivity; + [exact (model_rr_run_turns n actor step period cursor (boundary i) last + (batch i) Hrun)|]. + apply emit_list_sbisim, equ_sbisim. + exact (model_rr_equ n actor step R Hstep last (boundary (next i)) + (cursor + period) cursor Hlast Hcursor). + Qed. +End ModelRRBatches. + +(** ** Realizing an abstract execution by its model. *) +Section ModelRealization. + Context {St Act W X : Type} (n : nat) + (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)) + (slot : Act -> Fin.t (S n)) + (actor_slot : forall who, actor (slot who) = who) + (initial : St -> Prop). + + Lemma valid_execution_realizes_model (e : Execution St Act (option W)) : + execution_valid (fun a s o s' => step a s = Some (s',o)) initial e -> + forall k (t : ictreeW W X), + t ~ (model_nd n actor step (states e k) : ictreeW W X) -> + realizes (fun j => turn_labels (emitted e j)) k t. + Proof. + intro Hvalid. + apply (realizes_from_steps (fun j => turn_labels (emitted e j)) + (fun j => model_nd n actor step (states e j) : ictreeW W X)). + - intro j; apply turn_labels_nonempty. + - intro j; exists (Guard (model_nd n actor step (states e (S j)))); split. + + pose proof (execution_step step initial e j Hvalid) as Hstep. + rewrite <- (actor_slot (selected e j)) in Hstep. + eapply model_turn_finite_steps; exact Hstep. + + apply sb_guard. + Qed. +End ModelRealization. + +(** ** Raw scheduled executions. + + A raw execution is the SAME [Execution] record, at state + [pool E (S n) * Sigma], action [Act], output [list W]. *) +Section RawExecution. + Context {E W Sigma Act : Type} {HE : Encode E} + (n : nat) + (handler : E ~> stateT Sigma (ictreeW W)) + (slot : Act -> Fin.t (S n)). + + Notation Rsb := (fun Y (t u : ictreeW W Y) => t ~ u). + + Definition pool_step (who : Act) (p : pool E (S n) * Sigma) (logs : list W) + (q : pool E (S n) * Sigma) : Prop := + let '(ts,sigma) := p in + let '(ts',sigma') := q in + exists residual, + ThreadSegment handler Rsb (ts $ slot who) sigma logs residual sigma' /\ + pool_equ ts' (ts @ slot who := residual). + + Definition pool_execution_valid (ts0 : pool E (S n)) (sigma0 : Sigma) + (se : Execution (pool E (S n) * Sigma) Act (list W)) : Prop := + execution_valid pool_step + (fun p => pool_equ (fst p) ts0 /\ snd p = sigma0) se. + + (** Selections are physical branch witnesses, never inferred from logs. *) + Definition source_execution_of_slots + (actor : Fin.t (S n) -> Act) + (pools : nat -> pool E (S n)) (sigmas : nat -> Sigma) + (slots : nat -> Fin.t (S n)) (logs : nat -> list W) + : Execution (pool E (S n) * Sigma) Act (list W) := + {| states := fun k => (pools k,sigmas k); + selected := fun k => actor (slots k); + emitted := logs |}. + + (** A slot-built execution is valid from its initial facts and one raw + segment per step; the actor map is only required to name each slot. *) + Lemma source_execution_of_slots_valid + (actor : Fin.t (S n) -> Act) + (slot_actor : forall i, slot (actor i) = i) + (ts0 : pool E (S n)) (sigma0 : Sigma) + (pools : nat -> pool E (S n)) (sigmas : nat -> Sigma) + (slots : nat -> Fin.t (S n)) (logs : nat -> list W) : + pool_equ (pools 0) ts0 -> sigmas 0 = sigma0 -> + (forall k, exists residual, + ThreadSegment handler Rsb (pools k $ slots k) (sigmas k) + (logs k) residual (sigmas (S k)) /\ + pool_equ (pools (S k)) (pools k @ slots k := residual)) -> + pool_execution_valid ts0 sigma0 + (source_execution_of_slots actor pools sigmas slots logs). + Proof. + intros Hpool Hsigma Hsteps; split. + - cbn [source_execution_of_slots states fst snd]; split; assumption. + - intro k; cbn [source_execution_of_slots states selected emitted pool_step]. + rewrite slot_actor; apply Hsteps. + Qed. + + Lemma pool_step_branchfree who ts sigma logs ts' sigma' : + pool_step who (ts,sigma) logs (ts',sigma') -> + (forall j, BranchFree (ts $ j)) -> forall j, BranchFree (ts' $ j). + Proof. + intros (residual & Hseg & Epool) Hbf j. + eapply branchfree_equ_impl; [symmetry; apply Epool|]. + destruct (Fin.eq_dec j (slot who)) as [->|Hne]. + - rewrite Vector.nth_replace_eq. + eapply ThreadSegment_branchfree; [exact Hseg|apply Hbf]. + - rewrite Vector.nth_replace_neq by congruence; apply Hbf. + Qed. + + Theorem valid_pool_execution_scheduler_steps + (se : Execution (pool E (S n) * Sigma) Act (list W)) ts0 sigma0 k : + pool_execution_valid ts0 sigma0 se -> + exists next, + finite_steps + (interp_schedule_nd handler (S n) (fst (states se k)) None + (snd (states se k))) + (tau :: List.map (fun o => obs (Log o) tt) (emitted se k)) next /\ + next ~ interp_schedule_nd handler (S n) (fst (states se (S k))) None + (snd (states se (S k))). + Proof. + intros [_ Hsteps]; specialize (Hsteps k). + destruct (states se k) as [ts sigma] eqn:Ek. + destruct (states se (S k)) as [ts' sigma'] eqn:Ek'. + destruct Hsteps as (residual & Hseg & Epool). + cbn [fst snd]. + eapply (segment_scheduler_steps handler Rsb (fun Y t u (H : t ~ u) => H)); + eassumption. + Qed. +End RawExecution. + +Arguments pool_step {E W Sigma Act HE} n handler slot who p logs q. +Arguments pool_execution_valid {E W Sigma Act HE} n handler slot ts0 sigma0 se. + +(** ** Pool simulation. + + A proof-only certificate (not a typeclass) packaging exactly: executable + totality and invariant preservation, the actual handler-backed first-yield + segment of the selected slot, and stability of the unselected slots. It + assumes NO liveness, fairness, model trace, global bisimulation, or + function equality of states. *) +Section PoolSimulation. + Context {E W Sigma St Act : Type} {HE : Encode E} + (n : nat) + (handler : E ~> stateT Sigma (ictreeW W)) + (actor : Fin.t (S n) -> Act) (slot : Act -> Fin.t (S n)) + (actor_slot : forall who, actor (slot who) = who) + (slot_actor : forall i, slot (actor i) = i) + (step : Act -> St -> option (St * option W)) + (pool_of : St -> pool E (S n)) + (agree : Sigma -> St -> Prop) + (Inv : St -> Prop). + + Notation Rexact := (fun Y (t u : ictreeW W Y) => t ≅ u). + Notation Rsb := (fun Y (t u : ictreeW W Y) => t ~ u). + + Record PoolSimulation : Prop := { + simulation_total : forall who s, Inv s -> + exists s' event, step who s = Some (s',event) /\ Inv s'; + simulation_segment : forall who s s' event sigma, + Inv s -> agree sigma s -> step who s = Some (s',event) -> + exists residual sigma', + ThreadSegment handler Rexact + (pool_of s $ slot who) sigma (event_obs event) residual sigma' /\ + agree sigma' s' /\ + guard_equ residual (pool_of s' $ slot who) /\ + (forall j, j <> slot who -> (pool_of s $ j) ≅ (pool_of s' $ j)) + }. + + Context (Hsim : PoolSimulation). + + (** The same certificate transported to any pool aligned up to finitely + many leading guards. *) + Lemma selected_turn_segment (ts : pool E (S n)) s who s' event sigma : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + step who s = Some (s',event) -> + exists residual sigma', + ThreadSegment handler Rexact (ts $ slot who) sigma + (event_obs event) residual sigma' /\ + agree sigma' s' /\ + pool_guard_equ (ts @ slot who := residual) (pool_of s'). + Proof. + intros Hinv Hagree Hpool Hstep. + destruct (simulation_segment Hsim who s s' event sigma Hinv Hagree Hstep) + as (residual & sigma' & Hseg & Hagree' & Htail & Hframe). + exists residual, sigma'; split; [|split; [exact Hagree'|]]. + - apply (proj2 (guard_equ_segment_iff handler Rexact + (ts $ slot who) (pool_of s $ slot who) (Hpool (slot who)) + sigma (event_obs event) residual sigma')); exact Hseg. + - intro j; destruct (Fin.eq_dec j (slot who)) as [->|Hne]. + + rewrite Vector.nth_replace_eq; exact Htail. + + rewrite Vector.nth_replace_neq by congruence. + eapply guard_equ_trans; [apply Hpool|]. + apply guard_equ_equ, Hframe; exact Hne. + Qed. + + (** Completeness of the abstract model relative to the source: the segment + is unique, so the abstract turn determines its logs, its final handler + state (relationally), and the updated pool alignment. *) + Lemma selected_segment_deterministic (ts : pool E (S n)) s who s' event + sigma logs residual sigma' : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + step who s = Some (s',event) -> + ThreadSegment handler Rsb (ts $ slot who) sigma logs residual sigma' -> + logs = event_obs event /\ agree sigma' s' /\ + pool_guard_equ (ts @ slot who := residual) (pool_of s'). + Proof. + intros Hinv Hagree Hpool Hstep Hseg. + destruct (selected_turn_segment ts s who s' event sigma + Hinv Hagree Hpool Hstep) as (residual0 & sigma0 & Hseg0 & Hagree0 & Hpool0). + apply (ThreadSegment_mono handler Rexact Rsb + (fun Y t u => equ_sbisim t u)) in Hseg0. + destruct (ThreadSegment_deterministic handler Rsb + (fun Y t u (H : t ~ u) => H) (ts $ slot who) sigma + logs residual sigma' (event_obs event) residual0 sigma0 Hseg Hseg0) + as (Elogs & Esigma & Eresidual). + subst sigma0; split; [exact Elogs|]; split; [exact Hagree0|]. + eapply pool_equ_guard_trans; [|exact Hpool0]. + apply replace_pool_equ; [apply pool_equ_refl|exact Eresidual]. + Qed. + + (** Every raw segment of the selected slot is some model turn. *) + Lemma selected_segment_complete (ts : pool E (S n)) s who + sigma logs residual sigma' : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + ThreadSegment handler Rsb (ts $ slot who) sigma logs residual sigma' -> + exists s' event, step who s = Some (s',event) /\ Inv s' /\ + logs = event_obs event /\ agree sigma' s' /\ + pool_guard_equ (ts @ slot who := residual) (pool_of s'). + Proof. + intros Hinv Hagree Hpool Hseg. + destruct (simulation_total Hsim who s Hinv) as (s' & event & Hstep & Hinv'). + exists s', event; split; [exact Hstep|]; split; [exact Hinv'|]. + exact (selected_segment_deterministic ts s who s' event sigma logs residual + sigma' Hinv Hagree Hpool Hstep Hseg). + Qed. + + (** *** Worker guarantees of an aligned pool. + + Every slot reaches its next yield; no slot is finished, forking, + branching, stuck, divergent, or at a faulting handler call. *) + Lemma pool_simulation_worker_segment (ts : pool E (S n)) s who sigma : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + exists event residual sigma', + ThreadSegment handler Rsb (ts $ slot who) sigma + (event_obs event) residual sigma'. + Proof. + intros Hinv Hagree Hpool. + destruct (simulation_total Hsim who s Hinv) as (s' & event & Hstep & _). + destruct (selected_turn_segment ts s who s' event sigma Hinv Hagree Hpool Hstep) + as (residual & sigma' & Hseg & _ & _). + exists event, residual, sigma'. + apply (ThreadSegment_mono handler Rexact Rsb (fun Y t u => equ_sbisim t u)); + exact Hseg. + Qed. + + Lemma pool_simulation_no_terminal_prefix (ts : pool E (S n)) s who sigma : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + ~ guard_equ (ts $ slot who) (Ret tt) /\ + (forall k : bool -> thread E, + ~ guard_equ (ts $ slot who) (Vis (inr (inl Fork)) k)) /\ + (forall m (k : Fin.t (S m) -> thread E), + ~ guard_equ (ts $ slot who) (Br m k)) /\ + ~ guard_equ (ts $ slot who) (stuck : thread E). + Proof. + intros Hinv Hagree Hpool. + destruct (pool_simulation_worker_segment ts s who sigma Hinv Hagree Hpool) + as (event & residual & sigma' & Hseg). + repeat split. + - intro Hbad. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_ret_absurd handler Rsb sigma _ u sigma' Hfalse). + - intros k Hbad. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_fork_absurd handler Rsb k sigma _ u sigma' Hfalse). + - intros m k Hbad. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_br_absurd handler Rsb m k sigma _ u sigma' Hfalse). + - intro Hbad. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_stuck_absurd handler Rsb sigma _ u sigma' Hfalse). + Qed. + + Lemma pool_simulation_no_fault_or_divergence + (ts : pool E (S n)) s who sigma : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + ~ is_stuck (ts $ slot who) /\ + ~ guard_equ (ts $ slot who) (spin : thread E) /\ + (forall (e : E) (k : encode e -> thread E), + guard_equ (ts $ slot who) + (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k)) -> + ~ (runStateT (handler e) sigma ~ + (stuck : ictreeW W (encode e * Sigma)))). + Proof. + intros Hinv Hagree Hpool. + destruct (pool_simulation_worker_segment ts s who sigma Hinv Hagree Hpool) + as (event & residual & sigma' & Hseg). + split. + - intro Hstuck; apply Hstuck; eapply ThreadSegment_can_step; exact Hseg. + - split. + + intro Hbad. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hbad Hseg) as (u & Hfalse & _). + exact (ThreadSegment_spin_absurd handler Rsb sigma _ u sigma' Hfalse). + + intros e k Hhead Hfault. + destruct (guard_equ_segment handler Rsb _ _ _ _ _ _ Hhead Hseg) as (u & Hfalse & _). + exact (ThreadSegment_fault_absurd handler Rsb (fun Y t u (H : t ~ u) => H) + e k sigma _ u sigma' Hfault Hfalse). + Qed. + + (** *** Alignment of raw executions with model executions. + + Any valid raw execution and any valid model execution making the same + selections stay aligned at every index: invariant, relational state + agreement, guard-aligned pools, and equal observations. *) + Theorem source_execution_complete ts0 sigma0 s0 + (se : Execution (pool E (S n) * Sigma) Act (list W)) + (e : Execution St Act (option W)) : + Inv s0 -> agree sigma0 s0 -> pool_guard_equ ts0 (pool_of s0) -> + pool_execution_valid n handler slot ts0 sigma0 se -> + execution_valid (fun a s o s' => step a s = Some (s',o)) + (fun s => s = s0) e -> + (forall k, selected e k = selected se k) -> + forall k, Inv (states e k) /\ + agree (snd (states se k)) (states e k) /\ + pool_guard_equ (fst (states se k)) (pool_of (states e k)) /\ + emitted se k = event_obs (emitted e k). + Proof. + intros Hinv0 Hagree0 Hpool0 [Hinit Hsteps] [He0 Hestep] Hsel. + assert (Haligned : forall k, Inv (states e k) /\ + agree (snd (states se k)) (states e k) /\ + pool_guard_equ (fst (states se k)) (pool_of (states e k))). + { induction k as [|k (Hinv & Hagree & Hpool)]. + - destruct Hinit as [Hp Hs]; cbn beta in He0; rewrite He0, Hs. + split; [exact Hinv0|]; split; [exact Hagree0|]. + eapply pool_equ_guard_trans; [exact Hp|exact Hpool0]. + - specialize (Hsteps k); pose proof (Hestep k) as Hturn. + destruct (states se k) as [ts sigma]; + destruct (states se (S k)) as [ts' sigma']. + destruct Hsteps as (residual & Hseg & Epool); cbn [fst snd] in *. + destruct (selected_segment_complete ts (states e k) (selected se k) + sigma (emitted se k) residual sigma' Hinv Hagree Hpool Hseg) + as (s' & event & Hstep & Hinv' & _ & Hagree' & Hpool'). + rewrite <- (Hsel k), Hturn in Hstep; injection Hstep as <- <-. + split; [exact Hinv'|]; split; [exact Hagree'|]. + eapply pool_equ_guard_trans; [exact Epool|exact Hpool']. } + intro k; destruct (Haligned k) as (Hinv & Hagree & Hpool). + split; [exact Hinv|]; split; [exact Hagree|]; split; [exact Hpool|]. + specialize (Hsteps k); pose proof (Hestep k) as Hturn. + destruct (states se k) as [ts sigma]; + destruct (states se (S k)) as [ts' sigma']. + destruct Hsteps as (residual & Hseg & _); cbn [fst snd] in *. + rewrite (Hsel k) in Hturn. + exact (proj1 (selected_segment_deterministic ts (states e k) (selected se k) + (states e (S k)) (emitted e k) sigma (emitted se k) residual sigma' + Hinv Hagree Hpool Hturn Hseg)). + Qed. + + (** Every finitely reachable raw configuration is aligned with some model + state; reachability is the library closure, not a second inductive. *) + Lemma pool_simulation_reachable ts0 sigma0 s0 : + Inv s0 -> agree sigma0 s0 -> pool_guard_equ ts0 (pool_of s0) -> + forall ts sigma, + reachable (pool_step n handler slot) + (fun p => pool_equ (fst p) ts0 /\ snd p = sigma0) (ts,sigma) -> + exists s, Inv s /\ agree sigma s /\ pool_guard_equ ts (pool_of s). + Proof. + intros Hinv0 Hagree0 Hpool0 ts sigma. + apply (reachable_inv (pool_step n handler slot) + (fun p => pool_equ (fst p) ts0 /\ snd p = sigma0) + (fun p => exists s, Inv s /\ agree (snd p) s /\ + pool_guard_equ (fst p) (pool_of s))). + - intros [ts1 sigma1] [Hp Hs]; cbn [fst snd] in *; subst sigma1. + exists s0; split; [exact Hinv0|]; split; [exact Hagree0|]. + eapply pool_equ_guard_trans; [exact Hp|exact Hpool0]. + - intros a [ts1 sigma1] o [ts2 sigma2] (s & Hinv & Hagree & Hpool) Hstep; + cbn [fst snd] in *. + destruct Hstep as (residual & Hseg & Epool). + destruct (selected_segment_complete ts1 s a sigma1 o residual sigma2 + Hinv Hagree Hpool Hseg) + as (s' & event & _ & Hinv' & _ & Hagree' & Hpool'). + exists s'; split; [exact Hinv'|]; split; [exact Hagree'|]. + eapply pool_equ_guard_trans; [exact Epool|exact Hpool']. + Qed. + + (** *** Nondeterministic scheduling agrees with the ND model. *) + Local Notation st L := (coinduction.t (sb L)). + + Lemma pool_simulation_nd_bisim : forall s ts sigma, + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + interp_schedule_nd handler (S n) ts None sigma ~ + (model_nd n actor step s : ictreeW W (unit * Sigma)). + Proof. + unfold sbisim; apply_coinduction; fold_sbisim. + intros R IH s ts sigma Hinv Hagree Hpool. + etransitivity; + [apply (coinduction.gfp_bt (sb eq) R); + exact (interp_schedule_nd_select handler n ts sigma) |]. + eapply equ_sbt_closed_goal; + [reflexivity | exact (unfold_model_nd n actor step s) |]. + apply step_sb_br_id; [reflexivity | intro i]. + destruct (simulation_total Hsim (actor i) s Hinv) + as (next & event & Hstep & Hnextinv). + rewrite Hstep. + destruct (selected_turn_segment ts s (actor i) next event sigma + Hinv Hagree Hpool Hstep) as (residual & sigma' & Hseg & Hagree' & Hnextpool). + apply (ThreadSegment_mono handler Rexact Rsb + (fun Y t u => equ_sbisim t u)) in Hseg. + pose proof (segment_interp_nd handler Rsb (fun Y t u (H : t ~ u) => H) + n ts (slot (actor i)) (ts $ slot (actor i)) sigma + (event_obs event) residual sigma' Hseg) as Esegment. + rewrite slot_actor in Esegment, Hnextpool. + assert (Efocus : interp_schedule_nd handler (S n) ts (Some i) sigma ~ + emit_list (event_obs event) + (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma')). + { etransitivity; [| exact Esegment]. + symmetry; apply equ_sbisim; + exact (interp_schedule_nd_equ handler (S n) (ts @ i := (ts $ i)) ts + (Some i) sigma (pool_replace_current ts i)). } + etransitivity; [apply (coinduction.gfp_t (sb eq) R); exact Efocus |]. + assert (Hcontinue : st eq R + (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma') + (Guard (model_nd n actor step next))). + { etransitivity; + [exact (IH next (ts @ i := residual) sigma' Hnextinv Hagree' Hnextpool) |]. + apply (coinduction.gfp_t (sb eq) R); symmetry; + exact (sb_guard (model_nd n actor step next : ictreeW W (unit * Sigma))). } + destruct event as [o|]; cbn [event_obs]. + - eapply equ_clos_st_goal; + [reflexivity + | symmetry; + exact (emit_list_cons o [] + (Guard (model_nd n actor step next) : ictreeW W (unit * Sigma))) + |]. + apply (emit_list_st R [o]); exact Hcontinue. + - exact Hcontinue. + Qed. + + (** *** Round-robin scheduling is guard/log aligned with the RR model. *) + Lemma pool_simulation_rr_aligned : forall s ts sigma cursor, + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + rr_aligned + (interp_schedule_rr handler (S n) ts None cursor sigma) + (model_rr n actor step s cursor : ictreeW W (unit * Sigma)). + Proof. + cofix IH; intros s ts sigma cursor Hinv Hagree Hpool. + set (who := actor (rr_pick n cursor)). + assert (Eslot : slot who = rr_pick n cursor) by apply slot_actor. + destruct (simulation_total Hsim who s Hinv) + as (next & event & Hstep & Hnextinv). + destruct (selected_turn_segment ts s who next event sigma + Hinv Hagree Hpool Hstep) as (residual & sigma' & Hseg & Hagree' & Hnextpool). + destruct (exact_segment_rr_prefix handler n ts (slot who) + (ts $ slot who) (S cursor) sigma (event_obs event) residual sigma' Hseg) + as (word & Ew & Et). + set (next_tree := interp_schedule_rr handler (S n) + (ts @ slot who := residual) None (S cursor) sigma'). + set (next_model := + (model_rr n actor step next (S cursor) : ictreeW W (unit * Sigma))). + assert (Eprefix : interp_schedule_rr handler (S n) ts + (Some (slot who)) (S cursor) sigma ≅ rr_prefix word (Guard next_tree)). + { etransitivity; [| exact Et]. + symmetry; + exact (interp_schedule_rr_equ handler (S n) + (ts @ slot who := (ts $ slot who)) ts (Some (slot who)) (S cursor) sigma + (pool_replace_current ts (slot who))). } + assert (Hsource : interp_schedule_rr handler (S n) ts None cursor sigma ≅ + rr_guards 3 (rr_prefix word (Guard next_tree))). + { etransitivity; + [exact (segment_rr_select_exact handler n ts cursor sigma) |]. + apply (rr_guards_equ 3); rewrite <- Eslot; exact Eprefix. } + destruct event as [o|]; cbn [event_obs] in Ew. + - destruct (rr_prefix_one_event word o (Guard next_tree) Ew) as (a & b & Eword). + eapply rr_align_log with (n := 3 + a) (m := 0) (o := o) + (t' := rr_guards b (Guard next_tree)) (u' := Guard next_model). + + etransitivity; [exact Hsource |]. + rewrite (rr_guards_add 3 a + (Vis (Log o) (fun _ => rr_guards b (Guard next_tree)))). + apply rr_guards_equ; exact Eword. + + rewrite (unfold_model_rr n actor step s cursor); fold who; + rewrite Hstep; reflexivity. + + eapply rr_align_guard with (n := b) (m := 0) + (t' := next_tree) (u' := next_model). + * rewrite rr_guards_guard; reflexivity. + * reflexivity. + * apply IH; assumption. + - eapply rr_align_guard with (n := 3 + List.length word) (m := 0) + (t' := next_tree) (u' := next_model). + + etransitivity; [exact Hsource |]. + rewrite (rr_prefix_no_events word (Guard next_tree) Ew). + rewrite <- (rr_guards_add 3 (List.length word) (Guard next_tree)). + rewrite rr_guards_guard; reflexivity. + + rewrite (unfold_model_rr n actor step s cursor); fold who; + rewrite Hstep; reflexivity. + + apply IH; assumption. + Qed. + + Lemma pool_simulation_rr_bisim s ts sigma cursor : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + interp_schedule_rr handler (S n) ts None cursor sigma ~ + (model_rr n actor step s cursor : ictreeW W (unit * Sigma)). + Proof. + intros Hinv Hagree Hpool; apply rr_aligned_sbisim. + exact (pool_simulation_rr_aligned s ts sigma cursor Hinv Hagree Hpool). + Qed. + +End PoolSimulation. + +Arguments PoolSimulation {E W Sigma St Act HE} n handler slot step + pool_of agree Inv. + diff --git a/theories/ICTree/Interp/Yield/Nondeterministic.v b/theories/ICTree/Interp/Yield/Nondeterministic.v new file mode 100644 index 0000000..f5d41e5 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Nondeterministic.v @@ -0,0 +1,204 @@ +(** * Nondeterministic scheduling interpretation. + + The parallel of [ICTree.Interp.Yield.RoundRobin]: the same [schedule] + pool semantics, but every scheduling choice is an actual [Br] instead of + a cursor pick. The handler, effects, and auxiliary state are arbitrary; + no scheduler-policy record is introduced. *) + +From Stdlib Require Import Fin Vector. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Yield + ICTree.Events.State ICTree.Events.Writer + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.State.Mod Utils.Vectors. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +Section NondeterministicInterpretation. + Context {E F : Type} {HE : Encode E} {HF : Encode F} {Sigma : Type}. + + Definition interp_schedule_nd + (handler : E ~> stateT Sigma (ictree F)) + (n : nat) (ts : pool E n) (focus : option (Fin.t n)) (sigma : Sigma) + : ictree F (unit * Sigma) := + interp_state handler (interp_yield (interp_spawn (schedule n ts focus))) sigma. + + Lemma interp_schedule_nd_equ + (handler : E ~> stateT Sigma (ictree F)) n (ts ts' : pool E n) focus sigma : + pool_equ ts ts' -> + interp_schedule_nd handler n ts focus sigma ≅ + interp_schedule_nd handler n ts' focus sigma. + Proof. + intro Hts; unfold interp_schedule_nd. + apply equ_interp_state; [|reflexivity]. + apply interp_yield_equ, interp_spawn_equ. + now apply schedule_pool_proper. + Qed. + + (** Any zero-length pool, not only the literal empty vector: removing the + last slot yields an abstract [ts -- i] of length zero. *) + Lemma interp_schedule_nd_empty + (handler : E ~> stateT Sigma (ictree F)) (ts : pool E 0) sigma : + interp_schedule_nd handler 0 ts None sigma ~ Ret (tt,sigma). + Proof. + unfold interp_schedule_nd. + assert (Hempty : schedule 0 ts None ≅ Ret tt). + { rewrite (ictree_eta (schedule 0 ts None)), schedule_empty_none. + reflexivity. } + rewrite Hempty, interp_erase_ret, interp_state_ret; reflexivity. + Qed. + + Lemma interp_schedule_nd_ret + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) sigma : + observe (ts $ i) = RetF tt -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + interp_schedule_nd handler n (ts -- i) None sigma. + Proof. + intro Hobs; unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ Guard (schedule n (ts -- i) None)). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_ret n ts i Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_nd_guard + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) t sigma : + observe (ts $ i) = GuardF t -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma. + Proof. + intro Hobs; unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Guard (schedule (S n) (ts @ i := t) (Some i))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_guard n ts i t Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_nd_yield + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) k sigma : + observe (ts $ i) = VisF (inl Yield) k -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + interp_schedule_nd handler (S n) (ts @ i := k tt) None sigma. + Proof. + intro Hobs; unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Guard (schedule (S n) (ts @ i := k tt) None)). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_yield n ts i k Hobs); reflexivity. } + rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + Qed. + + (** The genuine nondeterministic choice: one real [Br] per selection. *) + Lemma interp_schedule_nd_select + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) sigma : + interp_schedule_nd handler (S n) ts None sigma ~ + Br n (fun i => interp_schedule_nd handler (S n) ts (Some i) sigma). + Proof. + unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts None ≅ + Vis (inl Yield) (fun _ => Br n (fun i => schedule (S n) ts (Some i)))). + { rewrite (ictree_eta (schedule (S n) ts None)), schedule_no_focus_nonempty. + reflexivity. } + rewrite Hnode, interp_erase_yield, interp_state_tau, sb_guard, + interp_state_tau, sb_guard. + rewrite interp_erase_br, interp_state_br. + apply sb_br_id; intro i. + rewrite sb_guard, interp_state_tau, sb_guard, interp_state_tau, sb_guard; + reflexivity. + Qed. + + Lemma interp_schedule_nd_fork + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) k sigma : + observe (ts $ i) = VisF (inr (inl Fork)) k -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + interp_schedule_nd handler (S (S n)) (k true :: (ts @ i := k false)) + (Some (Fin.FS i)) sigma. + Proof. + intro Hobs; unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Vis (inr (inl Spawn)) (fun _ => + schedule (S (S n)) (k true :: (ts @ i := k false)) (Some (Fin.FS i)))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_fork n ts i k Hobs); reflexivity. } + rewrite Hnode, interp_erase_spawn, interp_state_tau, sb_guard; reflexivity. + Qed. + + Lemma interp_schedule_nd_user + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) e k sigma : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + (runStateT (handler e) sigma >>= fun '(x,sigma') => + interp_schedule_nd handler (S n) (ts @ i := k x) (Some i) sigma'). + Proof. + intro Hobs; unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) ts (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => schedule (S n) (ts @ i := k x) (Some i))). + { rewrite (ictree_eta (schedule (S n) ts (Some i))), + (schedule_focused_user_event n ts i e k Hobs); reflexivity. } + rewrite Hnode, interp_erase_user, interp_state_vis. + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite sb_guard, interp_state_tau, sb_guard, + interp_state_tau, sb_guard; reflexivity. + Qed. + + (** Keep one scheduler continuation fixed while interpreting a raw user event. *) + Lemma interp_schedule_nd_user_bind + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) (t : thread E) (e : E) (k : encode e -> thread E) sigma : + t ≅ Vis (inr (inr e)) k -> + interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma ~ + (interp_state handler + (@ICtree.trigger E E _ _ ReSum_refl ReSumRet_refl e) sigma >>= + fun '(x,sigma') => + interp_schedule_nd handler (S n) (ts @ i := k x) (Some i) sigma'). + Proof. + intro Hnode. + pose proof (interp_schedule_nd_equ handler (S n) + (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) sigma + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_nd_user with (e:=e) (k:=k) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite interp_state_trigger_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. + rewrite Vector.replace_replace_eq; reflexivity. + Qed. +End NondeterministicInterpretation. + +Arguments interp_schedule_nd {E F HE HF Sigma} handler n ts focus sigma. + +(** The singleton state-update step under [h_stateW]: read the state, write + [f] of it, and finish. Exactly one [Log] of the new state is observable, + followed by the return of the emptied pool. *) +Lemma interp_schedule_nd_singleton_update {Sigma} (f : Sigma -> Sigma) + (ts : pool (stateE Sigma) 1) (sigma : Sigma) : + observe (ts $ Fin.F1) = + VisF ((inr (inr Get)) : yieldE + (forkE + stateE Sigma)) + (fun s : Sigma => + Vis ((inr (inr (Put (f s)))) : yieldE + (forkE + stateE Sigma)) + (fun _ : unit => Ret tt)) -> + interp_schedule_nd h_stateW 1 ts (Some Fin.F1) sigma ~ + (log (f sigma);; Ret (tt,f sigma)). +Proof. + intro Hobs. + rewrite (interp_schedule_nd_user h_stateW 0 ts Fin.F1 Get _ sigma Hobs). + cbn [h_stateW runStateT]; rewrite bind_ret_l; cbv beta. + rewrite (interp_schedule_nd_user h_stateW 0 _ Fin.F1 (Put (f sigma)) + (fun _ : unit => Ret tt) sigma) + by (rewrite Vector.nth_replace_eq; reflexivity). + cbn [h_stateW runStateT]; rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + rewrite bind_ret_l; cbv beta. + rewrite (interp_schedule_nd_ret h_stateW 0 _ Fin.F1 (f sigma)) + by (rewrite Vector.nth_replace_eq; reflexivity). + apply interp_schedule_nd_empty. +Qed. diff --git a/theories/ICTree/Interp/Yield/SBisim.v b/theories/ICTree/Interp/Yield/SBisim.v index 9a93d24..f1fae99 100644 --- a/theories/ICTree/Interp/Yield/SBisim.v +++ b/theories/ICTree/Interp/Yield/SBisim.v @@ -37,12 +37,9 @@ Section PoolSBisim. t1 ~ t2 -> pool_sbisim (v1 @ i := t1) (v2 @ i := t2). Proof. - intros Hv Ht j. - destruct (Fin.eq_dec i j) as [Hij | Hij]. - - subst j. rewrite Vector.nth_replace_eq, Vector.nth_replace_eq. exact Ht. - - rewrite Vector.nth_replace_neq by congruence. - rewrite Vector.nth_replace_neq by congruence. - apply Hv. + intros Hv Ht. + exact (vector_replace_pointwise (fun a b : thread E => a ~ b) + v1 v2 i t1 t2 (fun j _ => Hv j) Ht). Qed. Lemma remove_pool_sbisim {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : @@ -59,11 +56,7 @@ Section PoolSBisim. pool_sbisim v1 v2 -> pool_sbisim ((t1 :: v1)%vector) ((t2 :: v2)%vector). Proof. - intros Ht Hv i. - refine (Fin.caseS' i - (fun i => (((t1 :: v1)%vector) $ i) ~ (((t2 :: v2)%vector) $ i)) _ _). - - exact Ht. - - intro j. apply Hv. + exact (vector_cons_pointwise (fun a b : thread E => a ~ b) t1 t2 v1 v2). Qed. (** ** [equ]-level pool congruences, used by [schedule_pool_proper]. *) @@ -76,12 +69,9 @@ Section PoolSBisim. t1 ≅ t2 -> pool_equ (v1 @ i := t1) (v2 @ i := t2). Proof. - intros Hv Ht j. - destruct (Fin.eq_dec i j) as [Hij | Hij]. - - subst j. rewrite Vector.nth_replace_eq, Vector.nth_replace_eq. exact Ht. - - rewrite Vector.nth_replace_neq by congruence. - rewrite Vector.nth_replace_neq by congruence. - apply Hv. + intros Hv Ht. + exact (vector_replace_pointwise (fun a b : thread E => a ≅ b) + v1 v2 i t1 t2 (fun j _ => Hv j) Ht). Qed. Lemma remove_pool_equ {n} (v1 v2 : pool E (S n)) (i : Fin.t (S n)) : @@ -98,11 +88,7 @@ Section PoolSBisim. pool_equ v1 v2 -> pool_equ ((t1 :: v1)%vector) ((t2 :: v2)%vector). Proof. - intros Ht Hv i. - refine (Fin.caseS' i - (fun i => (((t1 :: v1)%vector) $ i) ≅ (((t2 :: v2)%vector) $ i)) _ _). - - exact Ht. - - intro j. apply Hv. + exact (vector_cons_pointwise (fun a b : thread E => a ≅ b) t1 t2 v1 v2). Qed. End PoolSBisim. @@ -936,3 +922,41 @@ Proof. rewrite (schedule_pool_proper n v v' focus Hvv). reflexivity. Qed. + +(** * Pools up to finitely many leading guards. + + The canonical slotwise lift of [guard_equ]. Reuses + [vector_replace_pointwise] and the Stdlib vector replacement laws; there + is no second pool relation. *) +Section PoolGuardEqu. + Context {E : Type} {HE : Encode E}. + + Definition pool_guard_equ {n} (ts us : pool E n) : Prop := + forall i, guard_equ (ts $ i) (us $ i). + + Lemma pool_equ_guard {n} (ts us : pool E n) : + pool_equ ts us -> pool_guard_equ ts us. + Proof. intros H i; apply guard_equ_equ, H. Qed. + + Lemma pool_guard_replace {n} (ts us : pool E n) (i : Fin.t n) t u : + pool_guard_equ ts us -> guard_equ t u -> + pool_guard_equ (ts @ i := t) (us @ i := u). + Proof. + intros Hpool Htu. + exact (vector_replace_pointwise guard_equ ts us i t u (fun j _ => Hpool j) Htu). + Qed. + + Lemma pool_replace_current {n} (ts : pool E n) (i : Fin.t n) : + pool_equ (ts @ i := (ts $ i)) ts. + Proof. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + - rewrite Vector.nth_replace_eq; reflexivity. + - rewrite Vector.nth_replace_neq by congruence; reflexivity. + Qed. + + Lemma pool_equ_guard_trans {n} (ts us vs : pool E n) : + pool_equ ts us -> pool_guard_equ us vs -> pool_guard_equ ts vs. + Proof. + intros Eq H i; eapply guard_equ_trans; [apply guard_equ_equ, Eq|apply H]. + Qed. +End PoolGuardEqu. diff --git a/theories/ICTree/Interp/Yield/Segments.v b/theories/ICTree/Interp/Yield/Segments.v new file mode 100644 index 0000000..0e0ef10 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Segments.v @@ -0,0 +1,796 @@ +(** * First-yield thread segments, parameterized by handler and response relation. + + One finite derivation stops at the first source yield. The handler premise + of [segment_user] is the handler's ACTUAL effect semantics, related to a + finite emission prefix by an arbitrary relation [R]; raw thread endpoints + still use [equ eq]. Exactly two instances are used downstream: + + [fun X (t u : ictreeW W X) => t ~ u] (bisimulation mode) + [fun X (t u : ictreeW W X) => t ≅ u] (exact mode) + + and [ThreadSegment_mono] transports between them. There is no relation + class or typeclass inference layer, and no second segment inductive. *) + +From Stdlib Require Import List Arith.PeanoNat Fin Vector + Classes.Morphisms Classes.RelationClasses Program.Equality. +From ExtLib Require Import Data.Monads.StateMonad. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace + ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod + ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic + Utils.Vectors. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope list_scope. + +Section ThreadSegments. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)) + (R : forall X : Type, ictreeW W X -> ictreeW W X -> Prop). + + Inductive ThreadSegment : + thread E -> Sigma -> list W -> thread E -> Sigma -> Prop := + | segment_yield (k : unit -> thread E) sigma : + ThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma + | segment_guard t sigma logs t' sigma' : + ThreadSegment t sigma logs t' sigma' -> + ThreadSegment (Guard t) sigma logs t' sigma' + | segment_user (e : E) (k : encode e -> thread E) sigma result sigma1 + before after t' sigma' : + R _ (runStateT (handler e) sigma) (emit_list before (Ret (result,sigma1))) -> + ThreadSegment (k result) sigma1 after t' sigma' -> + ThreadSegment + (@go (yieldE + (forkE + E)) _ unit (VisF (inr (inr e) : yieldE + (forkE + E)) k)) + sigma (before ++ after) t' sigma' + | segment_equ t u sigma logs u' t' sigma' : + t ≅ u -> ThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> + ThreadSegment t sigma logs t' sigma'. + + (** Raw congruence is allowed on both ends, but no source-side [sbisim] + congruence is used. *) + Lemma ThreadSegment_equ_input t u sigma xs residual sigma' : + t ≅ u -> ThreadSegment t sigma xs residual sigma' -> + ThreadSegment u sigma xs residual sigma'. + Proof. + intros Eq H; eapply segment_equ; [symmetry; exact Eq|exact H|reflexivity]. + Qed. + + Lemma ThreadSegment_equ_output t sigma xs residual residual' sigma' : + ThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> + ThreadSegment t sigma xs residual' sigma'. + Proof. intros H Eq; eapply segment_equ; [reflexivity|exact H|exact Eq]. Qed. + + Lemma ThreadSegment_yield_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : unit -> thread E, + t ≅ Vis (inl Yield) k -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. + Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros k Eq; split; [reflexivity|]; split; [reflexivity|]. + symmetry; exact (equ_vis_invE Eq tt). + - intros k Eq; step in Eq; cbn in Eq; inversion Eq. + - intros k Eq; pose proof (equ_vis_invT Eq) as [_ Ebad]; discriminate. + - intros k Eq. + assert (Eu : u ≅ Vis (inl Yield) k). + { transitivity t; [symmetry; exact Etu|exact Eq]. } + destruct (IH k Eu) as [Ex [Es Ek]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; assumption. + Qed. + + Lemma ThreadSegment_yield_inv k sigma xs residual sigma' : + ThreadSegment (Vis (inl Yield) k) sigma xs residual sigma' -> + xs = [] /\ sigma' = sigma /\ k tt ≅ residual. + Proof. intro H; eapply ThreadSegment_yield_inv_equ; [exact H|reflexivity]. Qed. + + Lemma ThreadSegment_guard_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall u, t ≅ Guard u -> ThreadSegment u sigma xs residual sigma'. + Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t v sigma xs v' residual sigma' Etv H IH Eout]. + - intros u Eq; step in Eq; cbn in Eq; inversion Eq. + - intros u Eq; apply equ_guard_invE in Eq. + eapply ThreadSegment_equ_input; [exact Eq|exact H]. + - intros u Eq; step in Eq; cbn in Eq; inversion Eq. + - intros u Eq. + eapply ThreadSegment_equ_output; [|exact Eout]. + apply IH; transitivity t; [symmetry; exact Etv|exact Eq]. + Qed. + + Lemma ThreadSegment_guard_inv t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' -> + ThreadSegment t sigma xs residual sigma'. + Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. + + Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : + ThreadSegment (Guard t) sigma xs residual sigma' <-> + ThreadSegment t sigma xs residual sigma'. + Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. + + Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall (e : E) (k : encode e -> thread E), + t ≅ (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k)) -> + exists result sigma1 before after, + xs = before ++ after /\ + R _ (runStateT (handler e) sigma) (emit_list before (Ret (result,sigma1))) /\ + ThreadSegment (k result) sigma1 after residual sigma'. + Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e0 k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - intros e k Eq; pose proof (equ_vis_invT Eq) as [_ Ebad]; discriminate. + - intros e k Eq; step in Eq; cbn in Eq; inversion Eq. + - intros e k Eq. + pose proof (equ_vis_invT Eq) as [_ Ee]. + assert (Eevent : e0 = e) by congruence; subst e. + exists result, sigma1, before, after. + split; [reflexivity|]; split; [exact Eh|]. + eapply ThreadSegment_equ_input; [exact (equ_vis_invE Eq result)|exact H]. + - intros e k Eq. + assert (Eu : u ≅ (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k))). + { transitivity t; [symmetry; exact Etu|exact Eq]. } + destruct (IH e k Eu) as [r [sigma1 [before [after [Ex [Eh Htail]]]]]]. + exists r, sigma1, before, after; split; [exact Ex|]; split; [exact Eh|]. + eapply ThreadSegment_equ_output; eassumption. + Qed. + + Lemma ThreadSegment_user_inv (e : E) (k : encode e -> thread E) + sigma xs residual sigma' : + ThreadSegment (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k)) + sigma xs residual sigma' -> + exists result sigma1 before after, + xs = before ++ after /\ + R _ (runStateT (handler e) sigma) (emit_list before (Ret (result,sigma1))) /\ + ThreadSegment (k result) sigma1 after residual sigma'. + Proof. intro H; eapply ThreadSegment_user_inv_equ; [exact H|reflexivity]. Qed. + + Lemma ThreadSegment_ret_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> ~ (t ≅ Ret tt). + Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intro Eq. + - step in Eq; cbn in Eq; inversion Eq. + - step in Eq; cbn in Eq; inversion Eq. + - step in Eq; cbn in Eq; inversion Eq. + - apply IH; transitivity t; [symmetry; exact Etu|exact Eq]. + Qed. + + Lemma ThreadSegment_ret_absurd sigma xs residual sigma' : + ~ ThreadSegment (Ret tt) sigma xs residual sigma'. + Proof. intro H; eapply ThreadSegment_ret_absurd_equ; [exact H|reflexivity]. Qed. + + Lemma ThreadSegment_fork_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall k : bool -> thread E, ~ (t ≅ Vis (inr (inl Fork)) k). + Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros k Eq. + - pose proof (equ_vis_invT Eq) as [_ Ebad]; discriminate. + - step in Eq; cbn in Eq; inversion Eq. + - pose proof (equ_vis_invT Eq) as [_ Ebad]; discriminate. + - apply (IH k); transitivity t; [symmetry; exact Etu|exact Eq]. + Qed. + + Lemma ThreadSegment_fork_absurd k sigma xs residual sigma' : + ~ ThreadSegment (Vis (inr (inl Fork)) k) sigma xs residual sigma'. + Proof. intro H; eapply ThreadSegment_fork_absurd_equ; [exact H|reflexivity]. Qed. + + Lemma ThreadSegment_br_absurd_equ t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> + forall n (k : Fin.t (S n) -> thread E), ~ (t ≅ Br n k). + Proof. + intro H; induction H as + [k0 sigma + |t sigma xs residual sigma' H IH + |e k0 sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n k Eq. + - step in Eq; cbn in Eq; inversion Eq. + - step in Eq; cbn in Eq; inversion Eq. + - step in Eq; cbn in Eq; inversion Eq. + - apply (IH n k); transitivity t; [symmetry; exact Etu|exact Eq]. + Qed. + + Lemma ThreadSegment_br_absurd n k sigma xs residual sigma' : + ~ ThreadSegment (Br n k) sigma xs residual sigma'. + Proof. intro H; eapply ThreadSegment_br_absurd_equ; [exact H|reflexivity]. Qed. + + (** A finite first-yield derivation cannot be manufactured by repeatedly + unfolding a divergent guard. A user case provides its actual response as + the witness needed for the first visible raw transition. *) + Lemma ThreadSegment_can_step t sigma xs residual sigma' : + ThreadSegment t sigma xs residual sigma' -> exists l u, trans l t u. + Proof. + intro H; induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]. + - exists (obs (inl Yield) tt), (k tt); apply trans_vis. + - destruct IH as [l [u Hstep]]; exists l, u; now apply trans_guard. + - exists (obs (inr (inr e) : yieldE + (forkE + E)) result), (k result); + apply trans_vis. + - destruct IH as [l [v Hstep]]; exists l, v; rewrite Etu; exact Hstep. + Qed. + + Lemma ThreadSegment_divergent_absurd t sigma xs residual sigma' : + is_stuck t -> ~ ThreadSegment t sigma xs residual sigma'. + Proof. intros Hdiv Hseg; apply Hdiv; eapply ThreadSegment_can_step; exact Hseg. Qed. + + Lemma ThreadSegment_stuck_absurd sigma xs residual sigma' : + ~ ThreadSegment (stuck : thread E) sigma xs residual sigma'. + Proof. apply ThreadSegment_divergent_absurd, stuck_is_stuck. Qed. + + Lemma ThreadSegment_spin_absurd sigma xs residual sigma' : + ~ ThreadSegment (spin : thread E) sigma xs residual sigma'. + Proof. + intro H; eapply ThreadSegment_br_absurd_equ; [exact H|]. + apply unfold_spin. + Qed. + + Lemma ThreadSegment_branchfree t sigma logs residual sigma' : + ThreadSegment t sigma logs residual sigma' -> + BranchFree t -> BranchFree residual. + Proof. + intro H; induction H as + [k sigma|t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intro Hbf. + - apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; assumption. + - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. + dependent destruction Hbf; auto. + - eapply branchfree_equ_impl; [exact Eout|]. + apply IH; eapply branchfree_equ_impl; eassumption. + Qed. + + (** Guard transport: the closure that forgets finitely many leading guards + preserves segments in both directions. Symmetry is handled by proving + both directions together, not by assuming a reverse simulation. *) + Lemma guard_equ_segment_iff t u : guard_equ t u -> + forall sigma xs residual sigma', + ThreadSegment t sigma xs residual sigma' <-> + ThreadSegment u sigma xs residual sigma'. + Proof. + intro H; induction H as + [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]; + intros sigma xs residual sigma'. + - split; intro Hseg. + + eapply ThreadSegment_equ_input; [exact Eq|exact Hseg]. + + eapply ThreadSegment_equ_input; [symmetry; exact Eq|exact Hseg]. + - split; intro Hseg. + + apply ThreadSegment_guard_inv. + eapply ThreadSegment_equ_input; [exact Eg|exact Hseg]. + + eapply ThreadSegment_equ_input; [symmetry; exact Eg|]. + apply segment_guard; exact Hseg. + - reflexivity. + - symmetry; apply IH. + - transitivity (ThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. + Qed. + + Lemma guard_equ_segment t u sigma xs t' sigma' : + guard_equ t u -> ThreadSegment t sigma xs t' sigma' -> + exists u', ThreadSegment u sigma xs u' sigma' /\ guard_equ t' u'. + Proof. + intros Eq Hseg; exists t'; split. + - apply (proj1 (guard_equ_segment_iff t u Eq sigma xs t' sigma')); exact Hseg. + - apply guard_equ_equ; reflexivity. + Qed. + + (** An exact segment may end at a residual differing from its target only by + finite leading guards and raw tree equivalence. *) + Definition segment_to (t : thread E) (sigma : Sigma) + (logs : list W) (target : thread E) (sigma' : Sigma) : Prop := + exists residual, ThreadSegment t sigma logs residual sigma' /\ + guard_equ residual target. + + Lemma segment_to_equ t u sigma logs target sigma' : + t ≅ u -> segment_to u sigma logs target sigma' -> + segment_to t sigma logs target sigma'. + Proof. + intros Htu (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply segment_equ; [exact Htu|exact Hseg|reflexivity]. + Qed. +End ThreadSegments. + +Arguments ThreadSegment {E W Sigma HE} handler R. +Arguments segment_to {E W Sigma HE} handler R. + +(** A branch node can never be a yield up to finite guard removal. *) +Lemma guard_equ_br_yield_absurd {E} {HE : Encode E} n + (k : Fin.t (S n) -> thread E) (ky : unit -> thread E) : + ~ guard_equ (Br n k) (Vis (inl Yield) ky). +Proof. + intro Eq; apply guard_equ_sbisim in Eq. + eapply (@sbisim_vis_br_inv (yieldE + (forkE + E)) _ unit n (inl Yield) ky k); + symmetry; exact Eq. +Qed. + +(** Weakening the response relation weakens the segment. This is how an exact + segment becomes a bisimulation-mode segment; [equ_sbisim] supplies the + premise for the two instances actually used. *) +Lemma ThreadSegment_mono {E W Sigma} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)) + (R R' : forall X : Type, ictreeW W X -> ictreeW W X -> Prop) + (Hmono : forall X t u, R X t u -> R' X t u) : + forall t sigma logs residual sigma', + ThreadSegment handler R t sigma logs residual sigma' -> + ThreadSegment handler R' t sigma logs residual sigma'. +Proof. + intros t sigma logs residual sigma' H; induction H as + [k sigma + |t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]. + - apply segment_yield. + - apply segment_guard; exact IH. + - eapply segment_user; [apply Hmono; exact Eh|exact IH]. + - eapply segment_equ; eassumption. +Qed. + +Lemma segment_to_mono {E W Sigma} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)) + (R R' : forall X : Type, ictreeW W X -> ictreeW W X -> Prop) + (Hmono : forall X t u, R X t u -> R' X t u) : + forall t sigma logs target sigma', + segment_to handler R t sigma logs target sigma' -> + segment_to handler R' t sigma logs target sigma'. +Proof. + intros t sigma logs target sigma' (residual & Hseg & Htail). + exists residual; split; [|exact Htail]. + eapply ThreadSegment_mono; eauto. +Qed. + +(** ** Scheduling laws. + + Response uniqueness, determinism, handler-fault exclusion, and the + bisimulation-based scheduling equations additionally need that the + response relation implies strong bisimulation. *) +Section SegmentScheduling. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)) + (R : forall X : Type, ictreeW W X -> ictreeW W X -> Prop) + (HR : forall X (t u : ictreeW W X), R X t u -> t ~ u). + + Lemma handler_response_unique (e : E) (sigma : Sigma) + (result : encode e) (sigma1 : Sigma) (before : list W) + (result' : encode e) (sigma2 : Sigma) (before' : list W) : + R _ (runStateT (handler e) sigma) (emit_list before (Ret (result,sigma1))) -> + R _ (runStateT (handler e) sigma) (emit_list before' (Ret (result',sigma2))) -> + before = before' /\ result = result' /\ sigma1 = sigma2. + Proof. + intros E1 E2; apply HR in E1; apply HR in E2. + assert (Eq : emit_list before (Ret (result,sigma1)) ~ + emit_list before' (Ret (result',sigma2))). + { transitivity (runStateT (handler e) sigma); [symmetry; exact E1|exact E2]. } + destruct (emit_list_ret_injective _ _ _ _ Eq) as [Ex Er]. + inversion Er; subst; auto. + Qed. + + Lemma ThreadSegment_fault_absurd (e : E) (k : encode e -> thread E) + sigma xs residual sigma' : + runStateT (handler e) sigma ~ (stuck : ictreeW W (encode e * Sigma)) -> + ~ ThreadSegment handler R + (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k)) + sigma xs residual sigma'. + Proof. + intros Ef Hseg. + destruct (ThreadSegment_user_inv handler R e k sigma xs residual sigma' Hseg) + as [result [sigma1 [before [after [_ [Eh _]]]]]]. + apply HR in Eh. + apply (emit_list_ret_not_stuck before (result,sigma1)). + transitivity (runStateT (handler e) sigma); [symmetry; exact Eh|exact Ef]. + Qed. + + Lemma ThreadSegment_deterministic t sigma xs u sigma1 ys v sigma2 : + ThreadSegment handler R t sigma xs u sigma1 -> + ThreadSegment handler R t sigma ys v sigma2 -> + xs = ys /\ sigma1 = sigma2 /\ u ≅ v. + Proof. + intros H1; revert ys v sigma2. + induction H1 as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros ys v sigma2 H2. + - destruct (ThreadSegment_yield_inv handler R k sigma ys v sigma2 H2) + as [Ex [Es Ek]]. + split; [symmetry; exact Ex|]; split; [symmetry; exact Es|exact Ek]. + - apply IH; now apply ThreadSegment_guard_inv in H2. + - destruct (ThreadSegment_user_inv handler R e k sigma ys v sigma2 H2) + as [r [sigma0 [before0 [after0 [Ey [Eh0 Htail]]]]]]. + destruct (handler_response_unique e sigma result sigma1 before + r sigma0 before0 Eh Eh0) as [Eb [Er Es]]. + subst before0; subst r; subst sigma0. + destruct (IH after0 v sigma2 Htail) as [Ea [Es Er]]. + split; [subst ys; now rewrite Ea|]; split; assumption. + - assert (H2u : ThreadSegment handler R u sigma ys v sigma2). + { eapply ThreadSegment_equ_input; [exact Etu|exact H2]. } + destruct (IH ys v sigma2 H2u) as [Ex [Es Er]]. + split; [exact Ex|]; split; [exact Es|]. + transitivity u'; [symmetry; exact Eout|exact Er]. + Qed. +End SegmentScheduling. + +(** ** Pool congruence for the focused slot. + + Pool equivalence is used only for genuine raw [equ]. Guard removal below + is deliberately restricted to the focused slot. *) +Section FocusedCongruence. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)). + + Lemma segment_nd_replace_equ n (ts : pool E (S n)) (i : Fin.t (S n)) + t u focus sigma : + t ≅ u -> + interp_schedule_nd handler (S n) (ts @ i := t) focus sigma ~ + interp_schedule_nd handler (S n) (ts @ i := u) focus sigma. + Proof. + intro Eq. + pose proof (interp_schedule_nd_equ handler (S n) (ts @ i := t) (ts @ i := u) + focus sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) Eq)) as Ep. + rewrite Ep; reflexivity. + Qed. + + Lemma segment_rr_replace_equ n (ts : pool E (S n)) (i : Fin.t (S n)) + t u focus m sigma : + t ≅ u -> + interp_schedule_rr handler (S n) (ts @ i := t) focus m sigma ~ + interp_schedule_rr handler (S n) (ts @ i := u) focus m sigma. + Proof. + intro Eq. + pose proof (interp_schedule_rr_equ handler (S n) (ts @ i := t) (ts @ i := u) + focus m sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) Eq)) as Ep. + rewrite Ep; reflexivity. + Qed. + + Lemma segment_nd_focused_guard n (ts : pool E (S n)) (i : Fin.t (S n)) t sigma : + interp_schedule_nd handler (S n) (ts @ i := Guard t) (Some i) sigma ~ + interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma. + Proof. + erewrite interp_schedule_nd_guard + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + Qed. + + Lemma segment_rr_focused_guard n (ts : pool E (S n)) (i : Fin.t (S n)) t m sigma : + interp_schedule_rr handler (S n) (ts @ i := Guard t) (Some i) m sigma ~ + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma. + Proof. + erewrite interp_schedule_rr_guard + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + Qed. + + Lemma guard_equ_focused_nd n (ts : pool E (S n)) (i : Fin.t (S n)) t u sigma : + guard_equ t u -> + interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma ~ + interp_schedule_nd handler (S n) (ts @ i := u) (Some i) sigma. + Proof. + intro H; induction H as [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_nd_replace_equ; exact Eq. + - etransitivity; [apply segment_nd_replace_equ; exact Eg|]. + apply segment_nd_focused_guard. + - reflexivity. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. + Qed. + + Lemma guard_equ_focused_rr n (ts : pool E (S n)) (i : Fin.t (S n)) t u m sigma : + guard_equ t u -> + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma ~ + interp_schedule_rr handler (S n) (ts @ i := u) (Some i) m sigma. + Proof. + intro H; induction H as [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]. + - apply segment_rr_replace_equ; exact Eq. + - etransitivity; [apply segment_rr_replace_equ; exact Eg|]. + apply segment_rr_focused_guard. + - reflexivity. + - symmetry; exact IH. + - etransitivity; [exact IH1|exact IH2]. + Qed. + + Lemma segment_nd_focused_user n (ts : pool E (S n)) (i : Fin.t (S n)) + (e : E) (k : encode e -> thread E) sigma : + interp_schedule_nd handler (S n) + (ts @ i := (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k))) (Some i) sigma ~ + (runStateT (handler e) sigma >>= fun '(x,sigma') => + interp_schedule_nd handler (S n) (ts @ i := k x) (Some i) sigma'). + Proof. + erewrite interp_schedule_nd_user + by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. + Qed. + + Lemma segment_rr_focused_user n (ts : pool E (S n)) (i : Fin.t (S n)) + (e : E) (k : encode e -> thread E) m sigma : + interp_schedule_rr handler (S n) + (ts @ i := (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k))) (Some i) m sigma ~ + (runStateT (handler e) sigma >>= fun '(x,sigma') => + interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma'). + Proof. + erewrite interp_schedule_rr_user + by (rewrite Vector.nth_replace_eq; reflexivity). + apply sbisim_clo_bind_eq; [reflexivity|]. + intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. + Qed. + + (** Exact equations retain the finite administrative guard path. RR + selection is NOT a visible branch after refinement: its three guards must + not be used as a guarded [sbisim] coinduction hypothesis. *) + Lemma segment_rr_guard_exact n (ts : pool E (S n)) (i : Fin.t (S n)) t m sigma : + observe (ts $ i) = GuardF t -> + interp_schedule_rr handler (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma). + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. + Qed. + + Lemma segment_rr_yield_exact n (ts : pool E (S n)) (i : Fin.t (S n)) k m sigma : + observe (ts $ i) = VisF (inl Yield) k -> + interp_schedule_rr handler (S n) ts (Some i) m sigma ≅ + Guard (interp_schedule_rr handler (S n) (ts @ i := k tt) None m sigma). + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). + rewrite interp_erase_guard, interp_state_tau; reflexivity. + Qed. + + Lemma segment_rr_user_exact n (ts : pool E (S n)) (i : Fin.t (S n)) + (e : E) (k : encode e -> thread E) m sigma : + observe (ts $ i) = VisF (inr (inr e)) k -> + interp_schedule_rr handler (S n) ts (Some i) m sigma ≅ + (runStateT (handler e) sigma >>= fun '(x,sigma') => + Guard (Guard (Guard + (interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma')))). + Proof. + intro Hobs; unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). + rewrite interp_erase_user, interp_state_vis. + apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] r <-; apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node, interp_state_tau. + Qed. + + Lemma segment_rr_select_exact n (ts : pool E (S n)) m sigma : + interp_schedule_rr handler (S n) ts None m sigma ≅ + Guard (Guard (Guard + (interp_schedule_rr handler (S n) ts (Some (rr_pick n m)) (S m) sigma))). + Proof. + unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin, schedule_no_focus_nonempty. + rewrite interp_erase_yield. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + etransitivity; [apply interp_state_tau|]. + apply guard_equ_node. + rewrite (unfold_run_round_robin + (Br n (fun i => schedule (S n) ts (Some i))) m). + change (interp_state handler + (interp_yield (interp_spawn + (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) sigma ≅ + Guard (interp_schedule_rr handler (S n) ts (Some (rr_pick n m)) (S m) sigma)). + rewrite interp_erase_guard, interp_state_tau; reflexivity. + Qed. + + Lemma exact_rr_user_replaced n (ts : pool E (S n)) (i : Fin.t (S n)) + (e : E) (k : encode e -> thread E) m sigma : + interp_schedule_rr handler (S n) + (ts @ i := (@go (yieldE + (forkE + E)) _ unit + (VisF (inr (inr e) : yieldE + (forkE + E)) k))) (Some i) m sigma ≅ + (runStateT (handler e) sigma >>= fun '(x,sigma') => + rr_guards 3 (interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma')). + Proof. + etransitivity. + - eapply segment_rr_user_exact; rewrite Vector.nth_replace_eq; reflexivity. + - apply equ_clo_bind with (S := eq); [reflexivity|]. + intros [x sigma'] y <-; rewrite Vector.replace_replace_eq; reflexivity. + Qed. +End FocusedCongruence. + +(** ** Segment-driven scheduling. + + These need the response relation to imply strong bisimulation. *) +Section SegmentInterpretation. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)) + (R : forall X : Type, ictreeW W X -> ictreeW W X -> Prop) + (HR : forall X (t u : ictreeW W X), R X t u -> t ~ u). + + Lemma segment_interp_nd n (ts : pool E (S n)) (i : Fin.t (S n)) + t sigma xs residual sigma' : + ThreadSegment handler R t sigma xs residual sigma' -> + interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma ~ + emit_list xs (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma'). + Proof. + intro H; revert n ts i. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. + - cbn [emit_list]. + erewrite interp_schedule_nd_yield + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_nd_focused_guard|apply IH]. + - etransitivity; [apply segment_nd_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => + interp_schedule_nd handler (S n) (ts @ i := k x) (Some i) sigma0). + + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. + Qed. + + Lemma segment_interp_rr n (ts : pool E (S n)) (i : Fin.t (S n)) + t m sigma xs residual sigma' : + ThreadSegment handler R t sigma xs residual sigma' -> + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma ~ + emit_list xs + (interp_schedule_rr handler (S n) (ts @ i := residual) None m sigma'). + Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma xs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - cbn [emit_list]. + erewrite interp_schedule_rr_yield + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_rr_focused_guard|apply IH]. + - etransitivity; [apply segment_rr_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma0) => + interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma0). + + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. + Qed. + + Theorem segment_scheduler_steps {n} (ts : pool E (S n)) sigma i + logs residual sigma' ts' : + ThreadSegment handler R (ts $ i) sigma logs residual sigma' -> + pool_equ ts' (ts @ i := residual) -> + exists next, + finite_steps (interp_schedule_nd handler (S n) ts None sigma) + (tau :: List.map (fun o => obs (Log o) tt) logs) next /\ + next ~ interp_schedule_nd handler (S n) ts' None sigma'. + Proof. + intros Hseg Epool. + assert (Efocused : interp_schedule_nd handler (S n) ts (Some i) sigma ~ + emit_list logs (interp_schedule_nd handler (S n) ts' None sigma')). + { + transitivity + (interp_schedule_nd handler (S n) (ts @ i := (ts $ i)) (Some i) sigma). + - rewrite (interp_schedule_nd_equ handler (S n) _ _ (Some i) sigma + (pool_replace_current ts i)); reflexivity. + - transitivity (emit_list logs + (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma')). + + eapply segment_interp_nd; exact Hseg. + + apply emit_list_sbisim. + rewrite <- (interp_schedule_nd_equ handler (S n) _ _ None sigma' Epool); + reflexivity. + } + assert (Hbranch : trans tau + (Br n (fun j => interp_schedule_nd handler (S n) ts (Some j) sigma)) + (interp_schedule_nd handler (S n) ts (Some i) sigma)). + { eapply trans_br with (x := i); reflexivity. } + pose proof (interp_schedule_nd_select handler n ts sigma) as Eselect; + symmetry in Eselect. + destruct (sbisim_trans _ _ _ tau eq Eselect Hbranch) + as (l & focused & Hchoose & El & Efocus); subst l. + assert (Eemit : emit_list logs + (interp_schedule_nd handler (S n) ts' None sigma') ~ focused). + { transitivity (interp_schedule_nd handler (S n) ts (Some i) sigma); + [symmetry; exact Efocused|exact Efocus]. } + destruct (finite_steps_sbisim _ _ _ + (finite_steps_emit_list logs + (interp_schedule_nd handler (S n) ts' None sigma')) focused Eemit) + as (next & Hlogs & Enext). + exists next; split; [econstructor; eassumption|symmetry; exact Enext]. + Qed. +End SegmentInterpretation. + +(** ** Exact-mode round-robin prefixes. + + Restricted to the [equ] instance: the administrative guard path is real + and must not be weakened to [sbisim]. *) +Section ExactRoundRobinPrefix. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)). + + Notation Rexact := (fun X (t u : ictreeW W X) => t ≅ u). + + Lemma exact_segment_rr_prefix n (ts : pool E (S n)) (i : Fin.t (S n)) + t m sigma logs residual sigma' : + ThreadSegment handler Rexact t sigma logs residual sigma' -> + exists word, rr_prefix_events word = logs /\ + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma ≅ + rr_prefix word (Guard + (interp_schedule_rr handler (S n) (ts @ i := residual) None m sigma')). + Proof. + intro H; revert n ts i m. + induction H as + [k sigma + |t sigma logs residual sigma' H IH + |e k sigma result sigma1 before after residual sigma' Eh H IH + |t u sigma logs u' residual sigma' Etu H IH Eout]; intros n ts i m. + - exists []; split; [reflexivity|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_yield_exact; rewrite Vector.nth_replace_eq; reflexivity. + + rewrite Vector.replace_replace_eq; reflexivity. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (RRGuard :: word); split; [exact Ew|]; cbn [rr_prefix]. + etransitivity. + + eapply segment_rr_guard_exact; rewrite Vector.nth_replace_eq; reflexivity. + + apply guard_equ_node; rewrite Vector.replace_replace_eq; exact Et. + - destruct (IH n ts i m) as (word & Ew & Et). + exists (List.map RRLog before ++ RRGuard :: RRGuard :: RRGuard :: word); split. + + rewrite rr_prefix_events_app, rr_prefix_events_logs; cbn [rr_prefix_events]. + now rewrite Ew. + + etransitivity; [apply exact_rr_user_replaced|]. + set (resume := fun response : (encode e * Sigma)%type => + let '(x,sigma0) := response in + rr_guards 3 + (interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma0)). + transitivity (emit_list before (Ret (result,sigma1)) >>= resume). + * apply equ_clo_bind with (S := eq); [exact Eh|intros x y <-; reflexivity]. + * etransitivity; [apply emit_list_ret_bind|]; unfold resume. + transitivity (emit_list before + (rr_guards 3 (rr_prefix word (Guard + (interp_schedule_rr handler (S n) + (ts @ i := residual) None m sigma'))))). + -- apply emit_list_equ, rr_guards_equ; exact Et. + -- rewrite rr_prefix_app; cbn [rr_prefix rr_guards]. + symmetry; apply rr_prefix_emit. + - destruct (IH n ts i m) as (word & Ew & Et). + exists word; split; [exact Ew|]. + etransitivity. + + apply interp_schedule_rr_equ, replace_pool_equ; + [apply pool_equ_refl|exact Etu]. + + etransitivity; [exact Et|]. + apply rr_prefix_equ, guard_equ_node, interp_schedule_rr_equ, + replace_pool_equ; [apply pool_equ_refl|exact Eout]. + Qed. +End ExactRoundRobinPrefix. diff --git a/theories/ICTree/Logic/CanStep.v b/theories/ICTree/Logic/CanStep.v index c284e8f..140413a 100644 --- a/theories/ICTree/Logic/CanStep.v +++ b/theories/ICTree/Logic/CanStep.v @@ -58,6 +58,8 @@ Section CanStepICtrees. now (exists t', w'). - destruct H as (t' & w' & TR). apply ktrans_guard in TR. + +From Coinduction Require Import coinduction. now (exists t', w'). Qed. Hint Resolve can_step_guard: ticl. @@ -305,4 +307,16 @@ Section CanStepLog. exists tt; intuition. constructor. Qed. -End CanStepLog. \ No newline at end of file +End CanStepLog. + +(** A bind cannot step when its prefix cannot: the residual continuation is + never reached. Arbitrary effect, arbitrary result types. *) +Lemma nostep_bind {E} {HE : Encode E} {X Y}: + forall (t : ictree E Y) (k : Y -> ictree E X) w, + ~ can_step t w -> ~ can_step (x <- t ;; k x) w. +Proof. + intros t k w Hns Hs. + apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]. + - apply Hns; exists t', w'; exact TR. + - apply Hns; exists ICtree.stuck, w'; exact TR. +Qed. \ No newline at end of file diff --git a/theories/ICTree/Logic/Heap.v b/theories/ICTree/Logic/Heap.v new file mode 100644 index 0000000..320c5fd --- /dev/null +++ b/theories/ICTree/Logic/Heap.v @@ -0,0 +1,48 @@ +(** * Logical corollaries of the checked heap interpreter. + + The only genuinely *logical* fact about the heap handler is that an + out-of-footprint dereference cannot step. It lives here, above the + interpreter, rather than in the event or model module. *) + +From Coinduction Require Import coinduction. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Interp.State.Mod + ICTree.Interp.Heap + ICTree.Events.Heap + ICTree.Logic.Trans + ICTree.Logic.CanStep + Logic.Core. + +Import ICtree ICTreeNotations. +Local Open Scope ictree_scope. + +(** [equ] is made typeclass-transparent for setoid rewriting, and + [coinduction] is imported so that its [#[export] Typeclasses Opaque t] + is in scope: without it, resolution unfolds past the companion and a + single [reflexivity] at a generic effect type costs tens of seconds. *) +Local Typeclasses Transparent equ. + +Section HeapNoStep. + Context {F G : Type} {HF : Encode F} {HG : Encode G} {Sigma : Type} + (other : G ~> stateT (Heap * Sigma) (ictree F)). + + (** An out-of-footprint read cannot step, regardless of its continuation. *) + Lemma interp_heap_rd_nostep {X} : forall a h (aux : Sigma) + (k : nat -> ictree (heapE + G) X) w, + h a = None -> + ~ can_step + (interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,aux)) w. + Proof. + intros a h aux k w H. + unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_rd_none (F:=F) a h aux H). + intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; + revert TR; apply ktrans_stuck. + Qed. +End HeapNoStep. diff --git a/theories/ICTree/Logic/State.v b/theories/ICTree/Logic/State.v index 2990cf9..b94babf 100644 --- a/theories/ICTree/Logic/State.v +++ b/theories/ICTree/Logic/State.v @@ -58,6 +58,8 @@ Section StateLemmas. Qed. (** Ret lemma for [interp_state] and suffix [AX] *) + +From Coinduction Require Import coinduction. Theorem axr_state_ret{X}: forall R (x: X) w, R (x, σ) w -> not_done w -> diff --git a/theories/ICTree/Logic/Trace.v b/theories/ICTree/Logic/Trace.v index e92da01..a56935d 100644 --- a/theories/ICTree/Logic/Trace.v +++ b/theories/ICTree/Logic/Trace.v @@ -1,9 +1,10 @@ -From Stdlib Require Import List. +From Stdlib Require Import List Lia. +From Coinduction Require Import coinduction. From TICL Require Export ICTree.Trace. From TICL Require Import ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer - ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.Bind Logic.Core. + ICTree.Logic.Trans ICTree.Logic.CanStep ICTree.Logic.AX ICTree.Logic.AF + ICTree.Logic.AG ICTree.Logic.Bind ICTree.Logic.Iter Logic.Core. Unset Implicit Arguments. Import ICtree ICTreeNotations TiclNotations ListNotations. @@ -68,3 +69,86 @@ Proof. apply afr_log; [exact Hd|]. apply IH; [constructor|exact HQ]. Qed. + +(** * Retained observations cannot masquerade as later ones. + + The world [Obs (Log (stamp a j)) tt] carries occurrence index [j], so it + does not satisfy a freshness predicate bounded below by [S j]: an [AF] of + that formula cannot be discharged by the world already in hand. The + payload [A] and the return type [X] are arbitrary. *) +Lemma indexed_excludes_retained {A X} (t : ictreeW (indexed A) X) P a j : + ~ <( t, {Obs (Log (stamp a j)) tt} + |= visW {indexed_after P (S j)} )>. +Proof. + intro H; apply ticll_vis in H. + inversion H as [e0 v0 Hphi Heq]; subst. + destruct v0; destruct Hphi as (_ & Hle); cbn in Hle; lia. +Qed. + +(** * Recurrence for repeating finite observation batches. + + Derived structural rules over the one public log-loop representation + [ICTree.Trace.emit_batches]: [AF] by the existing [aul_iter_nat], and + [AG AF] by coinduction over every finite suffix of a batch. *) +Section EmitBatches. + Context {W I X : Type} + (batch : I -> list W) (next : I -> I) + (Inv : I -> Prop) (rank : I -> nat) (P : W -> Prop) + (Hnext : forall i, Inv i -> Inv (next i)) + (Hnonempty : forall i, Inv i -> batch i <> []) + (Hprogress : forall i, Inv i -> + (exists o, List.In o (batch i) /\ P o) \/ rank (next i) < rank i). + + Lemma emit_batches_af : forall i w, Inv i -> not_done w -> + <( {(emit_batches batch next i : ictreeW W X)}, {w} |= AF visW {P} )>. + Proof. + intros i w Hi Hd; unfold emit_batches. + eapply aul_iter_nat with (Ri := fun j (_ : World (writerE W)) => Inv j) + (f := fun j (_ : World (writerE W)) => rank j). + - exact Hd. + - exact Hi. + - intros j v Hv Hj. + destruct (Hprogress j Hj) as [(o & Hin & HP) | Hlt]. + + left; eapply af_emit_list_member; [exact Hv | exact Hin | exact HP]. + + right; apply af_emit_list_ret; [exact Hv |]. + exists (next j); split; [reflexivity |]. + split; [apply after_logs_not_done; exact Hv |]. + split; [apply Hnext; exact Hj | exact Hlt]. + Qed. + + (** The invariant is closed under suffixes: a tree is bisimilar to a + remaining suffix of the current batch followed by the loop. Each + coinductive step is guarded by a real log, exposed either from the + suffix itself or, when it is empty, from the next nonempty batch. *) + Lemma emit_batches_agaf : forall i w, Inv i -> not_done w -> + <( {(emit_batches batch next i : ictreeW W X)}, {w} |= AG (AF visW {P}) )>. + Proof. + intros i w Hi Hd. + assert (Hsuffix : forall (t : ictreeW W X) v, + (exists j suffix, Inv j /\ not_done v /\ + t ~ emit_list suffix (emit_batches batch next j : ictreeW W X)) -> + <( t, v |= AG (AF visW {P}) )>). + { coinduction R CIH; intros t v (j & suffix & Hj & Hv & Ht). + assert (Haf : <( t, v |= AF visW {P} )>). + { rewrite Ht; apply af_emit_list; [exact Hv|]. + apply emit_batches_af; [exact Hj|apply after_logs_not_done; exact Hv]. } + assert (Hexp : exists o rest j', Inv j' /\ + t ~ emit_list (o :: rest) (emit_batches batch next j' : ictreeW W X)). + { destruct suffix as [|o rest]. + - destruct (batch j) as [|o rest] eqn:Eb; [exfalso; exact (Hnonempty j Hj Eb)|]. + exists o, rest, (next j); split; [apply Hnext, Hj|]. + rewrite Ht; cbn [emit_list fold_right]. + rewrite emit_batches_unfold_sbisim, Eb; reflexivity. + - exists o, rest, j; split; [exact Hj|exact Ht]. } + destruct Hexp as (o & rest & j' & Hj' & Ht'). + rewrite Ht', emit_list_cons. + rewrite Ht', emit_list_cons in Haf. + split; [exact Haf|]; split. + - apply can_step_vis; [exact tt|exact Hv]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & _). + apply CIH; exists j', rest; split; [exact Hj'|]. + split; [constructor|reflexivity]. } + apply Hsuffix; exists i, []; split; [exact Hi|]; split; [exact Hd|reflexivity]. + Qed. +End EmitBatches. diff --git a/theories/ICTree/Logic/Yield.v b/theories/ICTree/Logic/Yield.v index d76c544..dd53301 100644 --- a/theories/ICTree/Logic/Yield.v +++ b/theories/ICTree/Logic/Yield.v @@ -1,8 +1,14 @@ From Stdlib Require Import + List + Arith.PeanoNat + Classes.Morphisms + Classes.RelationPairs Fin Vector Program.Equality. +From ExtLib Require Import Data.Option. + From TICL Require Import ICTree.Core ICTree.Equ @@ -11,14 +17,19 @@ From TICL Require Import ICTree.Events.State ICTree.Events.Writer ICTree.Interp.Core + ICTree.Interp.Refine ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Yield.Execution ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State + ICTree.Logic.Trace Logic.Core + Utils.Execution Utils.Vectors. Import ICtree ICTreeNotations TiclNotations VectorNotations. @@ -31,112 +42,10 @@ Local Open Scope ticl_scope. [forkE] and [stateE] events. They know nothing about source syntax; a language lifts them by instantiating the raw trees with its denotations. *) -(** ** Singleton scheduler reductions. *) -(** A source program starts as a one-slot pool focused on its only thread. - These local reductions normalize that pool one observable step at a time. *) - -Local Lemma schedule_singleton_empty {E} `{Encode E} (v : pool E 0) : - schedule 0 v None ≅ Ret tt. -Proof. - rewrite (ictree_eta (schedule 0 v None)), schedule_empty_none. - reflexivity. -Qed. - -Local Lemma schedule_singleton_ret {E} `{Encode E} (v : pool E 1) : - observe (v $ Fin.F1) = RetF tt -> - schedule 1 v (Some Fin.F1) ≅ Guard (Ret tt). -Proof. - intro Hobs. - rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), - (schedule_focused_ret 0 v Fin.F1 Hobs). - apply guard_equ_node, schedule_singleton_empty. -Qed. - -Local Lemma schedule_singleton_yield {E} `{Encode E} (v : pool E 1) k : - observe (v $ Fin.F1) = VisF (inl Yield) k -> - schedule 1 v (Some Fin.F1) - ≅ Guard (Vis ((inl Yield) : yieldE + (spawnE + E)) - (fun _ => Br 0 (fun i => - schedule 1 (v @ Fin.F1 := (k tt)) (Some i)))). -Proof. - intro Hobs. - rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), - (schedule_focused_yield 0 v Fin.F1 k Hobs). - apply guard_equ_node. - rewrite (ictree_eta (schedule 1 (v @ Fin.F1 := (k tt)) None)), - (schedule_no_focus_nonempty 0 (v @ Fin.F1 := (k tt))). - reflexivity. -Qed. - -Local Lemma schedule_singleton_user {E} `{Encode E} (v : pool E 1) (e : E) k : - observe (v $ Fin.F1) = VisF (inr (inr e)) k -> - schedule 1 v (Some Fin.F1) - ≅ Vis ((inr (inr e)) : yieldE + (spawnE + E)) - (fun x => schedule 1 (v @ Fin.F1 := (k x)) (Some Fin.F1)). -Proof. - intro Hobs. - rewrite (ictree_eta (schedule 1 v (Some Fin.F1))), - (schedule_focused_user_event 0 v Fin.F1 e k Hobs). - reflexivity. -Qed. - -Local Lemma instr_schedule_singleton_ret {Σ} (v : pool (stateE Σ) 1) (σ : Σ) : - observe (v $ Fin.F1) = RetF tt -> - instr_schedule 1 v (Some Fin.F1) σ ~ Ret (tt, σ). -Proof. - intro Hobs. - unfold instr_schedule, instr_stateE. - rewrite (schedule_singleton_ret v Hobs), interp_erase_guard_ret. - rewrite interp_state_tau, sb_guard, interp_state_ret. - reflexivity. -Qed. - -(** The singleton update step: read the state, write [f] of it, and finish. - Exactly one [Log] of the new state is observable. *) -Local Lemma instr_schedule_singleton_update {Σ} (f : Σ -> Σ) - (v : pool (stateE Σ) 1) (σ : Σ) : - observe (v $ Fin.F1) = - VisF ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) - (fun σ0 : Σ => - Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt)) -> - instr_schedule 1 v (Some Fin.F1) σ ~ (log (f σ);; Ret (tt, f σ)). -Proof with eauto. - intro Hobs. - assert (Hput : observe - ((v @ Fin.F1 := - (Vis ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt))) $ Fin.F1) - = VisF ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt)) - by (now rewrite Vector.nth_replace_eq). - assert (Hend : observe - (((v @ Fin.F1 := - (Vis ((inr (inr (Put (f σ)))) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt))) - @ Fin.F1 := (Ret tt)) $ Fin.F1) = RetF tt) - by (now rewrite Vector.nth_replace_eq). - unfold instr_schedule, instr_stateE. - rewrite (schedule_singleton_user v Get _ Hobs). - rewrite interp_erase_user, interp_state_vis. - cbn [h_stateW runStateT]. - rewrite bind_ret_l, sb_guard. - cbv beta. - rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. - rewrite (schedule_singleton_user _ (Put (f σ)) _ Hput). - rewrite interp_erase_user, interp_state_vis. - cbn [h_stateW runStateT]. - rewrite bind_bind. - __upto_bind_sbisim... - intros []. - rewrite bind_ret_l, sb_guard. - cbv beta. - rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. - rewrite (schedule_singleton_ret _ Hend). - rewrite interp_erase_guard_ret. - rewrite interp_state_tau, sb_guard, interp_state_ret. - reflexivity. -Qed. +(** The singleton scheduler reductions are the operational equations of + [ICTree.Interp.Yield.Nondeterministic]: [instr_schedule] is definitionally + [interp_schedule_nd h_stateW], so the modal rules below only combine those + equations with the tree-level [AX]/[AN]/log rules. *) (** ** Raw thread rules. *) @@ -249,9 +158,11 @@ Lemma axr_schedule_ret {Σ} : forall (σ : Σ) w R, (Some Fin.F1) σ}, w |= AX done R ]>. Proof with eauto with ticl. intros σ w R Hnd HR. - rewrite (instr_schedule_singleton_ret + rewrite (interp_schedule_nd_ret h_stateW 0 [(Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)]%vector - σ eq_refl). + Fin.F1 σ eq_refl + : instr_schedule 1 _ (Some Fin.F1) σ ~ _). + rewrite interp_schedule_nd_empty. apply axr_ret... Qed. @@ -266,28 +177,20 @@ Lemma axax_schedule_yield {Σ} : forall (σ : Σ) w R, (Some Fin.F1) σ}, w |= AX AX done R ]>. Proof with eauto with ticl. intros σ w R Hnd HR. - assert (Hend : observe - (([Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt)]%vector - @ Fin.F1 := (Ret tt)) $ Fin.F1) = RetF tt) - by (now rewrite Vector.nth_replace_eq). - unfold instr_schedule, instr_stateE. - rewrite (schedule_singleton_yield + rewrite (interp_schedule_nd_yield h_stateW 0 [Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) (fun _ : unit => Ret tt)]%vector + Fin.F1 (fun _ : unit => (Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)) - eq_refl). - rewrite interp_erase_guard_yield. - rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard, - interp_state_tau, sb_guard. - rewrite interp_erase_br. - apply anr_state_br; split. + σ eq_refl + : instr_schedule 1 _ (Some Fin.F1) σ ~ _). + rewrite interp_schedule_nd_select. + apply anr_br; split. - csplit... - intro i; dependent destruction i. - + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. - rewrite (schedule_singleton_ret _ Hend). - rewrite interp_erase_guard_ret. - rewrite interp_state_tau, sb_guard, interp_state_ret. + + rewrite (interp_schedule_nd_ret h_stateW 0 _ Fin.F1 σ) + by (now rewrite Vector.nth_replace_eq). + rewrite interp_schedule_nd_empty. apply axr_ret... + inversion i. Qed. @@ -307,12 +210,13 @@ Lemma aur_schedule_update {Σ} : Proof with eauto with ticl. intros f σ w ψ R Hlog HR. pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. - rewrite (instr_schedule_singleton_update f + rewrite (interp_schedule_nd_singleton_update f [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) (fun σ0 : Σ => Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) (fun _ : unit => Ret tt))]%vector - σ eq_refl). + σ eq_refl + : instr_schedule 1 _ (Some Fin.F1) σ ~ _). eapply aur_log. - cleft; apply axr_ret... - now apply ticll_bind_l. @@ -332,14 +236,49 @@ Lemma aul_schedule_update {Σ} : w |= ψ AU φ )>. Proof with eauto with ticl. intros f σ w ψ φ Hlog Hret. - rewrite (instr_schedule_singleton_update f + rewrite (interp_schedule_nd_singleton_update f [Vis ((inr (inr Get)) : yieldE + (forkE + stateE Σ)) (fun σ0 : Σ => Vis ((inr (inr (Put (f σ0)))) : yieldE + (forkE + stateE Σ)) (fun _ : unit => Ret tt))]%vector - σ eq_refl). + σ eq_refl + : instr_schedule 1 _ (Some Fin.F1) σ ~ _). cright. apply anl_log. - cleft... - now apply ticll_bind_l. Qed. + +(** ** Round-robin recurrence from executable cycle certificates. + + The top-level entry point for clients holding finite RR cycle runs + rather than a preconstructed log loop: transport through + [model_rr_emit_batches], then [emit_batches_agaf]. *) +Section ModelRRRecurrence. + Context {St Act W X I : Type} + (n : nat) (actor : Fin.t (S n) -> Act) + (step : Act -> St -> option (St * option W)) + (R : St -> St -> Prop) + (Hstep : Proper (eq ==> R ==> Roption (RelProd R eq)) step) + (boundary : I -> St) (batch : I -> list W) (next : I -> I) + (Inv : I -> Prop) (cursor period : nat) + (Hcursor : (cursor + period) mod (S n) = cursor mod (S n)) + (Hnext : forall i, Inv i -> Inv (next i)) + (Hnonempty : forall i, Inv i -> batch i <> Datatypes.nil) + (Hcycle : forall i, Inv i -> exists last, + run_turns step event_obs (rr_script n actor cursor period) (boundary i) = + Some (last,batch i) /\ R last (boundary (next i))) + (rank : I -> nat) (P : W -> Prop) + (Hprogress : forall i, Inv i -> + (exists o, List.In o (batch i) /\ P o) \/ rank (next i) < rank i). + + Lemma model_rr_agaf : forall i w, Inv i -> not_done w -> + <( {(model_rr n actor step (boundary i) cursor : ictreeW W X)}, {w} + |= AG (AF visW {P}) )>. + Proof. + intros i w Hi Hd. + rewrite (model_rr_emit_batches n actor step R Hstep boundary batch next Inv + cursor period Hcursor Hnext Hnonempty Hcycle i Hi). + exact (emit_batches_agaf batch next Inv rank P Hnext Hnonempty Hprogress i w Hi Hd). + Qed. +End ModelRRRecurrence. diff --git a/theories/ICTree/SBisim.v b/theories/ICTree/SBisim.v index dde46fa..54f2acc 100644 --- a/theories/ICTree/SBisim.v +++ b/theories/ICTree/SBisim.v @@ -60,6 +60,18 @@ Lemma equ_sbisim {E} {HE : Encode E} {X} (t u : ictree E X) : t ≅ u -> t ~ u. Proof. intro Htu; rewrite Htu; reflexivity. Qed. +(** Forgetting finitely many leading guards is a strong bisimulation. *) +Lemma guard_equ_sbisim {E} {HE : Encode E} {X} (t u : ictree E X) : + guard_equ t u -> t ~ u. +Proof. + intro H; induction H as [t u [E1|E1]|t|t u H IH|t u v H1 IH1 H2 IH2]. + - now rewrite E1. + - rewrite E1; apply sb_guard. + - reflexivity. + - now symmetry. + - now transitivity u. +Qed. + (** Lemma relating [trans] and strong simulation [ssim]*) Lemma ssim_trans `{HE: Encode E} {X}: forall (s t s': ictree E X) l (L: rel _ _), diff --git a/theories/ICTree/Trace.v b/theories/ICTree/Trace.v index 62bde13..a324e5e 100644 --- a/theories/ICTree/Trace.v +++ b/theories/ICTree/Trace.v @@ -172,6 +172,33 @@ Proof. exact (@trans_vis (writerE W) _ X (Log o) tt (fun _ => emit_list logs t)). Qed. +(** * Realizing an infinite sequence of finite label chunks. + + Each chunk must be NONEMPTY: an empty chunk cannot witness progress of a + stuck tree, so the productivity of the realization is genuine. *) +CoInductive realizes {E : Type} {HE : Encode E} {X : Type} + (chunks : nat -> list (@label E HE)) (k : nat) (t : ictree E X) : Prop := +| realizes_next next : + chunks k <> [] -> + finite_steps t (chunks k) next -> + realizes chunks (S k) next -> realizes chunks k t. + +(** Any tree bisimilar to a root of a chunked sequence realizes its suffix. *) +Lemma realizes_from_steps {E : Type} {HE : Encode E} {X : Type} + (chunks : nat -> list (@label E HE)) (roots : nat -> ictree E X) : + (forall k, chunks k <> []) -> + (forall k, exists next, + finite_steps (roots k) (chunks k) next /\ next ~ roots (S k)) -> + forall k (t : ictree E X), t ~ roots k -> realizes chunks k t. +Proof. + intros Hne Hstep; cofix CIH; intros k t Eeq. + destruct (Hstep k) as (next & Hsteps & Enext). + assert (Esym : roots k ~ t) by (symmetry; exact Eeq). + destruct (finite_steps_sbisim _ _ _ Hsteps t Esym) as (next' & Hsteps' & Enext'). + eapply realizes_next; [apply Hne|exact Hsteps'|]. + apply CIH; transitivity next; [symmetry; exact Enext'|exact Enext]. +Qed. + (** * Guard/log alignment and finite prefixes. *) Fixpoint rr_guards {W X} (n : nat) (t : ictreeW W X) : ictreeW W X := @@ -363,3 +390,77 @@ Proof. exists 0, (List.length rest); cbn [rr_prefix rr_guards]. step; constructor; intros []; rewrite (rr_prefix_no_events rest t Er); reflexivity. Qed. + +(** * Repeating finite observation batches. + + One public representation of a log loop: each round emits the finite + batch of its index and advances the index. Batches may be empty, but an + empty batch cannot satisfy the productivity premise of the coinduction + below -- no dummy log is inserted. *) +Definition emit_batches {W I X : Type} + (batch : I -> list W) (next : I -> I) (i : I) : ictreeW W X := + ICtree.iter (fun j => emit_list (batch j) (Ret (@inl I X (next j)))) i. + +(** The RAW unfolding: the administrative guard of [iter] is retained. *) +Lemma emit_batches_unfold {W I X} (batch : I -> list W) (next : I -> I) i : + (emit_batches batch next i : ictreeW W X) ≅ + emit_list (batch i) (Guard (emit_batches batch next (next i))). +Proof. + unfold emit_batches at 1; rewrite unfold_iter. + rewrite emit_list_ret_bind; reflexivity. +Qed. + +(** The same unfolding after absorbing the administrative guard. *) +Lemma emit_batches_unfold_sbisim {W I X} (batch : I -> list W) (next : I -> I) i : + (emit_batches batch next i : ictreeW W X) ~ + emit_list (batch i) (emit_batches batch next (next i) : ictreeW W X). +Proof. + etransitivity; [apply equ_sbisim, emit_batches_unfold |]. + apply emit_list_sbisim, sb_guard. +Qed. + +(** A root family that emits its own batch each round IS the batch loop. + The nonempty-batch premise is essential: silent self-equations alone do + not justify this coinduction. + + NOTE: every companion step below is discharged by [exact] at explicit + arguments. With [W], [I] and [X] all variables, an [etransitivity] whose + middle term is still an evar leaves [apply] to solve a higher-order + unification problem that does not terminate. This is unrelated to + typeclass transparency -- [coinduction] is imported above, so the + companion is already opaque to instance resolution. *) +Lemma emit_batches_bisim {W I X} (batch : I -> list W) (next : I -> I) + (Inv : I -> Prop) (root : I -> ictreeW W X) + (Hnext : forall i, Inv i -> Inv (next i)) + (Hnonempty : forall i, Inv i -> batch i <> []) + (Hroot : forall i, Inv i -> root i ~ emit_list (batch i) (root (next i))) : + forall i, Inv i -> root i ~ (emit_batches batch next i : ictreeW W X). +Proof. + unfold sbisim; apply_coinduction; fold_sbisim; intros R IH i Hi. + assert (Hstep : coinduction.bt (sb eq) R + (emit_list (batch i) (root (next i))) + (emit_list (batch i) (emit_batches batch next (next i) : ictreeW W X))). + { destruct (batch i) as [|o rest] eqn:Eb; + [exfalso; exact (Hnonempty i Hi Eb) |]. + eapply equ_sbt_closed_goal; [apply emit_list_cons | apply emit_list_cons |]. + apply step_sb_vis; intros []; exists tt; split; try reflexivity; + apply emit_list_st; apply IH, Hnext, Hi. } + etransitivity; [apply (coinduction.gfp_bt (sb eq) R), (Hroot i Hi) |]. + etransitivity; [exact Hstep |]. + apply (coinduction.gfp_bt (sb eq) R); symmetry. + exact (emit_batches_unfold_sbisim batch next i). +Qed. + +(** An everywhere-empty batch loop is raw-equivalent to [stuck]. Both sides + unfold to a [Guard], so the recursive obligation sits under matching + [GuardF] constructors; this is a RAW equivalence, not an invisible-guard + justification of a strong bisimulation. *) +Lemma emit_batches_empty {W I X} (batch : I -> list W) (next : I -> I) : + (forall j, batch j = []) -> + forall i, (emit_batches batch next i : ictreeW W X) ≅ stuck. +Proof. + intro Hempty; __coinduction_equ R CIH; intro i. + rewrite emit_batches_unfold, (Hempty i), emit_list_nil. + rewrite unfold_stuck. + constructor; apply CIH. +Qed. diff --git a/theories/Lang/CSL.v b/theories/Lang/CSL.v index 4f047f7..a2f9f33 100644 --- a/theories/Lang/CSL.v +++ b/theories/Lang/CSL.v @@ -1,3 +1,3 @@ From TICL Require Export - Lang.CSL.Pcm Lang.CSL.Heap Lang.CSL.Syntax Lang.CSL.Denote + Lang.CSL.Heap Lang.CSL.Syntax Lang.CSL.Denote ICTree.Interp.Refine Lang.CSL.Interp Lang.CSL.Segments Lang.CSL.Ticl. diff --git a/theories/Lang/CSL/Heap.v b/theories/Lang/CSL/Heap.v index 81f61da..8bbe7c5 100644 --- a/theories/Lang/CSL/Heap.v +++ b/theories/Lang/CSL/Heap.v @@ -1,3 +1,10 @@ +(** * The CSL effect sum and its handler. + + Everything generic about checked heap access, allocation search and + indexed observation lives one layer down, in [ICTree.Interp.Heap] and + [ICTree.Events.Writer]. This module only fixes the CSL effect sum, its + interpretation state, and the handler instance that pairs them. *) + From Stdlib Require Import List Lia @@ -13,7 +20,6 @@ From TICL Require Import ICTree.SBisim ICTree.Interp.State.Mod ICTree.Events.State - ICTree.Events.Writer ICTree.Logic.Trans ICTree.Logic.CanStep ICTree.Logic.AX @@ -24,46 +30,12 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Export Lang.CSL.Pcm ICTree.Events.Heap. - -Definition upd (h : Heap) (a v : nat) : Heap := - fun x => if Nat.eqb x a then Some v else h x. - -(** ** The algebra of [upd]. - - Elementary lookup facts about the primitive defined just above. Stated - with explicit binders: they are applied positionally. *) - -Lemma upd_unfold: forall h a v x, upd h a v x = if Nat.eqb x a then Some v else h x. -Proof. reflexivity. Qed. - -Lemma upd_eq: forall h a v, upd h a v a = Some v. -Proof. intros; unfold upd; now rewrite Nat.eqb_refl. Qed. - -Lemma upd_neq: forall h a v x, x <> a -> upd h a v x = h x. -Proof. intros; unfold upd; now apply Nat.eqb_neq in H as ->. Qed. - -Lemma upd_mono: forall h a v x, h x <> None -> upd h a v x <> None. -Proof. intros h a v x H; unfold upd; destruct (Nat.eqb x a); [discriminate | exact H]. Qed. - -Lemma upd_dom: forall h a v x, h a <> None -> (upd h a v x <> None <-> h x <> None). -Proof. - intros h a v x Ha; unfold upd; destruct (Nat.eqb_spec x a) as [-> | Hne]. - - split; [intros _; exact Ha | intros _; discriminate]. - - reflexivity. -Qed. - -Lemma upd_lookup_agree: forall h f a v x, h x = f x -> upd h a v x = upd f a v x. -Proof. - intros h f a v x H; destruct (Nat.eq_dec x a) as [-> | Hne]. - - now rewrite !upd_eq. - - now rewrite !upd_neq by exact Hne. -Qed. - -Lemma upd_heq: forall h k a v, heq h k -> heq (upd h a v) (upd k a v). -Proof. - intros h k a v H x; unfold upd; destruct (Nat.eqb x a); [reflexivity | apply H]. -Qed. +From TICL Require Export + Events.HeapModel + ICTree.Events.Heap + ICTree.Events.Writer + ICTree.Interp.Heap + ICTree.Logic.Heap. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -73,10 +45,6 @@ Local Open Scope list_scope. Local Typeclasses Transparent equ. Local Typeclasses Transparent sbisim. -(** ** The queue-tagged observation alphabet *) - -Record SObs : Type := SPop { stag: nat ; sval: nat ; sidx: nat }. - (** ** Events *) Definition sE : Type := (heapE + writerE (nat * nat))%type. @@ -88,425 +56,10 @@ Definition semit (q v : nat) : ictree sE unit := outer frame) and one GLOBAL occurrence counter. *) Notation SSig := (Heap * nat)%type. -(** The immutable snapshot is searched without fuel or heap instrumentation. - Every rejected candidate is silent; only success changes the shared heap. *) -Fixpoint block_freeb (h : Heap) (base size : nat) : bool := - match size with - | 0 => true - | S rest => - match h base with - | None => block_freeb h (S base) rest - | Some _ => false - end - end. - -CoFixpoint alloc_search {W : Type} (h : Heap) (size candidate c : nat) - : ictreeW W (nat * SSig) := - match size with - | 0 => stuck - | S _ => - if block_freeb h candidate size - then Ret (candidate, (hunion (hblock candidate size) h, c)) - else Guard (alloc_search (W:=W) h size (S candidate) c) - end. - -(** ** Checked accesses and constructive allocation in one shared handler. *) -Definition heap_handler {W : Type} : heapE ~> stateT SSig (ictreeW W) := - fun e => - mkStateT (fun s => - match e return ictreeW W (encode e * SSig) with - | HRead a => match fst s a with - | Some v => Ret (v,s) - | None => stuck - end - | HWrite a v => match fst s a with - | Some _ => Ret (tt,(upd (fst s) a v,snd s)) - | None => stuck - end - | HAlloc size => alloc_search (W:=W) (fst s) size 1 (snd s) - | HFree a => Ret (tt,(Pcm.hfree a (fst s),snd s)) - | HCAS a expected desired => - match fst s a with - | None => stuck - | Some current => - if Nat.eqb current expected - then Ret (true,(upd (fst s) a desired,snd s)) - else Ret (false,s) - end - end). - -(** The checked read/write laws do not depend on the observation alphabet. *) -Lemma heap_handler_rd_some {W : Type} : forall a h c v, - h a = Some v -> - runStateT (heap_handler (W:=W) (HRead a)) (h,c) ≅ Ret (v,(h,c)). -Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. - -Lemma heap_handler_rd_none {W : Type} : forall a h c, - h a = None -> - runStateT (heap_handler (W:=W) (HRead a)) (h,c) ≅ stuck. -Proof. intros a h c H; cbn; rewrite H; reflexivity. Qed. - -Lemma heap_handler_wr_some {W : Type} : forall a h c v w, - h a = Some w -> - runStateT (heap_handler (W:=W) (HWrite a v)) (h,c) ≅ - Ret (tt,(upd h a v,c)). -Proof. intros a h c v w H; cbn; rewrite H; reflexivity. Qed. - -(** Adding another effect handler leaves the checked memory paths unchanged. *) -Section HeapInterp. - Context {W E : Type} {HE : Encode E} - (other : E ~> stateT SSig (ictreeW W)). - - Lemma interp_heap_rd {X} : forall a h c v (k : nat -> ictree (heapE + E) X), - h a = Some v -> - interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,c) ~ - interp_state (h_sum heap_handler other) (k v) (h,c). - Proof. - intros a h c v k H. - unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_rd_some (W:=W) a h c v H), bind_ret_l. - apply sb_guard. - Qed. - - Lemma interp_heap_wr {X} : forall a h c v w (k : unit -> ictree (heapE + E) X), - h a = Some w -> - interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,c) ~ - interp_state (h_sum heap_handler other) (k tt) (upd h a v,c). - Proof. - intros a h c v w k H. - unfold heap_write, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_wr_some (W:=W) a h c v w H), bind_ret_l. - apply sb_guard. - Qed. - - Lemma interp_heap_wr_present {X} : forall a h c v (k : unit -> ictree (heapE + E) X), - h a <> None -> - interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,c) ~ - interp_state (h_sum heap_handler other) (k tt) (upd h a v,c). - Proof. - intros a h c v k H; destruct (h a) as [w |] eqn:Ha; [| contradiction]. - eapply interp_heap_wr; eauto. - Qed. - - (** An out-of-footprint read cannot step, regardless of its continuation. *) - Lemma interp_heap_rd_nostep {X} : forall a h c (k : nat -> ictree (heapE + E) X) w, - h a = None -> - ~ can_step - (interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,c)) w. - Proof. - intros a h c k w H. - unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_rd_none (W:=W) a h c H). - intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; - revert TR; apply ktrans_stuck. - Qed. -End HeapInterp. - -Definition sh_tagged : writerE (nat * nat) ~> stateT SSig (ictreeW SObs) := - fun e => - match e with - | Log (tag,value) => mkStateT (fun '(h,c) => - log (SPop tag value c);; Ret (tt,(h,S c))) - end. - -Definition sh : sE ~> stateT SSig (ictreeW SObs) := - h_sum (heap_handler (W:=SObs)) sh_tagged. - -(** *** Handler equations *) - -Lemma sh_rd_some: forall a h c v, - h a = Some v -> runStateT (sh (inl (HRead a))) (h, c) ≅ Ret (v, (h, c)). -Proof. exact (heap_handler_rd_some (W:=SObs)). Qed. - -Lemma sh_rd_none: forall a h c, - h a = None -> runStateT (sh (inl (HRead a))) (h, c) ≅ ICtree.stuck. -Proof. exact (heap_handler_rd_none (W:=SObs)). Qed. - -Lemma sh_wr_some: forall a h c v w, - h a = Some w -> runStateT (sh (inl (HWrite a v))) (h, c) ≅ Ret (tt, (upd h a v, c)). -Proof. exact (heap_handler_wr_some (W:=SObs)). Qed. - -Lemma sh_emit: forall q v h c, - runStateT (sh (inr (Log (q,v)))) (h, c) ≅ (log (SPop q v c) ;; Ret (tt, (h, S c))). -Proof. intros; cbn; reflexivity. Qed. - -Lemma sh_cas_success a expected desired h c : - h a = Some expected -> - runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ - Ret (true,(upd h a desired,c)). -Proof. intro H; cbn; rewrite H, Nat.eqb_refl; reflexivity. Qed. - -Lemma sh_cas_failure a expected desired current h c : - h a = Some current -> current <> expected -> - runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ Ret (false,(h,c)). -Proof. - intros H N; cbn; rewrite H. - apply Nat.eqb_neq in N; rewrite N; reflexivity. -Qed. - -Lemma sh_cas_missing a expected desired h c : - h a = None -> - runStateT (sh (inl (HCAS a expected desired))) (h,c) ≅ - (stuck : ictreeW SObs (bool * SSig)). -Proof. intro H; cbn; rewrite H; reflexivity. Qed. - -Lemma sh_free a h c : - runStateT (sh (inl (HFree a))) (h,c) ≅ - Ret (tt,(Pcm.hfree a h,c)). -Proof. reflexivity. Qed. - -(** *** Lifting through [interp_state] *) - -Lemma sinterp_rd {X}: forall a h c v (k: nat -> ictree sE X), - h a = Some v -> - interp_state sh (x <- heap_read (E:=sE) a ;; k x) (h, c) ~ interp_state sh (k v) (h, c). -Proof. exact (interp_heap_rd sh_tagged (X:=X)). Qed. - -Lemma sinterp_wr {X}: forall a h c v w (k: unit -> ictree sE X), - h a = Some w -> - interp_state sh (x <- heap_write (E:=sE) a v ;; k x) (h, c) - ~ interp_state sh (k tt) (upd h a v, c). -Proof. exact (interp_heap_wr sh_tagged (X:=X)). Qed. - -Lemma sinterp_wr' {X}: forall a h c v (k: unit -> ictree sE X), - h a <> None -> - interp_state sh (x <- heap_write (E:=sE) a v ;; k x) (h, c) - ~ interp_state sh (k tt) (upd h a v, c). -Proof. exact (interp_heap_wr_present sh_tagged (X:=X)). Qed. - -Lemma sinterp_emit {X}: forall q v h c (k: unit -> ictree sE X), - interp_state sh (x <- semit q v ;; k x) (h, c) - ~ (log (SPop q v c) ;; interp_state sh (k tt) (h, S c)). -Proof. - intros q v h c k. - unfold semit, ICtree.trigger, resum, resum_ret, ReSum_inr, ReSumRet_inr; - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, sh_emit, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l; apply sb_guard. -Qed. - -Lemma sinterp_cas_success {X} a expected desired h c - (k : bool -> ictree sE X) : - h a = Some expected -> - interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ - interp_state sh (k true) (upd h a desired,c). -Proof. - intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, (sh_cas_success a expected desired h c H), bind_ret_l. - apply sb_guard. -Qed. - -Lemma sinterp_cas_failure {X} a expected desired current h c - (k : bool -> ictree sE X) : - h a = Some current -> current <> expected -> - interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ - interp_state sh (k false) (h,c). -Proof. - intros H N; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, - (sh_cas_failure a expected desired current h c H N), bind_ret_l. - apply sb_guard. -Qed. - -Lemma sinterp_cas_missing {X} a expected desired h c - (k : bool -> ictree sE X) : - h a = None -> - interp_state sh (b <- heap_cas (E:=sE) a expected desired;; k b) (h,c) ~ - (stuck : ictreeW SObs (X * SSig)). -Proof. - intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, (sh_cas_missing a expected desired h c H). - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma sinterp_free {X} a h c (k : unit -> ictree sE X) : - interp_state sh (heap_free (E:=sE) a >>= k) (h,c) ~ - interp_state sh (k tt) (Pcm.hfree a h,c). -Proof. - unfold heap_free, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl; - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, sh_free, bind_ret_l. - apply sb_guard. -Qed. - -(** An out-of-footprint read cannot step. *) -Lemma sinterp_rd_nostep {X}: forall a h c (k: nat -> ictree sE X) w, - h a = None -> - ~ can_step (interp_state sh (x <- heap_read (E:=sE) a ;; k x) (h, c)) w. -Proof. exact (interp_heap_rd_nostep sh_tagged (X:=X)). Qed. - -Lemma sh_wr_none : forall a h c v, - h a = None -> runStateT (sh (inl (HWrite a v))) (h,c) ≅ stuck. -Proof. intros a h c v H; cbn; rewrite H; reflexivity. Qed. - -Lemma sinterp_srd_stuck a h c : - h a = None -> - interp_state sh (heap_read (E:=sE) a) (h,c) ≅ (stuck : ictreeW SObs (nat * SSig)). -Proof. - intro H; unfold heap_read, ICtree.trigger. - rewrite interp_state_vis, (sh_rd_none a h c H). - apply bind_stuck_equ. -Qed. - -Lemma sinterp_swr_stuck a v h c : - h a = None -> - interp_state sh (heap_write (E:=sE) a v) (h,c) ≅ (stuck : ictreeW SObs (unit * SSig)). -Proof. - intro H; unfold heap_write, ICtree.trigger. - rewrite interp_state_vis, (sh_wr_none a h c v H). - apply bind_stuck_equ. -Qed. - -Lemma upd_pcm h a v : heq (upd h a v) (Pcm.hupd a v h). -Proof. - intro x; unfold upd, Pcm.hupd. - destruct (Nat.eqb_spec x a); destruct (Nat.eq_dec a x); congruence. -Qed. - -(** ** Allocation laws *) - -Lemma block_freeb_spec h base size : - block_freeb h base size = true <-> block_free h base size. -Proof. - revert base; induction size as [|size IH]; intro base. - - split; [intros _ offset O; lia | reflexivity]. - - cbn [block_freeb]; destruct (h base) as [v|] eqn:E. - + split; [discriminate | intro F]. - specialize (F 0 ltac:(lia)); rewrite Nat.add_0_r, E in F; discriminate. - + rewrite IH; split. - * intros F [|offset] O. - -- now rewrite Nat.add_0_r. - -- replace (base + S offset)%nat with (S base + offset)%nat by lia; apply F; lia. - * intros F offset O. - replace (S base + offset)%nat with (base + S offset)%nat by lia; apply F; lia. -Qed. - -Lemma unfold_alloc_search {W : Type} h size candidate c : - alloc_search (W:=W) h size candidate c ≅ - match size with - | 0 => stuck - | S _ => if block_freeb h candidate size - then Ret (candidate, (hunion (hblock candidate size) h, c)) - else Guard (alloc_search (W:=W) h size (S candidate) c) - end. -Proof. - step; cbn; unfold observe; cbn; reflexivity. -Qed. - -Lemma alloc_search_first {W : Type} h size start base c : - Nat.lt 0 size -> Nat.le start base -> block_free h base size -> - (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size) -> - alloc_search (W:=W) h size start c ~ - Ret (base, (hunion (hblock base size) h, c)). -Proof. - intros Pos L Free First; destruct size as [|size]; [lia |]. - remember (base - start) as distance eqn:D. - revert start L First D. - induction distance as [|distance IH]; intros start L First D. - - assert (start = base) by lia; subst start. - rewrite unfold_alloc_search. - apply block_freeb_spec in Free; rewrite Free; reflexivity. - - assert (Test : block_freeb h start (S size) = false). - { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. - exfalso; apply (First start); try lia; apply block_freeb_spec; exact T. } - rewrite unfold_alloc_search, Test. - etransitivity; [apply sb_guard |]. - apply IH; [lia | |lia]. - intros j J B; apply First; lia. -Qed. - -Lemma sh_alloc_zero h c : - runStateT (sh (inl (HAlloc 0))) (h,c) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. exact (unfold_alloc_search (W:=SObs) h 0 1 c). Qed. - -Lemma sh_alloc_first h size base c : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - runStateT (sh (inl (HAlloc size))) (h,c) ~ - Ret (base, (hunion (hblock base size) h, c)). -Proof. - intros Pos B F First. - apply (alloc_search_first (W:=SObs) h size 1 base c); try assumption; try lia. -Qed. - -Lemma sh_alloc_finite h size c : - heap_finite h -> Nat.lt 0 size -> - exists base, - Nat.lt 0 base /\ block_free h base size /\ - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) /\ - runStateT (sh (inl (HAlloc size))) (h,c) ~ - Ret (base, (hunion (hblock base size) h, c)). -Proof. - intros [B Bound] Pos. - assert (Search : forall distance start, - Nat.max 1 B = (start + distance)%nat -> - exists base, Nat.le start base /\ block_free h base size /\ - (forall j, Nat.le start j -> Nat.lt j base -> ~ block_free h j size)). - { induction distance as [|distance IH]; intros start D. - - exists start; split; [lia |]; split. - + eapply heap_bounded_block_free; [exact Bound |lia]. - + intros j J L; lia. - - destruct (block_freeb h start size) eqn:T. - + exists start; split; [lia |]; split. - * apply block_freeb_spec; exact T. - * intros j J L; lia. - + destruct (IH (S start) ltac:(lia)) as (base & L & F & First). - exists base; split; [lia |]; split; [exact F |]. - intros j J Lt Free; destruct (Nat.eq_dec j start) as [E|E]. - * subst j; apply block_freeb_spec in Free; congruence. - * apply (First j); try lia; exact Free. } - destruct (Search (Nat.max 1 B - 1) 1 ltac:(lia)) - as (base & L & F & First). - exists base; split; [lia |]; split; [exact F |]; split. - - intros j J Lt; apply First; lia. - - apply sh_alloc_first; try assumption; try lia. -Qed. - -Lemma sinterp_salloc_zero h c : - interp_state sh (heap_alloc (E:=sE) 0) (h,c) ≅ - (stuck : ictreeW SObs (nat * SSig)). -Proof. - unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. - rewrite interp_state_vis, sh_alloc_zero. - apply bind_stuck_equ. -Qed. - -Lemma sinterp_alloc_first {X} h size base c (k : nat -> ictree sE X) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_state sh (a <- heap_alloc (E:=sE) size;; k a) (h,c) ~ - interp_state sh (k base) (hunion (hblock base size) h,c). -Proof. - intros Pos B F First. - unfold heap_alloc, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, (sh_alloc_first h size base c Pos B F First), bind_ret_l. - apply sb_guard. -Qed. - -Lemma heap_finite_upd h a v : heap_finite h -> heap_finite (upd h a v). -Proof. - intros [B Bound]; exists (Nat.max B (S a)); intros x X. - unfold upd; destruct (Nat.eqb_spec x a); [lia | apply Bound; lia]. -Qed. +(** The CSL handler is exactly the shared checked-heap handler summed with + the shared indexing handler. The tag travels in the payload; the -Lemma alloc_search_no_space {W : Type} h size start c : - Nat.lt 0 size -> - (forall j, Nat.le start j -> ~ block_free h j size) -> - alloc_search (W:=W) h size start c ≅ (stuck : ictreeW W (nat * SSig)). -Proof. - intros Pos Full; destruct size as [|size]; [lia |]. - revert start Full; __coinduction_equ R CIH; intros start Full. - assert (Test : block_freeb h start (S size) = false). - { destruct (block_freeb h start (S size)) eqn:T; [|reflexivity]. - exfalso; apply (Full start); [lia | apply block_freeb_spec; exact T]. } - rewrite unfold_alloc_search, Test, unfold_stuck. - constructor; apply CIH; intros j J; apply Full; lia. -Qed. +From Coinduction Require Import coinduction. + occurrence index is supplied by [h_indexed], which owns the counter. *) +Definition sh : sE ~> stateT SSig (ictreeW (indexed (nat * nat))) := + h_sum heap_handler h_indexed. diff --git a/theories/Lang/CSL/Interp.v b/theories/Lang/CSL/Interp.v index eb28796..b7f0387 100644 --- a/theories/Lang/CSL/Interp.v +++ b/theories/Lang/CSL/Interp.v @@ -1,11 +1,12 @@ -From TICL Require Export ICTree.Trace. +From TICL Require Export ICTree.Trace ICTree.Interp.Yield.Nondeterministic. From Stdlib Require Import Fin Vector List Arith.PeanoNat Lia. From TICL Require Import Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Logic.State Logic.World ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim - ICTree.Interp.Yield.RoundRobin ICTree.Interp.Refine + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Refine ICTree.Interp.State.Mod Utils.Vectors. Import ICtree ICTreeNotations VectorNotations. @@ -153,17 +154,12 @@ Definition scheduled (p : CProg unit) : completed sE := Definition scheduled_rr (p : CProg unit) : completed sE := run_round_robin (scheduled p) 0. Definition run_rr (p : CProg unit) (h : Heap) (c : nat) - : ictreeW SObs (unit * SSig) := + : ictreeW (indexed (nat * nat)) (unit * SSig) := interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (h,c). -Definition interp_nd (n : nat) (ts : pool sE n) - (focus : option (Fin.t n)) (sigma : SSig) - : ictreeW SObs (unit * SSig) := - interp_state sh (interp_yield (interp_spawn (schedule n ts focus))) sigma. - Definition run_nd (p : CProg unit) (h : Heap) (c : nat) - : ictreeW SObs (unit * SSig) := - interp_nd 1 [denote p]%vector (Some Fin.F1) (h,c). + : ictreeW (indexed (nat * nat)) (unit * SSig) := + interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) (h,c). Lemma run_rr_unfold p h c : run_rr p h c ≅ @@ -336,235 +332,109 @@ Proof. reflexivity. Qed. -Lemma interp_nd_equ n (ts ts' : pool sE n) focus sigma : - pool_equ ts ts' -> - interp_nd n ts focus sigma ≅ interp_nd n ts' focus sigma. -Proof. - intro Hts; unfold interp_nd. - apply equ_interp_state; [|reflexivity]. - apply interp_yield_equ, interp_spawn_equ. - now apply schedule_pool_proper. -Qed. - -Lemma interp_nd_empty sigma : - interp_nd 0 ([] : pool sE 0) None sigma ~ Ret (tt,sigma). -Proof. - unfold interp_nd. - assert (Hempty : schedule 0 ([] : pool sE 0) None ≅ Ret tt). - { rewrite (ictree_eta (schedule 0 ([] : pool sE 0) None)), schedule_empty_none. - reflexivity. } - rewrite Hempty, interp_erase_ret, interp_state_ret; reflexivity. -Qed. - -Lemma interp_nd_ret n (ts : pool sE (S n)) (i : Fin.t (S n)) sigma : - observe (ts $ i) = RetF tt -> - interp_nd (S n) ts (Some i) sigma ~ interp_nd n (ts -- i) None sigma. -Proof. - intro Hobs; unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts (Some i) ≅ Guard (schedule n (ts -- i) None)). - { rewrite (ictree_eta (schedule (S n) ts (Some i))), - (schedule_focused_ret n ts i Hobs); reflexivity. } - rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. -Qed. - -Lemma interp_nd_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : - observe (ts $ i) = GuardF t -> - interp_nd (S n) ts (Some i) sigma ~ - interp_nd (S n) (ts @ i := t) (Some i) sigma. -Proof. - intro Hobs; unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts (Some i) ≅ - Guard (schedule (S n) (ts @ i := t) (Some i))). - { rewrite (ictree_eta (schedule (S n) ts (Some i))), - (schedule_focused_guard n ts i t Hobs); reflexivity. } - rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. -Qed. - -Lemma interp_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) k sigma : - observe (ts $ i) = VisF (inl Yield) k -> - interp_nd (S n) ts (Some i) sigma ~ - interp_nd (S n) (ts @ i := k tt) None sigma. -Proof. - intro Hobs; unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts (Some i) ≅ - Guard (schedule (S n) (ts @ i := k tt) None)). - { rewrite (ictree_eta (schedule (S n) ts (Some i))), - (schedule_focused_yield n ts i k Hobs); reflexivity. } - rewrite Hnode, interp_erase_guard, interp_state_tau, sb_guard; reflexivity. -Qed. - -Lemma interp_nd_select n (ts : pool sE (S n)) sigma : - interp_nd (S n) ts None sigma ~ - Br n (fun i => interp_nd (S n) ts (Some i) sigma). -Proof. - unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts None ≅ - Vis (inl Yield) (fun _ => Br n (fun i => schedule (S n) ts (Some i)))). - { rewrite (ictree_eta (schedule (S n) ts None)), schedule_no_focus_nonempty. - reflexivity. } - rewrite Hnode, interp_erase_yield, interp_state_tau, sb_guard, - interp_state_tau, sb_guard. - rewrite interp_erase_br, interp_state_br. - apply sb_br_id; intro i. - rewrite sb_guard, interp_state_tau, sb_guard, interp_state_tau, sb_guard; - reflexivity. -Qed. - -Lemma interp_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) k sigma : - observe (ts $ i) = VisF (inr (inl Fork)) k -> - interp_nd (S n) ts (Some i) sigma ~ - interp_nd (S (S n)) (k true :: (ts @ i := k false)) - (Some (Fin.FS i)) sigma. -Proof. - intro Hobs; unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts (Some i) ≅ - Vis (inr (inl Spawn)) (fun _ => - schedule (S (S n)) (k true :: (ts @ i := k false)) (Some (Fin.FS i)))). - { rewrite (ictree_eta (schedule (S n) ts (Some i))), - (schedule_focused_fork n ts i k Hobs); reflexivity. } - rewrite Hnode, interp_erase_spawn, interp_state_tau, sb_guard; reflexivity. -Qed. - -Lemma interp_nd_user n (ts : pool sE (S n)) (i : Fin.t (S n)) e k sigma : - observe (ts $ i) = VisF (inr (inr e)) k -> - interp_nd (S n) ts (Some i) sigma ~ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - interp_nd (S n) (ts @ i := k x) (Some i) sigma'). -Proof. - intro Hobs; unfold interp_nd at 1. - assert (Hnode : schedule (S n) ts (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + sE)) - (fun x => schedule (S n) (ts @ i := k x) (Some i))). - { rewrite (ictree_eta (schedule (S n) ts (Some i))), - (schedule_focused_user_event n ts i e k Hobs); reflexivity. } - rewrite Hnode, interp_erase_user, interp_state_vis. - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x sigma']; rewrite sb_guard, interp_state_tau, sb_guard, - interp_state_tau, sb_guard; reflexivity. -Qed. - -Lemma interp_nd_user_bind n (ts : pool sE (S n)) (i : Fin.t (S n)) - (t : thread sE) (e : sE) (k : encode e -> thread sE) sigma : - t ≅ Vis (inr (inr e)) k -> - interp_nd (S n) (ts @ i := t) (Some i) sigma ~ - (interp_state sh (@ICtree.trigger sE sE _ _ ReSum_refl ReSumRet_refl e) sigma >>= - fun '(x,sigma') => interp_nd (S n) (ts @ i := k x) (Some i) sigma'). -Proof. - intro Hnode. - pose proof (interp_nd_equ (S n) - (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) sigma - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_nd_user with (e:=e) (k:=k) - by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite interp_state_trigger_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - Lemma interp_nd_source_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ - interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ. + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ + interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ. Proof. - apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. apply source_raw_ret. Qed. Lemma interp_nd_source_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : option nat -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => - interp_nd (S n) (ts @ i := K (Some x)) (Some i) σ'). + interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ'). Proof. - apply (interp_nd_user_bind n ts i _ (inl (HRead a)) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HRead a)) (fun x => K (Some x)) σ). apply source_raw_read_head. Qed. Lemma interp_nd_source_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) sigma : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) sigma ~ (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => - interp_nd (S n) (ts @ i := K (Some base)) (Some i) sigma'). + interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) sigma'). Proof. - apply (interp_nd_user_bind n ts i _ (inl (HAlloc size)) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HAlloc size)) (fun base => K (Some base)) sigma). apply source_raw_alloc_head. Qed. Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired (K : option bool -> thread sE) sigma : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) sigma ~ (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => - interp_nd (S n) (ts @ i := K (Some b)) (Some i) sigma'). + interp_schedule_nd sh (S n) (ts @ i := K (Some b)) (Some i) sigma'). Proof. - apply (interp_nd_user_bind n ts i _ (inl (HCAS a expected desired)) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HCAS a expected desired)) (fun b => K (Some b)) sigma). apply source_raw_cas_head. Qed. Lemma interp_nd_source_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => - interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). Proof. - apply (interp_nd_user_bind n ts i _ (inl (HWrite a v)) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HWrite a v)) (fun _ => K (Some tt)) σ). apply source_raw_write_head. Qed. Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) q v (K : option unit -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) σ ~ (interp_state sh (semit q v) σ >>= fun '(_,σ') => - interp_nd (S n) (ts @ i := K (Some tt)) (Some i) σ'). + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). Proof. - apply (interp_nd_user_bind n ts i _ (inr (Log (q,v))) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inr (Log (q,v))) (fun _ => K (Some tt)) σ). apply source_raw_emit_head. Qed. Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) σ : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) σ ≅ - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun r => match r with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) σ. Proof. - apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. apply source_raw_bind. Qed. Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ - interp_nd (S n) (ts @ i := K (Some tt)) None σ. + interp_schedule_nd sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) None σ. Proof. - pose proof (interp_nd_equ (S n) + pose proof ((interp_schedule_nd_equ sh) (S n) (ts @ i := (denote_flow CYield >>= K)) (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. rewrite Hpool. - erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). + erewrite (interp_schedule_nd_yield sh) by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. Qed. Lemma interp_nd_source_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg unit) (K : option unit -> thread sE) σ : - interp_nd (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) σ ~ - interp_nd (S (S n)) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S (S n)) ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) (Some (Fin.FS i)) σ. Proof. - pose proof (interp_nd_equ (S n) + pose proof ((interp_schedule_nd_equ sh) (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (ts @ i := Vis (inr (inl Fork)) (fun child : bool => if child @@ -572,15 +442,15 @@ Proof. (Some i) σ (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. rewrite Hpool. - erewrite interp_nd_fork by (rewrite Vector.nth_replace_eq; reflexivity). + erewrite (interp_schedule_nd_fork sh) by (rewrite Vector.nth_replace_eq; reflexivity). rewrite Vector.replace_replace_eq; reflexivity. Qed. Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) σ : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) σ ≅ - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= fun r => match r with | None => K None @@ -588,7 +458,7 @@ Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) end)) (Some i) σ. Proof. - apply interp_nd_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. apply source_raw_until. Qed. @@ -605,7 +475,7 @@ Lemma interp_rr_write_present n (Some i) m (upd h a v,c). Proof. intro Present. - pose proof (sinterp_wr' a h c v + pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c v (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_write. @@ -622,13 +492,13 @@ Lemma interp_nd_source_write_present n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c : h a <> None -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some tt)) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c). Proof. intro Present. - pose proof (sinterp_wr' a h c v + pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c v (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_write. @@ -649,7 +519,7 @@ Lemma interp_rr_read_value n interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m (h,c). Proof. intro Lookup. - pose proof (sinterp_rd a h c value + pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c value (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_read. @@ -666,12 +536,12 @@ Lemma interp_nd_source_read_value n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c : h a = Some value -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) (ts @ i := K (Some value)) (Some i) (h,c). + interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c). Proof. intro Lookup. - pose proof (sinterp_rd a h c value + pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c value (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_read. @@ -690,15 +560,15 @@ Lemma interp_rr_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c) ~ - (log (SPop tag value c);; + (log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)). Proof. - pose proof (sinterp_emit tag value h c + pose proof (interp_indexed_emit heap_handler (tag,value) h c (fun x : unit => (Ret x : ictree sE unit))) as Hemit. rewrite bind_ret_r in Hemit. assert (Hstate : interp_state sh (semit tag value) (h,c) ~ - (log (SPop tag value c);; Ret (tt,(h,S c)))). + (log (stamp (tag,value) c);; Ret (tt,(h,S c)))). { etransitivity; [exact Hemit |]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. eapply equ_clos_sbisim_goal; @@ -730,7 +600,7 @@ Proof. intro Lookup; rewrite interp_rr_cas. destruct (Nat.eqb current expected) eqn:Cmp. - apply Nat.eqb_eq in Cmp; subst current. - pose proof (sinterp_cas_success a expected desired h c + pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -741,7 +611,7 @@ Proof. end. rewrite bind_ret_l; reflexivity. - apply Nat.eqb_neq in Cmp. - pose proof (sinterp_cas_failure a expected desired current h c + pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired current h c (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -763,7 +633,7 @@ Lemma interp_rr_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c). Proof. intros Pos Base Free First. - pose proof (sinterp_alloc_first h size base c + pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h size base c (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_alloc. @@ -781,10 +651,11 @@ Lemma interp_rr_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) h a = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_srd_stuck a h c Missing) as Hstate. + pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) + a h c Missing) as Hstate. rewrite interp_rr_read. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -800,10 +671,11 @@ Lemma interp_rr_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) h a = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_swr_stuck a v h c Missing) as Hstate. + pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) + a v h c Missing) as Hstate. rewrite interp_rr_write. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -819,10 +691,10 @@ Lemma interp_rr_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) h a = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_cas_missing a expected desired h c + pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. rewrite bind_ret_r in Hstate. rewrite interp_rr_cas. @@ -839,9 +711,9 @@ Lemma interp_rr_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option nat -> thread sE) m h c : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. - pose proof (sinterp_salloc_zero h c) as Hstate. + pose proof ((interp_heap_alloc_zero (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h c) as Hstate. rewrite interp_rr_alloc. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -858,19 +730,21 @@ Lemma interp_rr_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) (forall base, Nat.lt 0 base -> ~ block_free h base size) -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intros Pos Full. assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ - (stuck : ictreeW SObs (nat * SSig))). + (stuck : ictreeW (indexed (nat * nat)) (nat * SSig))). { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. rewrite interp_state_vis. - change ((alloc_search (W:=SObs) h size 1 c >>= + change ((alloc_search (F:=writerE (indexed (nat * nat))) (Sigma:=nat) + h size 1 c >>= fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). etransitivity. - apply equ_clo_bind with (S:=eq) (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). - + apply (alloc_search_no_space (W:=SObs) h size 1 c Pos). + + apply (alloc_search_no_space (F:=writerE (indexed (nat * nat))) + (Sigma:=nat) h size 1 c Pos). intros base Positive; apply Full; lia. + intros result result' <-; reflexivity. - @@ -887,17 +761,17 @@ Qed. Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c) ~ - (log (SPop tag value c);; - interp_nd (S n) + (log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)). Proof. - pose proof (sinterp_emit tag value h c + pose proof (interp_indexed_emit heap_handler (tag,value) h c (fun x : unit => (Ret x : ictree sE unit))) as Hemit. rewrite bind_ret_r in Hemit. assert (Hstate : interp_state sh (semit tag value) (h,c) ~ - (log (SPop tag value c);; Ret (tt,(h,S c)))). + (log (stamp (tag,value) c);; Ret (tt,(h,S c)))). { etransitivity; [exact Hemit |]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. eapply equ_clos_sbisim_goal; @@ -917,19 +791,19 @@ Qed. Lemma interp_nd_source_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c : h a = Some current -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ (if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)). Proof. intro Lookup; rewrite interp_nd_source_cas. destruct (Nat.eqb current expected) eqn:Cmp. - apply Nat.eqb_eq in Cmp; subst current. - pose proof (sinterp_cas_success a expected desired h c + pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -940,7 +814,7 @@ Proof. end. rewrite bind_ret_l; reflexivity. - apply Nat.eqb_neq in Cmp. - pose proof (sinterp_cas_failure a expected desired current h c + pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired current h c (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -956,13 +830,13 @@ Lemma interp_nd_source_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c). Proof. intros Pos Base Free First. - pose proof (sinterp_alloc_first h size base c + pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h size base c (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_alloc. @@ -978,12 +852,12 @@ Qed. Lemma interp_nd_source_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : option nat -> thread sE) h c : h a = None -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_srd_stuck a h c Missing) as Hstate. + pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c Missing) as Hstate. rewrite interp_nd_source_read. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -997,12 +871,12 @@ Qed. Lemma interp_nd_source_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c : h a = None -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_swr_stuck a v h c Missing) as Hstate. + pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a v h c Missing) as Hstate. rewrite interp_nd_source_write. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -1016,12 +890,12 @@ Qed. Lemma interp_nd_source_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired (K : option bool -> thread sE) h c : h a = None -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof (sinterp_cas_missing a expected desired h c + pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. rewrite bind_ret_r in Hstate. rewrite interp_nd_source_cas. @@ -1036,11 +910,11 @@ Qed. Lemma interp_nd_source_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option nat -> thread sE) h c : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. - pose proof (sinterp_salloc_zero h c) as Hstate. + pose proof ((interp_heap_alloc_zero (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h c) as Hstate. rewrite interp_nd_source_alloc. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -1055,21 +929,23 @@ Lemma interp_nd_source_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c : Nat.lt 0 size -> (forall base, Nat.lt 0 base -> ~ block_free h base size) -> - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW SObs (unit * SSig)). + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intros Pos Full. assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ - (stuck : ictreeW SObs (nat * SSig))). + (stuck : ictreeW (indexed (nat * nat)) (nat * SSig))). { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. rewrite interp_state_vis. - change ((alloc_search (W:=SObs) h size 1 c >>= + change ((alloc_search (F:=writerE (indexed (nat * nat))) (Sigma:=nat) + h size 1 c >>= fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). etransitivity. - apply equ_clo_bind with (S:=eq) (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). - + apply (alloc_search_no_space (W:=SObs) h size 1 c Pos). + + apply (alloc_search_no_space (F:=writerE (indexed (nat * nat))) + (Sigma:=nat) h size 1 c Pos). intros base Positive; apply Full; lia. + intros result result' <-; reflexivity. - @@ -1100,7 +976,7 @@ Lemma interp_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c) ~ interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c). + (ts @ i := K tt) (Some i) m (hfree a h,c). Proof. pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) @@ -1114,7 +990,7 @@ Proof. etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (sh_free a h c) | reflexivity | reflexivity] + [exact (heap_handler_free a h c) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. @@ -1122,39 +998,29 @@ Qed. Lemma interp_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c : - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c) ~ - interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c). + interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c). Proof. - pose proof (interp_nd_equ (S n) + pose proof ((interp_schedule_nd_equ sh) (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (ts @ i := Vis (inr (inr (inl (HFree a)))) K) (Some i) (h,c) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head a K))) as Hpool. rewrite Hpool. - erewrite interp_nd_user with (e:=inl (HFree a)) (k:=K) + erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree a)) (k:=K) by (rewrite Vector.nth_replace_eq; reflexivity). lazymatch goal with |- (?t >>= ?next) ~ _ => etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (sh_free a h c) | reflexivity | reflexivity] + [exact (heap_handler_free a h c) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. Qed. - -(** Only finite leading guards and raw tree equivalence are forgotten. - A real [Br] node is never included in this closure. *) -Inductive guard_equ : thread sE -> thread sE -> Prop := -| guard_equ_equ t u : t ≅ u -> guard_equ t u -| guard_equ_left t u : guard_equ t u -> guard_equ (Guard t) u -| guard_equ_right t u : guard_equ t u -> guard_equ t (Guard u) -| guard_equ_sym t u : guard_equ t u -> guard_equ u t -| guard_equ_trans t u v : guard_equ t u -> guard_equ u v -> guard_equ t v. - (** ** Pool-shape tactics for concrete round-robin computations. *) Ltac source_observe := diff --git a/theories/Lang/CSL/Pcm.v b/theories/Lang/CSL/Pcm.v deleted file mode 100644 index 0b6164d..0000000 --- a/theories/Lang/CSL/Pcm.v +++ /dev/null @@ -1,570 +0,0 @@ -(** * A partial commutative monoid with explicit definedness, and a concrete - disjoint-heap model. - - Design notes, all of them forced by the evidence collected earlier in this - project: - - - The composition is *partial*. We present it, as separation algebras - usually are, by a total operation [pop] together with a definedness - predicate [pdef]. This keeps every law a first-order statement and - avoids reasoning about [option] equalities inside a setoid. - - - The carrier comes with its own equivalence [peq]. This is deliberate: - the intended heap model is a *map*, and list concatenation is not - commutative under list equality. We therefore fix a justified map - representation (total functions [nat -> option nat]) and a justified map - equivalence (pointwise equality), and prove commutativity for that - equivalence rather than assuming it for a representation that does not - have it. - - - Cancellativity is NOT a field of the class. It is defined separately, - below, so that a theorem can be checked to be independent of it simply by - being provable in a section that only assumes [PCM]. [BoolPCM] below is - a PCM in which cancellativity provably fails; the transport theorems of - [Transport.v] instantiate at it. *) - -From Stdlib Require Import - Basics - Arith.PeanoNat - Lia - List - Relations. - -Generalizable All Variables. - -(** ** The interface *) -Class PCM (A: Type) := { - (** the justified equivalence on the carrier *) - peq : A -> A -> Prop; - (** definedness / compatibility of a composition *) - pdef : A -> A -> Prop; - (** the composition, meaningful exactly when [pdef] holds *) - pop : A -> A -> A; - (** the unit *) - pemp : A; - - peq_refl : forall a, peq a a; - peq_sym : forall a b, peq a b -> peq b a; - peq_trans : forall a b c, peq a b -> peq b c -> peq a c; - - (** both [pdef] and [pop] respect the equivalence *) - pdef_resp : forall a a' b b', peq a a' -> peq b b' -> pdef a b -> pdef a' b'; - pop_resp : forall a a' b b', peq a a' -> peq b b' -> peq (pop a b) (pop a' b'); - - (** commutativity, in both components *) - pdef_comm : forall a b, pdef a b -> pdef b a; - pop_comm : forall a b, pdef a b -> peq (pop a b) (pop b a); - - (** unit laws *) - pdef_emp : forall a, pdef pemp a; - pop_emp : forall a, peq (pop pemp a) a; - - (** associativity, with the definedness bookkeeping made explicit *) - pdef_assocL : forall a b c, pdef b c -> pdef a (pop b c) -> pdef a b; - pdef_assocR : forall a b c, pdef b c -> pdef a (pop b c) -> pdef (pop a b) c; - pdef_assocI : forall a b c, pdef b c -> pdef a b -> pdef (pop a b) c -> pdef a (pop b c); - pop_assoc : forall a b c, - pdef b c -> pdef a (pop b c) -> peq (pop a (pop b c)) (pop (pop a b) c) -}. - -Declare Scope pcm_scope. -Delimit Scope pcm_scope with pcm. -Notation "a ⊎ b" := (pop a b) (at level 50, left associativity): pcm_scope. -Notation "a # b" := (pdef a b) (at level 70, no associativity): pcm_scope. -Notation "a ≈ b" := (peq a b) (at level 70, no associativity): pcm_scope. -Local Open Scope pcm_scope. - -(** Cancellativity is a *separate* property. Everything proved in a section - that assumes only [PCM] is, by construction, independent of it. *) -Definition Cancellative (A: Type) `{PCM A} : Prop := - forall a b c, a # b -> a # c -> a ⊎ b ≈ a ⊎ c -> b ≈ c. - -Section PcmFacts. - Context {A: Type} `{PCM A}. - - Lemma pop_emp_r: forall a, a # pemp -> a ⊎ pemp ≈ a. - Proof. - intros a Hd. - eapply peq_trans; [apply pop_comm; auto | apply pop_emp]. - Qed. - - Lemma pdef_emp_r: forall a, a # pemp. - Proof. intro a; apply pdef_comm, pdef_emp. Qed. - - (** The "other" associativity direction, derived. *) - Lemma pop_assoc': forall a b c, - b # c -> a # (b ⊎ c) -> (a ⊎ b) ⊎ c ≈ a ⊎ (b ⊎ c). - Proof. intros; apply peq_sym, pop_assoc; auto. Qed. -End PcmFacts. - -(** ** Spatial assertions over an arbitrary PCM *) -Definition assn (A: Type) := A -> Prop. - -Section Assertions. - Context {A: Type} `{PCM A}. - - (** An assertion is *well formed* when it does not distinguish equivalent - resources. Every assertion built below is well formed. *) - Definition AProper (P: assn A) : Prop := forall a b, a ≈ b -> P a -> P b. - - Definition aemp : assn A := fun a => a ≈ pemp. - - Definition asep (P Q: assn A) : assn A := - fun a => exists a1 a2, a1 # a2 /\ a ≈ a1 ⊎ a2 /\ P a1 /\ Q a2. - - Definition awand (P Q: assn A) : assn A := - fun a => forall b, a # b -> P b -> Q (a ⊎ b). - - Definition atrue : assn A := fun _ => True. - - Lemma aemp_proper: AProper aemp. - Proof. intros a b Hab Ha; unfold aemp in *; eauto using peq_sym, peq_trans. Qed. - - Lemma asep_proper: forall P Q, AProper (asep P Q). - Proof. - intros P Q a b Hab (a1 & a2 & Hd & Heq & HP & HQ). - exists a1, a2; repeat split; auto. - eauto using peq_sym, peq_trans. - Qed. - - (** [⋆] is commutative. *) - Lemma asep_comm: forall P Q a, asep P Q a -> asep Q P a. - Proof. - intros P Q a (a1 & a2 & Hd & Heq & HP & HQ). - exists a2, a1; repeat split; auto using pdef_comm. - eapply peq_trans; [exact Heq | apply pop_comm; auto]. - Qed. - - (** [emp] is a left unit, in both directions. *) - Lemma asep_emp_l: forall P a, AProper P -> P a -> asep aemp P a. - Proof. - intros P a HP Ha. - exists pemp, a; repeat split; auto using pdef_emp, peq_refl. - - apply peq_sym, pop_emp. - - unfold aemp; apply peq_refl. - Qed. - - Lemma asep_emp_l_inv: forall P a, AProper P -> asep aemp P a -> P a. - Proof. - intros P a HP (a1 & a2 & Hd & Heq & Hemp & HQ). - eapply HP; [| exact HQ]. - apply peq_sym. - eapply peq_trans; [exact Heq |]. - eapply peq_trans; [| apply pop_emp]. - apply pop_resp; auto using peq_refl. - Qed. - - (** [⋆] is associative, one direction shown (the other is symmetric). *) - Lemma asep_assoc: forall P Q R a, - asep P (asep Q R) a -> asep (asep P Q) R a. - Proof. - intros P Q R a (a1 & a23 & Hd1 & Heq1 & HP & (a2 & a3 & Hd2 & Heq2 & HQ & HR)). - assert (Hd1': a1 # (a2 ⊎ a3)) by (eapply pdef_resp; [apply peq_refl | exact Heq2 | exact Hd1]). - exists (a1 ⊎ a2), a3; repeat split. - - eapply pdef_assocR; eauto. - - eapply peq_trans; [exact Heq1 |]. - eapply peq_trans; [| eapply pop_assoc; eauto]. - apply pop_resp; auto using peq_refl. - - exists a1, a2; repeat split; auto using peq_refl. - eapply pdef_assocL; eauto. - - assumption. - Qed. - - (** Monotonicity: the frame rule of the *spatial* layer. *) - Lemma asep_mono: forall (P P' Q Q': assn A) a, - (forall x, P x -> P' x) -> (forall x, Q x -> Q' x) -> - asep P Q a -> asep P' Q' a. - Proof. - intros * HP HQ (a1 & a2 & Hd & Heq & H1 & H2). - exists a1, a2; auto. - Qed. - - (** The adjunction, both directions. [awand] is recorded because the brief - lists it as optional; nothing downstream depends on it. *) - Lemma awand_intro: forall (P Q R: assn A), - (forall a, asep P Q a -> R a) -> - forall a, P a -> awand Q R a. - Proof. - intros P Q R Hpq a Ha b Hd HQ. - apply Hpq; exists a, b; repeat split; auto using peq_refl. - Qed. - - Lemma awand_elim: forall (P Q: assn A) a, - asep (awand P Q) P a -> AProper Q -> Q a. - Proof. - intros P Q a (a1 & a2 & Hd & Heq & Hw & HP) HQ. - eapply HQ; [apply peq_sym; exact Heq |]. - now apply Hw. - Qed. -End Assertions. - -Arguments AProper {A _} P. -Arguments aemp {A _}. -Arguments asep {A _} P Q. -Arguments awand {A _} P Q. -Arguments atrue {A _}. - -Notation "P ⋆ Q" := (asep P Q) (at level 55, right associativity): pcm_scope. -Notation "P -⋆ Q" := (awand P Q) (at level 60, right associativity): pcm_scope. - -(** ** The concrete model: partial maps as total functions. - - Representation: [nat -> option nat]. Equivalence: pointwise equality. - Composition: union, defined exactly on disjoint pairs. This is the - "justified map representation / equivalence" the brief asks for; it is not - an association list under list equality, for which commutativity is false. *) -Definition Heap := nat -> option nat. - -Definition hemp : Heap := fun _ => None. -Definition heq (h1 h2: Heap) : Prop := forall a, h1 a = h2 a. -Definition hdisj (h1 h2: Heap) : Prop := forall a, h1 a = None \/ h2 a = None. -Definition hunion (h1 h2: Heap) : Heap := - fun a => match h1 a with Some v => Some v | None => h2 a end. - -Definition hsingle (a v: nat) : Heap := - fun b => if Nat.eq_dec a b then Some v else None. -Definition hupd (a v: nat) (h: Heap) : Heap := - fun b => if Nat.eq_dec a b then Some v else h b. -Definition hfree (a: nat) (h: Heap) : Heap := - fun b => if Nat.eq_dec a b then None else h b. - -(** The empty heap has no allocated cell. *) - -Lemma hemp_dom: forall x, hemp x <> None -> False. -Proof. intros x H; apply H; reflexivity. Qed. - -(** Pointwise contents of a finite collection of heap cells. *) -Definition cellsat (W: list (nat * nat)) (h: Heap) : Prop := - Forall (fun p => h (fst p) = Some (snd p)) W. - -Lemma cellsat_heq: forall W h1 h2, heq h1 h2 -> cellsat W h1 -> cellsat W h2. -Proof. - intros W k1 k2 Heq H; unfold cellsat in *. - rewrite Forall_forall in *; intros p Hp; rewrite <- Heq; now apply H. -Qed. - -Lemma cellsat_agree: forall W h h', - (forall p, In p W -> h' (fst p) = h (fst p)) -> cellsat W h -> cellsat W h'. -Proof. - intros W h h' Hag H; unfold cellsat in *. - rewrite Forall_forall in *; intros p Hp; rewrite Hag by exact Hp; now apply H. -Qed. - -Ltac hcase a := unfold hunion, hupd, hfree, hsingle, hemp in *; - intros; repeat (destruct (Nat.eq_dec _ _)); subst; auto. - -Lemma hdisj_none: forall h1 h2 a v, hdisj h1 h2 -> h1 a = Some v -> h2 a = None. -Proof. intros h1 h2 a v Hd Hs; destruct (Hd a) as [Hn | Hn]; congruence. Qed. - -(** Elementary lookup consequences of [hunion]/[hdisj]. These read a single - address out of a union; the monoid laws below are stated pointwise on top - of them. *) - -Lemma hunion_some: forall h f x v, h x = Some v -> hunion h f x = Some v. -Proof. intros h f x v H; unfold hunion; now rewrite H. Qed. - -Lemma hunion_eq: forall h f x, h x <> None -> hunion h f x = h x. -Proof. - intros h f x H; destruct (h x) as [v |] eqn:E; [| congruence]. - now apply hunion_some. -Qed. - -Lemma hunion_none: forall h f x, h x = None -> hunion h f x = f x. -Proof. intros h f x H; unfold hunion; now rewrite H. Qed. - -Lemma hunion_dom: forall h f x, h x <> None -> hunion h f x <> None. -Proof. intros h f x H; now rewrite hunion_eq. Qed. - -Lemma hunion_null: forall h f, h 0 = None -> f 0 = None -> hunion h f 0 = None. -Proof. intros h f Hh Hf; unfold hunion; now rewrite Hh. Qed. - -Lemma hdisj_union: forall h1 h2 f, - hdisj h1 h2 -> hdisj h1 f -> hdisj h1 (hunion h2 f). -Proof. - intros h1 h2 f H12 H1f x. - destruct (h1 x) eqn:E1; [| now left]. - right; unfold hunion. - destruct (H12 x) as [C | E2]; [congruence |]; rewrite E2. - destruct (H1f x) as [C | Ef]; [congruence | exact Ef]. -Qed. - -(** Every law is proved as a standalone lemma first, so that the instance is a - list of [exact]s and its field order cannot silently drift. *) -Lemma heq_refl: forall a, heq a a. -Proof. intros a x; reflexivity. Qed. - -Lemma heq_sym: forall a b, heq a b -> heq b a. -Proof. intros a b Hab x; now rewrite Hab. Qed. - -Lemma heq_trans: forall a b c, heq a b -> heq b c -> heq a c. -Proof. intros a b c Hab Hbc x; now rewrite Hab, Hbc. Qed. - -Lemma hdisj_resp: forall a a' b b', heq a a' -> heq b b' -> hdisj a b -> hdisj a' b'. -Proof. intros a a' b b' Ha Hb Hd x; rewrite <- Ha, <- Hb; apply Hd. Qed. - -Lemma hunion_resp: forall a a' b b', heq a a' -> heq b b' -> heq (hunion a b) (hunion a' b'). -Proof. intros a a' b b' Ha Hb x; unfold hunion; rewrite Ha, Hb; reflexivity. Qed. - -Lemma hdisj_sym: forall a b, hdisj a b -> hdisj b a. -Proof. intros a b Hd x; destruct (Hd x); auto. Qed. - -Lemma hunion_comm: forall a b, hdisj a b -> heq (hunion a b) (hunion b a). -Proof. - intros a b Hd x; unfold hunion; destruct (Hd x) as [Hx | Hx]; rewrite Hx. - - destruct (b x); reflexivity. - - destruct (a x); reflexivity. -Qed. - -Lemma hdisj_hemp: forall a, hdisj hemp a. -Proof. intros a x; left; reflexivity. Qed. - -Lemma hunion_hemp: forall a, heq (hunion hemp a) a. -Proof. intros a x; reflexivity. Qed. - -Lemma hdisj_assocL: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj a b. -Proof. - intros a b c Hbc Ha x; specialize (Ha x); unfold hunion in Ha. - destruct (b x) eqn:Hb; auto. -Qed. - -Lemma hdisj_assocR: forall a b c, hdisj b c -> hdisj a (hunion b c) -> hdisj (hunion a b) c. -Proof. - intros a b c Hbc Ha x; specialize (Ha x); specialize (Hbc x); unfold hunion in *. - destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; - intuition (try discriminate); auto. -Qed. - -Lemma hdisj_assocI: forall a b c, - hdisj b c -> hdisj a b -> hdisj (hunion a b) c -> hdisj a (hunion b c). -Proof. - intros a b c Hbc Hab Habc x. - specialize (Hbc x); specialize (Hab x); specialize (Habc x); unfold hunion in *. - destruct (a x) eqn:Ha'; destruct (b x) eqn:Hb'; destruct (c x) eqn:Hc'; - intuition (try discriminate); auto. -Qed. - -Lemma hunion_assoc: forall a b c, - hdisj b c -> hdisj a (hunion b c) -> heq (hunion a (hunion b c)) (hunion (hunion a b) c). -Proof. intros a b c _ _ x; unfold hunion; destruct (a x); reflexivity. Qed. - -#[global] Instance HeapPCM : PCM Heap. -Proof. - refine {| peq := heq; pdef := hdisj; pop := hunion; pemp := hemp |}. - - exact heq_refl. - - exact heq_sym. - - exact heq_trans. - - exact hdisj_resp. - - exact hunion_resp. - - exact hdisj_sym. - - exact hunion_comm. - - exact hdisj_hemp. - - exact hunion_hemp. - - exact hdisj_assocL. - - exact hdisj_assocR. - - exact hdisj_assocI. - - exact hunion_assoc. -Defined. - -(** Heaps are cancellative -- recorded to show the class is not weakened by - leaving cancellativity out; nothing in [Transport.v] uses this. *) -Lemma HeapCancellative: Cancellative Heap. -Proof. - intros a b c Hab Hac Heq x; cbn in *. - unfold heq, hunion, hdisj in *. - specialize (Heq x); specialize (Hab x); specialize (Hac x). - destruct (a x) eqn:Ha; auto. - destruct Hab as [? | Hb]; [congruence |]. - destruct Hac as [? | Hc]; [congruence |]. - congruence. -Qed. - -(** ** A PCM in which cancellativity fails. - - Carrier [bool], composition [orb], always defined, unit [false]. Every PCM - law holds; cancellativity does not. [Transport.v] instantiates its six - transport theorems at this PCM, which is the evidence that generic - transport does not need cancellativity. *) -#[global] Instance BoolPCM : PCM bool. -Proof. - refine {| peq := @eq bool; pdef := fun _ _ => True; pop := orb; pemp := false |}. - - reflexivity. - - intros a b; auto. - - intros a b c; apply eq_trans. - - intros a a' b b' Ha Hb _; exact I. - - intros a a' b b' Ha Hb; now subst. - - intros a b _; exact I. - - intros a b _; apply Bool.orb_comm. - - intros a; exact I. - - intros a; reflexivity. - - intros a b c _ _; exact I. - - intros a b c _ _; exact I. - - intros a b c _ _ _; exact I. - - intros a b c _ _; now rewrite Bool.orb_assoc. -Defined. - -Theorem bool_pcm_not_cancellative: ~ Cancellative bool. -Proof. - intro Hc. - assert (Hd: (true # true)%pcm) by exact I. - assert (Hd': (true # false)%pcm) by exact I. - assert (Heq: (true ⊎ true ≈ true ⊎ false)%pcm) by reflexivity. - specialize (Hc true true false Hd Hd' Heq). - cbn in Hc; discriminate. -Qed. - -(** ** Points-to, and the separation it buys. - - [pto a v] is an assertion about the *owned* resource. Note the evidence - from the companion experiment: [CNow] is tree-blind, so this can never be a - TICL base predicate on its own. It is a predicate on the resource, lifted - into the temporal layer only through the owned projection in - [Transport.v]. *) -Definition pto (a v: nat) : assn Heap := fun h => heq h (hsingle a v). - -Lemma pto_proper: forall a v, AProper (pto a v). -Proof. intros a v h1 h2 Heq Hp x; rewrite <- Heq; apply Hp. Qed. - -Lemma pto_lookup: forall a v h, pto a v h -> h a = Some v. -Proof. intros a v h Hp; rewrite Hp; hcase a; congruence. Qed. - -(** Two points-to on the same address cannot be separated: the hallmark - consequence of a disjointness-based PCM. *) -Theorem pto_sep_same_false: forall a v v' h, ~ (pto a v ⋆ pto a v')%pcm h. -Proof. - intros a v v' h (h1 & h2 & Hd & Heq & H1 & H2). - apply pto_lookup in H1; apply pto_lookup in H2. - destruct (Hd a); congruence. -Qed. - -(** Distinct addresses do separate. *) -Theorem pto_sep_distinct: forall a b v v', - a <> b -> (pto a v ⋆ pto b v')%pcm (hunion (hsingle a v) (hsingle b v')). -Proof. - intros a b v v' Hab. - exists (hsingle a v), (hsingle b v'). - split; [| split; [| split]]. - - intro x; unfold hsingle; destruct (Nat.eq_dec a x); destruct (Nat.eq_dec b x); - subst; auto. - exfalso; auto. - - intro x; reflexivity. - - intro x; reflexivity. - - intro x; reflexivity. -Qed. - -(** ** Safe-access locality on the concrete heap. - - Each of the three laws is stated with the footprint hypothesis it needs, - and [HeapLocal.v] refutes each of them once that hypothesis is dropped. *) - -(** A read inside the owned footprint returns the owned value, under every - compatible frame. *) -Theorem read_local: forall h f a v, - hdisj h f -> h a = Some v -> hunion h f a = Some v. -Proof. intros h f a v Hd Ha; unfold hunion; now rewrite Ha. Qed. - -(** A write inside the owned footprint keeps the frame disjoint ... *) -Theorem write_local_disj: forall h f a v v0, - hdisj h f -> h a = Some v0 -> hdisj (hupd a v h) f. -Proof. - intros h f a v v0 Hd Ha x; unfold hupd; destruct (Nat.eq_dec a x). - - subst; right; eapply hdisj_none; eauto. - - apply Hd. -Qed. - -(** ... and commutes with framing. *) -Theorem write_local_frame: forall h f a v, - heq (hupd a v (hunion h f)) (hunion (hupd a v h) f). -Proof. intros h f a v x; unfold hupd, hunion; destruct (Nat.eq_dec a x); auto. Qed. - -(** A free inside the owned footprint keeps the frame disjoint ... *) -Theorem free_local_disj: forall h f a, - hdisj h f -> hdisj (hfree a h) f. -Proof. intros h f a Hd x; unfold hfree; destruct (Nat.eq_dec a x); auto. Qed. - -(** ... and commutes with framing, provided the address is owned. *) -Theorem free_local_frame: forall h f a v0, - hdisj h f -> h a = Some v0 -> - heq (hfree a (hunion h f)) (hunion (hfree a h) f). -Proof. - intros h f a v0 Hd Ha x; unfold hfree, hunion; destruct (Nat.eq_dec a x); auto. - subst; erewrite hdisj_none; eauto. -Qed. - -(** ** Finite blocks over the unrestricted function heap. - Bounds are proof witnesses only; allocation searches in its handler. - Fresh ownership preserves the old resource, not literal frame-stable bases. *) - -Definition heap_bounded (bound : nat) (h : Heap) : Prop := - forall x, Nat.le bound x -> h x = None. -Definition heap_finite (h : Heap) : Prop := - exists bound, heap_bounded bound h. -Definition hblock (base size : nat) : Heap := - fun x => if andb (Nat.leb base x) (Nat.ltb x (base + size)) - then Some 0 else None. -Definition block_free (h : Heap) (base size : nat) : Prop := - forall offset, Nat.lt offset size -> h (base + offset) = None. -Definition block_pto (base size : nat) : Heap -> Prop := - fun h => heq h (hblock base size). - -Lemma hblock_in base size offset : - Nat.lt offset size -> hblock base size (base + offset) = Some 0. -Proof. - intro H; unfold hblock. - assert (L : Nat.leb base (base + offset) = true) - by (apply Nat.leb_le; lia). - assert (R : Nat.ltb (base + offset) (base + size) = true) - by (apply Nat.ltb_lt; lia). - now rewrite L, R. -Qed. - -Lemma hblock_out base size x : - (Nat.lt x base \/ Nat.le (base + size) x) -> - hblock base size x = None. -Proof. - intro H; unfold hblock. - destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); - cbn; try reflexivity; lia. -Qed. - -Lemma block_free_disjoint h base size : - block_free h base size <-> hdisj (hblock base size) h. -Proof. - split. - - intros H x. - destruct (Nat.le_gt_cases base x) as [L | L]; - [destruct (Nat.lt_ge_cases x (base + size)) as [R | R] |]. - + right; replace x with (base + (x - base)) by lia; apply H; lia. - + left; apply hblock_out; auto. - + left; apply hblock_out; auto. - - intros H offset O; specialize (H (base + offset)). - rewrite (hblock_in base size offset O) in H; destruct H; congruence. -Qed. - -Lemma heap_finite_hemp : heap_finite hemp. -Proof. exists 0; intros x H; reflexivity. Qed. - -Lemma heap_finite_hblock base size : heap_finite (hblock base size). -Proof. - exists (base + size); intros x H; apply hblock_out; auto. -Qed. - -Lemma heap_finite_hunion h f : - heap_finite h -> heap_finite f -> heap_finite (hunion h f). -Proof. - intros [B HB] [C HC]; exists (Nat.max B C); intros x H. - unfold hunion; rewrite HB, HC; try reflexivity; lia. -Qed. - -Lemma heap_bounded_block_free bound h base size : - heap_bounded bound h -> Nat.le bound base -> block_free h base size. -Proof. intros H B offset O; apply H; lia. Qed. - -Lemma allocated_block_sep base size h (P : Heap -> Prop) : - block_free h base size -> P h -> - asep (block_pto base size) P (hunion (hblock base size) h). -Proof. - intros F H; exists (hblock base size), h. - split; [apply block_free_disjoint; exact F |]. - split; [apply heq_refl |]. - split; [apply heq_refl | exact H]. -Qed. diff --git a/theories/Lang/CSL/Queue/Alternating.v b/theories/Lang/CSL/Queue/Alternating.v index e8d86ae..3dc59e3 100644 --- a/theories/Lang/CSL/Queue/Alternating.v +++ b/theories/Lang/CSL/Queue/Alternating.v @@ -52,12 +52,14 @@ Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). Theorem turnk_spec {X}: forall q hdr a ns pv vs h c (kt: ictree sE X), qrep hdr (a :: ns) (pv :: vs) h -> interp_state sh (turnk q hdr kt) (h, c) - ~ (log (SPop q pv c) ;; - interp_state sh kt (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c)). + ~ (log (stamp (q,pv) c) ;; + interp_state sh kt (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c)). Proof. intros q hdr a ns pv vs h c kt Hq; unfold turnk. - eapply (queue_turn_spec sh_tagged (semit q) (fun value index => SPop q value index)). - - intros; apply sinterp_emit. + eapply (queue_turn_spec h_indexed (semit q) (fun value index => stamp (q,value) index)). + - intros; unfold semit; apply (interp_indexed_emit heap_handler). + +From Coinduction Require Import coinduction. - exact Hq. Qed. @@ -76,7 +78,7 @@ Definition sbody (u v: nat) (n: nat) : ictree sE (nat + unit) := Definition sched (u v n: nat) : ictree sE unit := ICtree.iter (sbody u v) n. -Definition srun (u v n: nat) (h: Heap) (c: nat) : ictreeW SObs (unit * SSig) := +Definition srun (u v n: nat) (h: Heap) (c: nat) : ictreeW (indexed (nat * nat)) (unit * SSig) := interp_state sh (sched u v n) (h, c). (** One scheduler turn, for EITHER phase, in one statement. [hdrof]/[tagof] @@ -85,9 +87,9 @@ Definition srun (u v n: nat) (h: Heap) (c: nat) : ictreeW SObs (unit * SSig) := Theorem sbody_spec: forall u v n a ns pv vs h c, qrep (hdrof u v n) (a :: ns) (pv :: vs) h -> interp_state sh (sbody u v n) (h, c) - ~ (log (SPop (tagof n) pv c) ;; + ~ (log (stamp ((tagof n),pv) c) ;; Ret (@inl nat unit (S n), - (rot_heap (hdrof u v n) a (hdf ns 0) (zof (hdrof u v n) ns) h, S c))). + (rot_heap (hdrof u v n) a (List.hd 0 ns) (zof (hdrof u v n) ns) h, S c))). Proof. intros u v n a ns pv vs h c Hq. unfold sbody, hdrof, tagof in *. @@ -122,24 +124,16 @@ Proof. intros n H; unfold tagof; now rewrite H. Qed. Lemma tagof_odd: forall n, Nat.even n = false -> tagof n = 2. Proof. intros n H; unfold tagof; now rewrite H. Qed. -(** ** Observation predicates *) - -Definition spopped (q nl: nat) : SObs -> Prop := - fun o => stag o = q /\ sval o = nl. +(** ** Observation predicates -Definition spopped_after (q nl kb: nat) : SObs -> Prop := - fun o => stag o = q /\ sval o = nl /\ Nat.le kb (sidx o). + Tagged observations are [indexed (nat * nat)]: the payload pairs the + queue tag with the (fun o => indexed_value o = value), and the occurrence index is the record's + own field. A plain predicate is therefore + [fun o => indexed_value o = (q,nl)] and its freshness companion is + [indexed_after (fun x => x = (q,nl)) kb]. -(** A retained observation cannot masquerade as a later one: the frozen - freshness argument, restated at the tagged alphabet. *) -Lemma sfresh_excludes_retained {X}: forall (t: ictreeW SObs X) q nl p pv j, - ~ <( t, {Obs (Log (SPop p pv j)) tt} |= visW {spopped_after q nl (S j)} )>. -Proof. - intros t q nl p pv j H. - apply ticll_vis in H. - inversion H as [e0 v0 Hphi Heq]; subst. - destruct v0; destruct Hphi as (_ & _ & Hle); cbn in Hle; lia. -Qed. + A retained observation cannot masquerade as a later one; that is + [ICTree.Logic.Trace.indexed_excludes_retained]. *) Lemma turnk_bind {X} q hdr (kt : ictree sE X) : diff --git a/theories/Lang/CSL/Queue/Composition.v b/theories/Lang/CSL/Queue/Composition.v index 66e44fb..6976317 100644 --- a/theories/Lang/CSL/Queue/Composition.v +++ b/theories/Lang/CSL/Queue/Composition.v @@ -56,6 +56,8 @@ From TICL Require Import Lang.CSL.Queue.Frame Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating Utils.Relations. +From Coinduction Require Import coinduction. + Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. @@ -68,7 +70,7 @@ Local Typeclasses Transparent sbisim. focused queue's node list non-empty across a FOREIGN turn without destructing it. *) Lemma qrep_find_nonnil: forall hdr ns vs h nl d, - qrep hdr ns vs h -> find nl vs = Some d -> ns <> []. + qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> ns <> []. Proof. intros hdr ns vs h nl d Hq Hf C; subst ns. apply qrep_len in Hq; cbn in Hq. @@ -104,8 +106,8 @@ Section Composition. qrep gh nsg vsg h -> Disj fh (a :: nsf) gh nsg -> qrep fh (nsf ++ [a]) (vsf ++ [pv]) - (rot_heap fh a (hdf nsf 0) (zof fh nsf) h) - /\ qrep gh nsg vsg (rot_heap fh a (hdf nsf 0) (zof fh nsf) h) + (rot_heap fh a (List.hd 0 nsf) (zof fh nsf) h) + /\ qrep gh nsg vsg (rot_heap fh a (List.hd 0 nsf) (zof fh nsf) h) /\ Disj fh (nsf ++ [a]) gh nsg. Proof. intros nsf vsf nsg vsg a pv h Hqf Hqg Hdj. @@ -123,9 +125,9 @@ Section Composition. qrep fh nsf vsf h -> nsf <> [] -> qrep gh (b :: nsg) (pw :: vsg) h -> Disj fh nsf gh (b :: nsg) -> - qrep fh nsf vsf (rot_heap gh b (hdf nsg 0) (zof gh nsg) h) + qrep fh nsf vsf (rot_heap gh b (List.hd 0 nsg) (zof gh nsg) h) /\ qrep gh (nsg ++ [b]) (vsg ++ [pw]) - (rot_heap gh b (hdf nsg 0) (zof gh nsg) h) + (rot_heap gh b (List.hd 0 nsg) (zof gh nsg) h) /\ Disj fh nsf gh (nsg ++ [b]). Proof. intros nsf vsf nsg vsg b pw h Hqf Hnef Hqg Hdj. @@ -145,7 +147,7 @@ Section Composition. Definition Iq (nlf nlg: nat) (h: Heap) : Prop := exists nsf vsf nsg vsg df dg, qrep fh nsf vsf h /\ qrep gh nsg vsg h /\ Disj fh nsf gh nsg - /\ find nlf vsf = Some df /\ find nlg vsg = Some dg. + /\ find_index Nat.eqb nlf vsf = Some df /\ find_index Nat.eqb nlg vsg = Some dg. (** The ghost invariant of the inner eventuality. The rank is (occurrence bound left, position in the focused queue, scheduler phase). @@ -154,14 +156,14 @@ Section Composition. : Prop := exists nsf vsf nsg vsg df dg, qrep fh nsf vsf (fst s) /\ qrep gh nsg vsg (fst s) /\ Disj fh nsf gh nsg - /\ find nlf vsf = Some df /\ find nlg vsg = Some dg + /\ find_index Nat.eqb nlf vsf = Some df /\ find_index Nat.eqb nlg vsg = Some dg /\ m = (kb - snd s, (df, if fturn n then 0 else 1)). (** ** The inner eventuality: the focused queue pops its element again *) Section Inner. - Context (nlf nlg kb: nat) (P: SObs -> Prop) - (HP: forall j, Nat.le kb j -> P (SPop fq nlf j)). + Context (nlf nlg kb: nat) (P: (indexed (nat * nat)) -> Prop) + (HP: forall j, Nat.le kb j -> P (stamp (fq,nlf) j)). Lemma inner_af: forall n h c w, not_done w -> @@ -190,7 +192,7 @@ Section Composition. destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) as (Hqf' & Hqg' & Hdj'). assert (Hstep: forall df', - find nlf (vsf' ++ [pv]) = Some df' -> + find_index Nat.eqb nlf (vsf' ++ [pv]) = Some df' -> rank3 (kb - S c, (df', 1)) m -> (exists g' i' s' w', not_done w' @@ -200,8 +202,8 @@ Section Composition. /\ rank3 g' m)). { intros df' Hdf' Hlex. exists (kb - S c, (df', 1)), (S n), - (rot_heap fh a (hdf nsf' 0) (zof fh nsf') h, S c), - (Obs (Log (SPop fq pv c)) tt). + (rot_heap fh a (List.hd 0 nsf') (zof fh nsf') h, S c), + (Obs (Log (stamp (fq,pv) c)) tt). split; [constructor |]. split. { rewrite Hspec; apply aur_log; @@ -214,7 +216,7 @@ Section Composition. rewrite (fturn_t n Eph); reflexivity. } destruct df as [| d0]. * (* the element is at the head of the focused queue *) - pose proof (find_head _ _ _ Hff) as Hv; subst pv. + pose proof (find_index_head Nat.eqb Nat.eqb_eq _ _ _ Hff) as Hv; subst pv. destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. -- (* and the occurrence bound is met: observe it now *) left. @@ -223,12 +225,12 @@ Section Composition. cleft; apply ticll_vis; constructor; now apply HP. -- (* the bound is not met yet: rotate, the bound gets closer *) right. - destruct (find_last_ex nlf vsf') as (df' & Hdf'). + destruct (find_index_last_ex Nat.eqb Nat.eqb_eq nlf vsf') as (df' & Hdf'). apply (Hstep df'); [exact Hdf' | rewrite Hm; apply rank3_bound; lia]. * (* the element is deeper: rotate, its position falls *) right. apply (Hstep d0). - -- rewrite <- rotl_cons; eapply find_rotl; exact Hff. + -- rewrite <- rotl_cons; eapply find_index_rotl; exact Hff. -- rewrite Hm; destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. ++ replace (kb - S c) with (kb - c) by lia. apply rank3_pos; lia. @@ -243,12 +245,12 @@ Section Composition. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) as (Hqf' & Hqg' & Hdj'). - destruct (find_rotl_pres _ _ _ _ Hfg) as (dg' & Hdg'). + destruct (find_index_rotl_pres Nat.eqb Nat.eqb_eq _ _ _ _ Hfg) as (dg' & Hdg'). rewrite rotl_cons in Hdg'. right. exists (kb - S c, (df, 0)), (S n), - (rot_heap gh b (hdf nsg' 0) (zof gh nsg') h, S c), - (Obs (Log (SPop (tagof n) pw c)) tt). + (rot_heap gh b (List.hd 0 nsg') (zof gh nsg') h, S c), + (Obs (Log (stamp ((tagof n),pw) c)) tt). split; [constructor |]. split. { rewrite Hspec; apply aur_log; @@ -274,7 +276,7 @@ Section Composition. intros n h c w Hd HI. unfold sched. apply (ag_state_iter sh (h, c) - (fun (_: nat) (s: SSig) (_: WorldW SObs) => Iq nlf nlg (fst s)) + (fun (_: nat) (s: SSig) (_: WorldW (indexed (nat * nat))) => Iq nlf nlg (fst s)) n w); [assumption | exact HI |]. clear n h c w Hd HI. intros n s w Hd HI. @@ -292,7 +294,7 @@ Section Composition. specialize (Hspec Hqf). destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) as (Hqf' & Hqg' & Hdj'). - destruct (find_rotl_pres _ _ _ _ Hff) as (df' & Hdf'). + destruct (find_index_rotl_pres Nat.eqb Nat.eqb_eq _ _ _ _ Hff) as (df' & Hdf'). rewrite rotl_cons in Hdf'. rewrite Hspec. apply anr_log; [| apply ticll_top; assumption]. @@ -311,7 +313,7 @@ Section Composition. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) as (Hqf' & Hqg' & Hdj'). - destruct (find_rotl_pres _ _ _ _ Hfg) as (dg' & Hdg'). + destruct (find_index_rotl_pres Nat.eqb Nat.eqb_eq _ _ _ _ Hfg) as (dg' & Hdg'). rewrite rotl_cons in Hdg'. rewrite Hspec. apply anr_log; [| apply ticll_top; assumption]. @@ -331,25 +333,14 @@ End Composition. the quantification over the turn counter [n]: the theorems hold from EITHER starting scheduler phase, and from any point of the schedule. *) -Lemma even_true_hdr: forall u v n, Nat.even n = true -> hdrof u v n = u. -Proof. exact hdrof_even. Qed. - -Lemma neg_even_true: forall n, negb (Nat.even n) = true -> Nat.even n = false. -Proof. intros n H; now apply negb_true_iff in H. Qed. - -Lemma neg_even_false: forall n, negb (Nat.even n) = false -> Nat.even n = true. -Proof. intros n H; now apply negb_false_iff in H. Qed. - -Lemma neg_even_flip: forall n, negb (Nat.even (S n)) = negb (negb (Nat.even n)). -Proof. intro n; now rewrite even_flip. Qed. (** *** Queue 1 (the one the scheduler serves on even turns) *) -Theorem sched_agaf_q1_gen: forall u v nl1 nl2 kb (P: SObs -> Prop), - (forall j, Nat.le kb j -> P (SPop 1 nl1 j)) -> +Theorem sched_agaf_q1_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), + (forall j, Nat.le kb j -> P (stamp (1,nl1) j)) -> forall n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. Proof. intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. @@ -367,41 +358,41 @@ Qed. Theorem sched_agaf_q1: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {spopped 1 nl1}) )>. + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros. - eapply (sched_agaf_q1_gen u v nl1 nl2 0 (spopped 1 nl1)); + eapply (sched_agaf_q1_gen u v nl1 nl2 0 ((fun o => indexed_value o = (1,nl1)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {spopped_after 1 nl1 k}) )>. + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros. - eapply (sched_agaf_q1_gen u v nl1 nl2 k (spopped_after 1 nl1 k)); - [intros j Hj; split; [reflexivity | split; [reflexivity | exact Hj]] + eapply (sched_agaf_q1_gen u v nl1 nl2 k ((indexed_after (fun x => x = (1,nl1)) k))); + [intros j Hj; split; [reflexivity | exact Hj] | eassumption .. ]. Qed. (** *** Queue 2 (the one the scheduler serves on odd turns) *) -Theorem sched_agaf_q2_gen: forall u v nl1 nl2 kb (P: SObs -> Prop), - (forall j, Nat.le kb j -> P (SPop 2 nl2 j)) -> +Theorem sched_agaf_q2_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), + (forall j, Nat.le kb j -> P (stamp (2,nl2) j)) -> forall n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. Proof. intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. unfold srun. apply (sched_agaf u v 2 v u (fun n => negb (Nat.even n)) - (fun n H => hdrof_odd u v n (neg_even_true n H)) - (fun n H => hdrof_even u v n (neg_even_false n H)) - (fun n H => tagof_odd n (neg_even_true n H)) - neg_even_flip nl2 nl1 kb P HP n h c Pure); + (fun n H => hdrof_odd u v n (proj1 (negb_true_iff _) H)) + (fun n H => hdrof_even u v n (proj1 (negb_false_iff _) H)) + (fun n H => tagof_odd n (proj1 (negb_true_iff _) H)) + (fun n => f_equal negb (even_flip n)) nl2 nl1 kb P HP n h c Pure); [constructor |]. exists ns2, vs2, ns1, vs1, d2, d1. split; [exact Hq2 |]; split; [exact Hq1 |]; @@ -410,21 +401,21 @@ Qed. Theorem sched_agaf_q2: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {spopped 2 nl2}) )>. + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. intros. - eapply (sched_agaf_q2_gen u v nl1 nl2 0 (spopped 2 nl2)); + eapply (sched_agaf_q2_gen u v nl1 nl2 0 ((fun o => indexed_value o = (2,nl2)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {spopped_after 2 nl2 k}) )>. + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> + <( {srun u v n h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros. - eapply (sched_agaf_q2_gen u v nl1 nl2 k (spopped_after 2 nl2 k)); - [intros j Hj; split; [reflexivity | split; [reflexivity | exact Hj]] + eapply (sched_agaf_q2_gen u v nl1 nl2 k ((indexed_after (fun x => x = (2,nl2)) k))); + [intros j Hj; split; [reflexivity | exact Hj] | eassumption .. ]. Qed. diff --git a/theories/Lang/CSL/Queue/Frame.v b/theories/Lang/CSL/Queue/Frame.v index da67761..f28d446 100644 --- a/theories/Lang/CSL/Queue/Frame.v +++ b/theories/Lang/CSL/Queue/Frame.v @@ -48,6 +48,8 @@ From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Trace Lang.CSL.Queue.Layout. +From Coinduction Require Import coinduction. + Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. @@ -217,8 +219,8 @@ Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f c, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> - find nlv vs = Some d -> - <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {popped nlv}) )>. + find_index Nat.eqb nlv vs = Some d -> + <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {(fun o => indexed_value o = nlv)}) )>. Proof. intros hdr nlv ns vs d h f c Hx Hd Hf Hfind. eapply rotate_agaf_pop_heap; [eapply qrepX_frame; eassumption | exact Hfind]. @@ -228,8 +230,8 @@ Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f c k, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> - find nlv vs = Some d -> - <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {popped_after nlv k}) )>. + find_index Nat.eqb nlv vs = Some d -> + <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nlv) k)}) )>. Proof. intros hdr nlv ns vs d h f c k Hx Hd Hf Hfind. eapply rotate_agaf_pop_fresh; [eapply qrepX_frame; eassumption | exact Hfind]. diff --git a/theories/Lang/CSL/Queue/Layout.v b/theories/Lang/CSL/Queue/Layout.v index 02dc716..9e78b21 100644 --- a/theories/Lang/CSL/Queue/Layout.v +++ b/theories/Lang/CSL/Queue/Layout.v @@ -1,5 +1,5 @@ From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL.Queue.Representation. +From TICL Require Import Events.HeapModel Lang.CSL.Queue.Representation. Import ListNotations. Local Open Scope list_scope. @@ -11,14 +11,14 @@ Fixpoint nodeval (ns vs: list nat) (x: nat) : option nat := match ns, vs with | a :: ns', v :: vs' => if Nat.eqb x a then Some v - else if Nat.eqb x (S a) then Some (hdf ns' 0) + else if Nat.eqb x (S a) then Some (List.hd 0 ns') else nodeval ns' vs' x | _, _ => None end. Definition qheap (hdr: nat) (ns vs: list nat) : Heap := fun x => if Nat.eqb x hdr then Some (last ns 0) - else if Nat.eqb x (S hdr) then Some (hdf ns 0) + else if Nat.eqb x (S hdr) then Some (List.hd 0 ns) else nodeval ns vs x. Lemma nodeval_dom: forall ns vs x, @@ -55,9 +55,10 @@ Lemma nodeval_chain: forall hdr ns vs, qwf hdr ns -> length ns = length vs -> chain (nodeval ns vs) ns vs 0. Proof. intros hdr; induction ns as [| a ns IH]; intros [| v vs] Hwf Hlen; - cbn in Hlen; try discriminate; [exact I |]. + cbn in Hlen; try discriminate; [apply chain_nil |]. destruct (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). - cbn [chain nodeval]. + apply (proj2 (chain_cons _ _ _ _ _ _)). + cbn [nodeval]. rewrite Nat.eqb_refl. split; [reflexivity |]. destruct (Nat.eqb_spec (S a) a) as [C | _]; [lia |]. @@ -79,7 +80,7 @@ Proof. pose proof (qwf_shdr_cells _ _ Hwf) as Hshnc. assert (Hhdr: qheap hdr ns vs hdr = Some (last ns 0)) by (unfold qheap; now rewrite Nat.eqb_refl). - assert (Hshdr: qheap hdr ns vs (S hdr) = Some (hdf ns 0)). + assert (Hshdr: qheap hdr ns vs (S hdr) = Some (List.hd 0 ns)). { unfold qheap; destruct (Nat.eqb_spec (S hdr) hdr) as [C | _]; [lia |]. now rewrite Nat.eqb_refl. } assert (Hcell: forall x, In x (cells ns) -> qheap hdr ns vs x = nodeval ns vs x). @@ -115,13 +116,10 @@ Proof. apply in_cons, in_cons, (nodeval_dom ns vs x), Hx. Qed. -(** ** Runtime-base contiguous queue layout *) +(** ** Runtime-base contiguous queue layout -Fixpoint node_addrs (first count : nat) : list nat := - match count with - | 0 => [] - | S rest => first :: node_addrs (first + 2) rest - end. + The stride-two node geometry ([node_addrs], [node_cells_range]) is owned + by [Events.HeapModel]. *) Definition queue_nodes (hdr count : nat) : list nat := node_addrs (hdr + 2) count. @@ -138,44 +136,15 @@ Fixpoint fill_nodes_heap (first : nat) (values : list nat) (h : Heap) : Heap := Definition init_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := let ns := queue_nodes hdr (length values) in fill_nodes_heap (hdr + 2) values - (upd (upd h hdr (last ns 0)) (S hdr) (hdf ns 0)). + (upd (upd h hdr (last ns 0)) (S hdr) (List.hd 0 ns)). Definition new_queue_heap (hdr : nat) (values : list nat) (h : Heap) : Heap := init_queue_heap hdr values (hunion (hblock hdr (2 * S (length values))) h). -Lemma node_addrs_in first count x : - In x (node_addrs first count) <-> - exists j, Nat.lt j count /\ x = first + 2*j. -Proof. - revert first x; induction count as [| count IH]; intros first x. - - cbn [node_addrs]; split; [contradiction | intros (j & Hj & _); lia]. - - cbn [node_addrs In]; rewrite IH; split. - + intros [Hx | (j & Hj & Hx)]. - * exists 0; split; lia. - * exists (S j); split; lia. - + intros (j & Hj & Hx); destruct j as [| j]. - * left; lia. - * right; exists j; split; lia. -Qed. - -Lemma node_addrs_length first count : length (node_addrs first count) = count. -Proof. - revert first; induction count as [| count IH]; intro first; - cbn [node_addrs length]; [reflexivity | now rewrite IH]. -Qed. - Lemma queue_nodes_length hdr count : length (queue_nodes hdr count) = count. Proof. apply node_addrs_length. Qed. -Lemma node_addrs_nodup first count : NoDup (node_addrs first count). -Proof. - revert first; induction count as [| count IH]; intro first; cbn [node_addrs]. - - constructor. - - constructor; [| apply IH]. - intro Hin; apply node_addrs_in in Hin as (j & Hj & Hx); lia. -Qed. - Lemma queue_nodes_qwf hdr count : Nat.lt 0 hdr -> qwf hdr (queue_nodes hdr count). Proof. intro Hhdr; unfold qwf, queue_nodes. @@ -191,23 +160,6 @@ Proof. lia. Qed. -Lemma node_cells_range first count x : - In x (cells (node_addrs first count)) <-> - Nat.le first x /\ Nat.lt x (first + 2 * count). -Proof. - revert first x; induction count as [| count IH]; intros first x. - - cbn [node_addrs cells]; split; [contradiction | lia]. - - change ((first = x \/ S first = x \/ - In x (cells (node_addrs (first + 2) count))) <-> - Nat.le first x /\ Nat.lt x (first + 2 * S count)). - rewrite IH; split. - + intros [Hx | [Hx | Hx]]; lia. - + intros [Hlo Hhi]. - destruct (Nat.eq_dec first x) as [Hx | Hx]; [now left |]. - destruct (Nat.eq_dec (S first) x) as [Hsx | Hsx]; [now right; left |]. - right; right; split; lia. -Qed. - Lemma queue_cells_range hdr count x : In x (qcells hdr (queue_nodes hdr count)) <-> Nat.le hdr x /\ Nat.lt x (hdr + 2 * S count). @@ -232,7 +184,7 @@ Proof. split; [exact (queue_nodes_qwf hdr 0 Hhdr) |]. split; [exact Hhead |]. split; [change (qheap hdr [] [] hdr <> None); rewrite Htail; discriminate |]. - split; [exact I | split]. + split; [apply chain_nil | split]. + unfold qheap; destruct (Nat.eqb_spec 0 hdr) as [Hbad | Hne]; [lia |]. reflexivity. + intros x [Hx | [Hx | []]]; subst x; diff --git a/theories/Lang/CSL/Queue/Operations.v b/theories/Lang/CSL/Queue/Operations.v index 539e9bc..38f102e 100644 --- a/theories/Lang/CSL/Queue/Operations.v +++ b/theories/Lang/CSL/Queue/Operations.v @@ -54,28 +54,28 @@ Lemma queue_turn_spec {E W : Type} {HE : Encode E} {X} interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) (h,c) ~ (log (observe_value value c);; interp_state (h_sum heap_handler other) tail - (rot_heap hdr a (hdf ns 0) (zof hdr ns) h,S c)). + (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,S c)). Proof. intros Emit hdr a ns value values h c tail Hq. pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). cbn in Hhd, Htl. - destruct Hch as (Ha & Hsa & Hch). + apply chain_cons in Hch as (Ha & Hsa & Hch). pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. assert (Hhdrdom : h hdr <> None) by (rewrite Htl; discriminate). assert (Hsadom : h (S a) <> None) by (rewrite Hsa; discriminate). assert (Hshdrdom : h (S hdr) <> None) by (rewrite Hhd; discriminate). - assert (Hread_hdr : upd h (S hdr) (hdf ns 0) hdr = Some (last (a :: ns) 0)) + assert (Hread_hdr : upd h (S hdr) (List.hd 0 ns) hdr = Some (last (a :: ns) 0)) by (rewrite upd_neq by congruence; exact Htl). unfold queue_turn. etransitivity; [apply (interp_heap_rd other (S hdr) h c a _ Hhd)|]. etransitivity; [apply (interp_heap_rd other a h c value _ Ha)|]. etransitivity; [apply Emit|]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. - etransitivity; [apply (interp_heap_rd other (S a) h (S c) (hdf ns 0) _ Hsa)|]. + etransitivity; [apply (interp_heap_rd other (S a) h (S c) (List.hd 0 ns) _ Hsa)|]. etransitivity; - [apply (interp_heap_wr_present other (S hdr) h (S c) (hdf ns 0) _ Hshdrdom)|]. - etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (hdf ns 0)) (S c) + [apply (interp_heap_wr_present other (S hdr) h (S c) (List.hd 0 ns) _ Hshdrdom)|]. + etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (List.hd 0 ns)) (S c) (last (a :: ns) 0) _ Hread_hdr)|]. cbn beta iota. rewrite (zof_compute hdr a ns Hwf). diff --git a/theories/Lang/CSL/Queue/Program.v b/theories/Lang/CSL/Queue/Program.v index d4cf410..1dddccd 100644 --- a/theories/Lang/CSL/Queue/Program.v +++ b/theories/Lang/CSL/Queue/Program.v @@ -5,7 +5,7 @@ From TICL Require Import ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.SBisim Utils.Vectors. From TICL Require Import Lang.CSL.Queue.Alternating Lang.CSL.Queue.Representation Lang.CSL.Queue.Separation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame - Lang.CSL.Queue.Operations. + Lang.CSL.Queue.Operations Lang.CSL.Queue.Trace. Import ICtree ICTreeNotations ListNotations VectorNotations. Local Open Scope ictree_scope. @@ -43,7 +43,7 @@ Fixpoint fill_nodes (first : nat) (values : list nat) : CProg unit := Definition init_queue (hdr : nat) (values : list nat) : CProg unit := let ns := queue_nodes hdr (length values) in CBind (CWrite hdr (last ns 0)) (fun _ => - CBind (CWrite (S hdr) (hdf ns 0)) (fun _ => + CBind (CWrite (S hdr) (List.hd 0 ns)) (fun _ => fill_nodes (hdr + 2) values)). Definition new_queue (values : list nat) : CProg nat := @@ -280,14 +280,14 @@ Local Ltac queue_prefix R law := Local Ltac queue_fault Hnone := cbv beta; lazymatch goal with - | |- interp_state sh (ICtree.bind (heap_read (E:=sE) ?a) ?next) (?h,?c) ~ _ => + | |- interp_state ?H (ICtree.bind (heap_read (E:=sE) ?a) ?next) (?h,?c) ~ _ => let Hfault := fresh "Hfault" in - assert (Hfault : interp_state sh (heap_read (E:=sE) a >>= next) (h,c) ≅ stuck) by + assert (Hfault : interp_state H (heap_read (E:=sE) a >>= next) (h,c) ≅ stuck) by (etransitivity; [apply interp_state_bind|]; etransitivity; [ apply equ_clo_bind with (S := eq) - (k2 := fun '(x,s') => interp_state sh (next x) s'); - [exact (sinterp_srd_stuck a h c Hnone) | intros x y <-; reflexivity] + (k2 := fun '(x,s') => interp_state H (next x) s'); + [exact ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c Hnone) | intros x y <-; reflexivity] | apply bind_stuck_equ ]); eapply equ_clos_sbisim_goal; [exact Hfault | reflexivity | reflexivity] end. @@ -303,10 +303,10 @@ Proof. [|apply (coinduction.gfp_bt (sb eq) R); symmetry; apply srun_turn]. unfold turn, turnk, queue_turn. destruct (h (S (hdrof u v n))) as [a|] eqn:Hhead. - - queue_prefix R ltac:(eapply sinterp_rd; exact Hhead). + - queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))); exact Hhead). destruct (h a) as [payload|] eqn:Hpayload. - + queue_prefix R ltac:(eapply sinterp_rd; exact Hpayload). - queue_prefix R ltac:(apply sinterp_emit). + + queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))); exact Hpayload). + queue_prefix R ltac:(unfold semit; apply (interp_indexed_emit heap_handler)). eapply equ_sbt_closed_goal; [apply bind_bind | apply bind_bind |]. unfold log, ICtree.trigger. eapply equ_sbt_closed_goal; [apply bind_vis | apply bind_vis |]. @@ -334,6 +334,101 @@ Proof. apply queue_pool_bisim. Qed. +(** One whole rotation of the reference scheduler, read off [sbody_spec]. *) +Local Ltac srun_pop_turn Hq := + lazymatch type of Hq with + | qrep ?hdr (?a :: ?ns) (?pv :: ?vs) ?h => + lazymatch goal with + | |- srun ?u ?v ?n h ?c ~ ?rhs => + let Hbody := constr:(sbody_spec u v n a ns pv vs h c Hq) in + unfold srun, sched at 1; + rewrite interp_state_unfold_iter; + cbv beta; + match goal with + | |- sbisim _ (ICtree.bind _ ?k) _ => + eapply Transitive_sbisim; + [ eapply sbisim_clo_bind_eq with (k2 := k); + [ exact Hbody | intros ?; reflexivity ] + | ] + end; + rewrite bind_bind; + apply sbisim_clo_bind_eq; [reflexivity | intros []]; + rewrite bind_ret_l, sb_guard; + lazymatch goal with + | |- _ ~ ?tail => + change (srun u v (S n) (qstep hdr (a :: ns) h) (S c) ~ tail) + end + end + end. + +(** The first four pops of two disjoint queues under the shared source + round-robin scheduler: queue 1 rotates [a;b], queue 2 its singleton [d], + alternating, with the observation counter advancing once per pop. *) +Lemma parallel_queues_four_pop_bisim u a b v d h x y z c : + qrep u [a;b] [x;y] h -> qrep v [d] [z] h -> Disj u [a;b] v [d] -> + let h1 := qstep u [a;b] h in + let h2 := qstep v [d] h1 in + let h3 := qstep u [b;a] h2 in + let h4 := qstep v [d] h3 in + run_rr (parallel_queues u v) h c ~ + (log (stamp (1,x) c);; log (stamp (2,z) (S c));; + log (stamp (1,y) (S (S c)));; log (stamp (2,z) (S (S (S c))));; + srun u v 4 h4 (S (S (S (S c))))). +Proof. + intros H1 H2 Hd; cbv zeta. + pose proof (qstep_qrep u [a;b] [x;y] h H1 ltac:(discriminate)) as H1a. + change (qrep u [b;a] [y;x] (qstep u [a;b] h)) in H1a. + pose proof (foreign_pres u [a;b] [x;y] v [d] [z] h + H1 ltac:(discriminate) H2 Hd) as H2a. + pose proof (Disj_rotl_l u [a;b] v [d] ltac:(discriminate) Hd) as Hda. + change (Disj u [b;a] v [d]) in Hda. + pose proof (foreign_pres v [d] [z] u [b;a] [y;x] + (qstep u [a;b] h) H2a ltac:(discriminate) H1a + (Disj_sym u [b;a] v [d] Hda)) as H1b. + pose proof (qstep_qrep v [d] [z] (qstep u [a;b] h) + H2a ltac:(discriminate)) as H2b. + change (qrep v [d] [z] (qstep v [d] (qstep u [a;b] h))) in H2b. + pose proof (foreign_pres u [b;a] [y;x] v [d] [z] + (qstep v [d] (qstep u [a;b] h)) H1b ltac:(discriminate) H2b Hda) as H2c. + etransitivity; [exact (run_rr_parallel_bisim u v h c) |]. + srun_pop_turn H1. + srun_pop_turn H2a. + srun_pop_turn H1b. + srun_pop_turn H2c. + reflexivity. +Qed. + +(** Queue 1 takes the first source turn; a fault there faults the whole run. *) +Local Lemma parallel_queues_first_turn_stuck u v h c : + interp_state sh (turn 1 u) (h,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)) -> + run_rr (parallel_queues u v) h c ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Hfault. + unfold parallel_queues; rewrite run_rr_fork_bind. + change (interp_schedule_rr sh 2 (queue_workers u v false false) + (Some (queue_slot 0)) 0 (h,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig))). + etransitivity; [apply queue_pool_turn |]. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hfault | intro result; reflexivity] |] + end. + eapply equ_clos_sbisim_goal; [apply bind_stuck_equ | reflexivity | reflexivity]. +Qed. + +Lemma parallel_queues_hemp_stuck u v c : + run_rr (parallel_queues u v) hemp c ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + apply parallel_queues_first_turn_stuck. + assert (Hhead : hemp (S u) = None) by reflexivity. + unfold turn, turnk, queue_turn; queue_fault Hhead. +Qed. + (** Silent initialization in the real shared source scheduler. *) @@ -428,7 +523,7 @@ Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) (Some i) m (new_queue_heap hdr values h,c). Proof. intro Finite. - destruct (sh_alloc_finite h (2 * S (length values)) c Finite ltac:(lia)) + destruct (heap_handler_alloc_finite h (2 * S (length values)) c Finite ltac:(lia)) as (hdr & Positive & Free & First & _). exists hdr; split; [exact Positive |]; split; [exact Free |]; split. - now apply new_queue_heap_finite. @@ -492,3 +587,20 @@ Proof. etransitivity; [exact Run2 |]. reflexivity. Qed. + +(** An allocated empty first queue has head pointer [0], and the null cell is + unallocated: the first source turn faults, whatever the second queue is. *) +Lemma allocated_parallel_queues_empty_stuck values c : + run_rr (allocated_parallel_queues [] values) hemp c ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + destruct (run_rr_allocated_parallel [] values c) + as (u & v & h & _ & Owned & Run). + destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) + as ((_ & Hhead & _ & _ & Hnull & _) & _ & _). + change (h (S u) = Some 0) in Hhead. + rewrite Run; apply parallel_queues_first_turn_stuck. + unfold turn, turnk, queue_turn. + etransitivity; [eapply (interp_heap_rd h_indexed); exact Hhead |]. + queue_fault Hnull. +Qed. diff --git a/theories/Lang/CSL/Queue/Recurrence.v b/theories/Lang/CSL/Queue/Recurrence.v index 76d87eb..4d66fc8 100644 --- a/theories/Lang/CSL/Queue/Recurrence.v +++ b/theories/Lang/CSL/Queue/Recurrence.v @@ -2,7 +2,7 @@ The reference theorem is [examples/Queue.v], [rotate_agaf_pop]: - find nl q = Some i -> + find_index rel_dec nl q = Some i -> <( instr_prog rotate q, Pure |= AG AF visW {fun h => h = nl} )> over an ABSTRACT queue held in the interpretation state as a [list T]. @@ -47,6 +47,8 @@ From TICL Require Import From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential Lang.CSL.Queue.Operations Utils.Relations. +From Coinduction Require Import coinduction. + Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. @@ -58,27 +60,18 @@ Local Typeclasses Transparent sbisim. (** ** The observation projection. - [qval] is the documented projection from the queue-tagged observation to - the reference alphabet: the reference logs the popped payload, this - language logs the popped payload PLUS its occurrence index. Erasing - [qidx] recovers the reference formula exactly. *) -Definition popped (nl: nat) : QObs -> Prop := fun o => qval o = nl. -Definition popped_after (nl kb: nat) : QObs -> Prop := - fun o => qval o = nl /\ Nat.le kb (qidx o). - -(** A retained observation cannot masquerade as a later one. This is what - makes the freshness companion say something the plain theorem does not: - the world [Obs (Log (Pop v j)) tt] does NOT satisfy [popped_after nl (S j)], - so an [AF] of that formula cannot be discharged by the world already in - hand. *) -Lemma fresh_excludes_retained {X}: forall (t: ictreeW QObs X) nl v j, - ~ <( t, {Obs (Log (Pop v j)) tt} |= visW {popped_after nl (S j)} )>. -Proof. - intros t nl v j H. - apply ticll_vis in H. - inversion H as [e0 v0 Hphi Heq]; subst. - destruct v0; destruct Hphi as (_ & Hle); cbn in Hle; lia. -Qed. + [indexed_value] is the documented projection from the queue observation + to the reference alphabet: the reference logs the (fun o => indexed_value o = payload), this + language logs the (fun o => indexed_value o = payload) PLUS its occurrence index. Erasing + [indexed_index] recovers the reference formula exactly, and + [indexed_after] adds the occurrence bound. + + A retained observation cannot masquerade as a later one: the world + [Obs (Log (stamp v j)) tt] does NOT satisfy + [indexed_after (fun x => x = nl) (S j)], so an [AF] of that formula + cannot be discharged by the world already in hand. That is + [ICTree.Logic.Trace.indexed_excludes_retained], proved once for every + payload and return type. *) Section Recurrence. @@ -86,14 +79,14 @@ Section Recurrence. bound, and [P] any observation predicate satisfied by every pop of [nl] at or after [kb]. Instantiating [kb := 0] gives the plain recurrence theorem; leaving [kb] free gives the freshness companion. *) - Context (hdr nl kb: nat) (P: QObs -> Prop) - (HP: forall j, Nat.le kb j -> P (Pop nl j)). + Context (hdr nl kb: nat) (P: (indexed nat) -> Prop) + (HP: forall j, Nat.le kb j -> P (stamp nl j)). (** The [AG] invariant: the state is a valid representation of SOME queue that still contains [nl]. The abstract queue is existentially quantified -- no extraction function from heaps to lists is needed. *) - Definition Rq (_: unit) (s: Sig) (_: WorldW QObs) : Prop := - exists ns vs d, qrep hdr ns vs (fst s) /\ find nl vs = Some d. + Definition Rq (_: unit) (s: Sig) (_: WorldW (indexed nat)) : Prop := + exists ns vs d, qrep hdr ns vs (fst s) /\ find_index Nat.eqb nl vs = Some d. (** *** One iteration, as a deterministic suffix formula. @@ -104,8 +97,8 @@ Section Recurrence. not_done w -> <[ {interp_state h_qE (rot_body hdr) (h, c)}, w |= ⊤ AU AX done= {(@inl unit unit tt, - (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))} - {Obs (Log (Pop v c)) tt} ]>. + (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c))} + {Obs (Log (stamp v c)) tt} ]>. Proof. intros ns vs a v h c w Hq Hd. rewrite (rot_body_spec hdr a ns v vs h c Hq). @@ -122,13 +115,13 @@ Section Recurrence. application of [aul_state_iter_ghost] plus a body case analysis. *) Definition InvQ (m: nat * nat) (_: unit) (s: Sig) : Prop := exists ns vs d, qrep hdr ns vs (fst s) - /\ find nl vs = Some d + /\ find_index Nat.eqb nl vs = Some d /\ m = (kb - snd s, d). Lemma inner_af: forall h c ns vs d w, not_done w -> qrep hdr ns vs h -> - find nl vs = Some d -> + find_index Nat.eqb nl vs = Some d -> <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AF visW {P} )>. Proof. intros h c ns vs d w Hd Hq Hf. @@ -142,7 +135,7 @@ Section Recurrence. destruct vs as [| v vs']; [cbn in Hf; discriminate |]. destruct ns as [| a ns']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. (* the shared "rotate once" step *) - assert (Hstep: forall d', find nl (vs' ++ [v]) = Some d' -> + assert (Hstep: forall d', find_index Nat.eqb nl (vs' ++ [v]) = Some d' -> lexnat (kb - S c, d') m -> (exists g' i' s' w', not_done w' @@ -153,8 +146,8 @@ Section Recurrence. /\ lexnat g' m)). { intros d' Hd' Hlex. exists (kb - S c, d'), tt, - (rot_heap hdr a (hdf ns' 0) (zof hdr ns') h, S c), - (Obs (Log (Pop v c)) tt). + (rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, S c), + (Obs (Log (stamp v c)) tt). split; [constructor |]. split; [eapply body_det; eassumption |]. split; [| exact Hlex]. @@ -163,7 +156,7 @@ Section Recurrence. | split; [exact Hd' | reflexivity]]. } destruct d as [| d0]. + (* the element is at the head *) - pose proof (find_head _ _ _ Hf) as Hv; subst v. + pose proof (find_index_head Nat.eqb Nat.eqb_eq _ _ _ Hf) as Hv; subst v. destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. * (* and the occurrence bound is already met: observe it now *) left. @@ -172,12 +165,12 @@ Section Recurrence. cleft; apply ticll_vis; constructor; now apply HP. * (* the bound is not met yet: rotate, the bound gets closer *) right. - destruct (find_last_ex nl vs') as (d' & Hd'). + destruct (find_index_last_ex Nat.eqb Nat.eqb_eq nl vs') as (d' & Hd'). apply (Hstep d'); [exact Hd' | rewrite Hm; left; cbn; lia]. + (* the element is deeper in the queue: rotate, it gets closer *) right. apply (Hstep d0). - * rewrite <- rotl_cons; eapply find_rotl; exact Hf. + * rewrite <- rotl_cons; eapply find_index_rotl; exact Hf. * rewrite Hm; destruct (Nat.le_gt_cases kb c); [right; cbn; split; lia | left; cbn; lia]. Qed. @@ -186,7 +179,7 @@ Section Recurrence. Theorem rotate_agaf_core: forall h c ns vs d w, not_done w -> qrep hdr ns vs h -> - find nl vs = Some d -> + find_index Nat.eqb nl vs = Some d -> <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AG (AF visW {P}) )>. Proof. intros h c ns vs d w Hd Hq Hf. @@ -204,7 +197,7 @@ Section Recurrence. apply anr_log; [| apply ticll_top; assumption]. cleft; apply axr_ret; [constructor |]. exists tt; split; [reflexivity | split; [constructor |]]. - destruct (find_rotl_pres _ _ _ _ Hf1) as (d' & Hd''). + destruct (find_index_rotl_pres Nat.eqb Nat.eqb_eq _ _ _ _ Hf1) as (d' & Hd''). exists (ns1' ++ [a1]), (vs1' ++ [v1]), d'; split. * apply (rot_heap_spec hdr a1 ns1' v1 vs1' h1 Hq1). * rewrite <- rotl_cons; exact Hd''. @@ -215,7 +208,7 @@ End Recurrence. [rotate_agaf_pop_heap] is the heap-backed counterpart of the reference [rotate_agaf_pop]: same modal shape, same natural position argument, same - pure [find] lemmas, but over owned heap nodes. + pure [find_index] lemmas, but over owned heap nodes. [rotate_agaf_pop_fresh] is what the reference formula does NOT give: for every occurrence bound [k], every reachable state still eventually @@ -225,23 +218,23 @@ End Recurrence. Theorem rotate_agaf_pop_heap: forall hdr nl h c ns vs d, qrep hdr ns vs h -> - find nl vs = Some d -> - <( {run hdr h c}, Pure |= AG (AF visW {popped nl}) )>. + find_index Nat.eqb nl vs = Some d -> + <( {run hdr h c}, Pure |= AG (AF visW {(fun o => indexed_value o = nl)}) )>. Proof. intros hdr nl h c ns vs d Hq Hf. unfold run. - eapply (rotate_agaf_core hdr nl 0 (popped nl)); + eapply (rotate_agaf_core hdr nl 0 ((fun o => indexed_value o = nl))); [ intros j _; reflexivity | constructor | exact Hq | exact Hf ]. Qed. Theorem rotate_agaf_pop_fresh: forall hdr nl h c ns vs d k, qrep hdr ns vs h -> - find nl vs = Some d -> - <( {run hdr h c}, Pure |= AG (AF visW {popped_after nl k}) )>. + find_index Nat.eqb nl vs = Some d -> + <( {run hdr h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nl) k)}) )>. Proof. intros hdr nl h c ns vs d k Hq Hf. unfold run. - eapply (rotate_agaf_core hdr nl k (popped_after nl k)); + eapply (rotate_agaf_core hdr nl k ((indexed_after (fun x => x = nl) k))); [ intros j Hj; split; [reflexivity | exact Hj] | constructor | exact Hq | exact Hf ]. Qed. @@ -251,21 +244,12 @@ Qed. about the SAFE handler: an out-of-footprint dereference is stuck, and a stuck state satisfies no [AG] formula. *) -Lemma nostep_bind {X Y}: forall (t: ictreeW QObs Y) (k: Y -> ictreeW QObs X) w, - ~ can_step t w -> ~ can_step (x <- t ;; k x) w. -Proof. - intros t k w Hns Hs. - apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]. - - apply Hns; exists t', w'; exact TR. - - apply Hns; exists ICtree.stuck, w'; exact TR. -Qed. - (** *** Control 1: the EMPTY queue. The head pointer is null, the null address is not allocated, so the first dereference of the body is out of footprint. The run cannot step at all, hence NO [AG] formula holds of it -- in particular not the recurrence - formula. This is what the hypothesis [find nl vs = Some d] (which forces + formula. This is what the hypothesis [find_index Nat.eqb nl vs = Some d] (which forces a non-empty queue) buys. *) Theorem empty_queue_no_ag: forall hdr h c vs w phi, qrep hdr [] vs h -> ~ <( {run hdr h c}, w |= AG phi )>. @@ -274,11 +258,12 @@ Proof. pose proof Hq as (Hwf & Hhd & _ & _ & _); cbn in Hhd. pose proof (qrep_null _ _ _ _ Hq) as H0. assert (Hns: ~ can_step (run hdr h c) w). - { unfold run, rotate; rewrite interp_state_unfold_iter. + { unfold run, rotate, h_qE; rewrite interp_state_unfold_iter. apply nostep_bind. unfold rot_body, queue_turn. - rewrite (interp_heap_rd q_emit_handler (S hdr) h c 0 _ Hhd). - now apply (interp_heap_rd_nostep q_emit_handler). } + rewrite (interp_heap_rd (h_indexed (A:=nat) (Sigma:=Heap)) + (S hdr) h c 0 _ Hhd). + now apply (interp_heap_rd_nostep (h_indexed (A:=nat) (Sigma:=Heap))). } cdestruct H; now apply Hns. Qed. @@ -290,8 +275,8 @@ Qed. statement below is the [AG] invariance; deriving [~ AF] from [AG ~] is the standard duality and is NOT mechanised here. *) -Definition obs_sat (Q: nat -> Prop) : WorldW QObs -> Prop := - fun w => forall o, w = Obs (Log o) tt -> Q (qval o). +Definition obs_sat (Q: nat -> Prop) : WorldW (indexed nat) -> Prop := + fun w => forall o, w = Obs (Log o) tt -> Q (indexed_value o). Theorem rotate_ag_obs: forall hdr h c ns vs w (Q: nat -> Prop), (forall x, In x vs -> Q x) -> @@ -304,7 +289,7 @@ Proof. intros hdr h c ns vs w Q HQ Hd Hq Hne Hw. unfold rotate. apply (ag_state_iter h_qE (h, c) - (fun (_: unit) (s: Sig) (w: WorldW QObs) => + (fun (_: unit) (s: Sig) (w: WorldW (indexed nat)) => (exists ns' vs', qrep hdr ns' vs' (fst s) /\ ns' <> [] /\ (forall x, In x vs' -> Q x)) /\ obs_sat Q w) diff --git a/theories/Lang/CSL/Queue/Representation.v b/theories/Lang/CSL/Queue/Representation.v index 7a07cd4..acc803c 100644 --- a/theories/Lang/CSL/Queue/Representation.v +++ b/theories/Lang/CSL/Queue/Representation.v @@ -8,8 +8,8 @@ null-terminated singly linked list of two-cell nodes at the DISTINCT addresses [ns] carrying the payloads [vs], anchored at a two-cell header [hdr] (tail pointer) / [S hdr] (head pointer); - - the pure list theory the temporal proof consumes: [chain] append/split, - the footprint permutation, and the [find] lemmas restated at [nat]. + - the pure list theory the temporal proof consumes: [chain] append/split + and the footprint permutation, using the generic [Utils.Lists] theory. Design notes, and why they are not free choices: @@ -40,29 +40,17 @@ Import ListNotations. (** ** The resource model *) -From TICL Require Export Lang.CSL.Heap. +From TICL Require Export Lang.CSL.Heap Utils.Lists. -(** ** Cells, footprints and well-formedness *) +(** ** Footprints and well-formedness -(** The two cells of a node named [a]: the payload cell [a] and the link cell - [S a]. *) -Definition cells (l: list nat) : list nat := flat_map (fun a => [a; S a]) l. + The stride-two node geometry ([cells], [in_cells]) is owned by + [TICL.Events.HeapModel]; the queue adds only its header pair. *) (** The footprint of a queue: the header's two cells plus every node's two cells. *) Definition qcells (hdr: nat) (ns: list nat) : list nat := hdr :: S hdr :: cells ns. -Lemma in_cells: forall x l, In x (cells l) <-> exists a, In a l /\ (x = a \/ x = S a). -Proof. - intros x l; unfold cells; rewrite in_flat_map; split. - - intros (a & Ha & Hx); exists a; split; [assumption |]. - cbn in Hx; destruct Hx as [Heq | [Heq | []]]; [left | right]; congruence. - - intros (a & Ha & Hx); exists a; split; [assumption |]. - cbn; destruct Hx as [-> | ->]; auto. -Qed. - -Lemma cells_app: forall l1 l2, cells (l1 ++ l2) = cells l1 ++ cells l2. -Proof. intros; apply flat_map_app. Qed. (** Well-formedness of the node NAMES: distinct, non-null, and non-overlapping (no node's payload cell is another node's link cell). Payloads are @@ -141,36 +129,71 @@ Qed. (** ** The chain of nodes *) -Definition hdf (l: list nat) (f: nat) : nat := match l with nil => f | a :: _ => a end. - -Lemma hdf_app: forall l1 l2 f, hdf (l1 ++ l2) f = hdf l1 (hdf l2 f). -Proof. now intros [| a l1] l2 f. Qed. - (** [chain h ns vs fin]: the addresses [ns] carry the payloads [vs] and are linked in order, the last link holding [fin]. The terminator is a PARAMETER: that is what lets the rotation retarget the last link by - [chain_split] + [chain_app] instead of a bespoke surgery lemma. *) -Fixpoint chain (h: Heap) (ns vs: list nat) (fin: nat) : Prop := - match ns, vs with - | nil, nil => True - | a :: ns', v :: vs' => - h a = Some v /\ h (S a) = Some (hdf ns' fin) /\ chain h ns' vs' fin - | _, _ => False - end. + [chain_split] + [chain_app] instead of a bespoke surgery lemma. + + The link structure is the generic [Utils.Lists.linked] predicate at the + successor cell [S a]; payload agreement is an ordinary [Forall2]. The + allocator's free list, whose links live at [a], reuses the same theory + through a different edge relation. *) +Definition chain (h: Heap) (ns vs: list nat) (fin: nat) : Prop := + linked (fun a next => h (S a) = Some next) ns fin + /\ List.Forall2 (fun a v => h a = Some v) ns vs. + +Lemma chain_nil: forall h fin, chain h [] [] fin. +Proof. intros h fin; split; [exact I | constructor]. Qed. + +Lemma chain_cons: forall h a ns v vs fin, + chain h (a :: ns) (v :: vs) fin <-> + h a = Some v /\ h (S a) = Some (List.hd fin ns) /\ chain h ns vs fin. +Proof. + intros h a ns v vs fin; unfold chain; cbn [linked]. + rewrite Forall2_cons_iff; tauto. +Qed. Lemma chain_len: forall h ns vs f, chain h ns vs f -> length ns = length vs. +Proof. intros h ns vs f (_ & Hf); eapply Forall2_length; exact Hf. Qed. + +Lemma Forall2_cells_mono: forall (h h': Heap) (ns vs: list nat), + Forall2 (fun a v => h a = Some v) ns vs -> + (forall x, In x (cells ns) -> h' x = h x) -> + Forall2 (fun a v => h' a = Some v) ns vs. Proof. - induction ns as [| a ns IH]; intros [| v vs] f Hc; cbn in *; try contradiction; auto. - destruct Hc as (_ & _ & Hc); f_equal; eauto. + intros h h' ns vs Hf; induction Hf as [| a v ns vs Hav Hf IH]; intro Hag; + [constructor |]. + constructor. + - rewrite Hag; [exact Hav |]. + apply in_cells; exists a; split; now left. + - apply IH; intros x Hx; apply Hag. + apply in_cells in Hx as (b & Hb & Hxb). + apply in_cells; exists b; split; [now right | exact Hxb]. +Qed. + +Lemma chain_mono: forall h h' ns vs fin, + chain h ns vs fin -> + (forall x, In x (cells ns) -> h' x = h x) -> + chain h' ns vs fin. +Proof. + intros h h' ns vs fin (Hl & Hf) Hag; split. + - eapply linked_mono; [| exact Hl]. + intros a b Ha Hab; rewrite Hag; [exact Hab |]. + apply in_cells; exists a; split; [exact Ha | now right]. + - eapply Forall2_cells_mono; [exact Hf | exact Hag]. Qed. Lemma chain_dom: forall h ns vs f x, chain h ns vs f -> In x (cells ns) -> h x <> None. Proof. - induction ns as [| a ns IH]; intros [| v vs] f x Hc Hin; cbn in *; - try contradiction; try tauto. - destruct Hc as (Ha & Hsa & Hc). - destruct Hin as [Heq | [Heq | Hin]]; [subst; now rewrite Ha | subst; now rewrite Hsa |]. - eapply IH; eauto. + intros h ns; induction ns as [| a ns IH]; intros vs f x Hc Hin. + - cbn in Hin; contradiction. + - destruct vs as [| v vs]; [destruct Hc as (_ & Hf); inversion Hf |]. + apply chain_cons in Hc as (Ha & Hsa & Hc). + change (In x ([a; S a] ++ cells ns)) in Hin. + rewrite in_app_iff in Hin; destruct Hin as [Hin | Hin]. + + cbn in Hin; destruct Hin as [Hx | [Hx | []]]; subst x; + [now rewrite Ha | now rewrite Hsa]. + + eapply IH; eauto. Qed. Definition agree_out (m: list nat) (h h': Heap) : Prop := @@ -182,37 +205,29 @@ Lemma chain_frame: forall h h' m ns vs f, (forall x, In x m -> ~ In x (cells ns)) -> chain h' ns vs f. Proof. - intros h h' m; induction ns as [| a ns IH]; intros [| v vs] f Hc Hag Hm; - cbn in *; try contradiction; auto. - destruct Hc as (Ha & Hsa & Hc). - split; [| split]. - - rewrite Hag; auto. intro Hin; eapply Hm; eauto; cbn; auto. - - rewrite Hag; auto. intro Hin; eapply Hm; eauto; cbn; auto. - - eapply IH; eauto. intros x Hx Hin; eapply Hm; eauto; cbn; auto. + intros h h' m ns vs f Hc Hag Hm; eapply chain_mono; [exact Hc |]. + intros x Hx; apply Hag; intro Hin; exact (Hm x Hin Hx). Qed. Lemma chain_app: forall h ns1 vs1 ns2 vs2 f, - chain h ns1 vs1 (hdf ns2 f) -> + chain h ns1 vs1 (List.hd f ns2) -> chain h ns2 vs2 f -> chain h (ns1 ++ ns2) (vs1 ++ vs2) f. Proof. - intros h; induction ns1 as [| a ns1 IH]; intros [| v vs1] ns2 vs2 f H1 H2; - cbn in *; try contradiction; auto. - destruct H1 as (Ha & Hsa & Hc). - split; [assumption | split; [rewrite Hsa; now rewrite hdf_app | now apply IH]]. + intros h ns1 vs1 ns2 vs2 f (H1l & H1f) (H2l & H2f); split. + - apply linked_app; assumption. + - apply Forall2_app; assumption. Qed. Lemma chain_split: forall h ns1 vs1 ns2 vs2 f, length ns1 = length vs1 -> chain h (ns1 ++ ns2) (vs1 ++ vs2) f -> - chain h ns1 vs1 (hdf ns2 f) /\ chain h ns2 vs2 f. + chain h ns1 vs1 (List.hd f ns2) /\ chain h ns2 vs2 f. Proof. - intros h; induction ns1 as [| a ns1 IH]; intros [| v vs1] ns2 vs2 f Hl Hc; - cbn in *; try discriminate; auto. - destruct Hc as (Ha & Hsa & Hc). - apply IH in Hc as (H1 & H2); [| lia]. - split; [| assumption]. - split; [assumption | split; [rewrite Hsa; now rewrite hdf_app | assumption]]. + intros h ns1 vs1 ns2 vs2 f Hl (Hlk & Hf). + apply linked_split in Hlk as (H1l & H2l). + destruct (Forall2_app_inv_len _ _ _ _ _ Hl Hf) as (H1f & H2f). + split; split; assumption. Qed. (** ** The representation predicate *) @@ -247,7 +262,7 @@ Definition tailok (hdr: nat) (ns: list nat) (h: Heap) : Prop := [(Hwf & Hhd & Htl & Hch & Hdom)] used by the queue operation proofs. *) Definition qrep (hdr: nat) (ns vs: list nat) (h: Heap) : Prop := qwf hdr ns - /\ h (S hdr) = Some (hdf ns 0) + /\ h (S hdr) = Some (List.hd 0 ns) /\ tailok hdr ns h /\ chain h ns vs 0 /\ (h 0 = None /\ forall x, In x (qcells hdr ns) -> h x <> None). @@ -279,7 +294,7 @@ Definition qex (hdr: nat) (ns: list nat) (h: Heap) : Prop := forall x, h x <> None -> In x (qcells hdr ns). Lemma qrep_head_null_iff: forall hdr ns vs h, - qrep hdr ns vs h -> (hdf ns 0 = 0 <-> ns = []). + qrep hdr ns vs h -> (List.hd 0 ns = 0 <-> ns = []). Proof. intros hdr ns vs h (Hwf & _ & _ & _ & _); destruct Hwf as (_ & H0 & _). destruct ns as [| a ns]; cbn; split; intro Hx; auto. @@ -289,23 +304,14 @@ Qed. (** ** Rotation on the abstract lists *) -Definition rotl {A} (l: list A) : list A := - match l with nil => nil | x :: xs => xs ++ [x] end. - -Lemma rotl_perm: forall {A} (l: list A), Permutation l (rotl l). -Proof. - intros A [| x xs]; cbn; [constructor |]. - apply Permutation_cons_app; rewrite app_nil_r; apply Permutation_refl. -Qed. Lemma qcells_rot: forall hdr a ns x, In x (qcells hdr (ns ++ [a])) <-> In x (qcells hdr (a :: ns)). Proof. intros hdr a ns x; unfold qcells. assert (Hc: forall y, In y (cells (ns ++ [a])) <-> In y (cells (a :: ns))). - { intro y; rewrite cells_app. - replace (cells (a :: ns)) with (cells [a] ++ cells ns) by reflexivity. - rewrite !in_app_iff; tauto. } + { intro y; unfold cells; rewrite flat_map_app. + cbn; rewrite in_app_iff; cbn; tauto. } split; intros [H | [H | H]]. - now left. - now right; left. @@ -315,74 +321,6 @@ Proof. - right; right; now apply Hc. Qed. -(** ** [find], restated at [nat]. - - The reference proof [examples/Queue.v] states these over the abstract - payload type [T] of the module [MeQ.ME] with a [RelDec] instance. That - module's [T] is an opaque parameter, so the lemmas cannot be instantiated; - the statements and proof structure are reproduced here at [nat] with - [Nat.eqb]. This is a REPRESENTATION-SPECIFIC ADAPTATION, recorded as such - in the reuse report. *) - -Fixpoint find (t: nat) (l: list nat) : option nat := - match l with - | nil => None - | h :: ts => if Nat.eqb h t then Some 0 else option_map S (find t ts) - end. - -Lemma unfold_find_hd: forall t h ts, - find t (h :: ts) = (if Nat.eqb h t then Some 0 else option_map S (find t ts)). -Proof. reflexivity. Qed. - -Lemma find_last_ex: forall nl ts, exists i0 : nat, find nl (ts ++ [nl]) = Some i0. -Proof. - induction ts as [| a ts IH]; cbn. - - exists 0; now rewrite Nat.eqb_refl. - - destruct IH as (x & Hx); destruct (Nat.eqb_spec a nl) as [-> |]. - + now exists 0. - + exists (S x); now rewrite Hx. -Qed. - -Lemma find_app_l: forall nl ts n l, find nl ts = Some n -> find nl (ts ++ l) = Some n. -Proof. - induction ts as [| a ts IH]; intros n l H; cbn in *; [discriminate |]. - destruct (Nat.eqb a nl); auto. - destruct (find nl ts) eqn:Hf; cbn in *; [| discriminate]. - erewrite IH; eauto. -Qed. - -Lemma find_in: forall nl l n, find nl l = Some n -> In nl l. -Proof. - induction l as [| a l IH]; intros n H; cbn in *; [discriminate |]. - destruct (Nat.eqb_spec a nl) as [-> |]; auto. - destruct (find nl l) eqn:Hf; cbn in *; [| discriminate]; eauto. -Qed. - -Lemma find_nonnil: forall nl l n, find nl l = Some n -> l <> []. -Proof. intros nl [| a l] n H; cbn in *; [discriminate | congruence]. Qed. - -(** The position of [nl] after one rotation: this is the natural rank of the - reference proof, restated here so that the temporal file never re-derives - it. If [nl] is at position [S d] it moves to [d]; if it is at position [0] - it is popped now. *) -Lemma find_rotl: forall nl v vs d, - find nl (v :: vs) = Some (S d) -> find nl (rotl (v :: vs)) = Some d. -Proof. - intros nl v vs d H; cbn in *. - destruct (Nat.eqb_spec v nl) as [-> | Hne]; [discriminate |]. - destruct (find nl vs) as [m |] eqn:Hf; cbn in *; [| discriminate]. - assert (m = d) by congruence; subst. - now apply find_app_l. -Qed. - -Lemma find_rotl_pres: forall nl v vs d, - find nl (v :: vs) = Some d -> exists d', find nl (rotl (v :: vs)) = Some d'. -Proof. - intros nl v vs [| d] H. - - cbn in H; destruct (Nat.eqb_spec v nl) as [-> |]; [| destruct (find nl vs); cbn in H; congruence]. - cbn; apply find_last_ex. - - eexists; eapply find_rotl; eauto. -Qed. (** ** The rotation, as heap surgery. @@ -555,17 +493,17 @@ Definition qnode (a: nat) (h: Heap) : Heap := Theorem rot_detach_split: forall hdr a ns v vs h, qrep hdr (a :: ns) (v :: vs) h -> qex hdr (a :: ns) h -> - hdisj (qres hdr a (hdf ns 0) h) (qnode a h) - /\ heq (upd h (S hdr) (hdf ns 0)) (hunion (qres hdr a (hdf ns 0) h) (qnode a h)) - /\ (qrep hdr ns vs (qres hdr a (hdf ns 0) h) - /\ qex hdr ns (qres hdr a (hdf ns 0) h)) - /\ nodeat a v (hdf ns 0) (qnode a h). + hdisj (qres hdr a (List.hd 0 ns) h) (qnode a h) + /\ heq (upd h (S hdr) (List.hd 0 ns)) (hunion (qres hdr a (List.hd 0 ns) h) (qnode a h)) + /\ (qrep hdr ns vs (qres hdr a (List.hd 0 ns) h) + /\ qex hdr ns (qres hdr a (List.hd 0 ns) h)) + /\ nodeat a v (List.hd 0 ns) (qnode a h). Proof. intros hdr a ns v vs h Hq Hex. pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom0). assert (Hdom: forall x, h x <> None <-> In x (qcells hdr (a :: ns))) by (intro x; split; [apply Hex | apply (proj2 Hdom0)]). - destruct Hch as (Ha & Hsa & Hch). + apply chain_cons in Hch as (Ha & Hsa & Hch). pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). pose proof (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). pose proof (qwf_tail _ _ _ Hwf) as Hwfns. @@ -575,18 +513,18 @@ Proof. assert (Esa: nodeb a (S a) = true) by (apply nodeb_true; now right). assert (Ehdr: nodeb a hdr = false) by (apply nodeb_false; split; congruence). assert (Eshdr: nodeb a (S hdr) = false) by (apply nodeb_false; split; congruence). - assert (Hqshdr: qres hdr a (hdf ns 0) h (S hdr) = Some (hdf ns 0)) + assert (Hqshdr: qres hdr a (List.hd 0 ns) h (S hdr) = Some (List.hd 0 ns)) by (unfold qres; rewrite Eshdr; apply upd_eq). - assert (Hqhdr: qres hdr a (hdf ns 0) h hdr = h hdr) + assert (Hqhdr: qres hdr a (List.hd 0 ns) h hdr = h hdr) by (unfold qres; rewrite Ehdr; rewrite upd_neq by congruence; reflexivity). split; [| split; [| split]]. - intro x; unfold qres, qnode; destruct (nodeb a x); [now left | now right]. - intro x; unfold qres, qnode, hunion; destruct (nodeb a x) eqn:E. + apply nodeb_true in E as [-> | ->]; rewrite upd_neq by congruence; reflexivity. - + destruct (upd h (S hdr) (hdf ns 0) x); reflexivity. + + destruct (upd h (S hdr) (List.hd 0 ns) x); reflexivity. - (* the remaining queue is a genuine representation; when the detach has emptied it, the tail pointer is stale and [tailok] does not constrain it *) - assert (Hres: forall x, qres hdr a (hdf ns 0) h x <> None + assert (Hres: forall x, qres hdr a (List.hd 0 ns) h x <> None <-> In x (qcells hdr ns)). { intro x; unfold qres; split. - destruct (nodeb a x) eqn:E; [congruence |]. @@ -612,8 +550,8 @@ Proof. destruct Hx as [C | [C | Hx]]; [subst; apply in_eq | subst; apply in_cons, in_eq | apply in_cons, in_cons; cbn; tauto]. } - assert (Hresnull: qres hdr a (hdf ns 0) h 0 = None). - { destruct (qres hdr a (hdf ns 0) h 0) eqn:E0; [| reflexivity]. + assert (Hresnull: qres hdr a (List.hd 0 ns) h 0 = None). + { destruct (qres hdr a (List.hd 0 ns) h 0) eqn:E0; [| reflexivity]. exfalso; apply (qwf_zero hdr ns Hwfns), Hres; congruence. } split; [| intros x Hx; apply Hres; exact Hx]. split; [exact Hwfns | split; [exact Hqshdr | split; [| split]]]. @@ -648,20 +586,18 @@ Corollary rot_detach_sep: forall hdr a ns v vs h, qex hdr (a :: ns) h -> exists hq hn, hdisj hq hn - /\ heq (upd h (S hdr) (hdf ns 0)) (hunion hq hn) + /\ heq (upd h (S hdr) (List.hd 0 ns)) (hunion hq hn) /\ qrep hdr ns vs hq - /\ nodeat a v (hdf ns 0) hn. + /\ nodeat a v (List.hd 0 ns) hn. Proof. intros hdr a ns v vs h H Hex. apply (rot_detach_split hdr a ns v vs h H) in Hex as (H1 & H2 & (H3 & _) & H4). eauto 6. Qed. -Lemma hdf_ne: forall l f g, l <> [] -> hdf l f = hdf l g. -Proof. now intros [| a l] f g H. Qed. Lemma cells_mono_app: forall x l1 l2, In x (cells l1) -> In x (cells (l1 ++ l2)). -Proof. intros x l1 l2 H; rewrite cells_app, in_app_iff; now left. Qed. +Proof. intros x l1 l2 H; unfold cells in *; rewrite flat_map_app, in_app_iff; now left. Qed. Lemma cells_mono_cons: forall x b l, In x (cells l) -> In x (cells (b :: l)). Proof. intros x b l H; cbn; auto. Qed. @@ -673,12 +609,12 @@ Proof. intros x b l H; cbn; auto. Qed. touches no cell outside the queue's own footprint. *) Theorem rot_heap_spec: forall hdr a ns v vs h, qrep hdr (a :: ns) (v :: vs) h -> - qrep hdr (ns ++ [a]) (vs ++ [v]) (rot_heap hdr a (hdf ns 0) (zof hdr ns) h) - /\ (forall x, rot_heap hdr a (hdf ns 0) (zof hdr ns) h x <> None <-> h x <> None). + qrep hdr (ns ++ [a]) (vs ++ [v]) (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h) + /\ (forall x, rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h x <> None <-> h x <> None). Proof. intros hdr a ns v vs h Hq. pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). - destruct Hch as (Ha & Hsa & Hch). + apply chain_cons in Hch as (Ha & Hsa & Hch). pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). pose proof (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). pose proof (qwf_hdr_cells _ _ Hwf) as Hhnc. @@ -690,7 +626,7 @@ Proof. - (* the queue had one element: detaching empties it, the append re-links the header itself, and the structure comes back to where it started *) subst ns. - destruct vs as [| v1 vs1]; [| cbn in Hch; contradiction]. + destruct vs as [| v1 vs1]; [| destruct Hch as (_ & Hf); inversion Hf]. cbn in Hsa |- *. assert (Hdom': forall x, rot_heap hdr a 0 hdr h x <> None <-> h x <> None) by (apply rot_heap_dom; assumption). @@ -698,9 +634,10 @@ Proof. split; [exact Hwf | split; [| split; [| split]]]. + rewrite (rot_heap_sz hdr a 0 hdr h); [reflexivity | congruence | congruence]. + cbn; apply rot_heap_hdr. - + cbn; split; [| split; [| exact I]]. + + cbn [app]; apply (proj2 (chain_cons _ _ _ _ _ _)); split; [| split]. * rewrite rot_heap_other by (first [congruence | lia]); exact Ha. * apply rot_heap_sa; congruence. + * apply chain_nil. + split. * destruct (rot_heap hdr a 0 hdr h 0) eqn:E0; [| reflexivity]. exfalso; assert (Hc: h 0 <> None) by (apply Hdom'; congruence). @@ -720,9 +657,9 @@ Proof. { apply chain_len in Hch; rewrite Hns, Hvs, !app_length in Hch; cbn in Hch; lia. } rewrite Hns, Hvs in Hch. apply chain_split in Hch as (Hch0 & Hchz); [| exact Hlen]. - cbn in Hch0, Hchz; destruct Hchz as (Hzv & Hszv & _). + cbn [List.hd] in Hch0; apply chain_cons in Hchz as (Hzv & Hszv & _). assert (Hszdom: h (S zz) <> None) by (rewrite Hszv; discriminate). - assert (Hdom': forall x, rot_heap hdr a (hdf ns 0) zz h x <> None <-> h x <> None) + assert (Hdom': forall x, rot_heap hdr a (List.hd 0 ns) zz h x <> None <-> h x <> None) by (apply rot_heap_dom; assumption). rewrite Hz. split; [| exact Hdom']. @@ -730,7 +667,7 @@ Proof. + eapply qwf_perm; [| exact Hwf]. change (Permutation (a :: ns) (ns ++ [a])); apply (rotl_perm (a :: ns)). + rewrite rot_heap_shdr by congruence. - rewrite hdf_app; cbn; f_equal; symmetry; now apply hdf_ne. + rewrite hd_app; cbn; f_equal; symmetry; now apply hd_default. + unfold tailok; destruct (ns ++ [a]) eqn:E. * exfalso; apply app_eq_nil in E as (_ & C); discriminate. * rewrite <- E, last_last; apply rot_heap_hdr. @@ -765,14 +702,16 @@ Proof. apply NoDup_cons_iff in Hnd as (_ & Hnd). rewrite Hns in Hnd; apply NoDup_remove_2 in Hnd. apply Hnd; rewrite app_nil_r; rewrite <- Hcz; exact Hc. - -- cbn; split; [| split; [| exact I]]. + -- cbn [app List.hd]; apply (proj2 (chain_cons _ _ _ _ _ _)); split; [| split]. ++ rewrite rot_heap_other by (first [congruence | lia]); exact Hzv. - ++ apply rot_heap_sz; congruence. - * cbn; split; [| split; [| exact I]]. + ++ cbn [List.hd]; apply rot_heap_sz; congruence. + ++ apply chain_nil. + * cbn [app List.hd]; apply (proj2 (chain_cons _ _ _ _ _ _)); split; [| split]. -- rewrite rot_heap_other by (first [congruence | lia]); exact Ha. - -- apply rot_heap_sa; congruence. + -- cbn [List.hd]; apply rot_heap_sa; congruence. + -- apply chain_nil. + split. - * destruct (rot_heap hdr a (hdf ns 0) zz h 0) eqn:E0; [| reflexivity]. + * destruct (rot_heap hdr a (List.hd 0 ns) zz h 0) eqn:E0; [| reflexivity]. exfalso; assert (Hc: h 0 <> None) by (apply Hdom'; congruence). apply Hc; exact (proj1 Hdom). * intro x; rewrite Hdom'; intro Hx; apply (proj2 Hdom). @@ -781,11 +720,6 @@ Qed. (** ** Two facts the language layer needs about the rotation's footprint. *) -Lemma last_in: forall (l: list nat) d, l <> [] -> In (last l d) l. -Proof. - intros l d H; destruct (exists_last H) as (l' & x & ->). - rewrite last_last, in_app_iff; right; apply in_eq. -Qed. (** The cell the append phase writes is always already allocated: it is the header's link cell when the detach empties the queue, and the last node's @@ -806,34 +740,11 @@ Qed. (** The address the program computes for the append is exactly [zof]. *) Lemma zof_compute: forall hdr a ns, qwf hdr (a :: ns) -> - (if Nat.eqb (hdf ns 0) 0 then hdr else last (a :: ns) 0) = zof hdr ns. + (if Nat.eqb (List.hd 0 ns) 0 then hdr else last (a :: ns) 0) = zof hdr ns. Proof. intros hdr a ns (Hnd & H0 & Hov); destruct ns as [| b ns1]; [reflexivity |]. - cbn [hdf]. + cbn [List.hd]. destruct (Nat.eqb_spec b 0) as [-> | Hb]; [exfalso; apply H0; cbn; tauto |]. reflexivity. Qed. -Lemma find_head: forall nl v vs, find nl (v :: vs) = Some 0 -> v = nl. -Proof. - intros nl v vs H; cbn in H. - destruct (Nat.eqb_spec v nl) as [-> | Hne]; [reflexivity |]. - destruct (find nl vs); cbn in H; discriminate. -Qed. - -Lemma rotl_cons: forall (v: nat) vs, rotl (v :: vs) = vs ++ [v]. -Proof. reflexivity. Qed. - -Lemma chain_mono: forall h h' ns vs fin, - chain h ns vs fin -> - (forall x, In x (cells ns) -> h' x = h x) -> - chain h' ns vs fin. -Proof. - intros h h'; induction ns as [| a ns IH]; intros [| v vs] fin Hc Hag; - cbn in *; try contradiction; auto. - destruct Hc as (Ha & Hsa & Hc). - split; [| split]. - - rewrite Hag; [exact Ha | auto]. - - rewrite Hag; [exact Hsa | auto]. - - apply (IH vs fin Hc); intros x Hx; apply Hag; auto. -Qed. diff --git a/theories/Lang/CSL/Queue/Separation.v b/theories/Lang/CSL/Queue/Separation.v index 07fb17d..c074886 100644 --- a/theories/Lang/CSL/Queue/Separation.v +++ b/theories/Lang/CSL/Queue/Separation.v @@ -7,7 +7,7 @@ happens when the other region is itself running. This file is the resource-level content of that difference. It contains - exactly two kinds of statement: + three kinds of statement: 1. [foreign_pres] -- a step of ONE queue preserves the OTHER queue's representation. This is NOT an instance of the frame rule: the frame @@ -23,6 +23,9 @@ ownership. Here the frame rule IS reused, unchanged ([Frame.qrepX_frame]). + 3. [owned_queues_sound] -- precise separating ownership of two queues + yields the two representations and their footprint disjointness. + Everything in this file is a statement about heaps. No temporal formula and no ICTree appears. *) @@ -91,13 +94,13 @@ Proof. Qed. (** The same statement in the [rot_heap] form the language layer produces. - [qstep u (a :: n1) h] is [rot_heap u a (hdf n1 0) (zof u n1) h] by + [qstep u (a :: n1) h] is [rot_heap u a (List.hd 0 n1) (zof u n1) h] by definition, so this is a restatement, not a second proof. *) Corollary foreign_pres_rot: forall u a n1 vs1 v n2 vs2 h, qrep u (a :: n1) vs1 h -> qrep v n2 vs2 h -> Disj u (a :: n1) v n2 -> - qrep v n2 vs2 (rot_heap u a (hdf n1 0) (zof u n1) h). + qrep v n2 vs2 (rot_heap u a (List.hd 0 n1) (zof u n1) h). Proof. intros u a n1 vs1 v n2 vs2 h Hq1 Hq2 Hd. exact (foreign_pres u (a :: n1) vs1 v n2 vs2 h Hq1 ltac:(discriminate) Hq2 Hd). @@ -142,3 +145,36 @@ Proof. assert (Hd2: h2 x <> None) by (eapply qrep_fp; eassumption). destruct (H12 x); contradiction. Qed. + +(** ** Precise ownership of two queues + + [owned_queues] is the separating conjunction of the two precise queue + resources. Soundness goes through [compose3] with an empty outer frame and + pointwise footprint agreement; heap functions are never equated. *) + +Definition owned_queues u ns1 vs1 v ns2 vs2 : Heap -> Prop := + asep (qrepX u ns1 vs1) (qrepX v ns2 vs2). + +Lemma owned_queues_sound u ns1 vs1 v ns2 vs2 h : + owned_queues u ns1 vs1 v ns2 vs2 h -> + qrep u ns1 vs1 h /\ qrep v ns2 vs2 h /\ Disj u ns1 v ns2. +Proof. + intros (h1 & h2 & Hd & Heq & H1 & H2). + change (hdisj h1 h2) in Hd. + change (heq h (hunion h1 h2)) in Heq. + assert (H1e : hdisj h1 hemp) by (intro x; right; reflexivity). + assert (H2e : hdisj h2 hemp) by (intro x; right; reflexivity). + destruct (compose3 u ns1 vs1 h1 v ns2 vs2 h2 hemp + H1 H2 Hd H1e H2e eq_refl) as (Q1 & Q2 & Hdisj). + assert (Hagree : forall x, hunion h1 (hunion h2 hemp) x = h x). + { intro x; rewrite Heq; unfold hunion, hemp. + destruct (h1 x); [reflexivity | destruct (h2 x); reflexivity]. } + split; [| split]. + - eapply qrep_agree_fp; [exact Q1 | |]. + + intros x _; symmetry; apply Hagree. + + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q1). + - eapply qrep_agree_fp; [exact Q2 | |]. + + intros x _; symmetry; apply Hagree. + + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q2). + - exact Hdisj. +Qed. diff --git a/theories/Lang/CSL/Queue/Sequential.v b/theories/Lang/CSL/Queue/Sequential.v index 52d4c69..64658cd 100644 --- a/theories/Lang/CSL/Queue/Sequential.v +++ b/theories/Lang/CSL/Queue/Sequential.v @@ -13,19 +13,19 @@ 2. **The observation is heap-free.** [HeapImp] logs the WHOLE memory on every write, which puts numeric addresses into the world and makes any world-literal specification frame-unstable. Here the only logged event - is the popped payload together with an occurrence index, so the world + is the (fun o => indexed_value o = payload) together with an occurrence index, so the world never mentions an address. - 3. **The observation is occurrence-tagged.** [Pop v k] carries the number - of pops that preceded it. A retained [Obs (Log (Pop v k)) tt] world + 3. **The observation is occurrence-tagged.** [stamp v k] carries the number + of pops that preceded it. A retained [Obs (Log (stamp v k)) tt] world cannot satisfy an occurrence-indexed formula for a later index, which is - what makes "the same element is popped AGAIN" a checkable statement + what makes "the same element is (fun o => indexed_value o = AGAIN)" a checkable statement rather than a re-reading of a stale world. - The projection back to the reference alphabet is [qval]: the reference - [examples/Queue.v] logs the popped payload [h : T] and specifies + The projection back to the reference alphabet is [indexed_value]: the reference + [examples/Queue.v] logs the (fun o => indexed_value o = payload) [h : T] and specifies [visW {fun h => h = nl}]; here the corresponding formula is - [visW {fun o => qval o = nl}]. *) + [visW {fun o => indexed_value o = nl}]. *) From Stdlib Require Import List @@ -56,6 +56,8 @@ From TICL Require Import From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Operations. +From Coinduction Require Import coinduction. + Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. @@ -66,9 +68,11 @@ Local Open Scope list_scope. Local Typeclasses Transparent equ. Local Typeclasses Transparent sbisim. -(** ** The observation alphabet and its projection *) +(** ** The observation alphabet and its projection. -Record QObs : Type := Pop { qval: nat ; qidx: nat }. + Observations are [indexed nat]: the (fun o => indexed_value o = payload) together with the + number of pops that preceded it. Both the record and its indexing + handler are owned by [Events.WriterE] / [ICTree.Events.Writer]. *) (** ** Events *) @@ -85,35 +89,8 @@ Definition emit (v: nat) : ictree qE unit := Notation Sig := (Heap * nat)%type. (** ** The safe handler *) -Definition q_emit_handler: writerE nat ~> stateT Sig (ictreeW QObs) := - fun e => - mkStateT (fun '(h, c) => - match e return ictreeW QObs (encode e * Sig) with - | Log v => log (Pop v c) ;; Ret (tt, (h, S c)) - end). - -Definition h_qE: qE ~> stateT Sig (ictreeW QObs) := - h_sum (heap_handler (W:=QObs)) q_emit_handler. - -(** *** Payload emission equations *) - -Lemma h_emit: forall v h c, - runStateT (h_qE (inr (Log v))) (h, c) ≅ (log (Pop v c) ;; Ret (tt, (h, S c))). -Proof. intros; cbn; reflexivity. Qed. - -(** *** Lifting the handler equations through [interp_state]. *) - -Lemma interp_emit {X}: forall v h c (k: unit -> ictree qE X), - interp_state h_qE (x <- emit v ;; k x) (h, c) - ~ (log (Pop v c) ;; interp_state h_qE (k tt) (h, S c)). -Proof. - intros v h c k. - unfold emit, ICtree.trigger, resum, ReSum_inr, resum_ret, ReSumRet_inr. - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis, h_emit, bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l; apply sb_guard. -Qed. +Definition h_qE: qE ~> stateT Sig (ictreeW (indexed nat)) := + h_sum heap_handler h_indexed. (** ** The rotating queue program. @@ -127,7 +104,7 @@ Definition rot_body (hdr: nat) : ictree qE (unit + unit) := Definition rotate (hdr: nat) : ictree qE unit := ICtree.iter (fun _: unit => rot_body hdr) tt. -Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW QObs (unit * Sig) := +Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW (indexed nat) (unit * Sig) := interp_state h_qE (rotate hdr) (h, c). (** ** The body correspondence. @@ -145,19 +122,19 @@ Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW QObs (unit * Sig) := - **operation correctness.** The resulting heap is [rot_heap], which [Representation.rot_heap_spec] proves implements the abstract pop-and-push. - - **the observation.** The single event is [Pop v c] where [v] is the + - **the observation.** The single event is [stamp v c] where [v] is the payload READ OUT OF the head node's cell and [c] is the occurrence counter before the pop. *) Theorem rot_body_spec: forall hdr a ns v vs h c, qrep hdr (a :: ns) (v :: vs) h -> interp_state h_qE (rot_body hdr) (h, c) - ~ (log (Pop v c) ;; - Ret (@inl unit unit tt, (rot_heap hdr a (hdf ns 0) (zof hdr ns) h, S c))). + ~ (log (stamp v c) ;; + Ret (@inl unit unit tt, (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c))). Proof. intros hdr a ns v vs h c Hq; unfold rot_body. etransitivity. - - eapply (queue_turn_spec q_emit_handler emit Pop). - + intros; apply interp_emit. + - eapply (queue_turn_spec h_indexed emit stamp). + + intros; apply (interp_indexed_emit heap_handler). + exact Hq. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. apply equ_sbisim, interp_state_ret. diff --git a/theories/Lang/CSL/Queue/Ticl.v b/theories/Lang/CSL/Queue/Ticl.v index a1a835b..9048836 100644 --- a/theories/Lang/CSL/Queue/Ticl.v +++ b/theories/Lang/CSL/Queue/Ticl.v @@ -1,11 +1,12 @@ +From Stdlib Require Import List. From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim - ICTree.Logic.Trans Logic.Core. + ICTree.Logic.Trans ICTree.Logic.State ICTree.Logic.AG Logic.Core. From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating Lang.CSL.Queue.Composition Lang.CSL.Queue.Program. -Import ICtree ICTreeNotations TiclNotations. +Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. Local Open Scope ticl_scope. Local Typeclasses Transparent equ sbisim. @@ -13,9 +14,9 @@ Local Typeclasses Transparent equ sbisim. Theorem rotate_agaf_pop_rr : forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {run_rr (parallel_queues u v) h c}, Pure - |= AG (AF visW {spopped 1 nl1}) )>. + |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. rewrite (run_rr_parallel_bisim u v h c). @@ -26,9 +27,9 @@ Qed. Theorem rotate_agaf_pop_rr_q2 : forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {run_rr (parallel_queues u v) h c}, Pure - |= AG (AF visW {spopped 2 nl2}) )>. + |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. rewrite (run_rr_parallel_bisim u v h c). @@ -39,9 +40,9 @@ Qed. Theorem rotate_agaf_pop_rr_fresh : forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {run_rr (parallel_queues u v) h c}, Pure - |= AG (AF visW {spopped_after 1 nl1 k}) )>. + |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. rewrite (run_rr_parallel_bisim u v h c). @@ -52,49 +53,24 @@ Qed. Theorem rotate_agaf_pop_rr_q2_fresh : forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {run_rr (parallel_queues u v) h c}, Pure - |= AG (AF visW {spopped_after 2 nl2 k}) )>. + |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. rewrite (run_rr_parallel_bisim u v h c). + +From Coinduction Require Import coinduction. exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. -Definition owned_queues u ns1 vs1 v ns2 vs2 : Heap -> Prop := - asep (qrepX u ns1 vs1) (qrepX v ns2 vs2). - -Lemma owned_queues_sound u ns1 vs1 v ns2 vs2 h : - owned_queues u ns1 vs1 v ns2 vs2 h -> - qrep u ns1 vs1 h /\ qrep v ns2 vs2 h /\ Disj u ns1 v ns2. -Proof. - intros (h1 & h2 & Hd & Heq & H1 & H2). - change (hdisj h1 h2) in Hd. - change (heq h (hunion h1 h2)) in Heq. - assert (H1e : hdisj h1 hemp) by (intro x; right; reflexivity). - assert (H2e : hdisj h2 hemp) by (intro x; right; reflexivity). - destruct (compose3 u ns1 vs1 h1 v ns2 vs2 h2 hemp - H1 H2 Hd H1e H2e eq_refl) as (Q1 & Q2 & Hdisj). - assert (Hagree : forall x, hunion h1 (hunion h2 hemp) x = h x). - { intro x; rewrite Heq; unfold hunion, hemp. - destruct (h1 x); [reflexivity | destruct (h2 x); reflexivity]. } - split; [| split]. - - eapply qrep_agree_fp; [exact Q1 | |]. - + intros x _; symmetry; apply Hagree. - + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q1). - - eapply qrep_agree_fp; [exact Q2 | |]. - + intros x _; symmetry; apply Hagree. - + rewrite <- Hagree; exact (qrep_null _ _ _ _ Q2). - - exact Hdisj. -Qed. - Theorem rotate_agaf_pop_rr_owned : forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, owned_queues u ns1 vs1 v ns2 vs2 h -> - find nl1 vs1 = Some d1 -> find nl2 vs2 = Some d2 -> + find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> <( {run_rr (parallel_queues u v) h c}, Pure - |= AG (AF visW {spopped 1 nl1}) )>. + |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. destruct (owned_queues_sound u ns1 vs1 v ns2 vs2 h Hown) as (H1 & H2 & Hd). @@ -103,9 +79,9 @@ Qed. Theorem rotate_agaf_pop_alloc : forall values1 values2 nl1 nl2 c d1 d2, - find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure - |= AG (AF visW {spopped 1 nl1}) )>. + |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros values1 values2 nl1 nl2 c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) @@ -118,9 +94,9 @@ Qed. Theorem rotate_agaf_pop_alloc_q2 : forall values1 values2 nl1 nl2 c d1 d2, - find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure - |= AG (AF visW {spopped 2 nl2}) )>. + |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. intros values1 values2 nl1 nl2 c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) @@ -133,9 +109,9 @@ Qed. Theorem rotate_agaf_pop_alloc_fresh : forall values1 values2 nl1 nl2 k c d1 d2, - find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure - |= AG (AF visW {spopped_after 1 nl1 k}) )>. + |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) @@ -148,9 +124,9 @@ Qed. Theorem rotate_agaf_pop_alloc_q2_fresh : forall values1 values2 nl1 nl2 k c d1 d2, - find nl1 values1 = Some d1 -> find nl2 values2 = Some d2 -> + find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure - |= AG (AF visW {spopped_after 2 nl2 k}) )>. + |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) @@ -160,3 +136,12 @@ Proof. destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). rewrite Run; eapply rotate_agaf_pop_rr_q2_fresh; eassumption. Qed. + +Lemma parallel_queues_hemp_no_ag u v c (phi : ticllW (indexed (nat * nat))) w : + ~ <( {run_rr (parallel_queues u v) hemp c}, {w} |= AG phi )>. +Proof. rewrite (parallel_queues_hemp_stuck u v c); apply ag_stuck. Qed. + +Lemma allocated_parallel_queues_empty_no_ag values c + (phi : ticllW (indexed (nat * nat))) w : + ~ <( {run_rr (allocated_parallel_queues [] values) hemp c}, {w} |= AG phi )>. +Proof. rewrite (allocated_parallel_queues_empty_stuck values c); apply ag_stuck. Qed. diff --git a/theories/Lang/CSL/Queue/Trace.v b/theories/Lang/CSL/Queue/Trace.v index 28bebdf..9017721 100644 --- a/theories/Lang/CSL/Queue/Trace.v +++ b/theories/Lang/CSL/Queue/Trace.v @@ -44,7 +44,7 @@ Local Typeclasses Transparent sbisim. Lemma run_step: forall hdr a ns v vs h c, qrep hdr (a :: ns) (v :: vs) h -> run hdr h c - ~ (log (Pop v c) ;; run hdr (rot_heap hdr a (hdf ns 0) (zof hdr ns) h) (S c)). + ~ (log (stamp v c) ;; run hdr (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h) (S c)). Proof. intros hdr a ns v vs h c Hq. unfold run, rotate. @@ -55,13 +55,15 @@ Proof. apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite bind_ret_l. apply sb_guard. + +From Coinduction Require Import coinduction. Qed. (** The heap after one rotation, and after [n] of them. *) Definition qstep (hdr: nat) (ns: list nat) (h: Heap) : Heap := match ns with | [] => h - | a :: ns' => rot_heap hdr a (hdf ns' 0) (zof hdr ns') h + | a :: ns' => rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h end. Fixpoint qstepN (hdr: nat) (n: nat) (ns: list nat) (h: Heap) : Heap := @@ -70,24 +72,17 @@ Fixpoint qstepN (hdr: nat) (n: nat) (ns: list nat) (h: Heap) : Heap := | S k => qstepN hdr k (rotl ns) (qstep hdr ns h) end. -Fixpoint rotlN {A} (n: nat) (l: list A) : list A := - match n with 0 => l | S k => rotlN k (rotl l) end. (** The observation prefix of [n] rotations, with the continuation threaded so that no [bind]-associativity reasoning is needed. *) Fixpoint runN (hdr: nat) (n: nat) (ns vs: list nat) (h: Heap) (c: nat) - (k: ictreeW QObs (unit * Sig)) : ictreeW QObs (unit * Sig) := + (k: ictreeW (indexed nat) (unit * Sig)) : ictreeW (indexed nat) (unit * Sig) := match n with | 0 => k - | S m => log (Pop (hd 0 vs) c) ;; + | S m => log (stamp (hd 0 vs) c) ;; runN hdr m (rotl ns) (rotl vs) (qstep hdr ns h) (S c) k end. -Lemma rotl_nonnil: forall (l: list nat), l <> [] -> rotl l <> []. -Proof. - intros [| a l] H; [contradiction |]; cbn. - intro C; apply app_eq_nil in C as (_ & C); discriminate. -Qed. Lemma qstep_qrep: forall hdr ns vs h, qrep hdr ns vs h -> ns <> [] -> diff --git a/theories/Lang/CSL/Segments.v b/theories/Lang/CSL/Segments.v index b95137e..afa3331 100644 --- a/theories/Lang/CSL/Segments.v +++ b/theories/Lang/CSL/Segments.v @@ -1,3 +1,13 @@ +(** * Source-instruction first-yield rules. + + Everything structural about first-yield segments — the inductive, its + inversion laws, guard transport, determinism, branch-freedom and the + scheduling equations — is owned by [ICTree.Interp.Yield.Segments] and is + polymorphic in the handler and the response relation. What remains here + is exactly the [CProg]-dependent layer: one rule per source instruction, + stated at the CSL handler [sh] in EXACT mode, plus the raw normalization + tactic those rules are applied through. *) + From Stdlib Require Import List Arith.PeanoNat Fin Vector Classes.Morphisms Classes.RelationClasses Program.Equality. From ExtLib Require Import Data.Monads.StateMonad. @@ -6,829 +16,163 @@ From TICL Require Import ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim - ICTree.Interp.Yield.RoundRobin Utils.Vectors. + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic + Utils.Vectors. + +From TICL Require Export ICTree.Interp.Yield.Segments. Import ICtree ICTreeNotations ListNotations VectorNotations. Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. Local Open Scope list_scope. -(** A finite derivation stops at the first source yield. The handler premise - is its actual effect semantics, not an allocator transition assumption. *) -Inductive ThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := -| segment_yield (k : unit -> thread sE) sigma : - ThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma -| segment_guard t sigma logs t' sigma' : - ThreadSegment t sigma logs t' sigma' -> - ThreadSegment (Guard t) sigma logs t' sigma' -| segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 - before after t' sigma' : - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> - ThreadSegment (k result) sigma1 after t' sigma' -> - ThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) - sigma (before ++ after) t' sigma' -| segment_equ t u sigma logs u' t' sigma' : - t ≅ u -> ThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> - ThreadSegment t sigma logs t' sigma'. - -Definition pool_guard_equ {n} (ts us : pool sE n) : Prop := - forall i, guard_equ (ts $ i) (us $ i). - -Lemma execution_pool_guard_equ {n} (ts us : pool sE n) : - pool_equ ts us -> pool_guard_equ ts us. -Proof. intros H i; apply guard_equ_equ, H. Qed. - -Lemma execution_pool_guard_replace {n} (ts us : pool sE n) - (i : Fin.t n) t u : - pool_guard_equ ts us -> guard_equ t u -> - pool_guard_equ (ts @ i := t) (us @ i := u). -Proof. - intros Hpool Htu j; destruct (Fin.eq_dec j i) as [->|Hneq]. - - rewrite !Vector.nth_replace_eq; exact Htu. - - rewrite !Vector.nth_replace_neq by congruence; apply Hpool. -Qed. - -Lemma source_replace_current n (ts : pool sE n) (i : Fin.t n) : - pool_equ (ts @ i := (ts $ i)) ts. -Proof. - intro j; destruct (Fin.eq_dec j i) as [->|Hne]. - - rewrite Vector.nth_replace_eq; reflexivity. - - rewrite Vector.nth_replace_neq by congruence; reflexivity. -Qed. - -Lemma source_pool_equ_guard_trans {n} (ts us vs : pool sE n) : - pool_equ ts us -> pool_guard_equ us vs -> pool_guard_equ ts vs. -Proof. - intros E H i; eapply guard_equ_trans; [apply guard_equ_equ, E|apply H]. -Qed. - -Lemma handler_response_unique (e : sE) (sigma : SSig) - (result : encode e) (sigma1 : SSig) (before : list SObs) - (result' : encode e) (sigma2 : SSig) (before' : list SObs) : - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) -> - runStateT (sh e) sigma ~ emit_list before' (Ret (result',sigma2)) -> - before = before' /\ result = result' /\ sigma1 = sigma2. -Proof. - intros E1 E2. - assert (E : emit_list before (Ret (result,sigma1)) ~ - emit_list before' (Ret (result',sigma2))). - { transitivity (runStateT (sh e) sigma); [symmetry; exact E1|exact E2]. } - destruct (emit_list_ret_injective _ _ _ _ E) as [Ex Er]. - inversion Er; subst; auto. -Qed. - -(** Raw congruence is allowed on both ends, but no source-side [sbisim] - congruence is used. *) -Lemma ThreadSegment_equ_input t u sigma xs residual sigma' : - t ≅ u -> ThreadSegment t sigma xs residual sigma' -> - ThreadSegment u sigma xs residual sigma'. -Proof. - intros E H; eapply segment_equ; [symmetry; exact E|exact H|reflexivity]. -Qed. - -Lemma ThreadSegment_equ_output t sigma xs residual residual' sigma' : - ThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> - ThreadSegment t sigma xs residual' sigma'. -Proof. intros H E; eapply segment_equ; [reflexivity|exact H|exact E]. Qed. - -Lemma ThreadSegment_yield_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall k : unit -> thread sE, - t ≅ Vis (inl Yield) k -> - xs = [] /\ sigma' = sigma /\ k tt ≅ residual. -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - intros k E; split; [reflexivity|]; split; [reflexivity|]. - symmetry; exact (equ_vis_invE E tt). - - intros k E; step in E; cbn in E; inversion E. - - intros k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - intros k E. - assert (Eu : u ≅ Vis (inl Yield) k). - { transitivity t; [symmetry; exact Etu|exact E]. } - destruct (IH k Eu) as [Ex [Es Ek]]. - split; [exact Ex|]; split; [exact Es|]. - transitivity u'; assumption. -Qed. - -Lemma ThreadSegment_yield_inv k sigma xs residual sigma' : - ThreadSegment (Vis (inl Yield) k) sigma xs residual sigma' -> - xs = [] /\ sigma' = sigma /\ k tt ≅ residual. -Proof. intro H; eapply ThreadSegment_yield_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_guard_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall u, t ≅ Guard u -> ThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t v sigma xs v' residual sigma' Etv H IH Eout]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E; apply equ_guard_invE in E. - eapply ThreadSegment_equ_input; [exact E|exact H]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E. - eapply ThreadSegment_equ_output; [|exact Eout]. - apply IH; transitivity t; [symmetry; exact Etv|exact E]. -Qed. - -Lemma ThreadSegment_guard_inv t sigma xs residual sigma' : - ThreadSegment (Guard t) sigma xs residual sigma' -> - ThreadSegment t sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : - ThreadSegment (Guard t) sigma xs residual sigma' <-> - ThreadSegment t sigma xs residual sigma'. -Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. - -Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall (e : sE) (k : encode e -> thread sE), - t ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) -> - exists result sigma1 before after, - xs = before ++ after /\ - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ - ThreadSegment (k result) sigma1 after residual sigma'. -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e0 k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - intros e k E; pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - intros e k E; step in E; cbn in E; inversion E. - - intros e k E. - pose proof (equ_vis_invT E) as [_ Ee]. - assert (Eevent : e0 = e) by congruence; subst e. - exists result, sigma1, before, after. - split; [reflexivity|]; split; [exact Eh|]. - eapply ThreadSegment_equ_input; [exact (equ_vis_invE E result)|exact H]. - - intros e k E. - assert (Eu : u ≅ (@go CEff _ unit (VisF (inr (inr e) : CEff) k))). - { transitivity t; [symmetry; exact Etu|exact E]. } - destruct (IH e k Eu) as [r [sigma1 [before [after [Ex [Eh Htail]]]]]]. - exists r, sigma1, before, after; split; [exact Ex|]; split; [exact Eh|]. - eapply ThreadSegment_equ_output; eassumption. -Qed. - -Lemma ThreadSegment_user_inv (e : sE) (k : encode e -> thread sE) - sigma xs residual sigma' : - ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma' -> - exists result sigma1 before after, - xs = before ++ after /\ - runStateT (sh e) sigma ~ emit_list before (Ret (result,sigma1)) /\ - ThreadSegment (k result) sigma1 after residual sigma'. -Proof. intro H; eapply ThreadSegment_user_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_ret_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> ~ (t ≅ Ret tt). -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intro E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - apply IH; transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_ret_absurd sigma xs residual sigma' : - ~ ThreadSegment (Ret tt) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_ret_absurd_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_fork_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall k : bool -> thread sE, ~ (t ≅ Vis (inr (inl Fork)) k). -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros k E. - - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - step in E; cbn in E; inversion E. - - pose proof (equ_vis_invT E) as [_ Ebad]; discriminate. - - apply (IH k); transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_fork_absurd k sigma xs residual sigma' : - ~ ThreadSegment (Vis (inr (inl Fork)) k) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_fork_absurd_equ; [exact H|reflexivity]. Qed. - -Lemma ThreadSegment_br_absurd_equ t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - forall n (k : Fin.t (S n) -> thread sE), ~ (t ≅ Br n k). -Proof. - intro H; induction H as - [k0 sigma - |t sigma xs residual sigma' H IH - |e k0 sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n k E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - step in E; cbn in E; inversion E. - - apply (IH n k); transitivity t; [symmetry; exact Etu|exact E]. -Qed. - -Lemma ThreadSegment_br_absurd n k sigma xs residual sigma' : - ~ ThreadSegment (Br n k) sigma xs residual sigma'. -Proof. intro H; eapply ThreadSegment_br_absurd_equ; [exact H|reflexivity]. Qed. - -(** A finite first-yield derivation cannot be manufactured by repeatedly - unfolding a divergent guard. A user case provides its actual response as - the witness needed for the first visible raw transition. *) -Lemma ThreadSegment_can_step t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> exists l u, trans l t u. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - exists (obs (inl Yield) tt), (k tt); apply trans_vis. - - destruct IH as [l [u Hstep]]; exists l, u; now apply trans_guard. - - exists (obs (inr (inr e) : CEff) result), (k result); apply trans_vis. - - destruct IH as [l [v Hstep]]; exists l, v; rewrite Etu; exact Hstep. -Qed. - -Lemma ThreadSegment_divergent_absurd t sigma xs residual sigma' : - is_stuck t -> ~ ThreadSegment t sigma xs residual sigma'. -Proof. intros Hdiv Hseg; apply Hdiv; eapply ThreadSegment_can_step; exact Hseg. Qed. - -Lemma ThreadSegment_stuck_absurd sigma xs residual sigma' : - ~ ThreadSegment (stuck : thread sE) sigma xs residual sigma'. -Proof. apply ThreadSegment_divergent_absurd, stuck_is_stuck. Qed. - -Lemma ThreadSegment_spin_absurd sigma xs residual sigma' : - ~ ThreadSegment (spin : thread sE) sigma xs residual sigma'. -Proof. - intro H; eapply ThreadSegment_br_absurd_equ; [exact H|]. - apply unfold_spin. -Qed. - -Lemma ThreadSegment_fault_absurd (e : sE) (k : encode e -> thread sE) - sigma xs residual sigma' : - runStateT (sh e) sigma ~ (stuck : ictreeW SObs (encode e * SSig)) -> - ~ ThreadSegment ((@go CEff _ unit (VisF (inr (inr e) : CEff) k))) sigma xs residual sigma'. -Proof. - intros Ef Hseg. - destruct (ThreadSegment_user_inv e k sigma xs residual sigma' Hseg) - as [result [sigma1 [before [after [_ [Eh _]]]]]]. - apply (emit_list_ret_not_stuck before (result,sigma1)). - transitivity (runStateT (sh e) sigma); [symmetry; exact Eh|exact Ef]. -Qed. - -Lemma ThreadSegment_deterministic t sigma xs u sigma1 ys v sigma2 : - ThreadSegment t sigma xs u sigma1 -> - ThreadSegment t sigma ys v sigma2 -> - xs = ys /\ sigma1 = sigma2 /\ u ≅ v. -Proof. - intros H1; revert ys v sigma2. - induction H1 as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros ys v sigma2 H2. - - destruct (ThreadSegment_yield_inv k sigma ys v sigma2 H2) - as [Ex [Es Ek]]. - split; [symmetry; exact Ex|]; split; [symmetry; exact Es|exact Ek]. - - apply IH; now apply ThreadSegment_guard_inv in H2. - - destruct (ThreadSegment_user_inv e k sigma ys v sigma2 H2) - as [r [sigma0 [before0 [after0 [Ey [Eh0 Htail]]]]]]. - destruct (handler_response_unique e sigma result sigma1 before - r sigma0 before0 Eh Eh0) as [Eb [Er Es]]. - subst before0; subst r; subst sigma0. - destruct (IH after0 v sigma2 Htail) as [Ea [Es Er]]. - split; [subst ys; now rewrite Ea|]; split; assumption. - - assert (H2u : ThreadSegment u sigma ys v sigma2). - { eapply ThreadSegment_equ_input; [exact Etu|exact H2]. } - destruct (IH ys v sigma2 H2u) as [Ex [Es Er]]. - split; [exact Ex|]; split; [exact Es|]. - transitivity u'; [symmetry; exact Eout|exact Er]. -Qed. - -#[global] Instance guard_equ_Equivalence : Equivalence guard_equ. -Proof. - split. - - intro t; apply guard_equ_equ; reflexivity. - - intros t u; apply guard_equ_sym. - - intros t u v; apply guard_equ_trans. -Qed. - -Lemma guard_equ_sbisim t u : guard_equ t u -> t ~ u. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - rewrite E; reflexivity. - - rewrite sb_guard; exact IH. - - rewrite sb_guard; exact IH. - - symmetry; exact IH. - - transitivity u; assumption. -Qed. - -(** This stronger same-residual transport follows from the output-equ rule. - Symmetry in the finite guard closure is handled by proving both directions - together, rather than assuming a reverse simulation. *) -Lemma guard_equ_segment_iff t u : guard_equ t u -> - forall sigma xs residual sigma', - ThreadSegment t sigma xs residual sigma' <-> - ThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; - intros sigma xs residual sigma'. - - split; intro Hseg. - + eapply ThreadSegment_equ_input; [exact E|exact Hseg]. - + eapply ThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. - - rewrite ThreadSegment_guard_iff; apply IH. - - rewrite ThreadSegment_guard_iff; apply IH. - - symmetry; apply IH. - - transitivity (ThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. -Qed. - -Lemma guard_equ_segment t u sigma xs t' sigma' : - guard_equ t u -> ThreadSegment t sigma xs t' sigma' -> - exists u', ThreadSegment u sigma xs u' sigma' /\ guard_equ t' u'. -Proof. - intros E Hseg; exists t'; split. - - apply (proj1 (guard_equ_segment_iff t u E sigma xs t' sigma')); exact Hseg. - - apply guard_equ_equ; reflexivity. -Qed. - -Lemma guard_equ_br_yield_absurd n (k : Fin.t (S n) -> thread sE) - (ky : unit -> thread sE) : ~ guard_equ (Br n k) (Vis (inl Yield) ky). -Proof. - intro E; apply guard_equ_sbisim in E. - eapply (@sbisim_vis_br_inv CEff _ unit n (inl Yield) ky k); symmetry; exact E. -Qed. - -(** Equivalence of pools is used only for genuine raw [equ]. Guard removal - below is deliberately restricted to the focused slot. *) -Lemma segment_nd_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) - t u focus sigma : - t ≅ u -> - interp_nd (S n) (ts @ i := t) focus sigma ~ - interp_nd (S n) (ts @ i := u) focus sigma. -Proof. - intro E. - pose proof (interp_nd_equ (S n) (ts @ i := t) (ts @ i := u) - focus sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. - rewrite Ep; reflexivity. -Qed. - -Lemma segment_rr_replace_equ n (ts : pool sE (S n)) (i : Fin.t (S n)) - t u focus m sigma : - t ≅ u -> - interp_schedule_rr sh (S n) (ts @ i := t) focus m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := u) focus m sigma. -Proof. - intro E. - pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := t) (ts @ i := u) - focus m sigma (replace_pool_equ ts ts i t u (pool_equ_refl ts) E)) as Ep. - rewrite Ep; reflexivity. -Qed. - -Lemma segment_nd_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t sigma : - interp_nd (S n) (ts @ i := Guard t) (Some i) sigma ~ - interp_nd (S n) (ts @ i := t) (Some i) sigma. -Proof. - erewrite interp_nd_guard by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma segment_rr_focused_guard n (ts : pool sE (S n)) (i : Fin.t (S n)) t m sigma : - interp_schedule_rr sh (S n) (ts @ i := Guard t) (Some i) m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma. -Proof. - erewrite interp_schedule_rr_guard by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma guard_equ_focused_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) t u sigma : - guard_equ t u -> - interp_nd (S n) (ts @ i := t) (Some i) sigma ~ - interp_nd (S n) (ts @ i := u) (Some i) sigma. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_nd_replace_equ; exact E. - - etransitivity; [apply segment_nd_focused_guard|exact IH]. - - etransitivity; [exact IH|symmetry; apply segment_nd_focused_guard]. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. -Qed. - -Lemma guard_equ_focused_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) t u m sigma : - guard_equ t u -> - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ - interp_schedule_rr sh (S n) (ts @ i := u) (Some i) m sigma. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_rr_replace_equ; exact E. - - etransitivity; [apply segment_rr_focused_guard|exact IH]. - - etransitivity; [exact IH|symmetry; apply segment_rr_focused_guard]. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. -Qed. - -Lemma segment_nd_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) sigma : - interp_nd (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) sigma ~ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - interp_nd (S n) (ts @ i := k x) (Some i) sigma'). -Proof. - erewrite interp_nd_user by (rewrite Vector.nth_replace_eq; reflexivity). - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. -Qed. +(** ** The two response-relation instances. -Lemma segment_rr_focused_user n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - interp_schedule_rr sh (S n) (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ~ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). -Proof. - erewrite interp_schedule_rr_user by (rewrite Vector.nth_replace_eq; reflexivity). - apply sbisim_clo_bind_eq; [reflexivity|]. - intros [x sigma']; rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma segment_interp_nd n (ts : pool sE (S n)) (i : Fin.t (S n)) - t sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - interp_nd (S n) (ts @ i := t) (Some i) sigma ~ - emit_list xs (interp_nd (S n) (ts @ i := residual) None sigma'). -Proof. - intro H; revert n ts i. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. - - cbn [emit_list]. - erewrite interp_nd_yield by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_nd_focused_guard|apply IH]. - - etransitivity; [apply segment_nd_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => interp_nd (S n) (ts @ i := k x) (Some i) sigma0). - + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. -Qed. - -Lemma segment_interp_rr n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma xs residual sigma' : - ThreadSegment t sigma xs residual sigma' -> - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ - emit_list xs (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'). -Proof. - intro H; revert n ts i m. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. - - cbn [emit_list]. - erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_rr_focused_guard|apply IH]. - - etransitivity; [apply segment_rr_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0). - + apply sbisim_clo_bind_eq; [exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. -Qed. - -(** Exact equations retain the finite administrative guard path. In particular - RR selection is not a visible branch after refinement: its three guards - must not be used as a guarded [sbisim] coinduction hypothesis. These laws - expose them for induction on an actual [trans_] derivation instead. *) -Lemma segment_rr_guard_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma : - observe (ts $ i) = GuardF t -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - Guard (interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_guard n ts i t Hobs). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -Lemma segment_rr_yield_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - k m sigma : - observe (ts $ i) = VisF (inl Yield) k -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - Guard (interp_schedule_rr sh (S n) (ts @ i := k tt) None m sigma). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_yield n ts i k Hobs). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -Lemma segment_rr_user_exact n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - observe (ts $ i) = VisF (inr (inr e)) k -> - interp_schedule_rr sh (S n) ts (Some i) m sigma ≅ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - Guard (Guard (Guard - (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')))). -Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_user_event n ts i e k Hobs). - rewrite interp_erase_user, interp_state_vis. - apply equ_clo_bind with (S := eq); [reflexivity|]. - intros [x sigma'] r <-; apply guard_equ_node. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node, interp_state_tau. -Qed. - -Lemma segment_rr_select_exact n (ts : pool sE (S n)) m sigma : - interp_schedule_rr sh (S n) ts None m sigma ≅ - Guard (Guard (Guard - (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma))). -Proof. - unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, schedule_no_focus_nonempty. - rewrite interp_erase_yield. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node. - etransitivity; [apply interp_state_tau|]. - apply guard_equ_node. - rewrite (unfold_run_round_robin - (Br n (fun i => schedule (S n) ts (Some i))) m). - change (interp_state sh - (interp_yield (interp_spawn - (Guard (run_round_robin (schedule (S n) ts (Some (rr_pick n m))) (S m))))) sigma ≅ - Guard (interp_schedule_rr sh (S n) ts (Some (rr_pick n m)) (S m) sigma)). - rewrite interp_erase_guard, interp_state_tau; reflexivity. -Qed. - -(** Primitive handlers return by raw equivalence in this stronger certificate. - Unlike [ThreadSegment], it retains the finite administrative guard path - needed for exact round-robin prefix alignment. *) -Inductive ExactThreadSegment : thread sE -> SSig -> list SObs -> thread sE -> SSig -> Prop := -| exact_segment_yield (k : unit -> thread sE) sigma : - ExactThreadSegment (Vis (inl Yield) k) sigma [] (k tt) sigma -| exact_segment_guard t sigma logs t' sigma' : - ExactThreadSegment t sigma logs t' sigma' -> - ExactThreadSegment (Guard t) sigma logs t' sigma' -| exact_segment_user (e : sE) (k : encode e -> thread sE) sigma result sigma1 - before after t' sigma' : - runStateT (sh e) sigma ≅ emit_list before (Ret (result,sigma1)) -> - ExactThreadSegment (k result) sigma1 after t' sigma' -> - ExactThreadSegment (@go CEff _ unit (VisF (inr (inr e) : CEff) k)) - sigma (before ++ after) t' sigma' -| exact_segment_equ t u sigma logs u' t' sigma' : - t ≅ u -> ExactThreadSegment u sigma logs u' sigma' -> u' ≅ t' -> - ExactThreadSegment t sigma logs t' sigma'. - -Lemma ExactThreadSegment_segment t sigma xs residual sigma' : - ExactThreadSegment t sigma xs residual sigma' -> - ThreadSegment t sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]. - - apply segment_yield. - - apply segment_guard; exact IH. - - eapply segment_user; [|exact IH]. - eapply equ_clos_sbisim_goal; [exact Eh|reflexivity|reflexivity]. - - eapply segment_equ; eassumption. -Qed. - -Lemma ExactThreadSegment_equ_input t u sigma xs residual sigma' : - t ≅ u -> ExactThreadSegment t sigma xs residual sigma' -> - ExactThreadSegment u sigma xs residual sigma'. -Proof. - intros E H; eapply exact_segment_equ; [symmetry; exact E|exact H|reflexivity]. -Qed. - -Lemma ExactThreadSegment_equ_output t sigma xs residual residual' sigma' : - ExactThreadSegment t sigma xs residual sigma' -> residual ≅ residual' -> - ExactThreadSegment t sigma xs residual' sigma'. -Proof. intros H E; eapply exact_segment_equ; [reflexivity|exact H|exact E]. Qed. - -Lemma ExactThreadSegment_guard_inv_equ t sigma xs residual sigma' : - ExactThreadSegment t sigma xs residual sigma' -> - forall u, t ≅ Guard u -> ExactThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t v sigma xs v' residual sigma' Etv H IH Eout]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E; apply equ_guard_invE in E. - eapply ExactThreadSegment_equ_input; [exact E|exact H]. - - intros u E; step in E; cbn in E; inversion E. - - intros u E. - eapply ExactThreadSegment_equ_output; [|exact Eout]. - apply IH; transitivity t; [symmetry; exact Etv|exact E]. -Qed. - -Lemma ExactThreadSegment_guard_inv t sigma xs residual sigma' : - ExactThreadSegment (Guard t) sigma xs residual sigma' -> - ExactThreadSegment t sigma xs residual sigma'. -Proof. intro H; eapply ExactThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. - -Lemma ExactThreadSegment_guard_iff t sigma xs residual sigma' : - ExactThreadSegment (Guard t) sigma xs residual sigma' <-> - ExactThreadSegment t sigma xs residual sigma'. -Proof. split; [apply ExactThreadSegment_guard_inv|apply exact_segment_guard]. Qed. - -Lemma guard_equ_exact_segment_iff t u : guard_equ t u -> - forall sigma xs residual sigma', - ExactThreadSegment t sigma xs residual sigma' <-> - ExactThreadSegment u sigma xs residual sigma'. -Proof. - intro H; induction H as [t u E|t u H IH|t u H IH|t u H IH|t u v H1 IH1 H2 IH2]; - intros sigma xs residual sigma'. - - split; intro Hseg. - + eapply ExactThreadSegment_equ_input; [exact E|exact Hseg]. - + eapply ExactThreadSegment_equ_input; [symmetry; exact E|exact Hseg]. - - rewrite ExactThreadSegment_guard_iff; apply IH. - - rewrite ExactThreadSegment_guard_iff; apply IH. - - symmetry; apply IH. - - transitivity (ExactThreadSegment u sigma xs residual sigma'); [apply IH1|apply IH2]. -Qed. - -Lemma ThreadSegment_branchfree t sigma logs residual sigma' : - ThreadSegment t sigma logs residual sigma' -> - BranchFree t -> BranchFree residual. -Proof. - intro H; induction H as - [k sigma|t sigma logs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma logs u' residual sigma' Etu H IH Eout]; intro Hbf. - - apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; auto. - - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; assumption. - - apply IH; apply branchfree_unfold in Hbf; cbn in Hbf. - dependent destruction Hbf; auto. - - eapply branchfree_equ_impl; [exact Eout|]. - apply IH; eapply branchfree_equ_impl; eassumption. -Qed. - -(** An exact segment may end at a residual differing from its target only by - finite leading guards and raw tree equivalence. *) -Definition exact_source_segment_to (t : thread sE) (sigma : SSig) - (logs : list SObs) (target : thread sE) (sigma' : SSig) : Prop := - exists residual, ExactThreadSegment t sigma logs residual sigma' /\ - guard_equ residual target. - -Lemma exact_source_equ t u sigma logs target sigma' : - t ≅ u -> exact_source_segment_to u sigma logs target sigma' -> - exact_source_segment_to t sigma logs target sigma'. -Proof. - intros Htu (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ; [exact Htu|exact Hseg|reflexivity]. -Qed. + Naming them is not a compatibility layer: they are the two arguments the + generic segment theory is instantiated at. *) +Notation csl_sb := + (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ~ u). +Notation csl_equ := + (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ≅ u). +(** ** Source-instruction rules, in exact mode. *) Lemma exact_source_bind {A B} (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) sigma logs target sigma' : - exact_source_segment_to (denote_flow p >>= fun flow => + segment_to sh csl_equ (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end) sigma logs target sigma' -> - exact_source_segment_to (denote_flow (CBind p next) >>= K) sigma logs target sigma'. + segment_to sh csl_equ (denote_flow (CBind p next) >>= K) sigma logs target sigma'. Proof. - intro H; eapply exact_source_equ; [apply source_raw_bind|exact H]. + intro H; eapply segment_to_equ; [apply source_raw_bind|exact H]. Qed. Lemma exact_source_ret {A} (x : A) (K : option A -> thread sE) sigma logs target sigma' : - exact_source_segment_to (K (Some x)) sigma logs target sigma' -> - exact_source_segment_to (denote_flow (CRet x) >>= K) sigma logs target sigma'. + segment_to sh csl_equ (K (Some x)) sigma logs target sigma' -> + segment_to sh csl_equ (denote_flow (CRet x) >>= K) sigma logs target sigma'. Proof. - intro H; eapply exact_source_equ; [apply source_raw_ret|exact H]. + intro H; eapply segment_to_equ; [apply source_raw_ret|exact H]. Qed. Lemma exact_source_until {A} (body : CProg (option A)) (K : option unit -> thread sE) sigma logs target sigma' : - exact_source_segment_to (denote_flow body >>= until_tail body K) + segment_to sh csl_equ (denote_flow body >>= until_tail body K) sigma logs target sigma' -> - exact_source_segment_to (denote_flow (CUntilNone body) >>= K) + segment_to sh csl_equ (denote_flow (CUntilNone body) >>= K) sigma logs target sigma'. Proof. - intro H; eapply exact_source_equ; [apply source_raw_until|exact H]. + intro H; eapply segment_to_equ; [apply source_raw_until|exact H]. Qed. Lemma exact_source_read a v (K : option nat -> thread sE) h c logs target sigma' : h a = Some v -> - exact_source_segment_to (K (Some v)) (h,c) logs target sigma' -> - exact_source_segment_to (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. + segment_to sh csl_equ (K (Some v)) (h,c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. Proof. intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) + eapply segment_equ with (u' := residual) (u := Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))). - apply source_raw_read_head. - - change (ExactThreadSegment (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_rd_some a h c v Hr); reflexivity. + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_rd_some a h c v Hr); reflexivity. - reflexivity. Qed. Lemma exact_source_write a v (K : option unit -> thread sE) h c logs target sigma' : h a <> None -> - exact_source_segment_to (K (Some tt)) (upd h a v,c) logs target sigma' -> - exact_source_segment_to (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. + segment_to sh csl_equ (K (Some tt)) (upd h a v,c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. Proof. intros Hp (residual & Hseg & Htail). destruct (h a) as [w|] eqn:Hw; [|contradiction]. exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) + eapply segment_equ with (u' := residual) (u := Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))). - apply source_raw_write_head. - - change (ExactThreadSegment (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (sh_wr_some a h c v w Hw); reflexivity. + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_wr_some a h c v w Hw); reflexivity. - reflexivity. Qed. +(** The raw handler equation [h_indexed_log] is the response certificate here; + [interp_indexed_emit] is an interpretation equation and cannot discharge + this premise. *) Lemma exact_source_emit tag block (K : option unit -> thread sE) h c logs target sigma' : - exact_source_segment_to (K (Some tt)) (h,S c) logs target sigma' -> - exact_source_segment_to (denote_flow (CEmit tag block) >>= K) (h,c) - (SPop tag block c :: logs) target sigma'. + segment_to sh csl_equ (K (Some tt)) (h,S c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CEmit tag block) >>= K) (h,c) + (stamp (tag,block) c :: logs) target sigma'. Proof. intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) + eapply segment_equ with (u' := residual) (u := Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))). - apply source_raw_emit_head. - - change (ExactThreadSegment + - change (ThreadSegment sh csl_equ (Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))) - (h,c) ([SPop tag block c] ++ logs) residual sigma'). - eapply exact_segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite sh_emit; reflexivity. + (h,c) ([stamp (tag,block) c] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (h_indexed_log (Sigma:=Heap) (tag,block) h c); + reflexivity. - reflexivity. Qed. Lemma exact_source_cas_success a expected desired (K : option bool -> thread sE) h c logs target sigma' : h a = Some expected -> - exact_source_segment_to (K (Some true)) (upd h a desired,c) logs target sigma' -> - exact_source_segment_to (denote_flow (CCAS a expected desired) >>= K) + segment_to sh csl_equ (K (Some true)) (upd h a desired,c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) (h,c) logs target sigma'. Proof. intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) + eapply segment_equ with (u' := residual) (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). - apply source_raw_cas_head. - - change (ExactThreadSegment + - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_cas_success a expected desired h c Hr); reflexivity. + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + rewrite (heap_handler_cas_success a expected desired h c Hr); reflexivity. - reflexivity. Qed. Lemma exact_source_cas_failure a expected desired current (K : option bool -> thread sE) h c logs target sigma' : h a = Some current -> current <> expected -> - exact_source_segment_to (K (Some false)) (h,c) logs target sigma' -> - exact_source_segment_to (denote_flow (CCAS a expected desired) >>= K) + segment_to sh csl_equ (K (Some false)) (h,c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) (h,c) logs target sigma'. Proof. intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply exact_segment_equ with (u' := residual) + eapply segment_equ with (u' := residual) (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). - apply source_raw_cas_head. - - change (ExactThreadSegment + - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) (h,c) ([] ++ logs) residual sigma'). - eapply exact_segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (sh_cas_failure a expected desired current h c Hr Hne); + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + rewrite (heap_handler_cas_failure a expected desired current h c Hr Hne); reflexivity. - reflexivity. Qed. Lemma exact_source_yield (K : option unit -> thread sE) sigma target : guard_equ (K (Some tt)) target -> - exact_source_segment_to (denote_flow CYield >>= K) sigma [] target sigma. + segment_to sh csl_equ (denote_flow CYield >>= K) sigma [] target sigma. Proof. intro Htail; exists (K (Some tt)); split; [|exact Htail]. - eapply exact_segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). + eapply segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). - apply source_raw_yield_head. - - apply exact_segment_yield. + - apply segment_yield. - reflexivity. Qed. @@ -852,109 +196,3 @@ Ltac csl_raw_equ := | |- _ ≅ (Ret _ >>= _) => symmetry; csl_raw_equ | |- Guard _ ≅ Guard _ => apply guard_equ_node; csl_raw_equ end]. - -#[global] Instance source_guard_equ_proper : - Proper (equ eq ==> equ eq ==> iff) guard_equ. -Proof. - intros t t' Ht u u' Hu; split; intro H. - - eapply guard_equ_trans; [apply guard_equ_equ; symmetry; exact Ht|]. - eapply guard_equ_trans; [exact H|apply guard_equ_equ; exact Hu]. - - eapply guard_equ_trans; [apply guard_equ_equ; exact Ht|]. - eapply guard_equ_trans; [exact H|apply guard_equ_equ; symmetry; exact Hu]. -Qed. - -Lemma exact_rr_user_replaced n (ts : pool sE (S n)) (i : Fin.t (S n)) - (e : sE) (k : encode e -> thread sE) m sigma : - interp_schedule_rr sh (S n) - (ts @ i := (@go CEff _ unit (VisF (inr (inr e) : CEff) k))) (Some i) m sigma ≅ - (runStateT (sh e) sigma >>= fun '(x,sigma') => - rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma')). -Proof. - etransitivity. - - eapply segment_rr_user_exact; rewrite Vector.nth_replace_eq; reflexivity. - - apply equ_clo_bind with (S := eq); [reflexivity|]. - intros [x sigma'] y <-; rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma exact_segment_rr_prefix n (ts : pool sE (S n)) (i : Fin.t (S n)) - t m sigma logs residual sigma' : - ExactThreadSegment t sigma logs residual sigma' -> - exists word, rr_prefix_events word = logs /\ - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ≅ - rr_prefix word (Guard - (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma')). -Proof. - intro H; revert n ts i m. - induction H as - [k sigma - |t sigma logs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma logs u' residual sigma' Etu H IH Eout]; intros n ts i m. - - exists []; split; [reflexivity|]; cbn [rr_prefix]. - etransitivity. - + eapply segment_rr_yield_exact; rewrite Vector.nth_replace_eq; reflexivity. - + rewrite Vector.replace_replace_eq; reflexivity. - - destruct (IH n ts i m) as (word & Ew & Et). - exists (RRGuard :: word); split; [exact Ew|]; cbn [rr_prefix]. - etransitivity. - + eapply segment_rr_guard_exact; rewrite Vector.nth_replace_eq; reflexivity. - + apply guard_equ_node; rewrite Vector.replace_replace_eq; exact Et. - - destruct (IH n ts i m) as (word & Ew & Et). - exists (List.map RRLog before ++ RRGuard :: RRGuard :: RRGuard :: word); split. - + rewrite rr_prefix_events_app, rr_prefix_events_logs; cbn [rr_prefix_events]. - now rewrite Ew. - + etransitivity; [apply exact_rr_user_replaced|]. - set (resume := fun response : (encode e * SSig)%type => - let '(x,sigma0) := response in - rr_guards 3 (interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma0)). - transitivity (emit_list before (Ret (result,sigma1)) >>= resume). - * apply equ_clo_bind with (S := eq); [exact Eh|intros x y <-; reflexivity]. - * etransitivity; [apply emit_list_ret_bind|]; unfold resume. - transitivity (emit_list before - (rr_guards 3 (rr_prefix word (Guard - (interp_schedule_rr sh (S n) (ts @ i := residual) None m sigma'))))). - -- apply emit_list_equ, rr_guards_equ; exact Et. - -- rewrite rr_prefix_app; cbn [rr_prefix rr_guards]. - symmetry; apply rr_prefix_emit. - - destruct (IH n ts i m) as (word & Ew & Et). - exists word; split; [exact Ew|]. - etransitivity. - + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|exact Etu]. - + etransitivity; [exact Et|]. - apply rr_prefix_equ, guard_equ_node, interp_schedule_rr_equ, replace_pool_equ; - [apply pool_equ_refl|exact Eout]. -Qed. - -Theorem source_segment_scheduler_steps {n} (ts : pool sE (S n)) sigma i logs residual sigma' ts' : - ThreadSegment (ts $ i) sigma logs residual sigma' -> - pool_equ ts' (ts @ i := residual) -> - exists next, - finite_steps (interp_nd (S n) ts None sigma) - (tau :: List.map (fun o => obs (Log o) tt) logs) next /\ - next ~ interp_nd (S n) ts' None sigma'. -Proof. - intros Hseg Epool. - assert (Efocused : interp_nd (S n) ts (Some i) sigma ~ - emit_list logs (interp_nd (S n) ts' None sigma')). - { - transitivity (interp_nd (S n) (ts @ i := (ts $ i)) (Some i) sigma). - - rewrite (interp_nd_equ (S n) _ _ (Some i) sigma (source_replace_current (S n) ts i)); - reflexivity. - - transitivity (emit_list logs (interp_nd (S n) (ts @ i := residual) None sigma')). - + eapply segment_interp_nd; exact Hseg. - + apply emit_list_sbisim. - rewrite <- (interp_nd_equ (S n) _ _ None sigma' Epool); reflexivity. - } - assert (Hbranch : trans tau (Br n (fun j => interp_nd (S n) ts (Some j) sigma)) - (interp_nd (S n) ts (Some i) sigma)). - { eapply trans_br with (x := i); reflexivity. } - pose proof (interp_nd_select n ts sigma) as Eselect; symmetry in Eselect. - destruct (sbisim_trans _ _ _ tau eq Eselect Hbranch) - as (l & focused & Hchoose & El & Efocus); subst l. - assert (Eemit : emit_list logs (interp_nd (S n) ts' None sigma') ~ focused). - { transitivity (interp_nd (S n) ts (Some i) sigma); [symmetry; exact Efocused|exact Efocus]. } - destruct (finite_steps_sbisim _ _ _ - (finite_steps_emit_list logs (interp_nd (S n) ts' None sigma')) focused Eemit) - as (next & Hlogs & Enext). - exists next; split; [econstructor; eassumption|symmetry; exact Enext]. -Qed. diff --git a/theories/Lang/CSL/Ticl.v b/theories/Lang/CSL/Ticl.v index 7b0265c..2962ce6 100644 --- a/theories/Lang/CSL/Ticl.v +++ b/theories/Lang/CSL/Ticl.v @@ -1,11 +1,12 @@ From Stdlib Require Import Arith.PeanoNat Fin Vector. +From Coinduction Require Import coinduction lattice tactics. From TICL Require Import - Lang.CSL.Syntax Lang.CSL.Pcm Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp + Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield ICTree.Events.Heap ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.Bind ICTree.Logic.State Logic.Core Utils.Vectors. + ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep Logic.Core Utils.Vectors. Import ICtree ICTreeNotations TiclNotations VectorNotations. Local Open Scope ictree_scope. @@ -16,88 +17,90 @@ Local Typeclasses Transparent equ sbisim. (** ** Selection from an unfocused nonempty pool *) Lemma anl_csl_nd_select n (ts : pool sE (S n)) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) ts (None) (h,c)}, {w} |= φ AN ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) ts (Some j) (h,c)}, {w} |= ψ )>)). Proof. - rewrite interp_nd_select. + rewrite (interp_schedule_nd_select sh). apply anl_br. Qed. Lemma anr_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) ts (None) (h,c)}, {w} |= φ AN ψ ]> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) ts (Some j) (h,c)}, {w} |= ψ ]>)). Proof. - rewrite interp_nd_select. + rewrite (interp_schedule_nd_select sh). apply anr_br. Qed. Lemma aul_csl_nd_select n (ts : pool sE (S n)) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) ts (None) (h,c)}, {w} |= φ AU ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= ψ )> \/ (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) ts (Some j) (h,c)}, {w} |= φ AU ψ )>))). + +From Coinduction Require Import coinduction. Proof. - rewrite interp_nd_select. + rewrite (interp_schedule_nd_select sh). symmetry; apply aul_br. Qed. Lemma aur_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) ts (None) (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= ψ ]> \/ (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) ts (Some j) (h,c)}, {w} |= φ AU ψ ]>))). Proof. - rewrite interp_nd_select. + rewrite (interp_schedule_nd_select sh). symmetry; apply aur_br. Qed. Lemma ag_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) ts (None) (h,c)}, {w} |= AG φ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) ts (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) ts (Some j) (h,c)}, {w} |= AG φ )>)). Proof. - rewrite interp_nd_select. + rewrite (interp_schedule_nd_select sh). symmetry; apply ag_br. Qed. Lemma anl_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) ts (None) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -107,7 +110,7 @@ Proof. Qed. Lemma anr_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) ts (None) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -117,7 +120,7 @@ Proof. Qed. Lemma aul_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) ts (None) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -127,7 +130,7 @@ Proof. Qed. Lemma aur_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) ts (None) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -137,7 +140,7 @@ Proof. Qed. Lemma ag_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) ts (None) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) @@ -150,11 +153,11 @@ Qed. Lemma anl_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some value -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). Proof. intros Lookup. @@ -163,11 +166,11 @@ Qed. Lemma anr_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some value -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. @@ -176,11 +179,11 @@ Qed. Lemma aul_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some value -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). Proof. intros Lookup. @@ -189,11 +192,11 @@ Qed. Lemma aur_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some value -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. @@ -202,11 +205,11 @@ Qed. Lemma ag_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a = Some value -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= AG φ )>)). Proof. intros Lookup. @@ -215,7 +218,7 @@ Qed. Lemma anl_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> @@ -228,7 +231,7 @@ Qed. Lemma anr_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> @@ -241,7 +244,7 @@ Qed. Lemma aul_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> @@ -254,7 +257,7 @@ Qed. Lemma aur_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> @@ -267,7 +270,7 @@ Qed. Lemma ag_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) a value (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> @@ -280,11 +283,11 @@ Qed. Lemma anl_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a <> None -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ )>)). Proof. intros Present. @@ -293,11 +296,11 @@ Qed. Lemma anr_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a <> None -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ ]>)). Proof. intros Present. @@ -306,11 +309,11 @@ Qed. Lemma aul_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a <> None -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ )>)). Proof. intros Present. @@ -319,11 +322,11 @@ Qed. Lemma aur_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a <> None -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ ]>)). Proof. intros Present. @@ -332,11 +335,11 @@ Qed. Lemma ag_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a <> None -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= AG φ )>)). Proof. intros Present. @@ -345,7 +348,7 @@ Qed. Lemma anl_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> @@ -358,7 +361,7 @@ Qed. Lemma anr_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> @@ -371,7 +374,7 @@ Qed. Lemma aul_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> @@ -384,7 +387,7 @@ Qed. Lemma aur_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> @@ -397,7 +400,7 @@ Qed. Lemma ag_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) a v (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> @@ -410,12 +413,12 @@ Qed. Lemma anl_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>)). Proof. intros Pos Base Free First. @@ -424,12 +427,12 @@ Qed. Lemma anr_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>)). Proof. intros Pos Base Free First. @@ -438,12 +441,12 @@ Qed. Lemma aul_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>)). Proof. intros Pos Base Free First. @@ -452,12 +455,12 @@ Qed. Lemma aur_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>)). Proof. intros Pos Base Free First. @@ -466,12 +469,12 @@ Qed. Lemma ag_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>)). Proof. intros Pos Base Free First. @@ -480,7 +483,7 @@ Qed. Lemma anl_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) @@ -494,7 +497,7 @@ Qed. Lemma anr_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_rr sh (S n) @@ -508,7 +511,7 @@ Qed. Lemma aul_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) @@ -522,7 +525,7 @@ Qed. Lemma aur_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_rr sh (S n) @@ -536,7 +539,7 @@ Qed. Lemma ag_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) size base (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) @@ -550,15 +553,15 @@ Qed. Lemma anl_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some current -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> (<( {if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). Proof. intros Lookup. @@ -567,15 +570,15 @@ Qed. Lemma anr_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some current -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. @@ -584,15 +587,15 @@ Qed. Lemma aul_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some current -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> (<( {if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). Proof. intros Lookup. @@ -601,15 +604,15 @@ Qed. Lemma aur_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some current -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. @@ -618,15 +621,15 @@ Qed. Lemma ag_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a = Some current -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> (<( {if Nat.eqb current expected then - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some true)) (Some i) (upd h a desired,c) else - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= AG φ )>)). Proof. intros Lookup. @@ -635,7 +638,7 @@ Qed. Lemma anl_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> @@ -652,7 +655,7 @@ Qed. Lemma anr_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> @@ -669,7 +672,7 @@ Qed. Lemma aul_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> @@ -686,7 +689,7 @@ Qed. Lemma aur_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> @@ -703,7 +706,7 @@ Qed. Lemma ag_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> @@ -722,10 +725,10 @@ Qed. Lemma anl_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). Proof. rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. @@ -733,10 +736,10 @@ Qed. Lemma anr_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). Proof. rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. @@ -744,10 +747,10 @@ Qed. Lemma aul_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). Proof. rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. @@ -755,10 +758,10 @@ Qed. Lemma aur_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). Proof. rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. @@ -766,10 +769,10 @@ Qed. Lemma ag_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= AG φ )>)). Proof. rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. @@ -777,7 +780,7 @@ Qed. Lemma anl_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -788,7 +791,7 @@ Qed. Lemma anr_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -799,7 +802,7 @@ Qed. Lemma aul_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -810,7 +813,7 @@ Qed. Lemma aur_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -821,7 +824,7 @@ Qed. Lemma ag_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) @@ -832,10 +835,10 @@ Qed. Lemma anl_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). Proof. @@ -844,10 +847,10 @@ Qed. Lemma anr_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). Proof. @@ -856,10 +859,10 @@ Qed. Lemma aul_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). Proof. @@ -868,10 +871,10 @@ Qed. Lemma aur_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). Proof. @@ -880,10 +883,10 @@ Qed. Lemma ag_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= AG φ )>)). Proof. @@ -892,7 +895,7 @@ Qed. Lemma anl_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -904,7 +907,7 @@ Qed. Lemma anr_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -916,7 +919,7 @@ Qed. Lemma aul_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -928,7 +931,7 @@ Qed. Lemma aur_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -940,7 +943,7 @@ Qed. Lemma ag_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) @@ -952,10 +955,10 @@ Qed. Lemma anl_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). Proof. rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. @@ -963,10 +966,10 @@ Qed. Lemma anr_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). Proof. rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. @@ -974,10 +977,10 @@ Qed. Lemma aul_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). Proof. rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. @@ -985,10 +988,10 @@ Qed. Lemma aur_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). Proof. rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. @@ -996,10 +999,10 @@ Qed. Lemma ag_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= AG φ )>)). Proof. rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. @@ -1007,7 +1010,7 @@ Qed. Lemma anl_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1018,7 +1021,7 @@ Qed. Lemma anr_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -1029,7 +1032,7 @@ Qed. Lemma aul_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1040,7 +1043,7 @@ Qed. Lemma aur_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -1051,7 +1054,7 @@ Qed. Lemma ag_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1062,10 +1065,10 @@ Qed. Lemma anl_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_nd (S (S n)) + (<( {interp_schedule_nd sh (S (S n)) ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ )>)). Proof. rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. @@ -1073,10 +1076,10 @@ Qed. Lemma anr_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_nd (S (S n)) + (<[ {interp_schedule_nd sh (S (S n)) ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ ]>)). Proof. rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. @@ -1084,10 +1087,10 @@ Qed. Lemma aul_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_nd (S (S n)) + (<( {interp_schedule_nd sh (S (S n)) ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ )>)). Proof. rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. @@ -1095,10 +1098,10 @@ Qed. Lemma aur_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_nd (S (S n)) + (<[ {interp_schedule_nd sh (S (S n)) ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ ]>)). Proof. rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. @@ -1106,10 +1109,10 @@ Qed. Lemma ag_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_nd (S (S n)) + (<( {interp_schedule_nd sh (S (S n)) ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= AG φ )>)). Proof. rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. @@ -1117,7 +1120,7 @@ Qed. Lemma anl_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S (S n)) @@ -1128,7 +1131,7 @@ Qed. Lemma anr_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S (S n)) @@ -1139,7 +1142,7 @@ Qed. Lemma aul_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S (S n)) @@ -1150,7 +1153,7 @@ Qed. Lemma aur_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S (S n)) @@ -1161,7 +1164,7 @@ Qed. Lemma ag_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S (S n)) @@ -1174,14 +1177,14 @@ Qed. Lemma anl_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_nd (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ )>)). + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). Proof. rewrite interp_nd_source_emit_log. apply anl_log_iff. @@ -1189,14 +1192,14 @@ Qed. Lemma anr_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <[ {interp_nd (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ ]>)). + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). Proof. rewrite interp_nd_source_emit_log. apply anr_log_iff. @@ -1204,17 +1207,17 @@ Qed. Lemma aul_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ )> \/ - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_nd (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ )>))). + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). Proof. rewrite interp_nd_source_emit_log. apply aul_log_iff. @@ -1222,17 +1225,17 @@ Qed. Lemma aur_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (SPop tag value c);; - interp_nd (S n) + (<[ {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ ]> \/ - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <[ {interp_nd (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ ]>))). + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). Proof. rewrite interp_nd_source_emit_log. apply aur_log_iff. @@ -1240,14 +1243,14 @@ Qed. Lemma ag_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {log (SPop tag value c);; - interp_nd (S n) + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_nd (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= AG φ )>)). + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). Proof. rewrite interp_nd_source_emit_log. apply ag_log_iff. @@ -1255,14 +1258,14 @@ Qed. Lemma anl_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ )>)). + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). Proof. rewrite interp_rr_emit_log. apply anl_log_iff. @@ -1270,14 +1273,14 @@ Qed. Lemma anr_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= ψ ]>)). + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). Proof. rewrite interp_rr_emit_log. apply anr_log_iff. @@ -1285,17 +1288,17 @@ Qed. Lemma aul_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ )> \/ - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ )>))). + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). Proof. rewrite interp_rr_emit_log. apply aul_log_iff. @@ -1303,17 +1306,17 @@ Qed. Lemma aur_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (SPop tag value c);; + (<[ {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ ]> \/ - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= φ AU ψ ]>))). + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). Proof. rewrite interp_rr_emit_log. apply aur_log_iff. @@ -1321,14 +1324,14 @@ Qed. Lemma ag_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {log (SPop tag value c);; + (<( {log (stamp (tag,value) c);; interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (SPop tag value c)) tt} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). Proof. rewrite interp_rr_emit_log. apply ag_log_iff. @@ -1336,14 +1339,14 @@ Qed. Lemma anl_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ )>)). Proof. rewrite interp_nd_source_yield. @@ -1352,14 +1355,14 @@ Qed. Lemma anr_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ ]>)). Proof. rewrite interp_nd_source_yield. @@ -1368,17 +1371,17 @@ Qed. Lemma aul_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ )> \/ (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ )>))). Proof. rewrite interp_nd_source_yield. @@ -1387,17 +1390,17 @@ Qed. Lemma aur_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ ]> \/ (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ ]>))). Proof. rewrite interp_nd_source_yield. @@ -1406,14 +1409,14 @@ Qed. Lemma ag_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> (<( {Br n (fun j : Fin.t (S n) => - interp_nd (S n) + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ forall j : Fin.t (S n), - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= AG φ )>)). Proof. rewrite interp_nd_source_yield. @@ -1422,7 +1425,7 @@ Qed. Lemma anl_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1434,7 +1437,7 @@ Qed. Lemma anr_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -1446,7 +1449,7 @@ Qed. Lemma aul_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1458,7 +1461,7 @@ Qed. Lemma aur_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) @@ -1470,7 +1473,7 @@ Qed. Lemma ag_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) (K : option unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) @@ -1484,21 +1487,21 @@ Qed. Lemma anl_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. apply (proj1 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1506,21 +1509,21 @@ Qed. Lemma anr_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. apply (proj1 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1528,21 +1531,21 @@ Qed. Lemma aul_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. apply (proj1 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1550,21 +1553,21 @@ Qed. Lemma aur_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> - (<[ {interp_nd (S n) + (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_nd (S n) + <[ {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. apply (proj1 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1572,21 +1575,21 @@ Qed. Lemma ag_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> - (<( {interp_nd (S n) + (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_nd (S n) + <( {interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. apply (proj1 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)). apply Hall; assumption. @@ -1594,7 +1597,7 @@ Qed. Lemma anl_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> @@ -1608,7 +1611,7 @@ Proof. - intros Hsource base Base Free First. apply (proj1 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1616,7 +1619,7 @@ Qed. Lemma anr_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> @@ -1630,7 +1633,7 @@ Proof. - intros Hsource base Base Free First. apply (proj1 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1638,7 +1641,7 @@ Qed. Lemma aul_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> @@ -1652,7 +1655,7 @@ Proof. - intros Hsource base Base Free First. apply (proj1 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1660,7 +1663,7 @@ Qed. Lemma aur_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> @@ -1674,7 +1677,7 @@ Proof. - intros Hsource base Base Free First. apply (proj1 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). apply Hall; assumption. @@ -1682,7 +1685,7 @@ Qed. Lemma ag_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) size (K : option nat -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> @@ -1696,7 +1699,7 @@ Proof. - intros Hsource base Base Free First. apply (proj1 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (sh_alloc_finite h size c Finite Pos) + destruct (heap_handler_alloc_finite h size c Finite Pos) as (base & Base & Free & First & _). apply (proj2 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)). apply Hall; assumption. @@ -1706,110 +1709,223 @@ Qed. Lemma anl_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - <( {interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AN ψ )>). + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AN ψ )>). Proof. rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. Qed. Lemma anr_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - <[ {interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AN ψ ]>). + <[ {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AN ψ ]>). Proof. rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. Qed. Lemma aul_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c w - (φ ψ : ticllW SObs) : - (<( {interp_nd (S n) + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - <( {interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AU ψ )>). + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AU ψ )>). Proof. rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. Qed. Lemma aur_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : - (<[ {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - <[ {interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= φ AU ψ ]>). + <[ {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AU ψ ]>). Proof. rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. Qed. Lemma ag_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) h c w - (φ : ticllW SObs) : - (<( {interp_nd (S n) + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - <( {interp_nd (S n) - (ts @ i := K tt) (Some i) (Pcm.hfree a h,c)}, {w} |= AG φ )>). + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= AG φ )>). Proof. rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. Qed. Lemma anl_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AN ψ )>). + (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AN ψ )>). Proof. rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. Qed. Lemma anr_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AN ψ ]>). + (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AN ψ ]>). Proof. rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. Qed. Lemma aul_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) m h c w - (φ ψ : ticllW SObs) : + (φ ψ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AU ψ )>). + (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AU ψ )>). Proof. rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. Qed. Lemma aur_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) m h c w - (φ : ticllW SObs) (ψ : ticlrW SObs (unit * SSig)) : + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= φ AU ψ ]>). + (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AU ψ ]>). Proof. rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. Qed. Lemma ag_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) a (K : unit -> thread sE) m h c w - (φ : ticllW SObs) : + (φ : ticllW (indexed (nat * nat))) : (<( {interp_schedule_rr sh (S n) (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (Pcm.hfree a h,c)}, {w} |= AG φ )>). + (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= AG φ )>). Proof. rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. Qed. + +(** ** Source loops: actual observations sustain AG; guard-only divergence does not *) + +Lemma run_nd_emit_loop_ag tag value h c w : + not_done w -> + <( {run_nd (CUntilNone (CBind (CEmit tag value) + (fun _ => CRet (Some tt : option unit)))) h c}, {w} |= AG ⊤ )>. +Proof. + revert c w; coinduction R CIH; intros c w Hw. + unfold run_nd, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_schedule_nd sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) (h,c)) w). + rewrite interp_nd_source_until_none, interp_nd_source_bind, + interp_nd_source_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_nd_source_ret. + erewrite (interp_schedule_nd_guard sh) by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. +Qed. + +Lemma run_rr_emit_loop_ag tag value h c w : + not_done w -> + <( {run_rr (CUntilNone (CBind (CEmit tag value) + (fun _ => CRet (Some tt : option unit)))) h c}, {w} |= AG ⊤ )>. +Proof. + revert c w; coinduction R CIH; intros c w Hw. + unfold run_rr, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_schedule_rr sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (h,c)) w). + rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_rr_ret. + erewrite interp_schedule_rr_guard by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. +Qed. + +(** The silent loop starts focused, so the whole run is raw-equivalent to its + own guard and hence to [stuck]; no scheduler tau is erased. *) +Lemma run_nd_silent_loop_no_ag h c w : + ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) h c}, {w} |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + assert (Hguard : run_nd p h c ≅ Guard (run_nd p h c)). + { unfold run_nd. + etransitivity. + - apply ((interp_schedule_nd_equ sh) 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_schedule_nd. + rewrite (SBisim.trans_schedule_focused_guard + 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, Mod.interp_state_tau. + reflexivity. } + rewrite (equ_guard_stuck _ Hguard). + apply ag_stuck. +Qed. + +Lemma run_rr_silent_loop_no_ag h c w : + ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) h c}, {w} |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + assert (Hguard : run_rr p h c ≅ Guard (run_rr p h c)). + { unfold run_rr. + etransitivity. + - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_schedule_rr. + rewrite unfold_run_round_robin, + (schedule_focused_guard 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, Mod.interp_state_tau. + reflexivity. } + rewrite (equ_guard_stuck _ Hguard). + apply ag_stuck. +Qed. diff --git a/theories/Lang/HeapImp.v b/theories/Lang/HeapImp.v index a775768..49fbf19 100644 --- a/theories/Lang/HeapImp.v +++ b/theories/Lang/HeapImp.v @@ -1,7 +1,8 @@ From Stdlib Require Import Nat Strings.String - QArith.QArith. + QArith.QArith + Arith.PeanoNat. From ExtLib Require Import @@ -143,6 +144,101 @@ Module HeapImp. end end. + (** Handler equations. Zero allocation and absent frees still log the + state; a matching CAS logs even when the value is unchanged, while a + mismatching CAS returns without logging. *) + Lemma instr_heapimp_alloc_zero (m : Mem) : + instr_stateE (h_heapimp (HAlloc 0)) m ~ + (log m;; Ret (fresh_addr (heap m),m)). + Proof. + destruct m as [s h]. + unfold h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + cbn [heap_init heap store]. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_put | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, interp_state_ret; reflexivity. + Qed. + + Lemma instr_heapimp_free a (m : Mem) : + instr_stateE (h_heapimp (HFree a)) m ~ + (log (free_heap a m);; Ret (tt,free_heap a m)). + Proof. + unfold h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + apply interp_state_put. + Qed. + + Lemma instr_heapimp_write a v (m : Mem) : + instr_stateE (h_heapimp (HWrite a v)) m ~ + (log (update_heap a v m);; Ret (tt,update_heap a v m)). + Proof. + unfold h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + apply interp_state_put. + Qed. + + Lemma instr_heapimp_cas_success a expected desired (m : Mem) : + lookup a (heap m) = Some expected -> + instr_stateE (h_heapimp (HCAS a expected desired)) m ~ + (log (update_heap a desired m);; Ret (true,update_heap a desired m)). + Proof. + intros Lookup. + unfold h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + rewrite Lookup, Nat.eqb_refl. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_put | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, interp_state_ret; reflexivity. + Qed. + + Lemma instr_heapimp_cas_failure a actual expected desired (m : Mem) : + lookup a (heap m) = Some actual -> actual <> expected -> + instr_stateE (h_heapimp (HCAS a expected desired)) m ~ Ret (false,m). + Proof. + intros Lookup Hne. + unfold h_heapimp, instr_stateE. + rewrite interp_state_bind. + lazymatch goal with |- (?t >>= ?k) ~ _ => + etransitivity; [apply sbisim_clo_bind_eq with (k2:=k); + [apply interp_state_get | intro result; reflexivity] |] + end. + rewrite bind_ret_l. + apply Nat.eqb_neq in Hne. + rewrite Lookup, Hne. + rewrite interp_state_ret; reflexivity. + Qed. + (** Denotation of expressions to [ictree] *) Fixpoint cdenote_exp(e: CExp): ictree memE nat := match e with diff --git a/theories/Utils/Execution.v b/theories/Utils/Execution.v new file mode 100644 index 0000000..d49b948 --- /dev/null +++ b/theories/Utils/Execution.v @@ -0,0 +1,501 @@ +(** * Infinite executions and finite replay. + + A reusable, language-independent execution record with: + + - a finite script runner [run_turns] over a partial transition, + - a constructive builder of an infinite execution from a choice + sequence and a total, invariant-preserving transition, + - counter/index bookkeeping, + - reachability through the Stdlib reflexive-transitive closure. + + Periodic choice sequences and window list facts live in [Utils.Lists]. + + This module imports only Stdlib, ExtLib and [Utils]; it never mentions + ictrees, schedulers, or any example. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat + Relations + Classes.Morphisms + Classes.RelationClasses + Classes.RelationPairs. + +From ExtLib Require Import Data.Option. + +From TICL Require Import Utils.Relations Utils.Lists. + +Import ListNotations. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** ** The record *) +Record Execution (St Act Out : Type) := { + states : nat -> St; + selected : nat -> Act; + emitted : nat -> Out +}. + +Arguments states {St Act Out} _ _. +Arguments selected {St Act Out} _ _. +Arguments emitted {St Act Out} _ _. + +Definition execution_valid {St Act Out} + (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) + (e : Execution St Act Out) : Prop := + initial (states e 0) /\ + forall k, step (selected e k) (states e k) (emitted e k) (states e (S k)). + +(** Every action is chosen infinitely often. *) +Definition fair_choices {Act} (pick : nat -> Act) : Prop := + forall a, infinitely (fun k => pick k = a). + +(** Result relations are ExtLib's inductive [Roption] and Stdlib's + [RelProd]; no client writes its own match-encoded result relation. *) + +(** ** Finite replay of a script *) +Section RunTurns. + Context {St Act Out W : Type} + (step : Act -> St -> option (St * Out)) + (logs : Out -> list W). + + Fixpoint run_turns (script : list Act) (s : St) : option (St * list W) := + match script with + | [] => Some (s,[]) + | who :: rest => + match step who s with + | None => None + | Some (next,output) => + match run_turns rest next with + | None => None + | Some (last,tail) => Some (last,logs output ++ tail) + end + end + end. + + Lemma run_turns_append left right s : + run_turns (left ++ right) s = + match run_turns left s with + | None => None + | Some (middle,first) => + match run_turns right middle with + | None => None + | Some (last,second) => Some (last,first ++ second) + end + end. + Proof. + revert s; induction left as [|who left IH]; intro s. + - cbn [run_turns app]. + destruct (run_turns right s) as [[last ws]|]; reflexivity. + - cbn [run_turns app]. + destruct (step who s) as [[next output]|]; [|reflexivity]. + rewrite IH. + destruct (run_turns left next) as [[middle first]|]; [|reflexivity]. + destruct (run_turns right middle) as [[last second]|]; [|reflexivity]. + now rewrite app_assoc. + Qed. + + Corollary run_turns_compose left right s middle last first second : + run_turns left s = Some (middle,first) -> + run_turns right middle = Some (last,second) -> + run_turns (left ++ right) s = Some (last,first ++ second). + Proof. + intros Hleft Hright; rewrite run_turns_append, Hleft, Hright; reflexivity. + Qed. + + Lemma run_turns_append_inv left right s last ws : + run_turns (left ++ right) s = Some (last,ws) -> + exists middle first second, + run_turns left s = Some (middle,first) /\ + run_turns right middle = Some (last,second) /\ + ws = first ++ second. + Proof. + rewrite run_turns_append; intro Hrun. + destruct (run_turns left s) as [[middle first]|] eqn:Hleft; [|discriminate]. + destruct (run_turns right middle) as [[last' second]|] eqn:Hright; + [|discriminate]. + inversion Hrun; subst. + exists middle, first, second; repeat split; assumption || reflexivity. + Qed. + + (** An invariant preserved by one transition is preserved by a whole run. *) + Lemma run_turns_preserves_inv (Inv : St -> Prop) + (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s') : + forall script s last ws, + Inv s -> run_turns script s = Some (last,ws) -> Inv last. + Proof. + induction script as [|who rest IH]; intros s last ws Hinv Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst; exact Hinv. + - cbn [run_turns] in Hrun. + destruct (step who s) as [[next output]|] eqn:Hstep; [|discriminate]. + destruct (run_turns rest next) as [[last' tail]|] eqn:Hrest; [|discriminate]. + inversion Hrun; subst. + eapply IH; [eapply preserves; eauto|exact Hrest]. + Qed. + + (** A total, invariant-preserving transition never faults on any script. *) + Lemma run_turns_total (Inv : St -> Prop) + (total : forall a s, Inv s -> exists r, step a s = Some r) + (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s') : + forall script s, Inv s -> exists last ws, run_turns script s = Some (last,ws). + Proof. + induction script as [|who rest IH]; intros s Hinv. + - exists s, []; reflexivity. + - cbn [run_turns]. + destruct (total who s Hinv) as ([next output] & Hstep). + rewrite Hstep. + destruct (IH next (preserves who s next output Hinv Hstep)) + as (last & tail & Hrest). + rewrite Hrest; exists last, (logs output ++ tail); reflexivity. + Qed. +End RunTurns. + +Arguments run_turns {St Act Out W} step logs script s. + +(** ** Congruence in the state, through an arbitrary state relation. *) +Section RunTurnsProper. + Context {St Act Out W : Type} + (step : Act -> St -> option (St * Out)) + (logs : Out -> list W) + (R : St -> St -> Prop) + (Hstep : Proper (eq ==> R ==> Roption (RelProd R eq)) step). + + Lemma step_some_compatible a s t s' o : + R s t -> step a s = Some (s',o) -> + exists t', step a t = Some (t',o) /\ R s' t'. + Proof. + intros Hst Hrun. + pose proof (Hstep a a eq_refl s t Hst) as H. + rewrite Hrun in H. + destruct (step a t) as [[t' o']|]; inversion H as [|p q Hpq]; subst. + unfold RelProd, RelCompFun in Hpq. + destruct Hpq as [Hnext Hobs]; cbn in Hnext, Hobs; subst o'. + exists t'; split; [reflexivity|exact Hnext]. + Qed. + + Lemma step_none_compatible a s t : + R s t -> (step a s = None <-> step a t = None). + Proof. + intro Hst; pose proof (Hstep a a eq_refl s t Hst) as H. + destruct (step a s); destruct (step a t); inversion H; + split; intro Hnone; congruence. + Qed. + + Lemma run_turns_proper script : + Proper (R ==> Roption (RelProd R eq)) (run_turns step logs script). + Proof. + revert script; intros script s t Hst; revert s t Hst. + induction script as [|who rest IH]; intros s t Hst. + - cbn [run_turns]; constructor; split; [exact Hst|exact eq_refl]. + - cbn [run_turns]. + pose proof (Hstep who who eq_refl s t Hst) as Hone. + destruct (step who s) as [[next output]|]; + destruct (step who t) as [[next' output']|]; + inversion Hone as [|p q Hpair]; subst; [|constructor]. + unfold RelProd, RelCompFun in Hpair. + destruct Hpair as [Hnext Hobs]; cbn in Hnext, Hobs; subst output'. + specialize (IH next next' Hnext). + destruct (run_turns step logs rest next) as [[last ws]|]; + destruct (run_turns step logs rest next') as [[last' ws']|]; + inversion IH as [|p q Hlast]; subst; [|constructor]. + unfold RelProd, RelCompFun in Hlast. + destruct Hlast as [Hlast Hlogs]; cbn in Hlast, Hlogs; subst ws'. + constructor; split; [exact Hlast|exact eq_refl]. + Qed. + + Corollary run_turns_some_compatible script s t last observations : + R s t -> run_turns step logs script s = Some (last,observations) -> + exists last', run_turns step logs script t = Some (last',observations) /\ + R last last'. + Proof. + intros Hst Hrun. + pose proof (run_turns_proper script s t Hst) as H. + rewrite Hrun in H. + destruct (run_turns step logs script t) as [[last' ws']|]; + inversion H as [|p q Hpq]; subst. + unfold RelProd, RelCompFun in Hpq. + destruct Hpq as [Hlast Hlogs]; cbn in Hlast, Hlogs; subst ws'. + exists last'; split; [reflexivity|exact Hlast]. + Qed. + + Corollary run_turns_none_compatible script s t : + R s t -> + (run_turns step logs script s = None <-> run_turns step logs script t = None). + Proof. + intro Hst; pose proof (run_turns_proper script s t Hst) as H. + destruct (run_turns step logs script s); destruct (run_turns step logs script t); + inversion H; split; intro Hnone; congruence. + Qed. +End RunTurnsProper. + +(** ** Constructing an infinite execution from a choice sequence. + + The impossible branch is eliminated in [Prop] using totality; no + existential witness is extracted into executable state, no classical + choice is used, and no initial/default state is manufactured on failure. *) +Section OfChoices. + Context {St Act Out : Type} + (step : Act -> St -> option (St * Out)) + (Inv : St -> Prop) + (total : forall a s, Inv s -> exists r, step a s = Some r) + (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s'). + + Definition next_valid (a : Act) (s : St) (Hinv : Inv s) + : { result : (St * Out)%type | step a s = Some result /\ Inv (fst result) }. + Proof. + destruct (step a s) as [[next output]|] eqn:Hstep. + - exists (next,output); split; [reflexivity|]. + eapply preserves; eauto. + - exfalso; destruct (total a s Hinv) as (r & H). + rewrite Hstep in H; discriminate. + Defined. + + Fixpoint chosen_state (s0 : St) (H0 : Inv s0) (picks : nat -> Act) (k : nat) + : { s : St | Inv s } := + match k with + | 0 => exist _ s0 H0 + | S j => + let prior := chosen_state s0 H0 picks j in + let next := next_valid (picks j) (proj1_sig prior) (proj2_sig prior) in + exist _ (fst (proj1_sig next)) (proj2 (proj2_sig next)) + end. + + Definition execution_of_choices (s0 : St) (H0 : Inv s0) (picks : nat -> Act) + : Execution St Act Out := + {| states := fun k => proj1_sig (chosen_state s0 H0 picks k); + selected := picks; + emitted := fun k => + let prior := chosen_state s0 H0 picks k in + snd (proj1_sig (next_valid (picks k) + (proj1_sig prior) (proj2_sig prior))) |}. + + Lemma execution_of_choices_valid s0 H0 picks : + execution_valid (fun a s o s' => step a s = Some (s',o)) + (fun s => s = s0) (execution_of_choices s0 H0 picks). + Proof. + split; [reflexivity|]; intro k. + unfold execution_of_choices; cbn [states selected emitted chosen_state]. + destruct (next_valid (picks k) + (proj1_sig (chosen_state s0 H0 picks k)) + (proj2_sig (chosen_state s0 H0 picks k))) as [[next output] [Hstep Hinv]]. + exact Hstep. + Qed. + + Lemma execution_of_choices_selected s0 H0 picks k : + selected (execution_of_choices s0 H0 picks) k = picks k. + Proof. reflexivity. Qed. + + (** A strict prefix of the choice sequence determines a prefix of states. *) + Lemma execution_of_choices_prefix s0 H0 picks picks' k : + (forall j, j < k -> picks j = picks' j) -> + states (execution_of_choices s0 H0 picks) k = + states (execution_of_choices s0 H0 picks') k. + Proof. + pose proof (execution_of_choices_valid s0 H0 picks) as [Hi Hs]. + pose proof (execution_of_choices_valid s0 H0 picks') as [Hi' Hs']. + induction k as [|k IH]; intro Hagree. + - reflexivity. + - specialize (Hs k); specialize (Hs' k). + change (selected (execution_of_choices s0 H0 picks) k) with (picks k) in Hs. + change (selected (execution_of_choices s0 H0 picks') k) with (picks' k) in Hs'. + rewrite (IH ltac:(intros j Hj; apply Hagree; lia)) in Hs. + rewrite (Hagree k ltac:(lia)) in Hs. + rewrite Hs in Hs'; now inversion Hs'. + Qed. +End OfChoices. + +Arguments next_valid {St Act Out} step Inv total preserves a s Hinv. +Arguments chosen_state {St Act Out} step Inv total preserves s0 H0 picks k. +Arguments execution_of_choices {St Act Out} step Inv total preserves s0 H0 picks. + +(** ** Reading an execution *) +Section ExecutionFacts. + Context {St Act Out : Type} + (step : Act -> St -> option (St * Out)) + (Inv : St -> Prop) (initial : St -> Prop). + + Notation valid := (execution_valid (fun a s o s' => step a s = Some (s',o)) initial). + + Lemma execution_step (e : Execution St Act Out) k : + valid e -> step (selected e k) (states e k) = Some (states e (S k),emitted e k). + Proof. intros [_ H]; apply H. Qed. + + Lemma execution_inv (e : Execution St Act Out) + (Hinit : forall s, initial s -> Inv s) + (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s') k : + valid e -> Inv (states e k). + Proof. + intros [Hi Hstep]; induction k as [|k IH]. + - now apply Hinit. + - eapply preserves; [exact IH|apply Hstep]. + Qed. +End ExecutionFacts. + +(** The flattened observation window of a half-open interval. *) +Definition execution_log_window {St Act Out W} + (logs : Out -> list W) (e : Execution St Act Out) (lo len : nat) : list W := + List.flat_map (fun k => logs (emitted e k)) (List.seq lo len). + +Section ExecutionRun. + Context {St Act Out W : Type} + (step : Act -> St -> option (St * Out)) + (logs : Out -> list W) + (initial : St -> Prop). + + Lemma execution_run_turns (e : Execution St Act Out) lo len : + execution_valid (fun a s o s' => step a s = Some (s',o)) initial e -> + run_turns step logs (List.map (selected e) (List.seq lo len)) (states e lo) = + Some (states e (lo + len), + List.flat_map (fun k => logs (emitted e k)) (List.seq lo len)). + Proof. + intro Hvalid; revert lo; induction len as [|len IH]; intro lo. + - cbn [List.seq List.map run_turns List.flat_map]; now rewrite Nat.add_0_r. + - cbn [List.seq List.map run_turns List.flat_map]. + rewrite (execution_step step initial e lo Hvalid), IH. + now replace (S lo + len) with (lo + S len) by lia. + Qed. +End ExecutionRun. + +(** Endpoint relatedness and exact output equality of one window, under a + state equivalence. *) +Section ExecutionWindow. + Context {St Act Out W : Type} + (step : Act -> St -> option (St * Out)) + (logs : Out -> list W) + (initial : St -> Prop) + (R : St -> St -> Prop) + (Hstep : Proper (eq ==> R ==> Roption (RelProd R eq)) step). + + Notation valid := (execution_valid (fun a s o s' => step a s = Some (s',o)) initial). + + Lemma execution_window_state (e : Execution St Act Out) lo len s : + valid e -> R (states e lo) s -> + exists last, run_turns step logs + (List.map (selected e) (List.seq lo len)) s = Some (last, + List.flat_map (fun k => logs (emitted e k)) (List.seq lo len)) /\ + R (states e (lo + len)) last. + Proof. + intros Hvalid Hs. + eapply run_turns_some_compatible; [exact Hstep|exact Hs|]. + eapply execution_run_turns; exact Hvalid. + Qed. + + Lemma execution_turn_observation (e : Execution St Act Out) k s : + valid e -> R (states e k) s -> + exists next, step (selected e k) s = Some (next,emitted e k) /\ + R (states e (S k)) next. + Proof. + intros Hvalid Hs. + eapply step_some_compatible; [exact Hstep|exact Hs|]. + eapply execution_step; exact Hvalid. + Qed. +End ExecutionWindow. + +(** ** Counters and observation indices. + + Generic over a state counter and an observation index, for executions + whose output is an optional observation. *) +Section ExecutionCounter. + Context {St Act W : Type} + (step : Act -> St -> option (St * option W)) + (initial : St -> Prop) + (counter : St -> nat) (index : W -> nat). + + Notation valid := (execution_valid (fun a s o s' => step a s = Some (s',o)) initial). + + Context (Hcounter : forall a s s' o, step a s = Some (s',o) -> + match o with + | None => counter s' = counter s + | Some w => counter s' = S (counter s) /\ index w = counter s + end). + + Lemma execution_event_index (e : Execution St Act (option W)) k w : + valid e -> emitted e k = Some w -> + counter (states e (S k)) = S (counter (states e k)) /\ + index w = counter (states e k). + Proof. + intros Hvalid Hobs. + pose proof (Hcounter (selected e k) (states e k) (states e (S k)) + (emitted e k) (execution_step step initial e k Hvalid)) as H. + now rewrite Hobs in H. + Qed. + + Lemma execution_counter_mono (e : Execution St Act (option W)) lo hi : + valid e -> lo <= hi -> counter (states e lo) <= counter (states e hi). + Proof. + intros Hvalid Hle. + assert (Hstep : forall k, counter (states e k) <= counter (states e (S k))). + { intro k; pose proof (Hcounter (selected e k) (states e k) (states e (S k)) + (emitted e k) (execution_step step initial e k Hvalid)) as H. + destruct (emitted e k); cbn in H; intuition lia. } + induction Hle as [|hi Hle IH]; [lia|specialize (Hstep hi); lia]. + Qed. + + Lemma execution_event_order (e : Execution St Act (option W)) k j w p : + valid e -> k < j -> + emitted e k = Some w -> emitted e j = Some p -> index w < index p. + Proof. + intros Hvalid Hkj Hw Hp. + pose proof (execution_event_index e k w Hvalid Hw) as [Hk Hi]. + pose proof (execution_event_index e j p Hvalid Hp) as [Hj Hjidx]. + pose proof (execution_counter_mono e (S k) j Hvalid ltac:(lia)); lia. + Qed. +End ExecutionCounter. + +(** The finite-run counter law, from the per-step increment. *) +Section RunCounter. + Context {St Act Out W : Type} + (step : Act -> St -> option (St * Out)) + (logs : Out -> list W) + (counter : St -> nat) + (Hcounter : forall a s s' o, step a s = Some (s',o) -> + counter s' = counter s + length (logs o)). + + Lemma run_turns_counter script s last ws : + run_turns step logs script s = Some (last,ws) -> + counter last = counter s + length ws. + Proof. + revert s last ws; induction script as [|who rest IH]; intros s last ws Hrun. + - cbn [run_turns] in Hrun; inversion Hrun; subst; cbn; lia. + - cbn [run_turns] in Hrun. + destruct (step who s) as [[next output]|] eqn:Hstep; [|discriminate]. + destruct (run_turns step logs rest next) as [[last' tail]|] eqn:Hrest; + [|discriminate]. + inversion Hrun; subst; clear Hrun. + pose proof (IH next _ _ Hrest) as Hsuffix. + pose proof (Hcounter who s next output Hstep) as Hone. + rewrite length_app; lia. + Qed. +End RunCounter. + +(** ** Reachability, through the Stdlib closure. *) +Definition reachable {St Act Out} + (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) (s : St) : Prop := + exists s0, initial s0 /\ + clos_refl_trans_1n St (fun x y => exists a o, step a x o y) s0 s. + +Lemma execution_reachable {St Act Out} + (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) + (e : Execution St Act Out) k : + execution_valid step initial e -> reachable step initial (states e k). +Proof. + intros [Hinit Hstep]; exists (states e 0); split; [exact Hinit|]. + apply clos_rt_rt1n. + induction k as [|k IH]; [apply rt_refl|]. + eapply rt_trans; [exact IH|]. + apply rt_step; exists (selected e k), (emitted e k); apply Hstep. +Qed. + +Lemma reachable_inv {St Act Out} + (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) + (Inv : St -> Prop) + (Hinit : forall s, initial s -> Inv s) + (preserves : forall a s o s', Inv s -> step a s o s' -> Inv s') s : + reachable step initial s -> Inv s. +Proof. + intros (s0 & H0 & Hclos). + apply Hinit in H0; revert H0. + induction Hclos as [x|x y z Hxy Hyz IH]; intro Hx; [exact Hx|]. + apply IH; destruct Hxy as (a & o & Hstep); eapply preserves; eauto. +Qed. diff --git a/theories/Utils/Lists.v b/theories/Utils/Lists.v new file mode 100644 index 0000000..ad0f4c0 --- /dev/null +++ b/theories/Utils/Lists.v @@ -0,0 +1,316 @@ +From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. + +Import ListNotations. + +(** Pure list operations shared by abstract and heap-backed queues. *) +Lemma hd_app {A} (l1 l2 : list A) d : + hd d (l1 ++ l2) = hd (hd d l2) l1. +Proof. now destruct l1. Qed. + +Lemma hd_default {A} (l : list A) d d' : + l <> [] -> hd d l = hd d' l. +Proof. destruct l; intro H; [contradiction | reflexivity]. Qed. + +Lemma last_in {A} (l : list A) d : l <> [] -> In (last l d) l. +Proof. + intro H; destruct (exists_last H) as (l' & x & ->). + rewrite last_last, in_app_iff; right; apply in_eq. +Qed. + +Definition rotl {A} (l : list A) : list A := + match l with [] => [] | x :: xs => xs ++ [x] end. + +Lemma rotl_cons {A} (x : A) xs : rotl (x :: xs) = xs ++ [x]. +Proof. reflexivity. Qed. + +Lemma rotl_perm {A} (l : list A) : Permutation l (rotl l). +Proof. + destruct l as [| x xs]; cbn; [constructor |]. + apply Permutation_cons_app; rewrite app_nil_r; apply Permutation_refl. +Qed. + +Lemma rotl_nonnil {A} (l : list A) : l <> [] -> rotl l <> []. +Proof. + intro H; destruct l as [| x xs]; [contradiction |]; cbn. + intro C; apply app_eq_nil in C as (_ & C); discriminate. +Qed. + +Fixpoint rotlN {A} (n : nat) (l : list A) : list A := + match n with 0 => l | S k => rotlN k (rotl l) end. + +(** Zero-based FIRST matching position. Duplicate payloads are allowed. + The comparator is explicit: clients can use [Nat.eqb] or their existing + [RelDec] equality without installing another equality instance. Only the + lemmas connecting matches to propositional equality require correctness. *) +Fixpoint find_index {A} (eqb : A -> A -> bool) (t : A) (l : list A) : option nat := + match l with + | [] => None + | h :: ts => if eqb h t then Some 0 else option_map S (find_index eqb t ts) + end. + +Lemma find_index_cons {A} (eqb : A -> A -> bool) t h ts : + find_index eqb t (h :: ts) = + (if eqb h t then Some 0 else option_map S (find_index eqb t ts)). +Proof. reflexivity. Qed. + +Lemma find_index_app_l {A} (eqb : A -> A -> bool) t ts n l : + find_index eqb t ts = Some n -> find_index eqb t (ts ++ l) = Some n. +Proof. + revert n; induction ts as [| a ts IH]; intros n H; cbn in *; [discriminate |]. + destruct (eqb a t); [exact H |]. + destruct (find_index eqb t ts) as [m |] eqn:Hf; cbn in *; [| discriminate]. + erewrite IH; eauto. +Qed. + +Lemma find_index_nonnil {A} (eqb : A -> A -> bool) t l n : + find_index eqb t l = Some n -> l <> []. +Proof. destruct l; cbn; intros H; [discriminate | congruence]. Qed. + +(** A non-head occurrence moves one position closer, even with duplicates. *) +Lemma find_index_rotl {A} (eqb : A -> A -> bool) t v vs d : + find_index eqb t (v :: vs) = Some (S d) -> + find_index eqb t (rotl (v :: vs)) = Some d. +Proof. + cbn; destruct (eqb v t); [discriminate |]. + destruct (find_index eqb t vs) as [m |] eqn:Hf; cbn; [| discriminate]. + intro H; injection H as H; subst m. + now apply find_index_app_l. +Qed. + +Section EqualitySearch. + Context {A : Type} (eqb : A -> A -> bool) + (eqb_correct : forall x y, eqb x y = true <-> x = y). + + Lemma find_index_last_ex t ts : + exists n, find_index eqb t (ts ++ [t]) = Some n. + Proof. + induction ts as [| a ts IH]; cbn. + - exists 0; now rewrite (proj2 (eqb_correct t t) eq_refl). + - destruct (eqb a t); [now exists 0 |]. + destruct IH as (n & Hn); exists (S n); now rewrite Hn. + Qed. + + Lemma find_index_in t l n : find_index eqb t l = Some n -> In t l. + Proof. + revert n; induction l as [| a l IH]; intros n H; cbn in *; [discriminate |]. + destruct (eqb a t) eqn:Ha. + - left; now apply eqb_correct. + - right; destruct (find_index eqb t l) eqn:Hf; cbn in H; [| discriminate]. + eapply IH; reflexivity. + Qed. + + Lemma find_index_none t l : find_index eqb t l = None <-> ~ In t l. + Proof. + induction l as [| a l IH]; cbn; [tauto |]. + destruct (eqb a t) eqn:Ha. + - apply eqb_correct in Ha; subst a; split; [discriminate | tauto]. + - assert (Hne : a <> t). + { intro H; apply eqb_correct in H; congruence. } + split. + + intro H; assert (Hnone : find_index eqb t l = None). + { destruct (find_index eqb t l); cbn in H; congruence. } + apply IH in Hnone; tauto. + + intro H; assert (Hnone : find_index eqb t l = None) by (apply IH; tauto). + now rewrite Hnone. + Qed. + + Lemma find_index_head t v vs : find_index eqb t (v :: vs) = Some 0 -> v = t. + Proof. + cbn; destruct (eqb v t) eqn:Hv. + - intros _; now apply eqb_correct. + - destruct (find_index eqb t vs); discriminate. + Qed. + + (** A head occurrence wraps around; an earlier duplicate may become first. *) + Lemma find_index_rotl_pres t v vs d : + find_index eqb t (v :: vs) = Some d -> + exists d', find_index eqb t (rotl (v :: vs)) = Some d'. + Proof. + intros H; destruct d as [| d]. + - apply find_index_head in H; subst v; cbn; apply find_index_last_ex. + - exists d; now apply find_index_rotl. + Qed. +End EqualitySearch. + +(** Splitting a pointwise relation across an append needs the prefix lengths; + [Forall2_app_inv_l] alone only produces an existential decomposition. *) +Lemma Forall2_app_inv_len {A B} (R : A -> B -> Prop) + (l1 l2 : list A) (l1' l2' : list B) : + length l1 = length l1' -> + Forall2 R (l1 ++ l2) (l1' ++ l2') -> Forall2 R l1 l1' /\ Forall2 R l2 l2'. +Proof. + revert l1'; induction l1 as [| a l1 IH]; intros [| b l1'] Hlen H; + cbn in Hlen, H; try discriminate. + - split; [constructor | exact H]. + - rewrite Forall2_cons_iff in H; destruct H as [Hab H]. + apply IH in H as [H1 H2]; [| lia]. + split; [rewrite Forall2_cons_iff; split; assumption | exact H2]. +Qed. + +(** ** Heads of lists that may be empty *) + +(** The head of a possibly-empty list is either the supplied default or an + actual member. Callers combine this with their own membership premise. *) +Lemma head_in_or_default {A} (d : A) (xs : list A) : + List.hd d xs = d \/ In (List.hd d xs) xs. +Proof. destruct xs as [| x xs]; cbn; [now left | right; now left]. Qed. + +Lemma head_not_in {A} (d x : A) (xs : list A) : + ~ In x xs -> d <> x -> List.hd d xs <> x. +Proof. + destruct xs as [| a xs]; cbn; intros Hnot Hd; [exact Hd |]. + intro E; apply Hnot; left; exact E. +Qed. + +(** ** Relation-polymorphic linking of a list of nodes + + [linked edge nodes last] says consecutive members of [nodes] are related by + [edge], with the final member related to [last]. The terminator is a + PARAMETER: that is what lets a client retarget the last link by + [linked_split] + [linked_app] instead of a bespoke surgery lemma. The + relation is arbitrary, so the same predicate serves free-list links stored + at [a] and queue links stored at [S a]. *) +Fixpoint linked {A : Type} (edge : A -> A -> Prop) + (nodes : list A) (last : A) : Prop := + match nodes with + | [] => True + | a :: rest => edge a (List.hd last rest) /\ linked edge rest last + end. + +Lemma linked_app {A} (edge : A -> A -> Prop) (xs ys : list A) last : + linked edge xs (List.hd last ys) -> + linked edge ys last -> + linked edge (xs ++ ys) last. +Proof. + revert last; induction xs as [| a xs IH]; intros last H1 H2; cbn in *; + [exact H2 |]. + destruct H1 as [Ha Hxs]; split. + - now rewrite hd_app. + - now apply IH. +Qed. + +Lemma linked_split {A} (edge : A -> A -> Prop) (xs ys : list A) last : + linked edge (xs ++ ys) last -> + linked edge xs (List.hd last ys) /\ linked edge ys last. +Proof. + revert last; induction xs as [| a xs IH]; intros last H; cbn in *; + [split; [exact I | exact H] |]. + destruct H as [Ha Hrest]; apply IH in Hrest as [H1 H2]. + rewrite hd_app in Ha; split; [split; assumption | exact H2]. +Qed. + +Lemma linked_mono {A} (edge edge' : A -> A -> Prop) (nodes : list A) last : + (forall a b, In a nodes -> edge a b -> edge' a b) -> + linked edge nodes last -> linked edge' nodes last. +Proof. + induction nodes as [| a rest IH]; cbn; intros Hmono H; [exact I |]. + destruct H as [Ha Hrest]; split. + - apply Hmono; [now left | exact Ha]. + - apply IH; [intros x y Hx; apply Hmono; now right | exact Hrest]. +Qed. + +(** Every list-suffix lookup licenses the whole chain at once. *) +Lemma linked_of_splits {A} (edge : A -> A -> Prop) (nodes : list A) last : + (forall prefix a rest, nodes = prefix ++ a :: rest -> edge a (List.hd last rest)) -> + linked edge nodes last. +Proof. + induction nodes as [| a rest IH]; intro Links; [exact I |]. + split. + - apply (Links [] a rest); reflexivity. + - apply IH; intros prefix b rest' E. + apply (Links (a :: prefix) b rest'); cbn; now rewrite E. +Qed. + +(** ** Small [map]/[seq]/[firstn] facts used to read windows. + + The write direction: a window is determined by its pointwise values. *) +Lemma map_seq_eq {A} lo len (f : nat -> A) xs d : + length xs = len -> + (forall i, i < len -> f (lo+i) = nth i xs d) -> + map f (seq lo len) = xs. +Proof. + intros Hlen Hnth; apply List.nth_ext with (d := f lo) (d' := d). + - rewrite List.length_map, List.length_seq; symmetry; exact Hlen. + - intros i Hi; rewrite List.length_map, List.length_seq in Hi. + rewrite List.map_nth, List.seq_nth by exact Hi; now apply Hnth. +Qed. + +Lemma firstn_seq lo len k : + k <= len -> List.firstn k (List.seq lo len) = List.seq lo k. +Proof. + revert lo len; induction k as [|k IH]; intros lo len Hk; [reflexivity|]. + destruct len as [|len]; [lia|]. + cbn [List.seq List.firstn]; f_equal; apply IH; lia. +Qed. + +Lemma map_seq_firstn {A} (f : nat -> A) lo len k : + k <= len -> + List.firstn k (List.map f (List.seq lo len)) = List.map f (List.seq lo k). +Proof. + intro Hk; now rewrite <- (firstn_seq lo len k Hk), List.firstn_map. +Qed. + +(** ** Periodic choice sequences. + + [first :: rest] makes the period nonempty, including a one-element + period, without an arbitrary default for an empty cycle. *) +Definition periodic_choices {A : Type} + (prefix : list A) (first : A) (rest : list A) (k : nat) : A := + if Nat.ltb k (length prefix) + then List.nth k prefix first + else List.nth ((k - length prefix) mod (S (length rest))) (first :: rest) first. + +Lemma periodic_choices_before {A} (prefix : list A) first rest k : + k < length prefix -> + periodic_choices prefix first rest k = List.nth k prefix first. +Proof. + intro Hk; unfold periodic_choices. + now rewrite (proj2 (Nat.ltb_lt k (length prefix)) Hk). +Qed. + +Lemma periodic_choices_after {A} (prefix : list A) first rest k : + length prefix <= k -> + periodic_choices prefix first rest k = + List.nth ((k - length prefix) mod (S (length rest))) (first :: rest) first. +Proof. + intro Hk; unfold periodic_choices. + destruct (Nat.ltb_spec k (length prefix)); [lia|reflexivity]. +Qed. + +Lemma periodic_choices_nth {A} (prefix : list A) first rest j : + periodic_choices prefix first rest (length prefix + j) = + List.nth (j mod (S (length rest))) (first :: rest) first. +Proof. + rewrite periodic_choices_after by lia. + now replace (length prefix + j - length prefix) with j by lia. +Qed. + +(** The [i]-th choice of any whole round. *) +Lemma periodic_choices_round {A} (prefix : list A) first rest rounds i : + i < S (length rest) -> + periodic_choices prefix first rest + (length prefix + rounds * S (length rest) + i) = + nth i (first :: rest) first. +Proof. + intro Hi. + replace (length prefix + rounds * S (length rest) + i) + with (length prefix + (i + rounds * S (length rest))) by lia. + rewrite periodic_choices_nth, Nat.Div0.mod_add. + now rewrite Nat.mod_small by exact Hi. +Qed. + +Lemma periodic_prefix_script {A} (prefix : list A) first rest : + map (periodic_choices prefix first rest) (seq 0 (length prefix)) = prefix. +Proof. + apply (map_seq_eq 0 (length prefix) _ prefix first); [reflexivity|]. + intros i Hi; cbn [Nat.add]; now apply periodic_choices_before. +Qed. + +Lemma periodic_cycle_script {A} (prefix : list A) first rest rounds : + map (periodic_choices prefix first rest) + (seq (length prefix + rounds * S (length rest)) (S (length rest))) = + first :: rest. +Proof. + apply (map_seq_eq _ (S (length rest)) _ (first :: rest) first); [reflexivity|]. + intros i Hi; now apply periodic_choices_round. +Qed. diff --git a/theories/Utils/Pcm.v b/theories/Utils/Pcm.v new file mode 100644 index 0000000..b2346f8 --- /dev/null +++ b/theories/Utils/Pcm.v @@ -0,0 +1,242 @@ +(** * A partial commutative monoid with explicit definedness. + + Design notes, all of them forced by the evidence collected earlier in this + project: + + - The composition is *partial*. We present it, as separation algebras + usually are, by a total operation [pop] together with a definedness + predicate [pdef]. This keeps every law a first-order statement and + avoids reasoning about [option] equalities inside a setoid. + + - The carrier comes with its own equivalence [peq]. This is deliberate: + the intended heap model is a *map*, and list concatenation is not + commutative under list equality. We therefore fix a justified map + representation (total functions [nat -> option nat]) and a justified map + equivalence (pointwise equality), and prove commutativity for that + equivalence rather than assuming it for a representation that does not + have it. That concrete model lives in [Events.HeapModel]. + + - Cancellativity is NOT a field of the class. It is defined separately, + below, so that a theorem can be checked to be independent of it simply by + being provable in a section that only assumes [PCM]. [BoolPCM] below is + a PCM in which cancellativity provably fails. + + ExtLib's [MonoidLaws] is a total, equality-based monoid; it is not a + replacement for partial composition with pointwise equivalence. *) + +From Stdlib Require Import + Basics + Arith.PeanoNat + Lia + List + Relations. + +Generalizable All Variables. + +(** ** The interface *) +Class PCM (A: Type) := { + (** the justified equivalence on the carrier *) + peq : A -> A -> Prop; + (** definedness / compatibility of a composition *) + pdef : A -> A -> Prop; + (** the composition, meaningful exactly when [pdef] holds *) + pop : A -> A -> A; + (** the unit *) + pemp : A; + + peq_refl : forall a, peq a a; + peq_sym : forall a b, peq a b -> peq b a; + peq_trans : forall a b c, peq a b -> peq b c -> peq a c; + + (** both [pdef] and [pop] respect the equivalence *) + pdef_resp : forall a a' b b', peq a a' -> peq b b' -> pdef a b -> pdef a' b'; + pop_resp : forall a a' b b', peq a a' -> peq b b' -> peq (pop a b) (pop a' b'); + + (** commutativity, in both components *) + pdef_comm : forall a b, pdef a b -> pdef b a; + pop_comm : forall a b, pdef a b -> peq (pop a b) (pop b a); + + (** unit laws *) + pdef_emp : forall a, pdef pemp a; + pop_emp : forall a, peq (pop pemp a) a; + + (** associativity, with the definedness bookkeeping made explicit *) + pdef_assocL : forall a b c, pdef b c -> pdef a (pop b c) -> pdef a b; + pdef_assocR : forall a b c, pdef b c -> pdef a (pop b c) -> pdef (pop a b) c; + pdef_assocI : forall a b c, pdef b c -> pdef a b -> pdef (pop a b) c -> pdef a (pop b c); + pop_assoc : forall a b c, + pdef b c -> pdef a (pop b c) -> peq (pop a (pop b c)) (pop (pop a b) c) +}. + +Declare Scope pcm_scope. +Delimit Scope pcm_scope with pcm. +Notation "a ⊎ b" := (pop a b) (at level 50, left associativity): pcm_scope. +Notation "a # b" := (pdef a b) (at level 70, no associativity): pcm_scope. +Notation "a ≈ b" := (peq a b) (at level 70, no associativity): pcm_scope. +Local Open Scope pcm_scope. + +(** Cancellativity is a *separate* property. Everything proved in a section + that assumes only [PCM] is, by construction, independent of it. *) +Definition Cancellative (A: Type) `{PCM A} : Prop := + forall a b c, a # b -> a # c -> a ⊎ b ≈ a ⊎ c -> b ≈ c. + +Section PcmFacts. + Context {A: Type} `{PCM A}. + + Lemma pop_emp_r: forall a, a # pemp -> a ⊎ pemp ≈ a. + Proof. + intros a Hd. + eapply peq_trans; [apply pop_comm; auto | apply pop_emp]. + Qed. + + Lemma pdef_emp_r: forall a, a # pemp. + Proof. intro a; apply pdef_comm, pdef_emp. Qed. + + (** The "other" associativity direction, derived. *) + Lemma pop_assoc': forall a b c, + b # c -> a # (b ⊎ c) -> (a ⊎ b) ⊎ c ≈ a ⊎ (b ⊎ c). + Proof. intros; apply peq_sym, pop_assoc; auto. Qed. +End PcmFacts. + +(** ** Spatial assertions over an arbitrary PCM *) +Definition assn (A: Type) := A -> Prop. + +Section Assertions. + Context {A: Type} `{PCM A}. + + (** An assertion is *well formed* when it does not distinguish equivalent + resources. Every assertion built below is well formed. *) + Definition AProper (P: assn A) : Prop := forall a b, a ≈ b -> P a -> P b. + + Definition aemp : assn A := fun a => a ≈ pemp. + + Definition asep (P Q: assn A) : assn A := + fun a => exists a1 a2, a1 # a2 /\ a ≈ a1 ⊎ a2 /\ P a1 /\ Q a2. + + Definition awand (P Q: assn A) : assn A := + fun a => forall b, a # b -> P b -> Q (a ⊎ b). + + Definition atrue : assn A := fun _ => True. + + Lemma aemp_proper: AProper aemp. + Proof. intros a b Hab Ha; unfold aemp in *; eauto using peq_sym, peq_trans. Qed. + + Lemma asep_proper: forall P Q, AProper (asep P Q). + Proof. + intros P Q a b Hab (a1 & a2 & Hd & Heq & HP & HQ). + exists a1, a2; repeat split; auto. + eauto using peq_sym, peq_trans. + Qed. + + (** [⋆] is commutative. *) + Lemma asep_comm: forall P Q a, asep P Q a -> asep Q P a. + Proof. + intros P Q a (a1 & a2 & Hd & Heq & HP & HQ). + exists a2, a1; repeat split; auto using pdef_comm. + eapply peq_trans; [exact Heq | apply pop_comm; auto]. + Qed. + + (** [emp] is a left unit, in both directions. *) + Lemma asep_emp_l: forall P a, AProper P -> P a -> asep aemp P a. + Proof. + intros P a HP Ha. + exists pemp, a; repeat split; auto using pdef_emp, peq_refl. + - apply peq_sym, pop_emp. + - unfold aemp; apply peq_refl. + Qed. + + Lemma asep_emp_l_inv: forall P a, AProper P -> asep aemp P a -> P a. + Proof. + intros P a HP (a1 & a2 & Hd & Heq & Hemp & HQ). + eapply HP; [| exact HQ]. + apply peq_sym. + eapply peq_trans; [exact Heq |]. + eapply peq_trans; [| apply pop_emp]. + apply pop_resp; auto using peq_refl. + Qed. + + (** [⋆] is associative, one direction shown (the other is symmetric). *) + Lemma asep_assoc: forall P Q R a, + asep P (asep Q R) a -> asep (asep P Q) R a. + Proof. + intros P Q R a (a1 & a23 & Hd1 & Heq1 & HP & (a2 & a3 & Hd2 & Heq2 & HQ & HR)). + assert (Hd1': a1 # (a2 ⊎ a3)) by (eapply pdef_resp; [apply peq_refl | exact Heq2 | exact Hd1]). + exists (a1 ⊎ a2), a3; repeat split. + - eapply pdef_assocR; eauto. + - eapply peq_trans; [exact Heq1 |]. + eapply peq_trans; [| eapply pop_assoc; eauto]. + apply pop_resp; auto using peq_refl. + - exists a1, a2; repeat split; auto using peq_refl. + eapply pdef_assocL; eauto. + - assumption. + Qed. + + (** Monotonicity: the frame rule of the *spatial* layer. *) + Lemma asep_mono: forall (P P' Q Q': assn A) a, + (forall x, P x -> P' x) -> (forall x, Q x -> Q' x) -> + asep P Q a -> asep P' Q' a. + Proof. + intros * HP HQ (a1 & a2 & Hd & Heq & H1 & H2). + exists a1, a2; auto. + Qed. + + (** The adjunction, both directions. [awand] is recorded because the brief + lists it as optional; nothing downstream depends on it. *) + Lemma awand_intro: forall (P Q R: assn A), + (forall a, asep P Q a -> R a) -> + forall a, P a -> awand Q R a. + Proof. + intros P Q R Hpq a Ha b Hd HQ. + apply Hpq; exists a, b; repeat split; auto using peq_refl. + Qed. + + Lemma awand_elim: forall (P Q: assn A) a, + asep (awand P Q) P a -> AProper Q -> Q a. + Proof. + intros P Q a (a1 & a2 & Hd & Heq & Hw & HP) HQ. + eapply HQ; [apply peq_sym; exact Heq |]. + now apply Hw. + Qed. +End Assertions. + +Arguments AProper {A _} P. +Arguments aemp {A _}. +Arguments asep {A _} P Q. +Arguments awand {A _} P Q. +Arguments atrue {A _}. + +Notation "P ⋆ Q" := (asep P Q) (at level 55, right associativity): pcm_scope. +Notation "P -⋆ Q" := (awand P Q) (at level 60, right associativity): pcm_scope. + +(** ** A PCM in which cancellativity fails. + + Carrier [bool], composition [orb], always defined, unit [false]. Every PCM + law holds; cancellativity does not. This is the evidence that generic + transport does not need cancellativity. *) +#[global] Instance BoolPCM : PCM bool. +Proof. + refine {| peq := @eq bool; pdef := fun _ _ => True; pop := orb; pemp := false |}. + - reflexivity. + - intros a b; auto. + - intros a b c; apply eq_trans. + - intros a a' b b' Ha Hb _; exact I. + - intros a a' b b' Ha Hb; now subst. + - intros a b _; exact I. + - intros a b _; apply Bool.orb_comm. + - intros a; exact I. + - intros a; reflexivity. + - intros a b c _ _; exact I. + - intros a b c _ _; exact I. + - intros a b c _ _ _; exact I. + - intros a b c _ _; now rewrite Bool.orb_assoc. +Defined. + +Theorem bool_pcm_not_cancellative: ~ Cancellative bool. +Proof. + intro Hc. + assert (Hd: (true # true)%pcm) by exact I. + assert (Hd': (true # false)%pcm) by exact I. + assert (Heq: (true ⊎ true ≈ true ⊎ false)%pcm) by reflexivity. + specialize (Hc true true false Hd Hd' Heq). + cbn in Hc; discriminate. +Qed. diff --git a/theories/Utils/Relations.v b/theories/Utils/Relations.v index 35afd2d..bc2f124 100644 --- a/theories/Utils/Relations.v +++ b/theories/Utils/Relations.v @@ -112,3 +112,80 @@ Proof. destruct (p k) eqn:Hp; [exfalso; exact (Hnone k Hk Hp)|reflexivity]. - left; exists k; split; assumption. Qed. + +(** * Bounded-credit progress. + + A [Credit] RELATION (not a computable rank extractor) that descends by at + least the charge of every uncharged-goal step bounds how many charged + indices can pass before the goal is met. Keeping the witnesses in [Prop] + is what lets the same theorem serve a concrete potential and a + heap-related ghost list. + + Charging counts selected USEFUL indices, not elapsed time, so arbitrarily + many idle indices are allowed. The zero-length interval is supported and + cannot fabricate a hit. *) + +Lemma credit_interval + (Credit : nat -> nat -> Prop) (charged : nat -> bool) (goal : nat -> Prop) + (step : forall k credit, Credit k credit -> ~ goal k -> + exists credit', Credit (S k) credit' /\ + (if charged k then 1 else 0) + credit' <= credit) : + forall lo len credit, + Credit lo credit -> + (forall k, lo <= k < lo + len -> ~ goal k) -> + exists credit', Credit (lo + len) credit' /\ + count_if charged lo len + credit' <= credit. +Proof. + intros lo len; revert lo; induction len as [|len IH]; intros lo credit Hc Hno. + - exists credit; rewrite Nat.add_0_r, count_if_zero; split; [exact Hc | lia]. + - destruct (step lo credit Hc (Hno lo ltac:(lia))) as (mid & Hmid & Hdrop). + destruct (IH (S lo) mid Hmid ltac:(intros k Hk; apply Hno; lia)) + as (credit' & Hcredit' & Hcount). + exists credit'; split. + + now replace (lo + S len) with (S lo + len) by lia. + + rewrite count_if_succ; destruct (charged lo); lia. +Qed. + +(** The first goal index inside an interval whose charge reaches a bound that + no goal-free prefix can reach. *) +Lemma count_if_first + (charged : nat -> bool) (goal : nat -> Prop) + (dec : forall k, sumbool (goal k) (not (goal k))) lo len bound : + (forall n, (forall k, lo <= k < lo + n -> ~ goal k) -> + count_if charged lo n < bound) -> + bound <= count_if charged lo len -> + exists k, lo <= k < lo + len /\ goal k /\ + count_if charged lo (S k - lo) <= bound. +Proof. + intros Hprefix Hreach. + destruct (finite_first goal dec lo len) as [Hnone | (k & Hk & Hgoal & Hfirst)]. + - exfalso; specialize (Hprefix len Hnone); lia. + - exists k; split; [exact Hk |]; split; [exact Hgoal |]. + (** The charge up to and including [k] is the goal-free prefix plus at + most one, and the goal-free prefix is strictly below [bound]. *) + assert (Hpre : count_if charged lo (k - lo) < bound) + by (apply Hprefix; intros i Hi; apply Hfirst; lia). + replace (S k - lo) with ((k - lo) + 1) by lia. + rewrite count_if_add. + replace (lo + (k - lo)) with k by lia. + rewrite count_if_succ, count_if_zero. + destruct (charged k); lia. +Qed. + +(** If every goal-free interval has bounded charge and charging happens + infinitely often, the goal is met infinitely often. *) +Lemma infinitely_progress + (charged : nat -> bool) (goal : nat -> Prop) + (dec : forall k, sumbool (goal k) (not (goal k))) : + (forall lo, exists bound, forall len, + (forall k, lo <= k < lo + len -> ~ goal k) -> + count_if charged lo len < bound) -> + infinitely (fun k => charged k = true) -> infinitely goal. +Proof. + intros Hbound Hinf n. + destruct (Hbound n) as (bound & Hprefix). + destruct (infinitely_count_if charged Hinf bound n) as (len & Hlen). + destruct (count_if_first charged goal dec n len bound Hprefix Hlen) + as (k & Hk & Hgoal & _). + exists k; split; [lia | exact Hgoal]. +Qed. diff --git a/theories/Utils/Utils.v b/theories/Utils/Utils.v index 704c84f..5bdc621 100644 --- a/theories/Utils/Utils.v +++ b/theories/Utils/Utils.v @@ -175,57 +175,3 @@ Ltac invert := Tactic Notation "hinduction" hyp(IND) "before" hyp(H) := move IND before H; revert_until IND; induction IND. -Lemma wf3_proj1{X Y Z: Type} (R: relation X): - well_founded R -> well_founded (fun (p: X * Y * Z) p' => R (fst (fst p)) (fst (fst p'))). -Proof. - unfold well_founded. - intros Hind [[x a] b]. - generalize dependent a. - generalize dependent b. - induction (Hind x) as [x Hx IH]. - constructor. - intros [[x' a'] b'] H. - apply IH. - assumption. -Defined. - -Lemma wf3_proj2{X Y Z: Type} (R: relation Y): - well_founded R -> well_founded (fun (p: X * Y * Z) p' => R (snd (fst p)) (snd (fst p'))). -Proof. - unfold well_founded. - intros Hind [[a x] b]. - generalize dependent a. - generalize dependent b. - induction (Hind x) as [x Hx IH]. - constructor. - intros [[a' x'] b'] H. - apply IH. - assumption. -Defined. - -Lemma wf3_proj3{X Y Z: Type} (R: relation Z): - well_founded R -> well_founded (fun (p: X * Y * Z) p' => R (snd p) (snd p')). -Proof. - unfold well_founded. - intros Hind [[a b] x]. - generalize dependent a. - generalize dependent b. - induction (Hind x) as [x Hx IH]. - constructor. - intros [[a' b'] x'] H. - apply IH. - assumption. -Defined. - -Lemma wf3_proj12{X Y Z: Type} (R: relation (X*Y)): - well_founded R -> well_founded (fun (p: X * Y * Z) p' => R (fst p) (fst p')). -Proof. - unfold well_founded. - intros Hind [x b]. - generalize dependent b. - induction (Hind x) as [x Hx IH]. - constructor. - intros [x' b'] H. - apply IH. - assumption. -Defined. diff --git a/theories/Utils/Vectors.v b/theories/Utils/Vectors.v index f96ad49..5c4c951 100644 --- a/theories/Utils/Vectors.v +++ b/theories/Utils/Vectors.v @@ -95,6 +95,31 @@ Proof. exact (Hagree (Fin.FS k) ltac:(intro Heq; apply Hk, (Fin.FS_inj _ _ Heq))). Qed. +(** Updating related vectors preserves their relation at every slot. *) +Lemma vector_replace_pointwise {A n} (R : A -> A -> Prop) + (v1 v2 : vec n A) (i : Fin.t n) (x1 x2 : A) : + (forall j, i <> j -> R (Vector.nth v1 j) (Vector.nth v2 j)) -> + R x1 x2 -> + forall j, R (Vector.nth (Vector.replace v1 i x1) j) + (Vector.nth (Vector.replace v2 i x2) j). +Proof. + intros Hv Hx j; destruct (Fin.eq_dec i j) as [->|Hne]. + - rewrite !Vector.nth_replace_eq; exact Hx. + - rewrite !Vector.nth_replace_neq by congruence; apply Hv, Hne. +Qed. + +Lemma vector_cons_pointwise {A n} (R : A -> A -> Prop) + (x1 x2 : A) (v1 v2 : vec n A) : + R x1 x2 -> (forall j, R (Vector.nth v1 j) (Vector.nth v2 j)) -> + forall i, R (Vector.nth (x1 :: v1) i) (Vector.nth (x2 :: v2) i). +Proof. + intros Hx Hv i. + refine (Fin.caseS' i + (fun j => R (Vector.nth (x1 :: v1) j) (Vector.nth (x2 :: v2) j)) _ _). + - exact Hx. + - intro j; apply Hv. +Qed. + Equations nth_map{A n}(v: vec n A)(i: fin n)(f: A -> A): vec n A by wf n lt := nth_map [] _ _ := []; nth_map (h :: h' :: ts) (FS (FS j)) _ := h :: (nth_map (h' :: ts) (FS j) f); @@ -179,10 +204,6 @@ Proof. exists x. intuition. Qed. -Lemma vec0 {T}: forall (v:Vector.t T 0), v = []. - apply (Vector.case0 (fun x => x=[])). - reflexivity. -Qed. Fixpoint zip {A B : Type} {n : nat} (a : Vector.t A n) (b : Vector.t B n) : Vector.t (A * B) n := match a in Vector.t _ n return Vector.t B n -> Vector.t (A * B) n with From 71ce36f6b53ccac789e252852d3917ba435eacc3 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 25 Sep 2026 21:24:08 +0000 Subject: [PATCH 09/14] refactor(yield): split observed scheduler into Interp and Logic Move the operational half of ICTree/Logic/SchedulerFairness.v into the new ICTree/Interp/Yield/Observed.v, leaving only temporal content behind; the Interp tier needs no Logic dependency. Generalize example machinery into the library: - segment_interp_{nd,rr} take the current slot, absorbing the pool_replace_current detour repeated by six callers - pool_simulation_turn_nd factors the one-turn ND fact that pool_simulation_nd_bisim inlined and the allocator contracts restate - PoolSimulation section parameters become maximal implicits - interp_schedule_rr_user_bind replaces CSL's interp_rr_user_bind - observe_eq_equ replaces a file-local equ-from-observe helper - execution_script_{state,emitted} replace window glue repeated five times in the allocator counterexamples Prune dead declarations across examples, ICTree/Interp, Utils/Execution, Lang/CSL/Interp and Lang/Yield, and merge the duplicate Ctx definitions onto Lang.Maps.Ctx.Ctx. Net: -30 definitions, -4 Ltac, -126 lemmas, -1674 LOC. No TICL judgement lemma removed; the 130 CSL rules and the allocator contracts are unchanged, and every checked root keeps its previous axiom set. --- examples/CSL/Allocator/Counterexamples.v | 244 +-- examples/CSL/Allocator/Execution.v | 59 +- examples/CSL/Allocator/Layout.v | 133 -- examples/CSL/Allocator/Liveness.v | 107 +- examples/CSL/Allocator/Model.v | 43 - theories/ICTree/Equ.v | 11 + theories/ICTree/Interp/Heap.v | 12 - theories/ICTree/Interp/Refine.v | 4 - theories/ICTree/Interp/State/Mod.v | 97 -- theories/ICTree/Interp/Yield/Execution.v | 87 +- theories/ICTree/Interp/Yield/Mod.v | 128 -- theories/ICTree/Interp/Yield/Observed.v | 1549 +++++++++++++++++ theories/ICTree/Interp/Yield/RoundRobin.v | 29 +- theories/ICTree/Interp/Yield/SBisim.v | 105 -- theories/ICTree/Interp/Yield/Segments.v | 193 +-- theories/ICTree/Logic/SchedulerFairness.v | 1906 +-------------------- theories/ICTree/Trace.v | 17 - theories/Lang/CSL/Interp.v | 248 +-- theories/Lang/StImp.v | 3 +- theories/Lang/Yield.v | 1 + theories/Lang/Yield/Denote.v | 43 +- theories/Lang/Yield/Interp.v | 24 +- theories/Lang/Yield/SchedulerFairness.v | 3 +- theories/Lang/Yield/Ticl.v | 237 +-- theories/Utils/Execution.v | 149 +- 25 files changed, 1879 insertions(+), 3553 deletions(-) create mode 100644 theories/ICTree/Interp/Yield/Observed.v diff --git a/examples/CSL/Allocator/Counterexamples.v b/examples/CSL/Allocator/Counterexamples.v index e91770b..8e761a6 100644 --- a/examples/CSL/Allocator/Counterexamples.v +++ b/examples/CSL/Allocator/Counterexamples.v @@ -165,13 +165,6 @@ Proof. apply periodic_prefix_script. Qed. -Local Lemma starve_selected_prefix k : k < 19 -> - selected starvation_execution k = List.nth k starvation_prefix Remote1. -Proof. - intro Hk; change (starvation_choices k = List.nth k starvation_prefix Remote1). - unfold starvation_choices; apply periodic_choices_before; exact Hk. -Qed. - Local Lemma starve_selected_cycle n i : i < 13 -> selected starvation_execution (19+13*n+i) = List.nth i starvation_cycle Remote1. @@ -206,91 +199,36 @@ Proof. induction n as [|n IH]. - destruct (starve_prefix_run 0) as (last & Hrun & Hlast). eapply state_equiv_trans; [|exact Hlast]. - destruct (execution_window_state (turn 1) event_obs - (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) - starvation_execution 0 (List.length starvation_prefix) (initial_state 2 0) - starvation_execution_valid starve_initial_equiv) as (actual & Hactual & Hstate). - rewrite starve_prefix_script, Hrun in Hactual. - assert (Elast : actual = last) by congruence; subst actual. replace (19+13*0) with (0 + List.length starvation_prefix) by reflexivity. - exact Hstate. + exact (execution_script_state (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution 0 starvation_prefix (initial_state 2 0) last + (starve_prefix_logs 0) starvation_execution_valid starve_initial_equiv + starve_prefix_script Hrun). - destruct (starve_cycle_run (6+4*n)) as (last & Hrun & Hlast). replace (6+4*S n) with (4+(6+4*n)) by lia. eapply state_equiv_trans; [|exact Hlast]. - replace (19+13*S n) with - ((19+13*n)+List.length starvation_cycle) + replace (19+13*S n) with ((19+13*n)+List.length starvation_cycle) by (cbn [starvation_cycle List.length]; lia). - destruct (execution_window_state (turn 1) event_obs + exact (execution_script_state (turn 1) event_obs (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) - starvation_execution (19+13*n) (List.length starvation_cycle) - (starve_boundary (6+4*n)) starvation_execution_valid IH) - as (actual & Hactual & Hstate). - rewrite starve_cycle_script, Hrun in Hactual. - assert (Elast : actual = last) by congruence; subst actual; exact Hstate. -Qed. - -Local Lemma starve_actual_cycle_run n : exists last, - run_turns (turn 1) event_obs starvation_cycle (states starvation_execution (19+13*n)) = - Some (last,starve_cycle_logs (6+4*n)) /\ - state_equiv last (starve_boundary (6+4*S n)). -Proof. - replace (6+4*S n) with (4+(6+4*n)) by lia. - apply starve_cycle_run_actual; apply starve_boundaries. -Qed. - -(** Every intermediate state is the result of a finite fold from the actual - returned boundary, not from a periodically reset representative. *) -Local Lemma starve_actual_cycle_position n i : i < 13 -> - exists logs next, - run_turns (turn 1) event_obs (List.firstn i starvation_cycle) - (states starvation_execution (19+13*n)) = - Some (states starvation_execution (19+13*n+i),logs) /\ - held (remote1_state (states starvation_execution (19+13*n+i))) = [8] /\ - turn 1 (List.nth i starvation_cycle Remote1) - (states starvation_execution (19+13*n+i)) = - Some (next,starve_cycle_event (6+4*n) i). -Proof. - intro Hi. - destruct (starve_cycle_position (6+4*n) i Hi) - as (middle & logs & next & Hrun & Hheld & Hturn). - destruct (run_turns_some_compatible (turn 1) event_obs state_equiv (turn_proper 1) - (List.firstn i starvation_cycle) - (starve_boundary (6+4*n)) (states starvation_execution (19+13*n)) - middle logs (state_equiv_sym _ _ (starve_boundaries n)) Hrun) - as (actual & Hactual & Heq). - assert (Hscript : List.map (selected starvation_execution) - (List.seq (19+13*n) i) = List.firstn i starvation_cycle). - { - rewrite <- (map_seq_firstn (selected starvation_execution) (19+13*n) - (List.length starvation_cycle) i ltac:(change (i <= 13); lia)). - rewrite (starve_cycle_script n); reflexivity. - } - pose proof (execution_run_turns (turn 1) event_obs - (fun s => s = initial_state 2 0) starvation_execution (19+13*n) i - starvation_execution_valid) as Hwindow. - rewrite Hscript, Hactual in Hwindow. - assert (Estate : actual = states starvation_execution (19+13*n+i)) - by congruence. - subst actual. - destruct (step_some_compatible (turn 1) state_equiv (turn_proper 1) - (List.nth i starvation_cycle Remote1) - middle (states starvation_execution (19+13*n+i)) next - (starve_cycle_event (6+4*n) i) Heq Hturn) - as (actual_next & Hnext & Hnext_eq). - exists logs, actual_next; split; [exact Hactual|]; split; [|exact Hnext]. - destruct Heq as (_ & _ & _ & _ & Hremote1). - rewrite <- Hremote1; exact Hheld. + starvation_execution (19+13*n) starvation_cycle + (starve_boundary (6+4*n)) last (starve_cycle_logs (6+4*n)) + starvation_execution_valid IH (starve_cycle_script n) Hrun). Qed. Local Lemma starve_cycle_emitted n i : i < 13 -> emitted starvation_execution (19+13*n+i) = starve_cycle_event (6+4*n) i. Proof. intro Hi. - destruct (starve_actual_cycle_position n i Hi) - as (logs & next & Hrun & Hheld & Hturn). - pose proof (execution_step (turn 1) (fun s => s = initial_state 2 0) - starvation_execution (19+13*n+i) starvation_execution_valid) as Hstep. - rewrite (starve_selected_cycle n i Hi), Hturn in Hstep; congruence. + destruct (starve_cycle_position (6+4*n) i Hi) + as (middle & logs & next & Hrun & Hheld & Hturn). + exact (proj2 (execution_script_emitted (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution (19+13*n) starvation_cycle i Remote1 + (starve_boundary (6+4*n)) middle logs next (starve_cycle_event (6+4*n) i) + starvation_execution_valid (starve_boundaries n) (starve_cycle_script n) + ltac:(change (i < 13); lia) Hrun Hturn)). Qed. Local Lemma starve_prefix_emitted i : i < 19 -> @@ -298,37 +236,12 @@ Local Lemma starve_prefix_emitted i : i < 19 -> Proof. intro Hi. destruct (starve_prefix_position 0 i Hi) as (middle & logs & next & Hrun & Hturn). - assert (Hscript : List.map (selected starvation_execution) (List.seq 0 i) = - List.firstn i starvation_prefix). - { - rewrite <- (map_seq_firstn (selected starvation_execution) 0 - (List.length starvation_prefix) i ltac:(change (i <= 19); lia)). - rewrite starve_prefix_script; reflexivity. - } - destruct (execution_window_state (turn 1) event_obs + exact (proj2 (execution_script_emitted (turn 1) event_obs (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) - starvation_execution 0 i (initial_state 2 0) - starvation_execution_valid starve_initial_equiv) as (actual & Hactual & Heq). - rewrite Hscript, Hrun in Hactual. - assert (Emiddle : actual = middle) by congruence; subst actual. - rewrite Nat.add_0_l in Heq. - rewrite <- (starve_selected_prefix i Hi) in Hturn. - destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) - state_equiv (turn_proper 1) starvation_execution i middle - starvation_execution_valid Heq) as (next' & Hturn' & _). - rewrite Hturn in Hturn'; congruence. -Qed. - -Local Lemma starve_cycle_event_offsets n : - emitted starvation_execution (19+13*n+5) = Some (stamp (tag_retire,6) (6+4*n)) /\ - emitted starvation_execution (19+13*n+6) = Some (stamp (tag_retry,8) (1+(6+4*n))) /\ - emitted starvation_execution (19+13*n+9) = Some (stamp (tag_reclaim,6) (2+(6+4*n))) /\ - emitted starvation_execution (19+13*n+11) = Some (stamp (tag_alloc,6) (3+(6+4*n))). -Proof. - split; [exact (starve_cycle_emitted n 5 ltac:(lia))|]. - split; [exact (starve_cycle_emitted n 6 ltac:(lia))|]. - split; [exact (starve_cycle_emitted n 9 ltac:(lia))|]. - exact (starve_cycle_emitted n 11 ltac:(lia)). + starvation_execution 0 starvation_prefix i Remote1 + (initial_state 2 0) middle logs next (starve_prefix_event 0 i) + starvation_execution_valid starve_initial_equiv starve_prefix_script + ltac:(change (i < 19); lia) Hrun Hturn)). Qed. Local Lemma starve_index k : 19 <= k -> @@ -354,8 +267,16 @@ Local Lemma starve_held_forever k : 19 <= k -> held (remote1_state (states starvation_execution k)) = [8]. Proof. intro Hk; destruct (starve_index k Hk) as (n & i & Hi & ->). - destruct (starve_actual_cycle_position n i Hi) - as (logs & next & Hrun & Hheld & Hturn); exact Hheld. + destruct (starve_cycle_position (6+4*n) i Hi) + as (middle & logs & next & Hrun & Hheld & Hturn). + destruct (proj1 (execution_script_emitted (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + starvation_execution (19+13*n) starvation_cycle i Remote1 + (starve_boundary (6+4*n)) middle logs next (starve_cycle_event (6+4*n) i) + starvation_execution_valid (starve_boundaries n) (starve_cycle_script n) + ltac:(change (i < 13); lia) Hrun Hturn)) + as (_ & _ & _ & _ & Hremote1). + rewrite Hremote1; exact Hheld. Qed. Local Lemma starve_prefix_never_retire8 c i idx : i < 19 -> @@ -508,33 +429,11 @@ Proof. intros [-> | ->]; vm_compute; reflexivity. Qed. -Local Lemma stalled_cycle_run c : - run_turns (turn 1) event_obs owner_stall_cycle (stalled_boundary c) = - Some (stalled_boundary c,[]). -Proof. reflexivity. Qed. - -(** Transfer the finite polling calculation to the actual accumulated heap; - neither this lemma nor the infinite witness resets that heap. *) -Local Lemma stalled_cycle_run_actual c s : - state_equiv s (stalled_boundary c) -> - exists last, run_turns (turn 1) event_obs owner_stall_cycle s = Some (last,[]) /\ - state_equiv last s. -Proof. - intro Hs. - destruct (run_turns_some_compatible (turn 1) event_obs state_equiv (turn_proper 1) - owner_stall_cycle (stalled_boundary c) s (stalled_boundary c) [] - (state_equiv_sym _ _ Hs) (stalled_cycle_run c)) - as (last & Hrun & Hlast). - exists last; split; [exact Hrun|]. - eapply state_equiv_trans; [apply state_equiv_sym; exact Hlast|]. - apply state_equiv_sym; exact Hs. -Qed. - Local Lemma stalled_prefix_position k : k < 13 -> exists before after logs, run_turns (turn 1) event_obs (List.firstn k owner_stall_prefix) (initial_state 2 0) = Some (before,logs) /\ - turn 1 (owner_stall_choices k) before = + turn 1 (List.nth k owner_stall_prefix Remote0) before = Some (after,List.nth k stalled_prefix_observations None). Proof. intro Hk. @@ -570,14 +469,13 @@ Local Lemma stalled_prefix_state : state_equiv (states owner_stall_execution 13) (stalled_boundary 4). Proof. destruct (stalled_prefix_run 0) as (last & Hrun & Hlast). - destruct (execution_window_state (turn 1) event_obs + eapply state_equiv_trans; [|exact Hlast]. + replace 13 with (0 + List.length owner_stall_prefix) by reflexivity. + exact (execution_script_state (turn 1) event_obs (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) - owner_stall_execution 0 (List.length owner_stall_prefix) (initial_state 2 0) - owner_stall_execution_valid stalled_initial_equiv) as (actual & Hactual & Hstate). - rewrite stalled_prefix_script, Hrun in Hactual. - assert (Elast : actual = last) by congruence; subst actual. - replace (0 + List.length owner_stall_prefix) with 13 in Hstate by reflexivity. - eapply state_equiv_trans; [exact Hstate|exact Hlast]. + owner_stall_execution 0 owner_stall_prefix (initial_state 2 0) last + (stalled_prefix_logs 0) owner_stall_execution_valid stalled_initial_equiv + stalled_prefix_script Hrun). Qed. Local Lemma stalled_prefix_observation k : k < 13 -> @@ -586,44 +484,19 @@ Local Lemma stalled_prefix_observation k : k < 13 -> Proof. intro Hk. destruct (stalled_prefix_position k Hk) as (before & after & logs & Hrun & Hturn). - assert (Hscript : List.map (selected owner_stall_execution) (List.seq 0 k) = - List.firstn k owner_stall_prefix). - { - rewrite <- (map_seq_firstn (selected owner_stall_execution) 0 - (List.length owner_stall_prefix) k ltac:(change (k <= 13); lia)). - rewrite stalled_prefix_script; reflexivity. - } - destruct (execution_window_state (turn 1) event_obs + exact (proj2 (execution_script_emitted (turn 1) event_obs (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) - owner_stall_execution 0 k (initial_state 2 0) - owner_stall_execution_valid stalled_initial_equiv) as (actual & Hactual & Hstate). - rewrite Hscript, Hrun in Hactual. - assert (Ebefore : actual = before) by congruence; subst actual. - rewrite Nat.add_0_l in Hstate. - change (turn 1 (selected owner_stall_execution k) before = - Some (after,List.nth k stalled_prefix_observations None)) in Hturn. - destruct (execution_turn_observation (turn 1) (fun s => s = initial_state 2 0) - state_equiv (turn_proper 1) owner_stall_execution k before - owner_stall_execution_valid Hstate) as (next & Hnext & _). - rewrite Hturn in Hnext; congruence. -Qed. - -Local Lemma stalled_prefix_events : - List.map (emitted owner_stall_execution) (List.seq 0 13) = - stalled_prefix_observations. -Proof. - apply (map_seq_eq 0 13 _ _ None); [reflexivity|]. - intros i Hi; cbn [Nat.add]; now apply stalled_prefix_observation. + owner_stall_execution 0 owner_stall_prefix k Remote0 + (initial_state 2 0) before logs after + (List.nth k stalled_prefix_observations None) + owner_stall_execution_valid stalled_initial_equiv stalled_prefix_script + ltac:(change (k < 13); lia) Hrun Hturn)). Qed. Local Lemma stalled_retire6 : emitted owner_stall_execution 8 = Some (stamp (tag_retire,6) 2). Proof. exact (stalled_prefix_observation 8 ltac:(lia)). Qed. -Local Lemma stalled_retire8 : - emitted owner_stall_execution 12 = Some (stamp (tag_retire,8) 3). -Proof. exact (stalled_prefix_observation 12 ltac:(lia)). Qed. - Local Lemma stalled_tail_choices n : selected owner_stall_execution (13+n) = List.nth (n mod 2) owner_stall_cycle Remote0. @@ -705,31 +578,6 @@ Proof. congruence. Qed. -Local Lemma stalled_suffix_stable n : - state_equiv (states owner_stall_execution (13+n)) - (states owner_stall_execution 13) /\ - emitted owner_stall_execution (13+n) = None. -Proof. - split; [|apply stalled_suffix_silent]. - eapply state_equiv_trans; [apply stalled_suffix_state|]. - apply state_equiv_sym; exact stalled_prefix_state. -Qed. - -Local Lemma stalled_remote_chain n : - aheap (states owner_stall_execution (13+n)) (remote_head 1) = Some 8 /\ - linked (fun a next => aheap (states owner_stall_execution (13+n)) a = Some next) [8;6] 0 /\ - acount (states owner_stall_execution (13+n)) = 4 /\ - owner_state (states owner_stall_execution (13+n)) = ORead /\ - remote0_state (states owner_stall_execution (13+n)) = RPoll /\ - remote1_state (states owner_stall_execution (13+n)) = RPoll. -Proof. - destruct (stalled_suffix_state n) as (Hheap & Hcount & Howner & Hzero & Hone). - split; [rewrite Hheap; reflexivity|]. - split. - - cbn [linked List.hd]; repeat split; rewrite Hheap; reflexivity. - - exact (conj Hcount (conj Howner (conj Hzero Hone))). -Qed. - Local Lemma stalled_no_reclaim k block : ~ block_event tag_reclaim block (emitted owner_stall_execution k). Proof. diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v index f1e2171..da37a4d 100644 --- a/examples/CSL/Allocator/Execution.v +++ b/examples/CSL/Allocator/Execution.v @@ -670,14 +670,11 @@ Proof. as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - - symmetry; apply equ_sbisim, (interp_schedule_nd_equ sh), pool_replace_current. - - etransitivity. - + exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) - ((allocator_pool base s) $ slot_of_actor who) (aheap s,acount s) - (event_obs event) residual (aheap t,acount t) Hseg). - + apply emit_list_sbisim, equ_sbisim, (interp_schedule_nd_equ sh). - exact (source_replace_turn base who s t event residual Hturn). + - exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) + 2 (allocator_pool base s) (slot_of_actor who) (aheap s,acount s) + (event_obs event) residual (aheap t,acount t) Hseg). + - apply emit_list_sbisim, equ_sbisim, (interp_schedule_nd_equ sh). + exact (source_replace_turn base who s t event residual Hturn). Qed. Theorem turn_interp_rr base capacity who s t event cursor : @@ -696,15 +693,11 @@ Proof. as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - - symmetry; apply equ_sbisim, interp_schedule_rr_equ, - pool_replace_current. - - etransitivity. - + exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) - ((allocator_pool base s) $ slot_of_actor who) cursor (aheap s,acount s) - (event_obs event) residual (aheap t,acount t) Hseg). - + apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. - exact (source_replace_turn base who s t event residual Hturn). + - exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) + 2 (allocator_pool base s) (slot_of_actor who) cursor (aheap s,acount s) + (event_obs event) residual (aheap t,acount t) Hseg). + - apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. + exact (source_replace_turn base who s t event residual Hturn). Qed. (** At an arbitrary aligned pool and store the final handler state is only @@ -722,18 +715,13 @@ Theorem selected_turn_interp_nd base capacity (ts : pool sE 3) (interp_schedule_nd sh 3 (ts @ slot_of_actor who := residual) None sigma'). Proof. intros Hpool Hagree Hinv Hturn. - destruct (selected_turn_segment 2 sh slot_of_actor (turn base) (allocator_pool base) - state_agrees (allocator_inv base capacity) (allocator_simulation base capacity) + destruct (pool_simulation_turn_nd (allocator_simulation base capacity) ts s who t event sigma Hinv Hagree Hpool Hturn) - as (residual & sigma' & Hseg & Hstate & Hnext). + as (residual & sigma' & Hstate & Hnext & Hinterp). exists residual, sigma'; split; [exact Hstate|]; split. - pose proof (Hnext (slot_of_actor who)) as Htail. rewrite Vector.nth_replace_eq in Htail; exact Htail. - - etransitivity. - + symmetry; apply equ_sbisim, (interp_schedule_nd_equ sh), pool_replace_current. - + exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) - 2 ts (slot_of_actor who) (ts $ slot_of_actor who) sigma - (event_obs event) residual sigma' Hseg). + - exact Hinterp. Qed. Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) @@ -749,18 +737,15 @@ Theorem selected_turn_interp_rr base capacity (ts : pool sE 3) (interp_schedule_rr sh 3 (ts @ slot_of_actor who := residual) None cursor sigma'). Proof. intros Hpool Hagree Hinv Hturn. - destruct (selected_turn_segment 2 sh slot_of_actor (turn base) (allocator_pool base) - state_agrees (allocator_inv base capacity) (allocator_simulation base capacity) + destruct (selected_turn_segment (allocator_simulation base capacity) ts s who t event sigma Hinv Hagree Hpool Hturn) as (residual & sigma' & Hseg & Hstate & Hnext). exists residual, sigma'; split; [exact Hstate|]; split. - pose proof (Hnext (slot_of_actor who)) as Htail. rewrite Vector.nth_replace_eq in Htail; exact Htail. - - etransitivity. - + symmetry; apply equ_sbisim, interp_schedule_rr_equ, pool_replace_current. - + exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) - 2 ts (slot_of_actor who) (ts $ slot_of_actor who) cursor sigma - (event_obs event) residual sigma' Hseg). + - exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) + 2 ts (slot_of_actor who) cursor sigma + (event_obs event) residual sigma' Hseg). Qed. From Coinduction Require Import coinduction rel tactics. @@ -788,9 +773,8 @@ Theorem run_rr_allocator_bisim capacity c : : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_allocator_initialized. - exact (pool_simulation_rr_bisim 2 sh actor_of_slot slot_of_actor - slot_of_actor_of_slot (turn 1) (allocator_pool 1) state_agrees - (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + exact (pool_simulation_rr_bisim actor_of_slot slot_of_actor_of_slot + (allocator_simulation 1 capacity) (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) 0 (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). @@ -802,9 +786,8 @@ Theorem run_nd_allocator_bisim capacity c : : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_nd_allocator_initialized. - exact (pool_simulation_nd_bisim 2 sh actor_of_slot slot_of_actor - slot_of_actor_of_slot (turn 1) (allocator_pool 1) state_agrees - (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + exact (pool_simulation_nd_bisim actor_of_slot slot_of_actor_of_slot + (allocator_simulation 1 capacity) (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). diff --git a/examples/CSL/Allocator/Layout.v b/examples/CSL/Allocator/Layout.v index 45a188b..b5d5c71 100644 --- a/examples/CSL/Allocator/Layout.v +++ b/examples/CSL/Allocator/Layout.v @@ -25,12 +25,6 @@ Definition tag_retire : nat := 1. Definition tag_reclaim : nat := 2. Definition tag_retry : nat := 3. -Definition page_metadata (base : nat) : list nat := - [remote_head base; local_head base; drain_head base; - mailbox base false; mailbox base true]. -Definition page_cells (base capacity : nat) : list nat := - page_metadata base ++ cells (page_blocks base capacity). - Lemma page_size_positive capacity : Nat.lt 0 (page_size capacity). Proof. unfold page_size; lia. Qed. @@ -60,67 +54,6 @@ Lemma page_blocks_link_payload_disjoint base capacity a b : a <> S b. Proof. apply node_addrs_link_payload_disjoint. Qed. -Lemma page_metadata_range base x : - In x (page_metadata base) <-> Nat.le base x /\ Nat.lt x (base + 5). -Proof. - unfold page_metadata, remote_head, local_head, drain_head, mailbox. - cbn [In]; lia. -Qed. - -Lemma page_metadata_nodup base : NoDup (page_metadata base). -Proof. - unfold page_metadata, remote_head, local_head, drain_head, mailbox. - repeat constructor; cbn [In]; intuition lia. -Qed. - - -Lemma mailbox_injective base client client' : - mailbox base client = mailbox base client' -> client = client'. -Proof. destruct client, client'; unfold mailbox; intros H; try reflexivity; lia. Qed. - -Lemma page_metadata_blocks_disjoint base capacity x b : - In x (page_metadata base) -> In b (page_blocks base capacity) -> - x <> b /\ x <> S b. -Proof. - intros Hx Hb; apply page_metadata_range in Hx. - apply page_blocks_bounds in Hb; lia. -Qed. - -Lemma page_block_cells_range base capacity x : - In x (cells (page_blocks base capacity)) <-> - Nat.le (base + 5) x /\ Nat.lt x (base + page_size capacity). -Proof. - unfold page_blocks; rewrite node_cells_range; unfold page_size; lia. -Qed. - -Lemma page_cells_range base capacity x : - In x (page_cells base capacity) <-> - Nat.le base x /\ Nat.lt x (base + page_size capacity). -Proof. - unfold page_cells; rewrite in_app_iff, page_metadata_range, page_block_cells_range. - unfold page_size; lia. -Qed. - -(** This is the addresswise coverage useful for splitting metadata, links, - and payloads in the ownership invariant. *) -Lemma page_interval_coverage base capacity x : - (Nat.le base x /\ Nat.lt x (base + page_size capacity)) <-> - In x (page_metadata base) \/ - exists b, In b (page_blocks base capacity) /\ (x = b \/ x = S b). -Proof. - rewrite <- page_cells_range; unfold page_cells. - rewrite in_app_iff, in_cells; reflexivity. -Qed. - -Lemma page_cells_nodup base capacity : NoDup (page_cells base capacity). -Proof. - unfold page_cells; apply NoDup_app. - - apply page_metadata_nodup. - - apply node_addrs_cells_nodup. - - intros x Hmeta Hblock. - apply page_metadata_range in Hmeta. - apply page_block_cells_range in Hblock; lia. -Qed. (** ** Pure counterparts of the checked initialization writes @@ -194,19 +127,6 @@ Proof. - intro H; now left. Qed. -Lemma page_heap_closed_none base capacity x : - page_heap base capacity hemp x = None <-> - Nat.lt x base \/ Nat.le (base + page_size capacity) x. -Proof. - split. - - intro Hnone; destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. - + now left. - + destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. - * exfalso; apply (page_heap_in base capacity hemp x (conj Hlo Hhi)); exact Hnone. - * now right. - - intro Hout; rewrite page_heap_frame by exact Hout; reflexivity. -Qed. - Lemma page_heap_old_frame base capacity h : block_free h base (page_size capacity) -> @@ -220,43 +140,6 @@ Proof. + apply page_heap_frame; now right. Qed. -Lemma page_heap_on_page base capacity h f x : - (Nat.le base x /\ Nat.lt x (base + page_size capacity)) -> - page_heap base capacity h x = page_heap base capacity f x. -Proof. - intro Hin; unfold page_heap; apply init_links_heap_lookup_agree. - repeat apply upd_lookup_agree. - rewrite (page_backing_in base capacity h x Hin). - rewrite (page_backing_in base capacity f x Hin); reflexivity. -Qed. - - -Lemma page_heap_split base capacity h : - heq (page_heap base capacity h) (hunion (page_heap base capacity hemp) h). -Proof. - intro x; destruct (Nat.lt_ge_cases x base) as [Hlo | Hlo]. - - rewrite hunion_none. - + apply page_heap_frame; now left. - + rewrite page_heap_frame by (now left); reflexivity. - - destruct (Nat.lt_ge_cases x (base + page_size capacity)) as [Hhi | Hhi]. - + rewrite hunion_eq by (apply page_heap_in; split; assumption). - apply page_heap_on_page; split; assumption. - + rewrite hunion_none. - * apply page_heap_frame; now right. - * rewrite page_heap_frame by (now right); reflexivity. -Qed. - -Lemma page_heap_disjoint base capacity h : - block_free h base (page_size capacity) -> - hdisj (page_heap base capacity hemp) h. -Proof. - intros Hfree x; destruct (page_heap base capacity hemp x) eqn:E. - - right. - assert (Hin : Nat.le base x /\ Nat.lt x (base + page_size capacity)). - { apply page_heap_closed_dom; rewrite E; discriminate. } - replace x with (base + (x - base)) by lia; apply Hfree; lia. - - now left. -Qed. Lemma page_heap_finite base capacity h : heap_finite h -> heap_finite (page_heap base capacity h). @@ -304,23 +187,7 @@ Lemma page_heap_local_blocks base capacity h : page_heap base capacity h (local_head base) = Some (hd 0 (page_blocks base capacity)). Proof. rewrite page_heap_local; destruct capacity; reflexivity. Qed. -Lemma page_heap_payload base capacity h b : - In b (page_blocks base capacity) -> page_heap base capacity h (S b) = Some 0. -Proof. - intro Hb; pose proof (page_blocks_bounds base capacity b Hb) as Hbounds. - unfold page_heap; rewrite init_links_heap_payload by exact Hb. - unfold remote_head, local_head, drain_head, mailbox. - repeat rewrite upd_neq by lia. - apply page_backing_in; lia. -Qed. - Lemma page_heap_link base capacity h prefix b rest : page_blocks base capacity = prefix ++ b :: rest -> page_heap base capacity h b = Some (hd 0 rest). Proof. intro H; unfold page_heap; apply init_links_heap_link with (prefix := prefix); exact H. Qed. - -Lemma page_heap_link_index base capacity h j : - Nat.lt j capacity -> - page_heap base capacity h (base + 5 + 2 * j) = - Some (if Nat.ltb (S j) capacity then base + 5 + 2 * S j else 0). -Proof. intro H; unfold page_heap; apply init_links_heap_link_index, H. Qed. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v index 806f232..6df4604 100644 --- a/examples/CSL/Allocator/Liveness.v +++ b/examples/CSL/Allocator/Liveness.v @@ -386,25 +386,21 @@ Proof. exact (pool_step_branchfree 2 sh slot_of_actor who ts1 sigma1 logs ts2 sigma2 Hstep H). } split; [apply Hbf|]. - destruct (pool_simulation_reachable 2 sh slot_of_actor (turn 1) (allocator_pool 1) - state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + destruct (pool_simulation_reachable (allocator_simulation 1 capacity) (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) ts sigma Hreach) as (s & Hinv & Hagree & Hpool). rewrite <- (slot_of_actor_of_slot i). split. - - destruct (pool_simulation_worker_segment 2 sh slot_of_actor (turn 1) - (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + - destruct (pool_simulation_worker_segment (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma Hinv Hagree Hpool) as (event & residual & sigma' & Hseg). exists (event_obs event), residual, sigma'; exact Hseg. - - destruct (pool_simulation_no_terminal_prefix 2 sh slot_of_actor (turn 1) - (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + - destruct (pool_simulation_no_terminal_prefix (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma Hinv Hagree Hpool) as (Hr & Hf & Hb & Hstuck). - destruct (pool_simulation_no_fault_or_divergence 2 sh slot_of_actor (turn 1) - (allocator_pool 1) state_agrees (allocator_inv 1 capacity) + destruct (pool_simulation_no_fault_or_divergence (allocator_simulation 1 capacity) ts s (actor_of_slot i) sigma Hinv Hagree Hpool) as (_ & Hspin & _). repeat split; assumption. @@ -532,8 +528,7 @@ Proof. intro Hvalid. assert (Hmodel : allocator_valid capacity c (allocator_execution capacity c (selected se))) by apply execution_of_choices_valid. - destruct (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) - state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + destruct (source_execution_complete (allocator_simulation 1 capacity) (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se (allocator_execution capacity c (selected se)) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel @@ -545,20 +540,16 @@ Proof. - apply raw_remote_pending_alignment; exact (Hpool (slot_of_actor Remote1)). Qed. -Definition source_has_event (kind block : nat) - (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) (k : nat) : Prop := - exists idx, List.In (stamp (kind,block) idx) (emitted se k). - Theorem source_remote_free_lockfree capacity c se : allocator_source_valid capacity c se -> infinitely (selected_source_pending se) -> - infinitely (fun k => exists block, source_has_event tag_retire block se k). + infinitely (fun k => + exists block idx, List.In (stamp (tag_retire,block) idx) (emitted se k)). Proof. intros Hvalid Hpending. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. - pose proof (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) - state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + pose proof (source_execution_complete (allocator_simulation 1 capacity) (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel @@ -684,18 +675,20 @@ Lemma execution_owner_rank capacity c e k : allocator_view 1 capacity (states e k) L R D /\ owner_rank capacity (owner_state (states e k)) R D <= owner_round_bound capacity. Proof. - intro Hv; induction k as [|k IH]. - - destruct (execution_inv (turn 1) (allocator_inv 1 capacity) - (fun s => s = initial_state capacity c) e (allocator_initial_inv capacity c) - (turn_preserves_inv 1 capacity) 0 Hv) as (L & R & D & Hview). + intro Hv. + apply (execution_inv (turn 1) + (fun s => exists L R D, allocator_view 1 capacity s L R D /\ + owner_rank capacity (owner_state s) R D <= owner_round_bound capacity) + (fun s => s = initial_state capacity c) e). + - intros s ->. + destruct (initial_state_inv capacity c) as (L & R & D & Hview). exists L, R, D; split; [exact Hview|]. - rewrite (proj1 Hv); cbn [initial_state owner_state owner_rank]. - unfold owner_round_bound; lia. - - destruct IH as (L & R & D & Hview & Hrank). - destruct (owner_lists_step_bounded capacity (selected e k) (states e k) - (states e (S k)) (emitted e k) L R D Hview Hrank - (execution_step (turn 1) (fun s => s = initial_state capacity c) e k Hv)) as (L' & R' & D' & Hview' & Hrank' & _). - now exists L', R', D'. + cbn [initial_state owner_state owner_rank]; unfold owner_round_bound; lia. + - intros a s s' o (L & R & D & Hview & Hrank) Hturn. + destruct (owner_lists_step_bounded capacity a s s' o L R D Hview Hrank Hturn) + as (L' & R' & D' & Hview' & Hrank' & _). + exists L', R', D'; split; [exact Hview'|exact Hrank']. + - exact Hv. Qed. Definition round_completion (e : (Execution AState Actor (option (indexed (nat * nat))))) k := @@ -766,15 +759,10 @@ Theorem owner_round_selection_bound capacity c e lo len : count_if (fun k => owner_selected (selected e k)) lo (S j - lo) <= 3 * capacity + 5. Proof. intros Hv Hcount. - destruct (finite_first (round_completion e) (round_completion_dec e) lo len) - as [Hnone|(j & Hj & Hdone & Hfirst)]. - - pose proof (no_round_completion_owner_bound capacity c e lo len Hv Hnone); lia. - - exists j; split; [exact Hj|]; split; [exact Hdone|]. - pose proof (no_round_completion_owner_bound capacity c e lo (j-lo) Hv - ltac:(intros i Hi; apply Hfirst; lia)) as Hbefore. - replace (S j-lo) with ((j-lo)+1) by lia. - rewrite count_if_add, count_if_succ, count_if_zero. - cbv beta; destruct (owner_selected (selected e (lo + (j-lo)))); lia. + apply (count_if_first (fun k => owner_selected (selected e k)) + (round_completion e) (round_completion_dec e) lo len (3 * capacity + 5)); + [|exact Hcount]. + intros m Hnone; exact (no_round_completion_owner_bound capacity c e lo m Hv Hnone). Qed. Inductive reclaim_credit (capacity block : nat) (pc : owner_pc) (R D : list nat) : nat -> Prop := @@ -970,31 +958,17 @@ Theorem retired_reclaimed_owner_selection_bound capacity c e k block idx len : count_if (fun k => owner_selected (selected e k)) (S k) (j-k) <= 6 * capacity + 10. Proof. intros Hv Hret Hcount. - destruct (finite_first (fun j => block_event tag_reclaim block (emitted e j)) - (fun j => block_event_dec tag_reclaim block (emitted e j)) (S k) len) - as [Hnone|(j & Hj & [idx' Hreclaim] & Hfirst)]. - - pose proof (no_reclaim_owner_bound capacity c e k block idx len Hv Hret Hnone); lia. - - exists j, idx'; split; [lia|]; split; [lia|]; split. - + exact (execution_event_order (turn 1) - (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e k j _ _ Hv ltac:(lia) Hret Hreclaim). - + split; [exact Hreclaim|]. - pose proof (no_reclaim_owner_bound capacity c e k block idx (j-S k) Hv Hret - ltac:(intros q Hq; apply Hfirst; lia)) as Hbefore. - replace (j-k) with ((j-S k)+1) by lia. - rewrite count_if_add, count_if_succ, count_if_zero. - cbv beta; destruct (owner_selected (selected e (S k + (j-S k)))); lia. -Qed. - -Lemma infinitely_owner_count (e : Execution AState Actor (option (indexed (nat * nat)))) : - infinitely (fun k => selected e k = Owner) -> - forall lo n, exists len, n <= count_if (fun k => owner_selected (selected e k)) lo len. -Proof. - intros Hinf lo n. - apply infinitely_count_if. - intro start. - destruct (Hinf start) as (k & Hk & Howner). - exists k; split; [exact Hk|]. - apply owner_selected_spec; exact Howner. + destruct (count_if_first (fun k => owner_selected (selected e k)) + (fun j => block_event tag_reclaim block (emitted e j)) + (fun j => block_event_dec tag_reclaim block (emitted e j)) + (S k) len (6 * capacity + 10) + (fun m Hnone => no_reclaim_owner_bound capacity c e k block idx m Hv Hret Hnone) + Hcount) as (j & Hj & [idx' Hreclaim] & Hbound). + exists j, idx'; split; [lia|]; split; [lia|]; split. + - exact (execution_event_order (turn 1) + (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) + e k j _ _ Hv ltac:(lia) Hret Hreclaim). + - split; [exact Hreclaim|exact Hbound]. Qed. Theorem retired_eventually_reclaimed capacity c e : @@ -1006,7 +980,11 @@ Theorem retired_eventually_reclaimed capacity c e : emitted e j = Some (stamp (tag_reclaim,block) idx'). Proof. intros Hv Howner k block idx Hret. - destruct (infinitely_owner_count e Howner (S k) (6*capacity+10)) as [len Hlen]. + assert (Hcharged : infinitely (fun j => owner_selected (selected e j) = true)). + { intro start; destruct (Howner start) as (m & Hm & Hsel). + exists m; split; [exact Hm|apply owner_selected_spec; exact Hsel]. } + destruct (infinitely_count_if (fun j => owner_selected (selected e j)) + Hcharged (6*capacity+10) (S k)) as [len Hlen]. destruct (retired_reclaimed_owner_selection_bound capacity c e k block idx len Hv Hret Hlen) as (j & idx' & Hkj & _ & Hidx & Hevent & _). now exists j, idx'. @@ -1067,8 +1045,7 @@ Proof. intros Hvalid Howner k block idx Hretire. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. - pose proof (source_execution_complete 2 sh slot_of_actor (turn 1) (allocator_pool 1) - state_agrees (allocator_inv 1 capacity) (allocator_simulation 1 capacity) + pose proof (source_execution_complete (allocator_simulation 1 capacity) (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v index e34e493..fd841ee 100644 --- a/examples/CSL/Allocator/Model.v +++ b/examples/CSL/Allocator/Model.v @@ -333,15 +333,6 @@ Proof. * intro impossible; inversion impossible. Qed. -Lemma turn_event_counter base who s s' event : - turn base who s = Some (s',event) -> - acount s' = (acount s + List.length (event_obs event))%nat. -Proof. - intro Hstep; pose proof (turn_counter base who s s' event Hstep) as H. - destruct event as [o|]; cbn [event_obs List.length] in H |- *; - [destruct H as [Hcount _]; lia | lia]. -Qed. - From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. From TICL Require Import Lang.CSL. From TICL Require Import Lang.CSL.Queue.Representation. @@ -380,40 +371,6 @@ Proof. rewrite upd_dom; [apply Hback | now apply (proj2 (Hback a))]. Qed. -Lemma allocator_inv_backing base capacity s : - allocator_inv base capacity s -> backing base capacity (aheap s). -Proof. intros (_ & _ & _ & _ & H & _); exact H. Qed. - -Lemma allocator_inv_null base capacity s : - allocator_inv base capacity s -> aheap s 0 = None. -Proof. - intros (_ & _ & _ & Hbase & Hback & _). - destruct (aheap s 0) as [v|] eqn:E; [|reflexivity]. - assert (Hpresent : aheap s 0 <> None) by (rewrite E; discriminate). - apply Hback in Hpresent; lia. -Qed. - -Lemma allocator_inv_outside base capacity s x : - allocator_inv base capacity s -> - (x < base \/ base + page_size capacity <= x) -> aheap s x = None. -Proof. - intros (_ & _ & _ & _ & Hback & _) Hout. - destruct (aheap s x) as [v|] eqn:E; [|reflexivity]. - assert (Hpresent : aheap s x <> None) by (rewrite E; discriminate). - apply Hback in Hpresent; lia. -Qed. - -Lemma allocator_inv_held_member base capacity s (client : bool) b : - allocator_inv base capacity s -> - In b (held (if client then remote1_state s else remote0_state s)) -> - In b (page_blocks base capacity). -Proof. - intros (L & R & D & _ & _ & m0 & m1 & Hr & Hl & Hd & CL & CR & CD & - Hm0 & Hm1 & Hp & Hop & Ho & Hc0 & Hc1) Hin. - eapply Permutation_in; [exact Hp |]. - repeat rewrite in_app_iff; destruct client; tauto. -Qed. - (* These small tactics only discharge finite ownership arithmetic. In particular, a cached head is never used as a freshness witness. *) Ltac ai_member := diff --git a/theories/ICTree/Equ.v b/theories/ICTree/Equ.v index 70b427b..1b013e3 100644 --- a/theories/ICTree/Equ.v +++ b/theories/ICTree/Equ.v @@ -48,6 +48,17 @@ Ltac observe_equ_all := | _ => idtac end. +(** Equal observations give [equ]-equal trees. *) +Lemma observe_eq_equ {E} {HE : Encode E} {X} (t u : ictree E X) : + observe t = observe u -> t ≅ u. +Proof. + intro Hobserve. + transitivity (go (observe t)). + - apply ictree_eta. + - rewrite Hobserve. + symmetry. apply ictree_eta. +Qed. + (** * Forgetting finitely many leading guards. [guard_equ] is the equivalence closure of "raw-equivalent, or one leading diff --git a/theories/ICTree/Interp/Heap.v b/theories/ICTree/Interp/Heap.v index 20bc194..0fece31 100644 --- a/theories/ICTree/Interp/Heap.v +++ b/theories/ICTree/Interp/Heap.v @@ -356,18 +356,6 @@ Section HeapInterp. rewrite bind_stuck_equ; reflexivity. Qed. - Lemma interp_heap_free {X} a h (aux : Sigma) - (k : unit -> ictree (heapE + G) X) : - interp_state (h_sum heap_handler other) (heap_free a >>= k) (h,aux) ~ - interp_state (h_sum heap_handler other) (k tt) (hfree a h,aux). - Proof. - unfold heap_free, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl; - rewrite bind_vis; setoid_rewrite bind_ret_l. - rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_free (F:=F) a h aux), bind_ret_l. - apply sb_guard. - Qed. - Lemma interp_heap_alloc_zero h (aux : Sigma) : interp_state (h_sum heap_handler other) (heap_alloc (E:=heapE + G) 0) (h,aux) ≅ (stuck : ictree F (nat * (Heap * Sigma))). diff --git a/theories/ICTree/Interp/Refine.v b/theories/ICTree/Interp/Refine.v index 2eb5709..2593c6a 100644 --- a/theories/ICTree/Interp/Refine.v +++ b/theories/ICTree/Interp/Refine.v @@ -113,10 +113,6 @@ Section BranchFreeLaws. Lemma bf_ret {A} (x : A) : BranchFree (Ret x : ictree E A). Proof. apply branchfree_unfold; constructor. Qed. - Lemma bf_guard {A} (t : ictree E A) : - BranchFree t -> BranchFree (Guard t). - Proof. intro Ht; apply branchfree_unfold; now constructor. Qed. - Lemma bf_vis {A} e (k : encode e -> ictree E A) : (forall x, BranchFree (k x)) -> BranchFree (Vis e k). Proof. intro Hk; apply branchfree_unfold; now constructor. Qed. diff --git a/theories/ICTree/Interp/State/Mod.v b/theories/ICTree/Interp/State/Mod.v index eceb1af..fe65ee1 100644 --- a/theories/ICTree/Interp/State/Mod.v +++ b/theories/ICTree/Interp/State/Mod.v @@ -148,58 +148,6 @@ Lemma interp_state_tau `{Encode E} `{Encode F} `(h: E ~> stateT W (ictree F)) {X interp_state h (Guard t) w ≅ Guard ((interp_state h t w)). Proof. rewrite !unfold_interp_state; reflexivity. Qed. -(** [interp_state] applied on subevents, interprets the events leaving behind a subevent *) -Definition h_resum `{Encode E1}`{Encode E2}`{Encode F}`{ReSum E1 E2}`{ReSumRet E1 E2} {W} - (h: E2 ~> stateT W (ictree F)): E1 ~> stateT W (ictree F) := - fun (e: E1) => - mkStateT - (fun w => runStateT (h (resum e)) w >>= fun '(x, w) => Ret (resum_ret e x, w)). - -Lemma interp_state_resumICtree`{Encode E1}`{Encode E2}`{Encode F} - `{ReSum E1 E2}`{ReSumRet E1 E2} {X} `(h: E2 ~> stateT W (ictree F)): - forall (t : ictree E1 X) (w : W), - interp_state h (resumICtree t) w ≅ interp_state (h_resum h) t w. -Proof. - coinduction RR CIH; intros. - rewrite unfold_resumICtree, unfold_interp_state. - setoid_rewrite unfold_interp_state. - cbn. - desobs t; cbn. - - reflexivity. - - constructor. - intro i. - step. - constructor. - apply CIH. - - constructor. - apply CIH. - - cbn. - rewrite bind_bind. - upto_bind_equ. - destruct x. - rewrite bind_ret_l. - constructor. - apply CIH. -Qed. - -(** Inversion lemma for [interp_state] applied on return values. *) -Lemma interp_state_ret_inv `{Encode E} `{Encode F} - `(h: E ~> stateT W (ictree F)) {X}: forall s (t : ictree E X) r, - interp_state h t s ≅ Ret r -> t ≅ Ret (fst r) /\ s = snd r. -Proof. - intros. - setoid_rewrite (ictree_eta t) in H1. - setoid_rewrite (ictree_eta t). - destruct (observe t) eqn:?. - - rewrite interp_state_ret in H1. step in H1. inv H1. split; reflexivity. - - rewrite interp_state_br in H1. step in H1. inv H1. - - rewrite interp_state_tau in H1. step in H1. inv H1. - - rewrite interp_state_vis in H1. apply ret_equ_bind in H1 as (? & ? & ?). - destruct x. - step in H2. - inv H2. -Qed. - (** [interp_state] applied on bind, commutes with the bind structure. *) Arguments interp_state: simpl never. Local Typeclasses Transparent equ. @@ -233,18 +181,6 @@ Proof. apply IH. Qed. -(** [interp_state] applied on map, commutes with the map structure. *) -Lemma interp_state_map `{Encode E} `{Encode F} `(h : E ~> stateT W (ictree F)) - {A B} (t : ictree E A) (f : A -> B) (s : W) : - interp_state h (ICtree.map f t) s ≅ ICtree.map (fun '(x, s) => (f x, s)) (interp_state h t s). -Proof. - unfold ICtree.map. - rewrite interp_state_bind. - upto_bind_equ. - destruct x1. - apply interp_state_ret. -Qed. - (** [interp_state] applied on iteration, unfolds the iteration structure and commutes the interpretation inside the loop body. *) Lemma interp_state_unfold_iter `{Encode E} `{Encode F} `(h : E ~> stateT W (ictree F)) {I R} @@ -294,23 +230,6 @@ Proof with eauto. reflexivity. Qed. -(** [instr_stateE] is a special version of [interp_state] for the instrumentation monad. - Commutes with the bind structure. *) -Lemma instr_state_bind {S A B} (t : ictree (stateE S) A) (k : A -> ictree (stateE S) B) (s : S) : - instr_stateE (t >>= k) s ≅ instr_stateE t s >>= fun '(x, s) => instr_stateE (k x) s. -Proof. - unfold instr_stateE. - apply interp_state_bind. -Qed. - -(** [instr_stateE] applied on map, commutes with the map structure. *) -Lemma instr_state_map {S A B} (t : ictree (stateE S) A) (f : A -> B) (s : S) : - instr_stateE (ICtree.map f t) s ≅ ICtree.map (fun '(x, s) => (f x, s)) (instr_stateE t s). -Proof. - unfold instr_stateE. - apply interp_state_map. -Qed. - (** [instr_state] applied on iteration, unfolds the iteration structure and interprets the loop body. *) Lemma instr_state_unfold_iter{S I R} (k : I -> ictree (stateE S) (I + R)) (i: I) (s: S) : @@ -324,22 +243,6 @@ Proof. apply interp_state_unfold_iter. Qed. -(** [instr_state] applied on get, returns the state. *) -Lemma instr_state_get {S}: forall (s: S), - instr_stateE get s ~ Ret (s, s). -Proof. - unfold instr_stateE. - apply interp_state_get. -Qed. - -(** [instr_state] applied on put, interprets the event and the state leaving behind a log event. *) -Lemma instr_state_put {S}: forall (s s': S), - instr_stateE (put s') s ~ log s' ;; Ret (tt, s'). -Proof with eauto. - unfold instr_stateE. - apply interp_state_put. -Qed. - (** * Interpreting one indexed emission. [h_indexed] leaves exactly one observation and advances the shared diff --git a/theories/ICTree/Interp/Yield/Execution.v b/theories/ICTree/Interp/Yield/Execution.v index 3d3ee96..4303466 100644 --- a/theories/ICTree/Interp/Yield/Execution.v +++ b/theories/ICTree/Interp/Yield/Execution.v @@ -307,38 +307,6 @@ Section RawExecution. execution_valid pool_step (fun p => pool_equ (fst p) ts0 /\ snd p = sigma0) se. - (** Selections are physical branch witnesses, never inferred from logs. *) - Definition source_execution_of_slots - (actor : Fin.t (S n) -> Act) - (pools : nat -> pool E (S n)) (sigmas : nat -> Sigma) - (slots : nat -> Fin.t (S n)) (logs : nat -> list W) - : Execution (pool E (S n) * Sigma) Act (list W) := - {| states := fun k => (pools k,sigmas k); - selected := fun k => actor (slots k); - emitted := logs |}. - - (** A slot-built execution is valid from its initial facts and one raw - segment per step; the actor map is only required to name each slot. *) - Lemma source_execution_of_slots_valid - (actor : Fin.t (S n) -> Act) - (slot_actor : forall i, slot (actor i) = i) - (ts0 : pool E (S n)) (sigma0 : Sigma) - (pools : nat -> pool E (S n)) (sigmas : nat -> Sigma) - (slots : nat -> Fin.t (S n)) (logs : nat -> list W) : - pool_equ (pools 0) ts0 -> sigmas 0 = sigma0 -> - (forall k, exists residual, - ThreadSegment handler Rsb (pools k $ slots k) (sigmas k) - (logs k) residual (sigmas (S k)) /\ - pool_equ (pools (S k)) (pools k @ slots k := residual)) -> - pool_execution_valid ts0 sigma0 - (source_execution_of_slots actor pools sigmas slots logs). - Proof. - intros Hpool Hsigma Hsteps; split. - - cbn [source_execution_of_slots states fst snd]; split; assumption. - - intro k; cbn [source_execution_of_slots states selected emitted pool_step]. - rewrite slot_actor; apply Hsteps. - Qed. - Lemma pool_step_branchfree who ts sigma logs ts' sigma' : pool_step who (ts,sigma) logs (ts',sigma') -> (forall j, BranchFree (ts $ j)) -> forall j, BranchFree (ts' $ j). @@ -384,15 +352,14 @@ Arguments pool_execution_valid {E W Sigma Act HE} n handler slot ts0 sigma0 se. function equality of states. *) Section PoolSimulation. Context {E W Sigma St Act : Type} {HE : Encode E} - (n : nat) - (handler : E ~> stateT Sigma (ictreeW W)) - (actor : Fin.t (S n) -> Act) (slot : Act -> Fin.t (S n)) - (actor_slot : forall who, actor (slot who) = who) + {n : nat} + {handler : E ~> stateT Sigma (ictreeW W)} + (actor : Fin.t (S n) -> Act) {slot : Act -> Fin.t (S n)} (slot_actor : forall i, slot (actor i) = i) - (step : Act -> St -> option (St * option W)) - (pool_of : St -> pool E (S n)) - (agree : Sigma -> St -> Prop) - (Inv : St -> Prop). + {step : Act -> St -> option (St * option W)} + {pool_of : St -> pool E (S n)} + {agree : Sigma -> St -> Prop} + {Inv : St -> Prop}. Notation Rexact := (fun Y (t u : ictreeW W Y) => t ≅ u). Notation Rsb := (fun Y (t u : ictreeW W Y) => t ~ u). @@ -437,6 +404,27 @@ Section PoolSimulation. apply guard_equ_equ, Hframe; exact Hne. Qed. + (** One model turn at a guard-aligned pool, run by the ND scheduler focused + on the selected slot. *) + Lemma pool_simulation_turn_nd (ts : pool E (S n)) s who s' event sigma : + Inv s -> agree sigma s -> pool_guard_equ ts (pool_of s) -> + step who s = Some (s',event) -> + exists residual sigma', + agree sigma' s' /\ + pool_guard_equ (ts @ slot who := residual) (pool_of s') /\ + interp_schedule_nd handler (S n) ts (Some (slot who)) sigma ~ + emit_list (event_obs event) + (interp_schedule_nd handler (S n) (ts @ slot who := residual) None sigma'). + Proof. + intros Hinv Hagree Hpool Hstep. + destruct (selected_turn_segment ts s who s' event sigma + Hinv Hagree Hpool Hstep) as (residual & sigma' & Hseg & Hagree' & Hpool'). + exists residual, sigma'; split; [exact Hagree'|split; [exact Hpool'|]]. + apply (segment_interp_nd handler Rsb (fun Y t u (H : t ~ u) => H)). + apply (ThreadSegment_mono handler Rexact Rsb + (fun Y t u => equ_sbisim t u)); exact Hseg. + Qed. + (** Completeness of the abstract model relative to the source: the segment is unique, so the abstract turn determines its logs, its final handler state (relationally), and the updated pool alignment. *) @@ -645,21 +633,10 @@ Section PoolSimulation. destruct (simulation_total Hsim (actor i) s Hinv) as (next & event & Hstep & Hnextinv). rewrite Hstep. - destruct (selected_turn_segment ts s (actor i) next event sigma - Hinv Hagree Hpool Hstep) as (residual & sigma' & Hseg & Hagree' & Hnextpool). - apply (ThreadSegment_mono handler Rexact Rsb - (fun Y t u => equ_sbisim t u)) in Hseg. - pose proof (segment_interp_nd handler Rsb (fun Y t u (H : t ~ u) => H) - n ts (slot (actor i)) (ts $ slot (actor i)) sigma - (event_obs event) residual sigma' Hseg) as Esegment. - rewrite slot_actor in Esegment, Hnextpool. - assert (Efocus : interp_schedule_nd handler (S n) ts (Some i) sigma ~ - emit_list (event_obs event) - (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma')). - { etransitivity; [| exact Esegment]. - symmetry; apply equ_sbisim; - exact (interp_schedule_nd_equ handler (S n) (ts @ i := (ts $ i)) ts - (Some i) sigma (pool_replace_current ts i)). } + destruct (pool_simulation_turn_nd ts s (actor i) next event sigma + Hinv Hagree Hpool Hstep) + as (residual & sigma' & Hagree' & Hnextpool & Efocus). + rewrite slot_actor in Hnextpool, Efocus. etransitivity; [apply (coinduction.gfp_t (sb eq) R); exact Efocus |]. assert (Hcontinue : st eq R (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma') diff --git a/theories/ICTree/Interp/Yield/Mod.v b/theories/ICTree/Interp/Yield/Mod.v index 63fdcfa..55073e1 100644 --- a/theories/ICTree/Interp/Yield/Mod.v +++ b/theories/ICTree/Interp/Yield/Mod.v @@ -128,15 +128,6 @@ Proof. intros t u Ht. unfold interp_yield. now rewrite Ht. Qed. Proper (equ eq ==> equ eq) (@interp_thread E HE X). Proof. intros t u Ht. unfold interp_thread, interp_yield. now rewrite Ht. Qed. -(** Erasure handlers intentionally hide scheduler/thread observations. *) -Lemma handle_spawn_spawn_erased {E} {HE : Encode E} : - @handle_spawn E HE (inr (inl Spawn)) = Ret tt. -Proof. reflexivity. Qed. - -Lemma handle_yield_yield_erased {E} {HE : Encode E} : - @handle_yield E HE (inl Yield) = Ret tt. -Proof. reflexivity. Qed. - (** * Scheduler one-step/case regression facts. *) Section SchedulerFacts. Context {E : Type} `{Encode E}. @@ -218,86 +209,6 @@ Section SchedulerFacts. Qed. End SchedulerFacts. -(** * Non-degenerate finite-pool scheduler regressions. *) -Section SchedulerPoolRegressions. - Context {E : Type} `{Encode E}. - - Lemma schedule_yield_two_threads_one_step (next other : thread E) : - observe - (schedule 2 - [Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); - other]%vector - (Some Fin.F1)) = - GuardF - (schedule 2 - ([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); - other]%vector @ Fin.F1 := next) - None). - Proof. reflexivity. Qed. - - Lemma schedule_yield_two_threads_focused_slot (next other : thread E) : - (([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); - other]%vector @ Fin.F1 := next) $ Fin.F1) = next. - Proof. apply Vector.nth_replace_eq. Qed. - - Lemma schedule_yield_two_threads_other_slot (next other : thread E) : - (([Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => next); - other]%vector @ Fin.F1 := next) $ (Fin.FS Fin.F1)) = other. - Proof. - rewrite Vector.nth_replace_neq by discriminate. - reflexivity. - Qed. - - Lemma schedule_fork_two_threads_one_step - (child parent other : thread E) : - observe - (schedule 2 - [Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector - (Some Fin.F1)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + E)) - (fun _ => - schedule 3 - ((child :: - ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector @ Fin.F1 := parent))%vector) - (Some (Fin.FS Fin.F1))). - Proof. reflexivity. Qed. - - Lemma schedule_fork_two_threads_child_slot - (child parent other : thread E) : - (((child :: - ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector @ Fin.F1 := parent))%vector) $ Fin.F1) = child. - Proof. reflexivity. Qed. - - Lemma schedule_fork_two_threads_parent_slot - (child parent other : thread E) : - (((child :: - ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector @ Fin.F1 := parent))%vector) $ (Fin.FS Fin.F1)) = parent. - Proof. apply Vector.nth_replace_eq. Qed. - - Lemma schedule_fork_two_threads_other_slot - (child parent other : thread E) : - (((child :: - ([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector @ Fin.F1 := parent))%vector) - $ (Fin.FS (Fin.FS Fin.F1))) = other. - Proof. - change ((([Vis ((inr (inl Fork)) : yieldE + (forkE + E)) - (fun in_child : bool => if in_child then child else parent); - other]%vector @ Fin.F1 := parent) $ (Fin.FS Fin.F1)) = other). - rewrite Vector.nth_replace_neq by discriminate. - reflexivity. - Qed. -End SchedulerPoolRegressions. - (** * Raw instrumentation entry points *) (** Instrument a standalone raw thread: erase [Fork] to the parent branch and @@ -368,18 +279,6 @@ Proof. reflexivity. Qed. -Lemma interp_thread_fork_node {E} `{Encode E} {X} - (k : bool -> ictree (yieldE + (forkE + E)) X) : - interp_thread (Vis (inr (inl Fork)) k) ≅ Guard (interp_thread (k false)). -Proof. - unfold interp_thread, interp_yield. - rewrite interp_vis_node. - cbn [handle_thread]. - rewrite bind_ret_l. - rewrite interp_guard_node. - reflexivity. -Qed. - Lemma interp_thread_user_node {E} `{Encode E} {X} (m : E) (k : encode m -> ictree (yieldE + (forkE + E)) X) : interp_thread (Vis (inr (inr m)) k) @@ -443,16 +342,6 @@ Proof. reflexivity. Qed. -Lemma instr_thread_fork {Σ X} - (k : bool -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : - instr_thread (Vis (inr (inl Fork)) k) σ ~ instr_thread (k false) σ. -Proof. - unfold instr_thread, instr_stateE. - rewrite interp_thread_fork_node. - rewrite interp_state_tau, sb_guard. - reflexivity. -Qed. - Lemma instr_thread_get {Σ X} (k : Σ -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : instr_thread (Vis (inr (inr Get)) k) σ ~ instr_thread (k σ) σ. @@ -505,14 +394,6 @@ Proof. reflexivity. Qed. -Lemma interp_erase_guard_ret {E} `{Encode E} {X} (x : X) : - interp_yield (interp_spawn (Guard (Ret x) : ictree (yieldE + (spawnE + E)) X)) - ≅ Guard (Ret x). -Proof. - rewrite interp_erase_guard. - apply guard_equ_node, interp_erase_ret. -Qed. - Lemma interp_erase_br {E} `{Encode E} {X} n (k : fin' n -> ictree (yieldE + (spawnE + E)) X) : interp_yield (interp_spawn (Br n k)) @@ -544,15 +425,6 @@ Proof. reflexivity. Qed. -Lemma interp_erase_guard_yield {E} `{Encode E} {X} - (k : unit -> ictree (yieldE + (spawnE + E)) X) : - interp_yield (interp_spawn (Guard (Vis (inl Yield) k))) - ≅ Guard (Guard (Guard (interp_yield (interp_spawn (k tt))))). -Proof. - rewrite interp_erase_guard. - apply guard_equ_node, interp_erase_yield. -Qed. - Lemma interp_erase_spawn {E} `{Encode E} {X} (k : unit -> ictree (yieldE + (spawnE + E)) X) : interp_yield (interp_spawn (Vis (inr (inl Spawn)) k)) diff --git a/theories/ICTree/Interp/Yield/Observed.v b/theories/ICTree/Interp/Yield/Observed.v new file mode 100644 index 0000000..b057dad --- /dev/null +++ b/theories/ICTree/Interp/Yield/Observed.v @@ -0,0 +1,1549 @@ +From Stdlib Require Import + Fin + Vector + Program.Equality. +From Coinduction Require Import coinduction lattice tactics. +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.Interp.Core + ICTree.Trans + Events.Core + Utils.Utils + ICTree.Events.Yield + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim + Utils.Vectors + ICTree.SBisim. + +Import ICtree ICTreeNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +(** Proof-facing scheduler observations for local fairness reasoning. + + The core scheduler is left unchanged. This module mirrors [schedule] with + an additive observation tier that records no-focus scheduling points and + the finite set of slots offered at each such point. + [forget_scheduler_offers_preserves_schedule] erases the observation tier + back to [schedule] up to strong bisimulation. *) + +Definition LiveSlot (n : nat) : Type := Fin.t n. + +Record SlotRef : Type := { + slot_pool_size : nat; + slot_live_slot : LiveSlot slot_pool_size; +}. + +Definition live_slot_ref {n : nat} (i : LiveSlot n) : SlotRef := + {| slot_pool_size := n; slot_live_slot := i |}. + +Variant SchedulerObs : Type := +| ObsSchedulingPoint : nat -> SchedulerObs +| ObsOffered : SlotRef -> SchedulerObs. + +Definition schedulerObsE : Type := SchedulerObs. + +#[global] Instance Encode_schedulerObsE : Encode SchedulerObs := + fun _ => unit. + +Definition scheduler_observedE (E : Type) : Type := + schedulerObsE + (yieldE + (spawnE + E)). + +Definition observed_completed (E : Type) `{Encode E} : Type := + ictree (scheduler_observedE E) unit. + + +Section ObservedScheduler. + Context {E : Type} `{Encode E}. + + (** Observed scheduler. The only extra visible events are proof-facing + [schedulerObsE] events at nonempty no-focus scheduling points. *) + CoFixpoint schedule_with_offers + (n : nat) (v : pool E n) (focus : option (Fin.t n)) + : observed_completed E := + match focus with + | None => + match n return pool E n -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inl (ObsSchedulingPoint (S n'))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n') (S n') + (fun i => i) v) + end v + | Some i => + match n return pool E n -> Fin.t n -> observed_completed E with + | 0 => fun _ i => match i with end + | S n' => fun v i => + match observe (v $ i) with + | RetF _ => + Guard (schedule_with_offers n' ((v -- i)) None) + | BrF b k => + Br b (fun j => + schedule_with_offers (S n') + ((v @ i := (k j))) (Some i)) + | GuardF t => + Guard (schedule_with_offers (S n') + ((v @ i := t)) (Some i)) + | VisF e k => + match e as e0 return + (encode e0 -> thread E) -> observed_completed E with + | inl Yield => fun k => + Guard (schedule_with_offers (S n') + ((v @ i := (k tt))) None) + | inr (inl Fork) => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inl Spawn)) + : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))) + | inr (inr e') => fun k => + @go (scheduler_observedE E) _ unit + (VisF (inr (inr (inr e')) + : scheduler_observedE E) + (fun x => schedule_with_offers (S n') + ((v @ i := (k x))) (Some i))) + end k + end + end v i + end + with schedule_with_offers_offer_prefix + (pool_size remaining : nat) + (embed : LiveSlot remaining -> LiveSlot pool_size) + (v : pool E pool_size) : observed_completed E := + match remaining return + (LiveSlot remaining -> LiveSlot pool_size) -> + pool E pool_size -> observed_completed E with + | 0 => fun _ v => + match pool_size return pool E pool_size -> observed_completed E with + | 0 => fun _ => Ret tt + | S n' => fun v => + Vis (inr (inl Yield) : scheduler_observedE E) + (fun _ : unit => + Br n' (fun i => + schedule_with_offers (S n') v (Some i))) + end v + | S n' => fun embed v => + Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix pool_size n' + (fun i => embed (Fin.FS i)) v) + end embed v. + + Definition handle_scheduler_offers + : scheduler_observedE E ~> ictree (yieldE + (spawnE + E)) := + fun event => + match event with + | inl _ => Ret tt + | inr event' => ICtree.trigger event' + end. + + Definition forget_scheduler_offers {X} + (t : ictree (scheduler_observedE E) X) + : ictree (yieldE + (spawnE + E)) X := + interp handle_scheduler_offers t. + + Lemma forget_scheduler_offers_no_focus_nonempty_unfold n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ + Guard (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. reflexivity. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_succ_stutter m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m (S n) embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. rewrite bind_ret_l. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_stutter m r + (embed : LiveSlot r -> LiveSlot m) (v : pool E m) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix m r embed v) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix m 0 + (fun i : LiveSlot 0 => match i with end) v). + Proof. + revert m embed v. + induction r as [| r IHr]; intros m embed v. + - destruct m as [| m']. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + apply sb_ret. reflexivity. + + unfold forget_scheduler_offers. + rewrite !unfold_interp. + cbn. + reflexivity. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix m r + (fun i => embed (Fin.FS i)) v)). + + apply forget_scheduler_offers_offer_prefix_succ_stutter. + + apply IHr. + Qed. + + Lemma forget_scheduler_offers_no_focus_stutters_to_offer_prefix n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v). + Proof. + rewrite forget_scheduler_offers_no_focus_nonempty_unfold. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_offer_prefix_zero_nonempty_unfold n + (embed : LiveSlot 0 -> LiveSlot (S n)) (v : pool E (S n)) : + forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 embed v) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard_l. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_br_id. intro i. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_no_focus_projection_to_focused n + (v : pool E (S n)) : + forget_scheduler_offers (schedule_with_offers (S n) v None) ~ + Vis (inl Yield) + (fun _ : unit => + Br n (fun i => + forget_scheduler_offers + (schedule_with_offers (S n) v (Some i)))). + Proof. + transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) + (fun i : LiveSlot (S n) => i) v)). + - apply forget_scheduler_offers_no_focus_stutters_to_offer_prefix. + - transitivity (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 + (fun i : LiveSlot 0 => match i with end) v)). + + apply forget_scheduler_offers_offer_prefix_stutter. + + apply forget_scheduler_offers_offer_prefix_zero_nonempty_unfold. + Qed. + + Local Ltac solve_focused_schedule_with_offers H := + lazy [schedule_with_offers observe _observe]; + match type of H with + | observe (Vector.nth ?v ?i) = _ => + change (@_observe _ _ unit (Vector.nth v i)) with (observe (Vector.nth v i)); + rewrite H; + reflexivity + end. + + Lemma schedule_with_offers_no_focus_nonempty n + (v : pool E (S n)) : + observe (schedule_with_offers (S n) v None) = + VisF (inl (ObsSchedulingPoint (S n))) + (fun _ : unit => + schedule_with_offers_offer_prefix (S n) (S n) + (fun i => i) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_offer_prefix_succ m n + (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : + observe (schedule_with_offers_offer_prefix m (S n) embed v) = + VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) + (fun _ : unit => + schedule_with_offers_offer_prefix m n + (fun i => embed (Fin.FS i)) v). + Proof. reflexivity. Qed. + + Lemma schedule_with_offers_focused_ret n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers n ((v -- i)) None). + Proof. + intro Hret. + solve_focused_schedule_with_offers Hret. + Qed. + + Lemma schedule_with_offers_focused_br n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + observe (schedule_with_offers (S n) v (Some i)) = + BrF b (fun j => + schedule_with_offers (S n) ((v @ i := (k j))) (Some i)). + Proof. + intro Hbr. + solve_focused_schedule_with_offers Hbr. + Qed. + + Lemma schedule_with_offers_focused_guard n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hg. + solve_focused_schedule_with_offers Hg. + Qed. + + Lemma schedule_with_offers_focused_yield n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + observe (schedule_with_offers (S n) v (Some i)) = + GuardF (schedule_with_offers (S n) + ((v @ i := (k tt))) None). + Proof. + intro Hy. + solve_focused_schedule_with_offers Hy. + Qed. + + Lemma schedule_with_offers_focused_fork n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inl Spawn)) : scheduler_observedE E) + (fun _ => schedule_with_offers (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + Proof. + intro Hf. + solve_focused_schedule_with_offers Hf. + Qed. + + Lemma schedule_with_offers_focused_user_event n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + observe (schedule_with_offers (S n) v (Some i)) = + VisF (inr (inr (inr e)) : scheduler_observedE E) + (fun x => schedule_with_offers (S n) + ((v @ i := (k x))) (Some i)). + Proof. + intro Hu. + solve_focused_schedule_with_offers Hu. + Qed. + + Lemma forget_scheduler_offers_empty_no_focus_projection + (v : pool E 0) : + forget_scheduler_offers (schedule_with_offers 0 v None) ~ Ret tt. + Proof. + unfold forget_scheduler_offers. + rewrite unfold_interp. + cbn. + apply sb_ret. reflexivity. + Qed. + + Lemma forget_scheduler_offers_focused_br_projection n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Br b (fun j => + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := (k j))) (Some i))). + Proof. + intro Hbr. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + cbn. + apply sb_br_id. intro j. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_fork_projection n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => + forget_scheduler_offers (schedule_with_offers (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intros []. + apply sb_guard. + Qed. + + Lemma forget_scheduler_offers_focused_user_event_projection n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => + forget_scheduler_offers + (schedule_with_offers (S n) ((v @ i := (k x))) (Some i))). + Proof. + intro Huser. + unfold forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + apply sb_vis. intro x. + apply sb_guard. + Qed. + + Local Notation completed' := (completed E). + Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). + + Local Definition erased_schedule (n : nat) (v : pool E n) + (focus : option (Fin.t n)) : completed E := + forget_scheduler_offers (schedule_with_offers n v focus). + + Local Lemma erased_focused_ret_equ n + (v : pool E (S n)) (i : Fin.t (S n)) : + observe (v $ i) = RetF tt -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule n ((v -- i)) None). + Proof. + intro Hret. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_ret n v i Hret). + reflexivity. + Qed. + + Local Lemma erased_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + erased_schedule (S n) v (Some i) ≅ + Br b (fun j => Guard (erased_schedule (S n) + ((v @ i := (k j))) (Some i))). + Proof. + intro Hbr. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma erased_focused_guard_equ n + (v : pool E (S n)) (i : Fin.t (S n)) t : + observe (v $ i) = GuardF t -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) ((v @ i := t)) (Some i)). + Proof. + intro Hguard. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_guard n v i t Hguard). + reflexivity. + Qed. + + Local Lemma erased_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + erased_schedule (S n) v (Some i) ≅ + Guard (erased_schedule (S n) ((v @ i := (k tt))) None). + Proof. + intro Hyield. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma erased_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + Proof. + intro Hfork. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_fork n v i k Hfork). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma erased_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + erased_schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n) + ((v @ i := (k x))) (Some i))). + Proof. + intro Huser. + unfold erased_schedule, forget_scheduler_offers. + rewrite unfold_interp. + rewrite (schedule_with_offers_focused_user_event n v i e k Huser). + cbn. + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, + ReSumRet_refl. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + Local Lemma schedule_focused_yield_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inl Yield) k -> + schedule (S n) v (Some i) ≅ + Guard (schedule (S n) ((v @ i := (k tt))) None). + Proof. + intro Hyield. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_yield n v i k Hyield). + reflexivity. + Qed. + + Local Lemma guard_residual_from_equ (actual target residual : completed') : + observe actual = GuardF residual -> + actual ≅ Guard target -> + residual ≅ target. + Proof. + intros Hobs Heq. + apply equ_guard_invE. + transitivity actual. + - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. + - exact Heq. + Qed. + + Local Ltac contradiction_from_shape_equ actual Hobs Heq := + exfalso; + rewrite (ictree_eta actual) in Heq; + rewrite <- Hobs in Heq; + step in Heq; inversion Heq. + + Local Lemma erased_schedule_match_left_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ erased_schedule 0 v None -> + trans l actual t' -> + exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + - rewrite (trans_schedule_empty_ret v). apply trans_ret. + - rewrite Hsb. rewrite Hmid. reflexivity. + Qed. + + Local Lemma erased_schedule_match_left_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ erased_schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. + Proof. + intros Hactual TRactual. + assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n (fun i => + erased_schedule (S n) v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (Br n (fun i => schedule (S n) v (Some i))). split. + - apply trans_schedule_no_focus_nonempty. + - rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n) + ((v @ i := (k j))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + exists (schedule (S n) ((v @ i := (k j))) (Some i)). + split. + - apply trans_schedule_focused_br. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + exists (schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). split. + - apply trans_schedule_focused_fork. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + actual ≅ erased_schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. + Proof. + intros Hvi Hactual TRactual. + assert (Hproj : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n) + ((v @ i := (k x))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + exists (schedule (S n) ((v @ i := (k x))) (Some i)). + split. + - apply trans_schedule_focused_user_event. exact Hvi. + - rewrite Hsb. rewrite Hmid. apply Hch. + Qed. + + Local Lemma schedule_focused_br_equ n + (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + schedule (S n) v (Some i) ≅ + Br b (fun j => schedule (S n) ((v @ i := (k j))) (Some i)). + Proof. + intro Hbr. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_br n v i b k Hbr). + reflexivity. + Qed. + + Local Lemma schedule_focused_fork_equ n + (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + Proof. + intro Hfork. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_fork n v i k Hfork). + reflexivity. + Qed. + + Local Lemma schedule_focused_user_event_equ n + (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + schedule (S n) v (Some i) ≅ + Vis (inr (inr e) : yieldE + (spawnE + E)) + (fun x => schedule (S n) ((v @ i := (k x))) (Some i)). + Proof. + intro Huser. + rewrite (ictree_eta (schedule (S n) v (Some i))). + rewrite (schedule_focused_user_event n v i e k Huser). + reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_empty + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' (v : pool E 0) : + actual ≅ schedule 0 v None -> + trans l actual t' -> + exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + assert (Hret : actual ~ Ret tt). + { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hret TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + assert (Hproj : Ret tt ~ erased_schedule 0 v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as + [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. + Qed. + + Local Lemma erased_schedule_match_right_no_focus + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) : + actual ≅ schedule (S n) v None -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. + Proof. + intros Hactual TRactual. + set (sres := Br n (fun i => schedule (S n) v (Some i))). + set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). + assert (Hshape : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) + (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) + lres). + { apply trans_vis. } + assert (Hproj : + Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ + erased_schedule (S n) v None). + { symmetry. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + destruct (sbisim_trans _ _ lres + (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_br + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : + observe (v $ i) = BrF b k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun j => + schedule (S n) ((v @ i := (k j))) (Some i)). + set (lres := fun j => + erased_schedule (S n) ((v @ i := (k j))) (Some i)). + assert (Hshape : actual ~ Br b sres). + { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans tau (Br b lres) (lres j)). + { apply trans_br with (x := j). reflexivity. } + assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_br_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) + as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_fork + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : + observe (v $ i) = VisF (inr (inl Fork)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + set (lres := erased_schedule (S (S n)) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). + assert (Hshape : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => sres)). + { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. destruct x. + assert (Hstep_lres : trans + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) + (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres)) lres). + { apply trans_vis. } + assert (Hproj : + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ : unit => lres) ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } + destruct (sbisim_trans _ _ lres + (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_right_user + (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) + l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : + observe (v $ i) = VisF (inr (inr e)) k -> + actual ≅ schedule (S n) v (Some i) -> + trans l actual t' -> + exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. + Proof. + intros Hvi Hactual TRactual. + set (sres := fun x => + schedule (S n) ((v @ i := (k x))) (Some i)). + set (lres := fun x => + erased_schedule (S n) ((v @ i := (k x))) (Some i)). + assert (Hshape : actual ~ + Vis (inr (inr e) : yieldE + (spawnE + E)) sres). + { rewrite Hactual. + rewrite (schedule_focused_user_event_equ n v i e k Hvi). + reflexivity. } + destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as + [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. + subst l. + assert (Hstep_lres : trans + (obs (inr (inr e) : yieldE + (spawnE + E)) x) + (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). + { apply trans_vis. } + assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ + erased_schedule (S n) v (Some i)). + { symmetry. + apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } + destruct (sbisim_trans _ _ (lres x) + (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj + Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. + subst l''. + exists u'. split. + - exact Htru. + - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. + Qed. + + Local Lemma erased_schedule_match_left (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ erased_schedule n v focus -> + exists u', trans l (schedule n v focus) u' /\ stR R t' u'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule n' ((v -- i)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' ((v -- i)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_ret n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * assert (Hproj : actual ~ + Br b (fun j => erased_schedule (S n') + ((v @ i := (k j))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_br_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_br_inv in Hmid as [j [Hmid ->]]. + exists (schedule (S n') ((v @ i := (k j))) (Some i)). + split. + -- apply trans_schedule_focused_br. exact Hvi. + -- rewrite Hsb. rewrite Hmid. apply Hch. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + assert (Ht : t ≅ + erased_schedule (S n') ((v @ i := g)) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (trans_schedule_focused_guard n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ erased_schedule (S n') + ((v @ i := (k tt))) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := (k tt))) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + assert (Hproj : actual ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => erased_schedule (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i)))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_fork_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (schedule (S (S n')) + (((k true) :: ((v @ i := (k false))))%vector) + (Some (Fin.FS i))). split. + ++ apply trans_schedule_focused_fork. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + -- assert (Hproj : actual ~ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => erased_schedule (S n') + ((v @ i := (k x))) (Some i))). + { rewrite Hactual. + apply forget_scheduler_offers_focused_user_event_projection. + exact Hvi. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + exists (schedule (S n') ((v @ i := (k x))) (Some i)). + split. + ++ apply trans_schedule_focused_user_event. exact Hvi. + ++ rewrite Hsb. rewrite Hmid. apply Hch. + + destruct nn as [| n']. + * assert (Hproj : actual ~ Ret tt). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_empty_no_focus_projection. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_ret_inv in Hmid as [Hmid ->]. + exists stuck. split. + -- rewrite (trans_schedule_empty_ret v). apply trans_ret. + -- rewrite Hsb. rewrite Hmid. reflexivity. + * assert (Hproj : actual ~ + Vis (inl Yield : yieldE + (spawnE + E)) + (fun _ : unit => Br n' (fun i => + erased_schedule (S n') v (Some i)))). + { rewrite Hactual. + unfold erased_schedule. + apply forget_scheduler_offers_no_focus_projection_to_focused. } + assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as + [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. + apply trans_vis_inv in Hmid as [x [Hmid ->]]. + destruct x. + exists (Br n' (fun i => schedule (S n') v (Some i))). split. + -- apply trans_schedule_no_focus_nonempty. + -- rewrite Hsb. rewrite Hmid. + apply (coinduction.bt_t (sb eq)). + apply step_sb_br_id; [reflexivity | intro j]. + apply Hch. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_left_br; eauto. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (((k0 true) :: ((v @ i := (k0 false))))%vector) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + ((v @ i := (k0 x))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + ((v @ i := (k0 j))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_left_fork; eauto. + -- eapply erased_schedule_match_left_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (erased_schedule n' ((v -- i)) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_ret_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * assert (Hbr : actual ≅ + Br b (fun j => Guard (erased_schedule (S n') + ((v @ i := (k0 j))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_br_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hbr. + * assert (Hguard : actual ≅ + Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_guard_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (erased_schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + assert (Hvis : actual ≅ + Vis (inr (inl Spawn) : yieldE + (spawnE + E)) + (fun _ => Guard (erased_schedule (S (S n')) + (((k0 true) :: ((v @ i := (k0 false))))%vector) + (Some (Fin.FS i))))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_fork_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + -- assert (Hvis : actual ≅ + Vis (inr (inr usr) : yieldE + (spawnE + E)) + (fun x => Guard (erased_schedule (S n') + ((v @ i := (k0 x))) (Some i)))). + { transitivity (erased_schedule (S n') v (Some i)). + - exact Hactual. + - apply erased_focused_user_event_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hvis. + + destruct nn as [| n']. + * eapply erased_schedule_match_left_empty; eauto. + * eapply erased_schedule_match_left_no_focus; eauto. + Qed. + + Local Lemma erased_schedule_match_right (R : rel completed' completed') + (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)) : + forall l os ot', trans_ l os ot' -> + forall actual n (v : pool E n) focus t', + os = observe actual -> + ot' = observe t' -> + actual ≅ schedule n v focus -> + exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. + Proof. + intros l os ot' TR. + induction TR; intros actual nn v focus t' Hos Hot Hactual. + - assert (TRactual : trans l actual t'). + { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + assert (Ht : t ≅ schedule n' ((v -- i)) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t n' ((v -- i)) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_ret_equ n' v i Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + assert (Ht : t ≅ + schedule (S n') ((v @ i := g)) (Some i)). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + -- rewrite (erased_focused_guard_equ n' v i g Hvi). + apply trans_guard. exact Htru. + -- exact Hres. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + assert (Ht : t ≅ schedule (S n') + ((v @ i := (k tt))) None). + { eapply guard_residual_from_equ. + - symmetry. exact Hos. + - exact Hguard. } + destruct (IHTR t (S n') ((v @ i := (k tt))) None t' + eq_refl Hot Ht) as [u' [Htru Hres]]. + exists u'. split. + ++ rewrite (erased_focused_yield_equ n' v i k Hvi). + apply trans_guard. exact Htru. + ++ exact Hres. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans tau actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Steptau. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (obs e x) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepobs. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. + * destruct r. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e0 as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + - assert (TRactual : trans (val r) actual t'). + { unfold trans. rewrite <- Hos, <- Hot. + eapply Stepval. exact H0. } + destruct focus as [i |]. + + destruct nn as [| n']; [inversion i |]. + destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. + * destruct r0. + assert (Hguard : actual ≅ + Guard (schedule n' ((v -- i)) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_ret. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * eapply erased_schedule_match_right_br; eauto. + * assert (Hguard : actual ≅ + Guard (schedule (S n') ((v @ i := g)) (Some i))). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply trans_schedule_focused_guard. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + * destruct e as [yld | [frk | usr]]. + -- destruct yld. + assert (Hguard : actual ≅ + Guard (schedule (S n') + ((v @ i := (k0 tt))) None)). + { transitivity (schedule (S n') v (Some i)). + - exact Hactual. + - apply schedule_focused_yield_equ. exact Hvi. } + contradiction_from_shape_equ actual Hos Hguard. + -- destruct frk. + eapply erased_schedule_match_right_fork; eauto. + -- eapply erased_schedule_match_right_user; eauto. + + destruct nn as [| n']. + * eapply erased_schedule_match_right_empty; eauto. + * eapply erased_schedule_match_right_no_focus; eauto. + Qed. + + Theorem forget_scheduler_offers_preserves_schedule + n (v : pool E n) focus : + forget_scheduler_offers (schedule_with_offers n v focus) ~ + schedule n v focus. + Proof. + change (erased_schedule n v focus ~ schedule n v focus). + revert n v focus. + coinduction R CH. + intros n v focus. + assert (Hch : forall m (w : pool E m) f, + stR R (erased_schedule m w f) (schedule m w f)). + { intros m w f. apply CH. } + split. + - intros l t' TR. + destruct (erased_schedule_match_left R Hch _ _ _ TR + (erased_schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + exact Hres. + + reflexivity. + - intros l t' TR. + destruct (erased_schedule_match_right R Hch _ _ _ TR + (schedule n v focus) n v focus t' + eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. + exists l, u'. split; [exact Htru | split]. + + unfold Basics.flip. exact Hres. + + reflexivity. + Qed. + + Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) + : observed_completed E -> Prop := + | offered_prefix_here t k : + observe t = VisF (inl (ObsOffered (live_slot_ref i))) k -> + offered_in_scheduler_prefix n i t + | offered_prefix_later t obs k : + observe t = VisF (inl obs) k -> + offered_in_scheduler_prefix n i (k tt) -> + offered_in_scheduler_prefix n i t. + + Lemma schedule_with_offers_offer_prefix_offers m : + forall n (embed : LiveSlot n -> LiveSlot m) (v : pool E m) + (i : LiveSlot n), + offered_in_scheduler_prefix m (embed i) + (schedule_with_offers_offer_prefix m n embed v). + Proof. + intros n embed v i. + induction i as [n' | n' i IH]. + - apply offered_prefix_here with + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun i => embed (Fin.FS i)) v). + apply schedule_with_offers_offer_prefix_succ. + - apply offered_prefix_later with + (obs := ObsOffered (live_slot_ref (embed Fin.F1))) + (k := fun _ : unit => + schedule_with_offers_offer_prefix m n' + (fun j => embed (Fin.FS j)) v). + + apply schedule_with_offers_offer_prefix_succ. + + apply (IH (fun j => embed (Fin.FS j))). + Qed. + + Lemma observed_equ_refl_no_eqdep (t : observed_completed E) : t ≅ t. + Proof. + unfold equ. + apply (leq_gfp (@fequ _ _ unit unit eq) + (fun u v : observed_completed E => u = v)). + - intros u v <-. cbn. destruct (observe u); constructor; auto. + - reflexivity. + Qed. + + Lemma observed_equ_step_no_eqdep (t u : observed_completed E) : + t ≅ u -> equF eq (equ eq) (observe t) (observe u). + Proof. + intro Htu. unfold equ in Htu. + exact (proj1 (gfp_fp (@fequ _ _ unit unit eq) t u) Htu). + Qed. + + Definition equF_scheduler_vis_result + (p q : ictree' (scheduler_observedE E) unit) : Prop := + match q with + | VisF (inl sched_obs) k_right => + exists k_left, + p = VisF (inl sched_obs) k_left /\ k_left tt ≅ k_right tt + | _ => True + end. + + Lemma equF_scheduler_vis_inv_no_eqdep p q : + equF eq (equ eq) p q -> equF_scheduler_vis_result p q. + Proof. + intro Hf. + destruct Hf as [x y Hxy | e k1 k2 Hk | t1 t2 Ht | + n k1 k2 Hk]; cbn; try exact I. + destruct e as [sched_obs | rest]; cbn; try exact I. + exists k1. split; [reflexivity | apply Hk]. + Qed. + + Lemma equ_scheduler_vis_inv_from_observe_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + t ≅ u -> + observe u = VisF (inl obs) k -> + exists k_t, observe t = VisF (inl obs) k_t /\ k_t tt ≅ k tt. + Proof. + intros Htu Hu. + pose proof (equF_scheduler_vis_inv_no_eqdep _ _ + (observed_equ_step_no_eqdep _ _ Htu)) as Hshape. + rewrite Hu in Hshape. + exact Hshape. + Qed. + + Inductive SchedulerEquChain : + observed_completed E -> observed_completed E -> Prop := + | scheduler_equ_chain_refl t : SchedulerEquChain t t + | scheduler_equ_chain_cons t u v : + t ≅ u -> + SchedulerEquChain u v -> + SchedulerEquChain t v. + + Lemma scheduler_equ_chain_scheduler_vis_inv_no_eqdep + (obs : schedulerObsE) + (k : encode (inl obs : scheduler_observedE E) -> + observed_completed E) + (t u : observed_completed E) : + SchedulerEquChain t u -> + observe u = VisF (inl obs) k -> + exists k_t, + observe t = VisF (inl obs) k_t /\ + SchedulerEquChain (k_t tt) (k tt). + Proof. + intros Hchain Hobs. + induction Hchain as [u | t mid u Htm _ IH]. + - exists k. split; [exact Hobs | constructor]. + - destruct (IH Hobs) as [k_mid [Hmid Hcont]]. + destruct (equ_scheduler_vis_inv_from_observe_no_eqdep obs k_mid + t mid Htm Hmid) as [k_t [Ht Hstep]]. + exists k_t. split; [exact Ht |]. + econstructor; [exact Hstep | exact Hcont]. + Qed. + + Lemma show_no_focus_offers_every_live_slot_prefix n + (v : pool E (S n)) (i : LiveSlot (S n)) : + offered_in_scheduler_prefix (S n) i + (schedule_with_offers (S n) v None). + Proof. + eapply offered_prefix_later. + - apply schedule_with_offers_no_focus_nonempty. + - apply (schedule_with_offers_offer_prefix_offers (S n) (S n) + (fun i => i) v i). + Qed. + +End ObservedScheduler. diff --git a/theories/ICTree/Interp/Yield/RoundRobin.v b/theories/ICTree/Interp/Yield/RoundRobin.v index b7ffadd..d7aa9cb 100644 --- a/theories/ICTree/Interp/Yield/RoundRobin.v +++ b/theories/ICTree/Interp/Yield/RoundRobin.v @@ -124,18 +124,29 @@ Section RoundRobinInterpretation. interp_state_tau, sb_guard; reflexivity. Qed. - Lemma interp_schedule_rr_branch + (** Keep one scheduler continuation fixed while interpreting a raw user event. *) + Lemma interp_schedule_rr_user_bind (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) - (i : Fin.t (S n)) b k m σ : - observe (ts $ i) = BrF b k -> - interp_schedule_rr handler (S n) ts (Some i) m σ ~ - interp_schedule_rr handler (S n) (ts @ i := k (rr_pick b m)) - (Some i) (S m) σ. + (i : Fin.t (S n)) (t : thread E) (e : E) (k : encode e -> thread E) m σ : + t ≅ Vis (inr (inr e)) k -> + interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m σ ~ + (interp_state handler + (@ICtree.trigger E E _ _ ReSum_refl ReSumRet_refl e) σ >>= + fun '(x,σ') => + interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m σ'). Proof. - intro Hobs; unfold interp_schedule_rr at 1. - rewrite unfold_run_round_robin, (schedule_focused_br n ts i b k Hobs). - rewrite interp_erase_guard, interp_state_tau, sb_guard; reflexivity. + intro Hnode. + pose proof (interp_schedule_rr_equ handler (S n) + (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) m σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user with (e:=e) (k:=k) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite interp_state_trigger_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros [x σ']]. + rewrite Vector.replace_replace_eq; reflexivity. Qed. + End RoundRobinInterpretation. Arguments interp_schedule_rr {E F HE HF Σ} handler n ts focus cursor σ. diff --git a/theories/ICTree/Interp/Yield/SBisim.v b/theories/ICTree/Interp/Yield/SBisim.v index f1fae99..66a550c 100644 --- a/theories/ICTree/Interp/Yield/SBisim.v +++ b/theories/ICTree/Interp/Yield/SBisim.v @@ -24,9 +24,6 @@ Section PoolSBisim. Definition pool_sbisim {n : nat} (v1 v2 : pool E n) : Prop := forall i, (v1 $ i) ~ (v2 $ i). - Lemma pool_sbisim_refl {n} (v : pool E n) : pool_sbisim v v. - Proof. intro i; reflexivity. Qed. - Lemma pool_sbisim_sym {n} (v1 v2 : pool E n) : pool_sbisim v1 v2 -> pool_sbisim v2 v1. Proof. intros Hpool i; symmetry; apply Hpool. Qed. @@ -108,14 +105,6 @@ Section SchedulerTransitions. reflexivity. Qed. - Lemma trans_schedule_no_focus_choose n (v : pool E (S n)) (i : Fin.t (S n)) : - trans tau - (Br n (fun i => schedule (S n) v (Some i))) - (schedule (S n) v (Some i)). - Proof. - apply trans_br with (x := i). reflexivity. - Qed. - Lemma trans_schedule_focused_yield n (v : pool E (S n)) (i : Fin.t (S n)) k : observe (v $ i) = VisF (inl Yield) k -> trans (obs (inl Yield : yieldE + (spawnE + E)) tt) @@ -244,92 +233,6 @@ Section SchedulerTransitions. split; auto. Qed. - Lemma trans_schedule_focused_inv n (v : pool E (S n)) (i : Fin.t (S n)) l t' : - trans l (schedule (S n) v (Some i)) t' -> - (** focused [Ret]: collapse the [Guard], step the residual pool *) - (observe (v $ i) = RetF tt /\ - trans l (schedule n ((v -- i)) None) t') - \/ - (** focused [Guard]: collapse, step the replaced-slot residual *) - (exists g, observe (v $ i) = GuardF g /\ - trans l (schedule (S n) ((v @ i := g)) (Some i)) t') - \/ - (** focused [Br b k]: [tau] to one of the branches *) - (exists b k (j : Fin.t (S b)), observe (v $ i) = BrF b k /\ - l = tau /\ - t' ≅ schedule (S n) ((v @ i := (k j))) (Some i)) - \/ - (** focused [Yield]: visible [Yield], [Br] back over the residual pool *) - (exists k, observe (v $ i) = VisF (inl Yield) k /\ - l = obs (inl Yield : yieldE + (spawnE + E)) tt /\ - t' ≅ Br n (fun j => - schedule (S n) ((v @ i := (k tt))) (Some j))) - \/ - (** focused [Fork]: visible [Spawn], cons the child, focus it *) - (exists k, observe (v $ i) = VisF (inr (inl Fork)) k /\ - l = obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt /\ - t' ≅ schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))) - \/ - (** focused user event [e]: visible [e], step the focused thread *) - (exists e k x, observe (v $ i) = VisF (inr (inr e)) k /\ - l = obs (inr (inr e) : yieldE + (spawnE + E)) x /\ - t' ≅ schedule (S n) ((v @ i := (k x))) (Some i)). - Proof. - intro TR. - destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hobs. - - (* RetF *) - destruct r. - left. - split; auto. - rewrite (trans_schedule_focused_ret _ v i Hobs) in TR. - now apply trans_guard_inv in TR. - - (* BrF b k *) - do 2 right; left. - assert (Hsch := schedule_focused_br _ v i b k Hobs). - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite Hsch in TR. - apply trans_br_inv in TR as (j & Heq & Hl). - exists b, k, j; auto. - - (* GuardF g *) - right; left. - exists g. - split; auto. - rewrite (trans_schedule_focused_guard _ v i g Hobs) in TR. - now apply trans_guard_inv in TR. - - (* VisF e k *) - destruct e as [yld | [frk | usr]]. - + (* Yield *) - destruct yld. - do 3 right; left. - exists k. - split; auto. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_yield _ v i k Hobs) in TR. - apply trans_guard_inv in TR. - rewrite schedule_no_focus_equ in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - destruct x. - split; auto. - + (* Fork *) - destruct frk. - do 4 right; left. - exists k. - split; auto. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_fork _ v i k Hobs) in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - destruct x. - split; auto. - + (* user event *) - do 5 right. - rewrite (ictree_eta (schedule (S n) v (Some i))) in TR. - rewrite (schedule_focused_user_event _ v i usr k Hobs) in TR. - apply trans_vis_inv in TR as (x & Heq & Hl). - exists usr, k, x; auto. - Qed. - (** ** [schedule] respects [equ]-equality of pools, in every focus. *) Lemma schedule_pool_proper n (v w : pool E n) focus : pool_equ v w -> @@ -938,14 +841,6 @@ Section PoolGuardEqu. pool_equ ts us -> pool_guard_equ ts us. Proof. intros H i; apply guard_equ_equ, H. Qed. - Lemma pool_guard_replace {n} (ts us : pool E n) (i : Fin.t n) t u : - pool_guard_equ ts us -> guard_equ t u -> - pool_guard_equ (ts @ i := t) (us @ i := u). - Proof. - intros Hpool Htu. - exact (vector_replace_pointwise guard_equ ts us i t u (fun j _ => Hpool j) Htu). - Qed. - Lemma pool_replace_current {n} (ts : pool E n) (i : Fin.t n) : pool_equ (ts @ i := (ts $ i)) ts. Proof. diff --git a/theories/ICTree/Interp/Yield/Segments.v b/theories/ICTree/Interp/Yield/Segments.v index 0e0ef10..09c93dc 100644 --- a/theories/ICTree/Interp/Yield/Segments.v +++ b/theories/ICTree/Interp/Yield/Segments.v @@ -114,11 +114,6 @@ Section ThreadSegments. ThreadSegment t sigma xs residual sigma'. Proof. intro H; eapply ThreadSegment_guard_inv_equ; [exact H|reflexivity]. Qed. - Lemma ThreadSegment_guard_iff t sigma xs residual sigma' : - ThreadSegment (Guard t) sigma xs residual sigma' <-> - ThreadSegment t sigma xs residual sigma'. - Proof. split; [apply ThreadSegment_guard_inv|apply segment_guard]. Qed. - Lemma ThreadSegment_user_inv_equ t sigma xs residual sigma' : ThreadSegment t sigma xs residual sigma' -> forall (e : E) (k : encode e -> thread E), @@ -321,16 +316,6 @@ End ThreadSegments. Arguments ThreadSegment {E W Sigma HE} handler R. Arguments segment_to {E W Sigma HE} handler R. -(** A branch node can never be a yield up to finite guard removal. *) -Lemma guard_equ_br_yield_absurd {E} {HE : Encode E} n - (k : Fin.t (S n) -> thread E) (ky : unit -> thread E) : - ~ guard_equ (Br n k) (Vis (inl Yield) ky). -Proof. - intro Eq; apply guard_equ_sbisim in Eq. - eapply (@sbisim_vis_br_inv (yieldE + (forkE + E)) _ unit n (inl Yield) ky k); - symmetry; exact Eq. -Qed. - (** Weakening the response relation weakens the segment. This is how an exact segment becomes a bisimulation-mode segment; [equ_sbisim] supplies the premise for the two instances actually used. *) @@ -353,19 +338,6 @@ Proof. - eapply segment_equ; eassumption. Qed. -Lemma segment_to_mono {E W Sigma} {HE : Encode E} - (handler : E ~> stateT Sigma (ictreeW W)) - (R R' : forall X : Type, ictreeW W X -> ictreeW W X -> Prop) - (Hmono : forall X t u, R X t u -> R' X t u) : - forall t sigma logs target sigma', - segment_to handler R t sigma logs target sigma' -> - segment_to handler R' t sigma logs target sigma'. -Proof. - intros t sigma logs target sigma' (residual & Hseg & Htail). - exists residual; split; [|exact Htail]. - eapply ThreadSegment_mono; eauto. -Qed. - (** ** Scheduling laws. Response uniqueness, determinism, handler-fault exclusion, and the @@ -488,34 +460,6 @@ Section FocusedCongruence. rewrite Vector.replace_replace_eq; reflexivity. Qed. - Lemma guard_equ_focused_nd n (ts : pool E (S n)) (i : Fin.t (S n)) t u sigma : - guard_equ t u -> - interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma ~ - interp_schedule_nd handler (S n) (ts @ i := u) (Some i) sigma. - Proof. - intro H; induction H as [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_nd_replace_equ; exact Eq. - - etransitivity; [apply segment_nd_replace_equ; exact Eg|]. - apply segment_nd_focused_guard. - - reflexivity. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. - Qed. - - Lemma guard_equ_focused_rr n (ts : pool E (S n)) (i : Fin.t (S n)) t u m sigma : - guard_equ t u -> - interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma ~ - interp_schedule_rr handler (S n) (ts @ i := u) (Some i) m sigma. - Proof. - intro H; induction H as [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]. - - apply segment_rr_replace_equ; exact Eq. - - etransitivity; [apply segment_rr_replace_equ; exact Eg|]. - apply segment_rr_focused_guard. - - reflexivity. - - symmetry; exact IH. - - etransitivity; [exact IH1|exact IH2]. - Qed. - Lemma segment_nd_focused_user n (ts : pool E (S n)) (i : Fin.t (S n)) (e : E) (k : encode e -> thread E) sigma : interp_schedule_nd handler (S n) @@ -630,62 +574,88 @@ Section SegmentInterpretation. (HR : forall X (t u : ictreeW W X), R X t u -> t ~ u). Lemma segment_interp_nd n (ts : pool E (S n)) (i : Fin.t (S n)) - t sigma xs residual sigma' : - ThreadSegment handler R t sigma xs residual sigma' -> - interp_schedule_nd handler (S n) (ts @ i := t) (Some i) sigma ~ + sigma xs residual sigma' : + ThreadSegment handler R (ts $ i) sigma xs residual sigma' -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ emit_list xs (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma'). Proof. - intro H; revert n ts i. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i. - - cbn [emit_list]. - erewrite interp_schedule_nd_yield - by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_nd_focused_guard|apply IH]. - - etransitivity; [apply segment_nd_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => - interp_schedule_nd handler (S n) (ts @ i := k x) (Some i) sigma0). - + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. + intro Hseg. + assert (Hgen : forall t s0 ys r0 s1, + ThreadSegment handler R t s0 ys r0 s1 -> + forall p (us : pool E (S p)) (j : Fin.t (S p)), + interp_schedule_nd handler (S p) (us @ j := t) (Some j) s0 ~ + emit_list ys (interp_schedule_nd handler (S p) (us @ j := r0) None s1)). + { + intros t s0 ys r0 s1 H; induction H as + [k sigma0 + |t0 sigma0 xs0 residual0 sigma0' H IH + |e k sigma0 result sigma1 before after residual0 sigma0' Eh H IH + |t0 u sigma0 xs0 u' residual0 sigma0' Etu H IH Eout]; intros p us j. + - cbn [emit_list]. + erewrite interp_schedule_nd_yield + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_nd_focused_guard|apply IH]. + - etransitivity; [apply segment_nd_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma2) => + interp_schedule_nd handler (S p) (us @ j := k x) (Some j) sigma2). + + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_nd_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_nd_replace_equ; exact Eout. + } + transitivity + (interp_schedule_nd handler (S n) (ts @ i := (ts $ i)) (Some i) sigma). + - symmetry; apply equ_sbisim; + exact (interp_schedule_nd_equ handler (S n) (ts @ i := (ts $ i)) ts + (Some i) sigma (pool_replace_current ts i)). + - apply Hgen; exact Hseg. Qed. Lemma segment_interp_rr n (ts : pool E (S n)) (i : Fin.t (S n)) - t m sigma xs residual sigma' : - ThreadSegment handler R t sigma xs residual sigma' -> - interp_schedule_rr handler (S n) (ts @ i := t) (Some i) m sigma ~ + m sigma xs residual sigma' : + ThreadSegment handler R (ts $ i) sigma xs residual sigma' -> + interp_schedule_rr handler (S n) ts (Some i) m sigma ~ emit_list xs (interp_schedule_rr handler (S n) (ts @ i := residual) None m sigma'). Proof. - intro H; revert n ts i m. - induction H as - [k sigma - |t sigma xs residual sigma' H IH - |e k sigma result sigma1 before after residual sigma' Eh H IH - |t u sigma xs u' residual sigma' Etu H IH Eout]; intros n ts i m. - - cbn [emit_list]. - erewrite interp_schedule_rr_yield - by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. - - etransitivity; [apply segment_rr_focused_guard|apply IH]. - - etransitivity; [apply segment_rr_focused_user|]. - transitivity (emit_list before (Ret (result,sigma1)) >>= - fun '(x,sigma0) => - interp_schedule_rr handler (S n) (ts @ i := k x) (Some i) m sigma0). - + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. - + rewrite emit_list_ret_bind, emit_list_app. - apply emit_list_sbisim; apply IH. - - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. - etransitivity; [apply IH|]. - apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. + intro Hseg. + assert (Hgen : forall t s0 ys r0 s1, + ThreadSegment handler R t s0 ys r0 s1 -> + forall p (us : pool E (S p)) (j : Fin.t (S p)) c, + interp_schedule_rr handler (S p) (us @ j := t) (Some j) c s0 ~ + emit_list ys (interp_schedule_rr handler (S p) (us @ j := r0) None c s1)). + { + intros t s0 ys r0 s1 H; induction H as + [k sigma0 + |t0 sigma0 xs0 residual0 sigma0' H IH + |e k sigma0 result sigma1 before after residual0 sigma0' Eh H IH + |t0 u sigma0 xs0 u' residual0 sigma0' Etu H IH Eout]; intros p us j c. + - cbn [emit_list]. + erewrite interp_schedule_rr_yield + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + - etransitivity; [apply segment_rr_focused_guard|apply IH]. + - etransitivity; [apply segment_rr_focused_user|]. + transitivity (emit_list before (Ret (result,sigma1)) >>= + fun '(x,sigma2) => + interp_schedule_rr handler (S p) (us @ j := k x) (Some j) c sigma2). + + apply sbisim_clo_bind_eq; [apply HR; exact Eh|intro r; reflexivity]. + + rewrite emit_list_ret_bind, emit_list_app. + apply emit_list_sbisim; apply IH. + - etransitivity; [apply segment_rr_replace_equ; exact Etu|]. + etransitivity; [apply IH|]. + apply emit_list_sbisim, segment_rr_replace_equ; exact Eout. + } + transitivity + (interp_schedule_rr handler (S n) (ts @ i := (ts $ i)) (Some i) m sigma). + - symmetry; apply equ_sbisim; + exact (interp_schedule_rr_equ handler (S n) (ts @ i := (ts $ i)) ts + (Some i) m sigma (pool_replace_current ts i)). + - apply Hgen; exact Hseg. Qed. Theorem segment_scheduler_steps {n} (ts : pool E (S n)) sigma i @@ -701,16 +671,11 @@ Section SegmentInterpretation. assert (Efocused : interp_schedule_nd handler (S n) ts (Some i) sigma ~ emit_list logs (interp_schedule_nd handler (S n) ts' None sigma')). { - transitivity - (interp_schedule_nd handler (S n) (ts @ i := (ts $ i)) (Some i) sigma). - - rewrite (interp_schedule_nd_equ handler (S n) _ _ (Some i) sigma - (pool_replace_current ts i)); reflexivity. - - transitivity (emit_list logs - (interp_schedule_nd handler (S n) (ts @ i := residual) None sigma')). - + eapply segment_interp_nd; exact Hseg. - + apply emit_list_sbisim. - rewrite <- (interp_schedule_nd_equ handler (S n) _ _ None sigma' Epool); - reflexivity. + etransitivity; + [exact (segment_interp_nd n ts i sigma logs residual sigma' Hseg)|]. + apply emit_list_sbisim. + rewrite <- (interp_schedule_nd_equ handler (S n) _ _ None sigma' Epool); + reflexivity. } assert (Hbranch : trans tau (Br n (fun j => interp_schedule_nd handler (S n) ts (Some j) sigma)) diff --git a/theories/ICTree/Logic/SchedulerFairness.v b/theories/ICTree/Logic/SchedulerFairness.v index a2c9d5b..a89b109 100644 --- a/theories/ICTree/Logic/SchedulerFairness.v +++ b/theories/ICTree/Logic/SchedulerFairness.v @@ -19,6 +19,7 @@ From TICL Require Import ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim Utils.Vectors + ICTree.Interp.Yield.Observed ICTree.SBisim. Import ICtree ICTreeNotations TiclNotations VectorNotations. @@ -26,1797 +27,18 @@ Local Open Scope ictree_scope. Local Open Scope fin_vector_scope. Local Open Scope ticl_scope. -(** Proof-facing scheduler observations for local fairness reasoning. - - The core scheduler is left unchanged. This module mirrors [schedule] with - an additive observation tier that records no-focus scheduling points and - the finite set of slots offered at each such point. *) - -Definition LiveSlot (n : nat) : Type := Fin.t n. - -Record SlotRef : Type := { - slot_pool_size : nat; - slot_live_slot : LiveSlot slot_pool_size; -}. - -Definition live_slot_ref {n : nat} (i : LiveSlot n) : SlotRef := - {| slot_pool_size := n; slot_live_slot := i |}. - -Variant SchedulerObs : Type := -| ObsSchedulingPoint : nat -> SchedulerObs -| ObsOffered : SlotRef -> SchedulerObs. - -Definition schedulerObsE : Type := SchedulerObs. - -#[global] Instance Encode_schedulerObsE : Encode SchedulerObs := - fun _ => unit. - -Definition scheduler_observedE (E : Type) : Type := - schedulerObsE + (yieldE + (spawnE + E)). - -Definition observed_completed (E : Type) `{Encode E} : Type := - ictree (scheduler_observedE E) unit. - -Definition observed_scheduling_point (n : nat) (obs : schedulerObsE) : Prop := - obs = ObsSchedulingPoint n. - -Definition offer_live_slot_obs (n : nat) (i : LiveSlot n) - (obs : schedulerObsE) : Prop := - obs = ObsOffered (live_slot_ref i). +(** Temporal consequences of the observed scheduler of + [ICTree.Interp.Yield.Observed]: every live slot is offered after each + scheduling point, conditional on [SchedulerProgress]. *) Definition offer_live_slot {E : Type} `{Encode E} (n : nat) (i : LiveSlot n) : ticll (scheduler_observedE E) := CNow (fun w => w = Obs (inl (ObsOffered (live_slot_ref i))) tt). -Definition recognize_live_slot {E : Type} `{Encode E} - (n : nat) (_ : pool E n) (_ : LiveSlot n) : Prop := - True. - -Lemma live_slot_one_eq (i j : LiveSlot 1) : i = j. -Proof. - refine (Fin.caseS' i (fun i => forall j, i = j) _ _ j). - - intro j'. - refine (Fin.caseS' j' (fun j => Fin.F1 = j) eq_refl _). - intro j0. - exact (Fin.case0 (fun j0 => Fin.F1 = Fin.FS j0) j0). - - intro i0. - exact (Fin.case0 (fun i0 => forall j, Fin.FS i0 = j) i0). -Qed. Section ObservedScheduler. Context {E : Type} `{Encode E}. - Definition emit_scheduler_obs (obs : schedulerObsE) : observed_completed E := - Vis (inl obs) (fun _ : unit => Ret tt). - - Fixpoint emit_live_slot_offers_into_then - (m n : nat) (embed : LiveSlot n -> LiveSlot m) - (k : observed_completed E) {struct n} : observed_completed E := - match n return (LiveSlot n -> LiveSlot m) -> observed_completed E with - | 0 => fun _ => k - | S n' => fun embed => - Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun i => embed (Fin.FS i)) k) - end embed. - - Definition emit_live_slot_offers_then - (n : nat) (k : observed_completed E) : observed_completed E := - emit_live_slot_offers_into_then n n (fun i => i) k. - - Definition emit_live_slot_offers (n : nat) : observed_completed E := - emit_live_slot_offers_then n (Ret tt). - - (** Observed scheduler. The only extra visible events are proof-facing - [schedulerObsE] events at nonempty no-focus scheduling points. *) - CoFixpoint schedule_with_offers - (n : nat) (v : pool E n) (focus : option (Fin.t n)) - : observed_completed E := - match focus with - | None => - match n return pool E n -> observed_completed E with - | 0 => fun _ => Ret tt - | S n' => fun v => - Vis (inl (ObsSchedulingPoint (S n'))) - (fun _ : unit => - schedule_with_offers_offer_prefix (S n') (S n') - (fun i => i) v) - end v - | Some i => - match n return pool E n -> Fin.t n -> observed_completed E with - | 0 => fun _ i => match i with end - | S n' => fun v i => - match observe (v $ i) with - | RetF _ => - Guard (schedule_with_offers n' ((v -- i)) None) - | BrF b k => - Br b (fun j => - schedule_with_offers (S n') - ((v @ i := (k j))) (Some i)) - | GuardF t => - Guard (schedule_with_offers (S n') - ((v @ i := t)) (Some i)) - | VisF e k => - match e as e0 return - (encode e0 -> thread E) -> observed_completed E with - | inl Yield => fun k => - Guard (schedule_with_offers (S n') - ((v @ i := (k tt))) None) - | inr (inl Fork) => fun k => - @go (scheduler_observedE E) _ unit - (VisF (inr (inr (inl Spawn)) - : scheduler_observedE E) - (fun _ => schedule_with_offers (S (S n')) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))) - | inr (inr e') => fun k => - @go (scheduler_observedE E) _ unit - (VisF (inr (inr (inr e')) - : scheduler_observedE E) - (fun x => schedule_with_offers (S n') - ((v @ i := (k x))) (Some i))) - end k - end - end v i - end - with schedule_with_offers_offer_prefix - (pool_size remaining : nat) - (embed : LiveSlot remaining -> LiveSlot pool_size) - (v : pool E pool_size) : observed_completed E := - match remaining return - (LiveSlot remaining -> LiveSlot pool_size) -> - pool E pool_size -> observed_completed E with - | 0 => fun _ v => - match pool_size return pool E pool_size -> observed_completed E with - | 0 => fun _ => Ret tt - | S n' => fun v => - Vis (inr (inl Yield) : scheduler_observedE E) - (fun _ : unit => - Br n' (fun i => - schedule_with_offers (S n') v (Some i))) - end v - | S n' => fun embed v => - Vis (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - schedule_with_offers_offer_prefix pool_size n' - (fun i => embed (Fin.FS i)) v) - end embed v. - - Definition observe_scheduler_offers - (n : nat) (v : pool E n) (focus : option (Fin.t n)) - : observed_completed E := - schedule_with_offers n v focus. - - Definition handle_scheduler_offers - : scheduler_observedE E ~> ictree (yieldE + (spawnE + E)) := - fun event => - match event with - | inl _ => Ret tt - | inr event' => ICtree.trigger event' - end. - - Definition forget_scheduler_offers {X} - (t : ictree (scheduler_observedE E) X) - : ictree (yieldE + (spawnE + E)) X := - interp handle_scheduler_offers t. - - Lemma handle_scheduler_offers_obs obs : - handle_scheduler_offers (inl obs) = Ret tt. - Proof. reflexivity. Qed. - - Lemma handle_scheduler_offers_visible event : - handle_scheduler_offers (inr event) = ICtree.trigger event. - Proof. reflexivity. Qed. - - Lemma forget_scheduler_offers_no_focus_nonempty_unfold n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ - Guard (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v)). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. rewrite bind_ret_l. reflexivity. - Qed. - - Theorem forget_scheduler_offers_preserves_schedule_exact_no_focus_impossible n - (v : pool E (S n)) : - ~ forget_scheduler_offers (schedule_with_offers (S n) v None) ≅ - schedule (S n) v None. - Proof. - intro Heq. - step in Heq. - cbn in Heq. - inversion Heq. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_succ_stutter m n - (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix m (S n) embed v) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix m n - (fun i => embed (Fin.FS i)) v). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. rewrite bind_ret_l. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_stutter m r - (embed : LiveSlot r -> LiveSlot m) (v : pool E m) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix m r embed v) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix m 0 - (fun i : LiveSlot 0 => match i with end) v). - Proof. - revert m embed v. - induction r as [| r IHr]; intros m embed v. - - destruct m as [| m']. - + unfold forget_scheduler_offers. - rewrite !unfold_interp. - cbn. - apply sb_ret. reflexivity. - + unfold forget_scheduler_offers. - rewrite !unfold_interp. - cbn. - reflexivity. - - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix m r - (fun i => embed (Fin.FS i)) v)). - + apply forget_scheduler_offers_offer_prefix_succ_stutter. - + apply IHr. - Qed. - - Lemma forget_scheduler_offers_no_focus_stutters_to_offer_prefix n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ~ - forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v). - Proof. - rewrite forget_scheduler_offers_no_focus_nonempty_unfold. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_offer_prefix_zero_nonempty_unfold n - (embed : LiveSlot 0 -> LiveSlot (S n)) (v : pool E (S n)) : - forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) 0 embed v) ~ - Vis (inl Yield) - (fun _ : unit => - Br n (fun i => - forget_scheduler_offers - (schedule_with_offers (S n) v (Some i)))). - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intros []. - apply sb_guard_l. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - apply sb_br_id. intro i. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_no_focus_projection_to_focused n - (v : pool E (S n)) : - forget_scheduler_offers (schedule_with_offers (S n) v None) ~ - Vis (inl Yield) - (fun _ : unit => - Br n (fun i => - forget_scheduler_offers - (schedule_with_offers (S n) v (Some i)))). - Proof. - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) (S n) - (fun i : LiveSlot (S n) => i) v)). - - apply forget_scheduler_offers_no_focus_stutters_to_offer_prefix. - - transitivity (forget_scheduler_offers - (schedule_with_offers_offer_prefix (S n) 0 - (fun i : LiveSlot 0 => match i with end) v)). - + apply forget_scheduler_offers_offer_prefix_stutter. - + apply forget_scheduler_offers_offer_prefix_zero_nonempty_unfold. - Qed. - - Lemma emit_live_slot_offers_into_then_zero m - (embed : LiveSlot 0 -> LiveSlot m) k : - emit_live_slot_offers_into_then m 0 embed k = k. - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_into_then_succ m n - (embed : LiveSlot (S n) -> LiveSlot m) k : - observe (emit_live_slot_offers_into_then m (S n) embed k) = - VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - emit_live_slot_offers_into_then m n - (fun i => embed (Fin.FS i)) k). - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_zero : - observe (emit_live_slot_offers 0) = RetF tt. - Proof. reflexivity. Qed. - - Lemma emit_live_slot_offers_succ n : - observe (emit_live_slot_offers (S n)) = - VisF (inl (ObsOffered (live_slot_ref (Fin.F1 : LiveSlot (S n))))) - (fun _ : unit => - emit_live_slot_offers_into_then (S n) n - (fun i => Fin.FS i) (Ret tt)). - Proof. reflexivity. Qed. - - Local Ltac solve_focused_schedule_with_offers H := - lazy [schedule_with_offers observe _observe]; - match type of H with - | observe (Vector.nth ?v ?i) = _ => - change (@_observe _ _ unit (Vector.nth v i)) with (observe (Vector.nth v i)); - rewrite H; - reflexivity - end. - - Lemma schedule_with_offers_empty_none (v : pool E 0) : - observe (schedule_with_offers 0 v None) = RetF tt. - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_no_focus_nonempty n - (v : pool E (S n)) : - observe (schedule_with_offers (S n) v None) = - VisF (inl (ObsSchedulingPoint (S n))) - (fun _ : unit => - schedule_with_offers_offer_prefix (S n) (S n) - (fun i => i) v). - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_offer_prefix_zero m - (embed : LiveSlot 0 -> LiveSlot m) (v : pool E m) : - observe (schedule_with_offers_offer_prefix m 0 embed v) = - match m return pool E m -> ictree' (scheduler_observedE E) unit with - | 0 => fun _ => RetF tt - | S n => fun v => - VisF (inr (inl Yield) : scheduler_observedE E) - (fun _ : unit => - Br n (fun i => schedule_with_offers (S n) v (Some i))) - end v. - Proof. destruct m; reflexivity. Qed. - - Lemma schedule_with_offers_offer_prefix_succ m n - (embed : LiveSlot (S n) -> LiveSlot m) (v : pool E m) : - observe (schedule_with_offers_offer_prefix m (S n) embed v) = - VisF (inl (ObsOffered (live_slot_ref (embed Fin.F1)))) - (fun _ : unit => - schedule_with_offers_offer_prefix m n - (fun i => embed (Fin.FS i)) v). - Proof. reflexivity. Qed. - - Lemma schedule_with_offers_focused_ret n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v $ i) = RetF tt -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers n ((v -- i)) None). - Proof. - intro Hret. - solve_focused_schedule_with_offers Hret. - Qed. - - Lemma schedule_with_offers_focused_br n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - observe (schedule_with_offers (S n) v (Some i)) = - BrF b (fun j => - schedule_with_offers (S n) ((v @ i := (k j))) (Some i)). - Proof. - intro Hbr. - solve_focused_schedule_with_offers Hbr. - Qed. - - Lemma schedule_with_offers_focused_guard n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v $ i) = GuardF t -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) ((v @ i := t)) (Some i)). - Proof. - intro Hg. - solve_focused_schedule_with_offers Hg. - Qed. - - Lemma schedule_with_offers_focused_yield n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inl Yield) k -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) - ((v @ i := (k tt))) None). - Proof. - intro Hy. - solve_focused_schedule_with_offers Hy. - Qed. - - Lemma schedule_with_offers_focused_fork n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - observe (schedule_with_offers (S n) v (Some i)) = - VisF (inr (inr (inl Spawn)) : scheduler_observedE E) - (fun _ => schedule_with_offers (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - Proof. - intro Hf. - solve_focused_schedule_with_offers Hf. - Qed. - - Lemma schedule_with_offers_focused_user_event n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - observe (schedule_with_offers (S n) v (Some i)) = - VisF (inr (inr (inr e)) : scheduler_observedE E) - (fun x => schedule_with_offers (S n) - ((v @ i := (k x))) (Some i)). - Proof. - intro Hu. - solve_focused_schedule_with_offers Hu. - Qed. - - Lemma focused_yield_returns_to_scheduling_point n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inl Yield) k -> - observe (schedule_with_offers (S n) v (Some i)) = - GuardF (schedule_with_offers (S n) - ((v @ i := (k tt))) None). - Proof. apply schedule_with_offers_focused_yield. Qed. - - Lemma forget_scheduler_offers_empty_no_focus_projection - (v : pool E 0) : - forget_scheduler_offers (schedule_with_offers 0 v None) ~ Ret tt. - Proof. - unfold forget_scheduler_offers. - rewrite unfold_interp. - cbn. - apply sb_ret. reflexivity. - Qed. - - Lemma forget_scheduler_offers_focused_ret_projection n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v $ i) = RetF tt -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers (schedule_with_offers n ((v -- i)) None). - Proof. - intro Hret. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_ret n v i Hret). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_br_projection n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Br b (fun j => - forget_scheduler_offers - (schedule_with_offers (S n) ((v @ i := (k j))) (Some i))). - Proof. - intro Hbr. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_br n v i b k Hbr). - cbn. - apply sb_br_id. intro j. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_guard_projection n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v $ i) = GuardF t -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers - (schedule_with_offers (S n) ((v @ i := t)) (Some i)). - Proof. - intro Hguard. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_guard n v i t Hguard). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_yield_projection n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inl Yield) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - forget_scheduler_offers - (schedule_with_offers (S n) ((v @ i := (k tt))) None). - Proof. - intro Hyield. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_yield n v i k Hyield). - cbn. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_fork_projection n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => - forget_scheduler_offers (schedule_with_offers (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - Proof. - intro Hfork. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_fork n v i k Hfork). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intros []. - apply sb_guard. - Qed. - - Lemma forget_scheduler_offers_focused_user_event_projection n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - forget_scheduler_offers (schedule_with_offers (S n) v (Some i)) ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => - forget_scheduler_offers - (schedule_with_offers (S n) ((v @ i := (k x))) (Some i))). - Proof. - intro Huser. - unfold forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_user_event n v i e k Huser). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - apply sb_vis. intro x. - apply sb_guard. - Qed. - - Local Notation completed' := (completed E). - Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). - - Local Definition erased_schedule (n : nat) (v : pool E n) - (focus : option (Fin.t n)) : completed E := - forget_scheduler_offers (schedule_with_offers n v focus). - - Local Lemma erased_focused_ret_equ n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v $ i) = RetF tt -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule n ((v -- i)) None). - Proof. - intro Hret. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_ret n v i Hret). - reflexivity. - Qed. - - Local Lemma erased_focused_br_equ n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - erased_schedule (S n) v (Some i) ≅ - Br b (fun j => Guard (erased_schedule (S n) - ((v @ i := (k j))) (Some i))). - Proof. - intro Hbr. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_br n v i b k Hbr). - reflexivity. - Qed. - - Local Lemma erased_focused_guard_equ n - (v : pool E (S n)) (i : Fin.t (S n)) t : - observe (v $ i) = GuardF t -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule (S n) ((v @ i := t)) (Some i)). - Proof. - intro Hguard. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_guard n v i t Hguard). - reflexivity. - Qed. - - Local Lemma erased_focused_yield_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inl Yield) k -> - erased_schedule (S n) v (Some i) ≅ - Guard (erased_schedule (S n) ((v @ i := (k tt))) None). - Proof. - intro Hyield. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_yield n v i k Hyield). - reflexivity. - Qed. - - Local Lemma erased_focused_fork_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - erased_schedule (S n) v (Some i) ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - Proof. - intro Hfork. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_fork n v i k Hfork). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - reflexivity. - Qed. - - Local Lemma erased_focused_user_event_equ n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - erased_schedule (S n) v (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n) - ((v @ i := (k x))) (Some i))). - Proof. - intro Huser. - unfold erased_schedule, forget_scheduler_offers. - rewrite unfold_interp. - rewrite (schedule_with_offers_focused_user_event n v i e k Huser). - cbn. - unfold ICtree.trigger, resum, ReSum_refl, resum_ret, - ReSumRet_refl. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - reflexivity. - Qed. - - Local Lemma schedule_focused_yield_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inl Yield) k -> - schedule (S n) v (Some i) ≅ - Guard (schedule (S n) ((v @ i := (k tt))) None). - Proof. - intro Hyield. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_yield n v i k Hyield). - reflexivity. - Qed. - - Local Lemma guard_residual_from_equ (actual target residual : completed') : - observe actual = GuardF residual -> - actual ≅ Guard target -> - residual ≅ target. - Proof. - intros Hobs Heq. - apply equ_guard_invE. - transitivity actual. - - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. - - exact Heq. - Qed. - - Local Ltac contradiction_from_shape_equ actual Hobs Heq := - exfalso; - rewrite (ictree_eta actual) in Heq; - rewrite <- Hobs in Heq; - step in Heq; inversion Heq. - - Local Lemma erased_schedule_match_left_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ erased_schedule 0 v None -> - trans l actual t' -> - exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - - rewrite (trans_schedule_empty_ret v). apply trans_ret. - - rewrite Hsb. rewrite Hmid. reflexivity. - Qed. - - Local Lemma erased_schedule_match_left_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ erased_schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n (fun i => - erased_schedule (S n) v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (Br n (fun i => schedule (S n) v (Some i))). split. - - apply trans_schedule_no_focus_nonempty. - - rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n) - ((v @ i := (k j))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - exists (schedule (S n) ((v @ i := (k j))) (Some i)). - split. - - apply trans_schedule_focused_br. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). split. - - apply trans_schedule_focused_fork. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n) - ((v @ i := (k x))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - exists (schedule (S n) ((v @ i := (k x))) (Some i)). - split. - - apply trans_schedule_focused_user_event. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma schedule_focused_br_equ n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - schedule (S n) v (Some i) ≅ - Br b (fun j => schedule (S n) ((v @ i := (k j))) (Some i)). - Proof. - intro Hbr. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_br n v i b k Hbr). - reflexivity. - Qed. - - Local Lemma schedule_focused_fork_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - Proof. - intro Hfork. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_fork n v i k Hfork). - reflexivity. - Qed. - - Local Lemma schedule_focused_user_event_equ n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => schedule (S n) ((v @ i := (k x))) (Some i)). - Proof. - intro Huser. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_user_event n v i e k Huser). - reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ schedule 0 v None -> - trans l actual t' -> - exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - assert (Hret : actual ~ Ret tt). - { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hret TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - assert (Hproj : Ret tt ~ erased_schedule 0 v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as - [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - set (sres := Br n (fun i => schedule (S n) v (Some i))). - set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). - assert (Hshape : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) - lres). - { apply trans_vis. } - assert (Hproj : - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ - erased_schedule (S n) v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans _ _ lres - (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun j => - schedule (S n) ((v @ i := (k j))) (Some i)). - set (lres := fun j => - erased_schedule (S n) ((v @ i := (k j))) (Some i)). - assert (Hshape : actual ~ Br b sres). - { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans tau (Br b lres) (lres j)). - { apply trans_br with (x := j). reflexivity. } - assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_br_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) - as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - set (lres := erased_schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - assert (Hshape : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) - (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres)) lres). - { apply trans_vis. } - assert (Hproj : - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres) ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } - destruct (sbisim_trans _ _ lres - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun x => - schedule (S n) ((v @ i := (k x))) (Some i)). - set (lres := fun x => - erased_schedule (S n) ((v @ i := (k x))) (Some i)). - assert (Hshape : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) sres). - { rewrite Hactual. - rewrite (schedule_focused_user_event_equ n v i e k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans - (obs (inr (inr e) : yieldE + (spawnE + E)) x) - (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). - { apply trans_vis. } - assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres x) - (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ erased_schedule n v focus -> - exists u', trans l (schedule n v focus) u' /\ stR R t' u'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule n' ((v -- i)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' ((v -- i)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_ret n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n') - ((v @ i := (k j))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid ->]]. - exists (schedule (S n') ((v @ i := (k j))) (Some i)). - split. - -- apply trans_schedule_focused_br. exact Hvi. - -- rewrite Hsb. rewrite Hmid. apply Hch. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - assert (Ht : t ≅ - erased_schedule (S n') ((v @ i := g)) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_guard n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule (S n') - ((v @ i := (k tt))) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := (k tt))) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n')) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (schedule (S (S n')) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). split. - ++ apply trans_schedule_focused_fork. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - -- assert (Hproj : actual ~ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n') - ((v @ i := (k x))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - exists (schedule (S n') ((v @ i := (k x))) (Some i)). - split. - ++ apply trans_schedule_focused_user_event. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - + destruct nn as [| n']. - * assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - -- rewrite (trans_schedule_empty_ret v). apply trans_ret. - -- rewrite Hsb. rewrite Hmid. reflexivity. - * assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n' (fun i => - erased_schedule (S n') v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (Br n' (fun i => schedule (S n') v (Some i))). split. - -- apply trans_schedule_no_focus_nonempty. - -- rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_left_br; eauto. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (((k0 true) :: ((v @ i := (k0 false))))%vector) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - ((v @ i := (k0 x))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - ((v @ i := (k0 j))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_left_fork; eauto. - -- eapply erased_schedule_match_left_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - ((v @ i := (k0 j))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (((k0 true) :: ((v @ i := (k0 false))))%vector) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - ((v @ i := (k0 x))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - Qed. - - Local Lemma erased_schedule_match_right (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ schedule n v focus -> - exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - assert (Ht : t ≅ schedule n' ((v -- i)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' ((v -- i)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_ret_equ n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - assert (Ht : t ≅ - schedule (S n') ((v @ i := g)) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_guard_equ n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ schedule (S n') - ((v @ i := (k tt))) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := (k tt))) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (erased_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - Qed. - - Theorem forget_scheduler_offers_preserves_schedule - n (v : pool E n) focus : - forget_scheduler_offers (schedule_with_offers n v focus) ~ - schedule n v focus. - Proof. - change (erased_schedule n v focus ~ schedule n v focus). - revert n v focus. - coinduction R CH. - intros n v focus. - assert (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)). - { intros m w f. apply CH. } - split. - - intros l t' TR. - destruct (erased_schedule_match_left R Hch _ _ _ TR - (erased_schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + exact Hres. - + reflexivity. - - intros l t' TR. - destruct (erased_schedule_match_right R Hch _ _ _ TR - (schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + unfold Basics.flip. exact Hres. - + reflexivity. - Qed. - - Record ReturnSlotTransport {n : nat} - (v : pool E (S n)) (removed : LiveSlot (S n)) - (v' : pool E n) : Prop := { - return_new_slots_come_from_old_survivors : - forall j_new : LiveSlot n, - exists j_old : LiveSlot (S n), - j_old <> removed /\ (v' $ j_new) = (v $ j_old); - return_old_survivors_reappear : - forall j_old : LiveSlot (S n), - j_old <> removed -> - exists j_new : LiveSlot n, (v' $ j_new) = (v $ j_old) - }. - - Theorem return_removes_live_slot n - (v : pool E (S n)) (i : Fin.t (S n)) : - observe (v $ i) = RetF tt -> - ReturnSlotTransport v i (v -- i). - Proof. - intro Hret; clear Hret. - revert v i. - induction n as [| n IH]; intros v i. - - constructor. - + intro j_new. inversion j_new. - + intros j_old Hneq. - contradiction Hneq. apply live_slot_one_eq. - - refine (Vector.caseS' v - (fun v0 => ReturnSlotTransport v0 i (v0 -- i)) _). - clear v; intros h tl. - refine (Fin.caseS' i - (fun i0 => ReturnSlotTransport ((h :: tl)%vector) i0 - (((h :: tl)%vector) -- i0)) _ _); clear i. - + rewrite vector_remove_head. - constructor. - * intro j_new. - exists (Fin.FS j_new). split; [discriminate | reflexivity]. - * intros j_old Hneq. - refine (Fin.caseS' j_old - (fun j => j <> Fin.F1 -> - exists j_new : LiveSlot (S n), - (tl $ j_new) = (((h :: tl)%vector) $ j)) _ _ Hneq). - -- intro Hcontra. contradiction Hcontra; reflexivity. - -- intros j_new _. exists j_new. reflexivity. - + intro i_tail. - rewrite vector_remove_tail. - destruct (IH tl i_tail) as [IHnew IHold]. - constructor. - * intro j_new. - refine (Fin.caseS' j_new - (fun j => exists j_old : LiveSlot (S (S n)), - j_old <> Fin.FS i_tail /\ - (((h :: (tl -- i_tail))%vector) $ j) - = (((h :: tl)%vector) $ j_old)) _ _). - -- exists Fin.F1. split; [discriminate | reflexivity]. - -- intro j_new'. - destruct (IHnew j_new') as [j_old [Hneq Hv]]. - exists (Fin.FS j_old). split. - ++ intro Heq. apply Fin.FS_inj in Heq. - contradiction Hneq. - ++ exact Hv. - * intros j_old Hneq. - refine (Fin.caseS' j_old - (fun j => j <> Fin.FS i_tail -> - exists j_new : LiveSlot (S n), - (((h :: (tl -- i_tail))%vector) $ j_new) - = (((h :: tl)%vector) $ j)) _ _ Hneq). - -- intros _. exists Fin.F1. reflexivity. - -- intros j_old' Hneq'. - assert (Hsurv : j_old' <> i_tail) by - (intro Heq; subst; apply Hneq'; reflexivity). - destruct (IHold j_old' Hsurv) as [j_new Hv]. - exists (Fin.FS j_new). exact Hv. - Qed. - - Definition shift_live_slot_across_spawn {n : nat} - (i : LiveSlot n) : LiveSlot (S n) := - Fin.FS i. - - Lemma shift_live_slot_across_spawn_head {n} - (child : thread E) (v : pool E n) : - (((child :: v)%vector) $ Fin.F1) = child. - Proof. reflexivity. Qed. - - Lemma shift_live_slot_across_spawn_tail {n} - (child : thread E) (v : pool E n) (i : LiveSlot n) : - (((child :: v)%vector) $ (shift_live_slot_across_spawn i)) = (v $ i). - Proof. reflexivity. Qed. - - Lemma shift_live_slot_across_spawn_parent_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - ((((k true) :: (v @ i := (k false)))%vector) - $ (shift_live_slot_across_spawn i)) = k false. - Proof. - rewrite shift_live_slot_across_spawn_tail. - apply Vector.nth_replace_eq. - Qed. - - Lemma shift_live_slot_across_spawn_other_slot n - (v : pool E (S n)) (i j : LiveSlot (S n)) k : - i <> j -> - ((((k true) :: (v @ i := (k false)))%vector) - $ (shift_live_slot_across_spawn j)) = (v $ j). - Proof. - intro Hneq. - rewrite shift_live_slot_across_spawn_tail. - apply Vector.nth_replace_neq. congruence. - Qed. - - Lemma transport_live_slots_across_spawn_head {n} - (child : thread E) (v : pool E n) : - (((child :: v)%vector) $ Fin.F1) = child. - Proof. apply shift_live_slot_across_spawn_head. Qed. - - Lemma transport_live_slots_across_spawn_tail {n} - (child : thread E) (v : pool E n) (i : LiveSlot n) : - (((child :: v)%vector) $ (shift_live_slot_across_spawn i)) = (v $ i). - Proof. apply shift_live_slot_across_spawn_tail. Qed. - - Lemma transport_live_slots_across_spawn_parent_slot n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - ((((k true) :: (v @ i := (k false)))%vector) - $ (shift_live_slot_across_spawn i)) = k false. - Proof. apply shift_live_slot_across_spawn_parent_slot. Qed. - - Lemma transport_live_slots_across_spawn_other_slot n - (v : pool E (S n)) (i j : LiveSlot (S n)) k : - i <> j -> - ((((k true) :: (v @ i := (k false)))%vector) - $ (shift_live_slot_across_spawn j)) = (v $ j). - Proof. apply shift_live_slot_across_spawn_other_slot. Qed. - - Record SpawnSlotTransport {n : nat} - (v : pool E (S n)) (parent : LiveSlot (S n)) - (k : bool -> thread E) (spawned : pool E (S (S n))) : Prop := { - spawn_child_at_head : (spawned $ Fin.F1) = k true; - spawn_parent_at_shifted_slot : (spawned $ (Fin.FS parent)) = k false; - spawn_other_old_slots_shifted : - forall j : LiveSlot (S n), - j <> parent -> (spawned $ (Fin.FS j)) = (v $ j) - }. - - Theorem transport_live_slots_across_spawn n - (v : pool E (S n)) (i : LiveSlot (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - SpawnSlotTransport v i k ((k true :: (v @ i := (k false)))%vector). - Proof. - intro Hfork; clear Hfork. - constructor. - - reflexivity. - - exact (Vector.nth_replace_eq _ _ i v (k false)). - - intros j Hneq. - exact (Vector.nth_replace_neq _ _ j i Hneq v (k false)). - Qed. - - Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) - : observed_completed E -> Prop := - | offered_prefix_here t k : - observe t = VisF (inl (ObsOffered (live_slot_ref i))) k -> - offered_in_scheduler_prefix n i t - | offered_prefix_later t obs k : - observe t = VisF (inl obs) k -> - offered_in_scheduler_prefix n i (k tt) -> - offered_in_scheduler_prefix n i t. - - Lemma emit_live_slot_offers_into_then_offers m : - forall n (embed : LiveSlot n -> LiveSlot m) k (i : LiveSlot n), - offered_in_scheduler_prefix m (embed i) - (emit_live_slot_offers_into_then m n embed k). - Proof. - intros n embed k i. - induction i as [n' | n' i IH]. - - apply offered_prefix_here with - (k := fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun i => embed (Fin.FS i)) k). - reflexivity. - - apply offered_prefix_later with - (obs := ObsOffered (live_slot_ref (embed Fin.F1))) - (k := fun _ : unit => - emit_live_slot_offers_into_then m n' - (fun j => embed (Fin.FS j)) k). - + reflexivity. - + apply (IH (fun j => embed (Fin.FS j))). - Qed. - - Lemma emit_live_slot_offers_then_offers n k (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers_then n k). - Proof. - unfold emit_live_slot_offers_then. - apply (emit_live_slot_offers_into_then_offers n n (fun i => i) k i). - Qed. - - Lemma emit_live_slot_offers_offers n (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers n). - Proof. - apply emit_live_slot_offers_then_offers. - Qed. - - Lemma emit_live_slot_offers_contains_every_slot n (i : LiveSlot n) : - offered_in_scheduler_prefix n i (emit_live_slot_offers n). - Proof. - apply emit_live_slot_offers_offers. - Qed. - - Lemma schedule_with_offers_offer_prefix_offers m : - forall n (embed : LiveSlot n -> LiveSlot m) (v : pool E m) - (i : LiveSlot n), - offered_in_scheduler_prefix m (embed i) - (schedule_with_offers_offer_prefix m n embed v). - Proof. - intros n embed v i. - induction i as [n' | n' i IH]. - - apply offered_prefix_here with - (k := fun _ : unit => - schedule_with_offers_offer_prefix m n' - (fun i => embed (Fin.FS i)) v). - apply schedule_with_offers_offer_prefix_succ. - - apply offered_prefix_later with - (obs := ObsOffered (live_slot_ref (embed Fin.F1))) - (k := fun _ : unit => - schedule_with_offers_offer_prefix m n' - (fun j => embed (Fin.FS j)) v). - + apply schedule_with_offers_offer_prefix_succ. - + apply (IH (fun j => embed (Fin.FS j))). - Qed. - Lemma offer_live_slot_now n (i : LiveSlot n) (t : observed_completed E) : <( {t}, {Obs (inl (ObsOffered (live_slot_ref i))) tt} |= @@ -1826,57 +48,6 @@ Section ObservedScheduler. split; [reflexivity | constructor]. Qed. - Lemma observed_equ_refl_no_eqdep (t : observed_completed E) : t ≅ t. - Proof. - unfold equ. - apply (leq_gfp (@fequ _ _ unit unit eq) - (fun u v : observed_completed E => u = v)). - - intros u v <-. cbn. destruct (observe u); constructor; auto. - - reflexivity. - Qed. - - Lemma observed_equ_step_no_eqdep (t u : observed_completed E) : - t ≅ u -> equF eq (equ eq) (observe t) (observe u). - Proof. - intro Htu. unfold equ in Htu. - exact (proj1 (gfp_fp (@fequ _ _ unit unit eq) t u) Htu). - Qed. - - Definition equF_scheduler_vis_result - (p q : ictree' (scheduler_observedE E) unit) : Prop := - match q with - | VisF (inl sched_obs) k_right => - exists k_left, - p = VisF (inl sched_obs) k_left /\ k_left tt ≅ k_right tt - | _ => True - end. - - Lemma equF_scheduler_vis_inv_no_eqdep p q : - equF eq (equ eq) p q -> equF_scheduler_vis_result p q. - Proof. - intro Hf. - destruct Hf as [x y Hxy | e k1 k2 Hk | t1 t2 Ht | - n k1 k2 Hk]; cbn; try exact I. - destruct e as [sched_obs | rest]; cbn; try exact I. - exists k1. split; [reflexivity | apply Hk]. - Qed. - - Lemma equ_scheduler_vis_inv_from_observe_no_eqdep - (obs : schedulerObsE) - (k : encode (inl obs : scheduler_observedE E) -> - observed_completed E) - (t u : observed_completed E) : - t ≅ u -> - observe u = VisF (inl obs) k -> - exists k_t, observe t = VisF (inl obs) k_t /\ k_t tt ≅ k tt. - Proof. - intros Htu Hu. - pose proof (equF_scheduler_vis_inv_no_eqdep _ _ - (observed_equ_step_no_eqdep _ _ Htu)) as Hshape. - rewrite Hu in Hshape. - exact Hshape. - Qed. - Lemma ktrans_vis_raw_inv_no_eqdep {X} (e : scheduler_observedE E) (k : encode e -> ictree (scheduler_observedE E) X) (w : World (scheduler_observedE E)) t' w' : @@ -1918,35 +89,6 @@ Section ObservedScheduler. exists target. split; [exact Hw | split; [exact Ht | split; assumption]]. Qed. - Inductive SchedulerEquChain : - observed_completed E -> observed_completed E -> Prop := - | scheduler_equ_chain_refl t : SchedulerEquChain t t - | scheduler_equ_chain_cons t u v : - t ≅ u -> - SchedulerEquChain u v -> - SchedulerEquChain t v. - - Lemma scheduler_equ_chain_scheduler_vis_inv_no_eqdep - (obs : schedulerObsE) - (k : encode (inl obs : scheduler_observedE E) -> - observed_completed E) - (t u : observed_completed E) : - SchedulerEquChain t u -> - observe u = VisF (inl obs) k -> - exists k_t, - observe t = VisF (inl obs) k_t /\ - SchedulerEquChain (k_t tt) (k tt). - Proof. - intros Hchain Hobs. - induction Hchain as [u | t mid u Htm _ IH]. - - exists k. split; [exact Hobs | constructor]. - - destruct (IH Hobs) as [k_mid [Hmid Hcont]]. - destruct (equ_scheduler_vis_inv_from_observe_no_eqdep obs k_mid - t mid Htm Hmid) as [k_t [Ht Hstep]]. - exists k_t. split; [exact Ht |]. - econstructor; [exact Hstep | exact Hcont]. - Qed. - Lemma offered_in_scheduler_prefix_chain_implies_AF n (i : LiveSlot n) (u actual bridge : observed_completed E) w : observe bridge = observe actual -> @@ -2019,25 +161,6 @@ Section ObservedScheduler. - exact Hprefix. Qed. - Lemma show_no_focus_offers_every_live_slot_prefix n - (v : pool E (S n)) (i : LiveSlot (S n)) : - offered_in_scheduler_prefix (S n) i - (schedule_with_offers (S n) v None). - Proof. - eapply offered_prefix_later. - - apply schedule_with_offers_no_focus_nonempty. - - apply (schedule_with_offers_offer_prefix_offers (S n) (S n) - (fun i => i) v i). - Qed. - - Lemma no_focus_offers_every_live_slot_prefix n - (v : pool E (S n)) (i : LiveSlot (S n)) : - offered_in_scheduler_prefix (S n) i - (schedule_with_offers (S n) v None). - Proof. - apply show_no_focus_offers_every_live_slot_prefix. - Qed. - Theorem show_no_focus_offers_every_live_slot n (v : pool E (S n)) (i : LiveSlot (S n)) : <( {schedule_with_offers (S n) v None}, Pure |= @@ -2134,15 +257,6 @@ Section ObservedScheduler. - exact Hcanonical. Qed. - Local Lemma observed_equ_of_observe_eq (t u : observed_completed E) : - observe t = observe u -> t ≅ u. - Proof. - intro Hobserve. - transitivity (go (observe t)). - - apply ictree_eta. - - rewrite Hobserve. - symmetry. apply ictree_eta. - Qed. Local Lemma scheduler_offer_shape_schedule n (v : pool E n) focus w : @@ -2271,7 +385,7 @@ Section ObservedScheduler. n v focused_slot Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. + ++ apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs @@ -2292,7 +406,7 @@ Section ObservedScheduler. n v focused_slot t Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. + ++ apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs @@ -2308,7 +422,7 @@ Section ObservedScheduler. n v focused_slot k Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ** apply observed_equ_of_observe_eq. + ** apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs @@ -2343,7 +457,7 @@ Section ObservedScheduler. n v focused_slot Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. + ++ apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs @@ -2364,7 +478,7 @@ Section ObservedScheduler. n v focused_slot t Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ++ apply observed_equ_of_observe_eq. + ++ apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs @@ -2380,7 +494,7 @@ Section ObservedScheduler. n v focused_slot k Hthread) in Htr. dependent destruction Htr. eapply scheduler_offer_shape_equ. - ** apply observed_equ_of_observe_eq. + ** apply observe_eq_equ. match goal with | Hobs : observe ?mid = observe t' |- _ => symmetry; exact Hobs diff --git a/theories/ICTree/Trace.v b/theories/ICTree/Trace.v index a324e5e..00d0f95 100644 --- a/theories/ICTree/Trace.v +++ b/theories/ICTree/Trace.v @@ -37,9 +37,6 @@ Proof. - apply IH; constructor. Qed. -Lemma emit_list_nil {W X} (t : ictreeW W X) : emit_list [] t = t. -Proof. reflexivity. Qed. - Lemma emit_list_cons {W X} o xs (t : ictreeW W X) : emit_list (o :: xs) t ≅ Vis (Log o) (fun _ => emit_list xs t). Proof. @@ -450,17 +447,3 @@ Proof. apply (coinduction.gfp_bt (sb eq) R); symmetry. exact (emit_batches_unfold_sbisim batch next i). Qed. - -(** An everywhere-empty batch loop is raw-equivalent to [stuck]. Both sides - unfold to a [Guard], so the recursive obligation sits under matching - [GuardF] constructors; this is a RAW equivalence, not an invisible-guard - justification of a strong bisimulation. *) -Lemma emit_batches_empty {W I X} (batch : I -> list W) (next : I -> I) : - (forall j, batch j = []) -> - forall i, (emit_batches batch next i : ictreeW W X) ≅ stuck. -Proof. - intro Hempty; __coinduction_equ R CIH; intro i. - rewrite emit_batches_unfold, (Hempty i), emit_list_nil. - rewrite unfold_stuck. - constructor; apply CIH. -Qed. diff --git a/theories/Lang/CSL/Interp.v b/theories/Lang/CSL/Interp.v index b7f0387..a387444 100644 --- a/theories/Lang/CSL/Interp.v +++ b/theories/Lang/CSL/Interp.v @@ -149,10 +149,6 @@ Proof. + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. Qed. -Definition scheduled (p : CProg unit) : completed sE := - schedule 1 [denote p]%vector (Some Fin.F1). -Definition scheduled_rr (p : CProg unit) : completed sE := - run_round_robin (scheduled p) 0. Definition run_rr (p : CProg unit) (h : Heap) (c : nat) : ictreeW (indexed (nat * nat)) (unit * SSig) := interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (h,c). @@ -161,32 +157,6 @@ Definition run_nd (p : CProg unit) (h : Heap) (c : nat) : ictreeW (indexed (nat * nat)) (unit * SSig) := interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) (h,c). -Lemma run_rr_unfold p h c : - run_rr p h c ≅ - interp_state sh (interp_yield (interp_spawn (scheduled_rr p))) (h,c). -Proof. reflexivity. Qed. - -(** Keep one scheduler continuation fixed while interpreting a raw user event. *) -Lemma interp_rr_user_bind n (ts : pool sE (S n)) (i : Fin.t (S n)) - (t : thread sE) (e : sE) (k : encode e -> thread sE) m sigma : - t ≅ Vis (inr (inr e)) k -> - interp_schedule_rr sh (S n) (ts @ i := t) (Some i) m sigma ~ - (interp_state sh (@ICtree.trigger sE sE _ _ ReSum_refl ReSumRet_refl e) sigma >>= - fun '(x,sigma') => - interp_schedule_rr sh (S n) (ts @ i := k x) (Some i) m sigma'). -Proof. - intro Hnode. - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := t) (ts @ i := Vis (inr (inr e)) k) (Some i) m sigma - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) Hnode)) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user with (e:=e) (k:=k) - by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite interp_state_trigger_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m σ : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m σ ≅ @@ -202,7 +172,7 @@ Lemma interp_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). Proof. - apply (interp_rr_user_bind n ts i _ (inl (HRead a)) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HRead a)) (fun x => K (Some x)) m σ). apply source_raw_read_head. Qed. @@ -214,7 +184,7 @@ Lemma interp_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). Proof. - apply (interp_rr_user_bind n ts i _ (inl (HAlloc size)) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HAlloc size)) (fun base => K (Some base)) m sigma). apply source_raw_alloc_head. Qed. @@ -227,7 +197,7 @@ Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). Proof. - apply (interp_rr_user_bind n ts i _ (inl (HCAS a expected desired)) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HCAS a expected desired)) (fun b => K (Some b)) m sigma). apply source_raw_cas_head. Qed. @@ -238,7 +208,7 @@ Lemma interp_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). Proof. - apply (interp_rr_user_bind n ts i _ (inl (HWrite a v)) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HWrite a v)) (fun _ => K (Some tt)) m σ). apply source_raw_write_head. Qed. @@ -249,7 +219,7 @@ Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (semit q v) σ >>= fun '(_,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). Proof. - apply (interp_rr_user_bind n ts i _ (inr (Log (q,v))) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inr (Log (q,v))) (fun _ => K (Some tt)) m σ). apply source_raw_emit_head. Qed. @@ -666,99 +636,6 @@ Proof. rewrite bind_stuck_equ; reflexivity. Qed. -Lemma interp_rr_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c : - h a = None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) - a v h c Missing) as Hstate. - rewrite interp_rr_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_rr_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) m h c : - h a = None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c - (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. - rewrite bind_ret_r in Hstate. - rewrite interp_rr_cas. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_rr_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) m h c : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - pose proof ((interp_heap_alloc_zero (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h c) as Hstate. - rewrite interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_rr_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c : - Nat.lt 0 size -> - (forall base, Nat.lt 0 base -> ~ block_free h base size) -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intros Pos Full. - assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ - (stuck : ictreeW (indexed (nat * nat)) (nat * SSig))). - { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. - rewrite interp_state_vis. - change ((alloc_search (F:=writerE (indexed (nat * nat))) (Sigma:=nat) - h size 1 c >>= - fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). - etransitivity. - - apply equ_clo_bind with (S:=eq) - (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). - + apply (alloc_search_no_space (F:=writerE (indexed (nat * nat))) - (Sigma:=nat) h size 1 c Pos). - intros base Positive; apply Full; lia. - + intros result result' <-; reflexivity. - - - apply bind_stuck_equ. } - rewrite interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) tag value (K : option unit -> thread sE) h c : interp_schedule_nd sh (S n) @@ -868,98 +745,6 @@ Proof. rewrite bind_stuck_equ; reflexivity. Qed. -Lemma interp_nd_source_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c : - h a = None -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a v h c Missing) as Hstate. - rewrite interp_nd_source_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_nd_source_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) h c : - h a = None -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c - (fun x : bool => (Ret x : ictree sE bool)) Missing) as Hstate. - rewrite bind_ret_r in Hstate. - rewrite interp_nd_source_cas. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_nd_source_alloc_zero n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option nat -> thread sE) h c : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc 0) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - pose proof ((interp_heap_alloc_zero (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h c) as Hstate. - rewrite interp_nd_source_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_nd_source_alloc_no_space n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c : - Nat.lt 0 size -> - (forall base, Nat.lt 0 base -> ~ block_free h base size) -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intros Pos Full. - assert (Hstate : interp_state sh (heap_alloc (E:=sE) size) (h,c) ≅ - (stuck : ictreeW (indexed (nat * nat)) (nat * SSig))). - { unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. - rewrite interp_state_vis. - change ((alloc_search (F:=writerE (indexed (nat * nat))) (Sigma:=nat) - h size 1 c >>= - fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')) ≅ stuck). - etransitivity. - - apply equ_clo_bind with (S:=eq) - (k2:=fun '(base,sigma') => Guard (interp_state sh (Ret base) sigma')). - + apply (alloc_search_no_space (F:=writerE (indexed (nat * nat))) - (Sigma:=nat) h size 1 c Pos). - intros base Positive; apply Full; lia. - + intros result result' <-; reflexivity. - - - apply bind_stuck_equ. } - rewrite interp_nd_source_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - (** Physical free is a raw shared command, not a source constructor. *) Lemma raw_heap_free_head a (K : unit -> thread sE) : @@ -1020,26 +805,3 @@ Proof. end. rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. Qed. - -(** ** Pool-shape tactics for concrete round-robin computations. *) - -Ltac source_observe := - lazy [observe _observe Vector.nth Vector.replace Vector.caseS' - denote denote_flow ICtree.bind ICtree.subst' rr_pick - heap_read heap_write heap_alloc heap_cas ICtree.trigger - resum resum_ret ReSum_heap_CEff ReSumRet_heap_CEff - ReSum_tagged_CEff ReSumRet_tagged_CEff - Nat.modulo Nat.divmod Fin.of_nat_lt]; reflexivity. - -Ltac pool_simpl := - cbv [Vector.replace Vector.caseS' rr_pick Nat.modulo Nat.divmod Fin.of_nat_lt]. - -Ltac finish_pool := - repeat first - [ progress pool_simpl - | rewrite vector_remove_head - | rewrite vector_remove_tail - | erewrite interp_schedule_rr_ret by source_observe - | rewrite interp_schedule_rr_select - | rewrite interp_schedule_rr_empty ]; - reflexivity. diff --git a/theories/Lang/StImp.v b/theories/Lang/StImp.v index 98b8505..6be3876 100644 --- a/theories/Lang/StImp.v +++ b/theories/Lang/StImp.v @@ -45,9 +45,8 @@ Generalizable All Variables. *) Module StImp. (** A context is a map from strings to natural numbers *) - Definition Ctx := alist string nat. - Definition Mem := stateE Ctx. Import Ctx. + Definition Mem := stateE Ctx. Opaque lookup. (** * The syntax of StImp programs *) diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v index ec872c3..045aeda 100644 --- a/theories/Lang/Yield.v +++ b/theories/Lang/Yield.v @@ -7,6 +7,7 @@ From TICL Require Export Utils.Vectors ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.Observed ICTree.Logic.Yield ICTree.Logic.SchedulerFairness Lang.Yield.Syntax diff --git a/theories/Lang/Yield/Denote.v b/theories/Lang/Yield/Denote.v index a8fcd75..8baeccf 100644 --- a/theories/Lang/Yield/Denote.v +++ b/theories/Lang/Yield/Denote.v @@ -10,16 +10,15 @@ From TICL Require Import Import ICtree ICTreeNotations. Local Open Scope ictree_scope. -Definition Ctx := alist string nat. -Definition Mem := stateE Ctx. +Definition Mem := stateE Ctx.Ctx. (** Raw Yield denotations can yield, fork, and access memory. *) Definition YEff := yieldE + (forkE + Mem). Definition ytrigger (e : YEff) : ictree YEff (encode e) := @ICtree.trigger YEff YEff _ _ ReSum_refl ReSumRet_refl e. -Definition yget : ictree YEff Ctx := ytrigger (inr (inr Get)). -Definition yput (m : Ctx) : ictree YEff unit := +Definition yget : ictree YEff Ctx.Ctx := ytrigger (inr (inr Get)). +Definition yput (m : Ctx.Ctx) : ictree YEff unit := ytrigger (inr (inr (Put m))). Definition yyield : ictree YEff unit := ytrigger (inl Yield). Definition yfork : ictree YEff bool := ytrigger (inr (inl Fork)). @@ -170,42 +169,6 @@ Lemma denote_stmt_flow_yif test then_branch else_branch : denote_stmt_flow else_branch). Proof. reflexivity. Qed. -Lemma denote_stmt_flow_ywhile test body : - denote_stmt_flow (YWhile test body) = - ICtree.iter - (fun _ => - condition_value <- denote_exp test;; - if YieldSyntax.is_true condition_value then - flow <- denote_stmt_flow body;; - match flow with - | Fallthrough => Ret (inl tt) - | HaltThread => Ret (inr HaltThread) - end - else - Ret (inr Fallthrough)) tt. -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yfork body : - denote_stmt_flow (YFork body) = - (in_child <- yfork;; - if in_child then - _ <- denote_stmt_flow body;; - Ret HaltThread - else - Ret Fallthrough). -Proof. reflexivity. Qed. - -Lemma denote_stmt_yfork body : - denote_stmt (YFork body) = - (_ <- (in_child <- yfork;; - if in_child then - _ <- denote_stmt_flow body;; - Ret HaltThread - else - Ret Fallthrough);; - Ret tt). -Proof. reflexivity. Qed. - Lemma denote_stmt_flow_yskip : denote_stmt_flow YSkip = Ret Fallthrough. Proof. reflexivity. Qed. diff --git a/theories/Lang/Yield/Interp.v b/theories/Lang/Yield/Interp.v index 8020039..e0f17eb 100644 --- a/theories/Lang/Yield/Interp.v +++ b/theories/Lang/Yield/Interp.v @@ -34,37 +34,19 @@ Local Open Scope ictree_scope. Definition scheduled_visible (s : YStmt) : completed Mem := schedule 1 [denote_stmt s]%vector (Some Fin.F1). -(** Backward-compatible name for the scheduler-visible scheduled computation. *) -Definition scheduled : YStmt -> completed Mem := scheduled_visible. - -(** Erased scheduled interpretation: both scheduler [Spawn] and cooperative - [Yield] observations are intentionally erased, leaving only memory effects. *) -Definition interp_scheduled_erased (s : YStmt) : ictree Mem unit := - interp_yield (interp_spawn (scheduled_visible s)). - -(** Backward-compatible erased scheduled interpretation. New concurrency-facing - code should choose explicitly between [scheduled_visible] and - [interp_scheduled_erased]. *) -Definition interp_scheduled : YStmt -> ictree Mem unit := interp_scheduled_erased. - (** Erased expression instrumentation: raw thread-level [Yield] observations are erased before state instrumentation. *) -Definition instr_exp_erased (e : YExp) (ctx : Ctx) : ictreeW Ctx (nat * Ctx) := +Definition instr_exp_erased (e : YExp) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (nat * Ctx.Ctx) := instr_thread (denote_exp e) ctx. (** Flow-preserving erased statement instrumentation for structural facts whose contracts must expose [Fallthrough] versus [HaltThread]. The public [instr_stmt_erased] remains the scheduled unit-returning view. *) Definition instr_stmt_flow_erased - (s : YStmt) (ctx : Ctx) : ictreeW Ctx (YStmtFlow * Ctx) := + (s : YStmt) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (YStmtFlow * Ctx.Ctx) := instr_thread (denote_stmt_flow s) ctx. (** Erased statement instrumentation: scheduler [Spawn] and cooperative [Yield] observations are erased before state instrumentation. *) -Definition instr_stmt_erased (s : YStmt) (ctx : Ctx) : ictreeW Ctx (unit * Ctx) := +Definition instr_stmt_erased (s : YStmt) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (unit * Ctx.Ctx) := instr_schedule 1 [denote_stmt s]%vector (Some Fin.F1) ctx. - -(** Backward-compatible erased instrumentation aliases. These names preserve the - iteration-1 API, where instrumentation observed only memory/state effects. *) -Definition instr_exp : YExp -> Ctx -> ictreeW Ctx (nat * Ctx) := instr_exp_erased. -Definition instr_stmt : YStmt -> Ctx -> ictreeW Ctx (unit * Ctx) := instr_stmt_erased. diff --git a/theories/Lang/Yield/SchedulerFairness.v b/theories/Lang/Yield/SchedulerFairness.v index 64c30ff..61fe6e2 100644 --- a/theories/Lang/Yield/SchedulerFairness.v +++ b/theories/Lang/Yield/SchedulerFairness.v @@ -3,7 +3,8 @@ From Stdlib Require Import Vector Program.Equality. -From TICL Require Export +From TICL Require Import + ICTree.Interp.Yield.Observed ICTree.Logic.SchedulerFairness. From TICL Require Import diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v index b1a5145..55f6eff 100644 --- a/theories/Lang/Yield/Ticl.v +++ b/theories/Lang/Yield/Ticl.v @@ -7,16 +7,12 @@ - [ICTree.Interp.Yield.Mod] exposes the scheduler, and [scheduled_visible] exposes scheduled programs with scheduler [Spawn], cooperative [Yield], and memory effects visible. - - [interp_scheduled_erased], [instr_exp_erased], and [instr_stmt_erased] + - [instr_exp_erased], [instr_stmt_flow_erased], and [instr_stmt_erased] expose the state-only TICL view where scheduler/yield observations are intentionally erased. - - [interp_scheduled], [instr_exp], and [instr_stmt] are compatibility - aliases for the erased tier. Every temporal lemma below is an instantiation of a raw rule from - [ICTree.Logic.Yield] at the Yield denotations. This file also carries a - small regression surface: concrete visible YYield/YFork examples, and alias - facts documenting that the compatibility APIs are erased. *) + [ICTree.Logic.Yield] at the Yield denotations. *) From Stdlib Require Import Fin Morphisms @@ -54,6 +50,7 @@ From TICL Require Import ICTree.Logic.Iter ICTree.Logic.State ICTree.SBisim + Lang.Maps Logic.Core Utils.Vectors. @@ -67,7 +64,7 @@ Local Open Scope fin_vector_scope. [Vis] node the raw rules expect. They unfold only source denotations and triggers; no interpreter is unfolded here. *) -Local Lemma yget_bind {X} (k : Ctx -> ictree YEff X) : +Local Lemma yget_bind {X} (k : Ctx.Ctx -> ictree YEff X) : (x <- yget;; k x) ≅ Vis ((inr (inr Get)) : YEff) k. Proof. unfold yget, ytrigger, ICtree.trigger. @@ -77,7 +74,7 @@ Proof. reflexivity. Qed. -Local Lemma yput_bind {X} (m : Ctx) (k : unit -> ictree YEff X) : +Local Lemma yput_bind {X} (m : Ctx.Ctx) (k : unit -> ictree YEff X) : (x <- yput m;; k x) ≅ Vis ((inr (inr (Put m))) : YEff) k. Proof. unfold yput, ytrigger, ICtree.trigger. @@ -101,7 +98,7 @@ Qed. Local Lemma denote_yassign_tail name value : (ctx <- yget;; yput (add name value ctx);; Ret Fallthrough) ≅ Vis ((inr (inr Get)) : YEff) - (fun σ0 : Ctx => + (fun σ0 : Ctx.Ctx => Vis ((inr (inr (Put (add name value σ0)))) : YEff) (fun _ : unit => Ret Fallthrough)). Proof. @@ -134,7 +131,7 @@ Qed. Local Lemma denote_stmt_yassign_ylit_update name n : denote_stmt (YAssign name (YLit n)) ≅ Vis ((inr (inr Get)) : YEff) - (fun σ0 : Ctx => + (fun σ0 : Ctx.Ctx => Vis ((inr (inr (Put (add name n σ0)))) : YEff) (fun _ : unit => Ret tt)). Proof. @@ -153,15 +150,6 @@ Proof. reflexivity. Qed. -Local Lemma pool_equ_singleton (t u : thread Mem) : - t ≅ u -> pool_equ [t]%vector [u]%vector. -Proof. - intros Ht i. - dependent destruction i. - - exact Ht. - - inversion i. -Qed. - (** * Expression rules *) Lemma axr_yexp_ylit : forall n n' ctx ctx' w w', @@ -310,7 +298,7 @@ Proof. intros ctx ctx' w w' Hctx Hw Hnd; subst. unfold instr_stmt_erased. rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' - (pool_equ_singleton _ _ denote_stmt_yskip_ret)). + (cons_pool_equ _ _ _ _ denote_stmt_yskip_ret (pool_equ_refl _))). apply axr_schedule_ret; [ assumption | split; reflexivity ]. Qed. @@ -324,7 +312,7 @@ Proof. intros ctx ctx' w w' Hctx Hw Hnd; subst. unfold instr_stmt_erased. rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' - (pool_equ_singleton _ _ denote_stmt_yyield_vis)). + (cons_pool_equ _ _ _ _ denote_stmt_yyield_vis (pool_equ_refl _))). apply axax_schedule_yield; [ assumption | split; reflexivity ]. Qed. @@ -641,7 +629,7 @@ Proof. intros name n ctx w ψ R Hlog HR. unfold instr_stmt_erased. rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx - (pool_equ_singleton _ _ (denote_stmt_yassign_ylit_update name n))). + (cons_pool_equ _ _ _ _ (denote_stmt_yassign_ylit_update name n) (pool_equ_refl _))). now apply (aur_schedule_update (add name n) ctx). Qed. @@ -654,209 +642,6 @@ Proof. intros name n ctx w ψ φ Hlog Hret. unfold instr_stmt_erased. rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx - (pool_equ_singleton _ _ (denote_stmt_yassign_ylit_update name n))). + (cons_pool_equ _ _ _ _ (denote_stmt_yassign_ylit_update name n) (pool_equ_refl _))). now apply (aul_schedule_update (add name n) ctx). Qed. - -(** * Concrete scheduler-visible examples *) -Local Ltac solve_visible_regression := - cbn; - unfold resum, ReSum_refl, resum_ret, ReSumRet_refl; - reflexivity. - -Lemma scheduled_visible_yyield_one_step : - observe (scheduled_visible YYield) = - GuardF - (schedule 1 - ([denote_stmt YYield]%vector @ Fin.F1 := (denote_stmt YSkip)) - None). -Proof. - unfold scheduled_visible. - apply (@schedule_focused_yield Mem _ 0 - [denote_stmt YYield]%vector - Fin.F1 - (fun _ : unit => denote_stmt YSkip)). - solve_visible_regression. -Qed. - -Definition yfork_body_fork_continuation - (body : YStmt) (in_child : bool) : thread Mem := - ICtree.subst' - (fun _ : YStmtFlow => Ret tt) - (observe - (ICtree.subst' - (fun branch : bool => - if branch then - denote_stmt_flow body;; Ret HaltThread - else - Ret Fallthrough) - (RetF in_child))). - -Lemma scheduled_visible_yfork_body_one_step : forall body, - observe (scheduled_visible (YFork body)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) - (fun _ => - schedule 2 - ((yfork_body_fork_continuation body true :: - ([denote_stmt (YFork body)]%vector - @ Fin.F1 := (yfork_body_fork_continuation body false)))%vector) - (Some (Fin.FS Fin.F1))). -Proof. - intro body. - unfold scheduled_visible. - apply (@schedule_focused_fork Mem _ 0 - [denote_stmt (YFork body)]%vector - Fin.F1 - (yfork_body_fork_continuation body)). - solve_visible_regression. -Qed. - -Lemma yfork_child_halts_after_body body : - yfork_body_fork_continuation body true = - ICtree.subst' (fun _ : YStmtFlow => Ret tt) - (observe (denote_stmt_flow body;; Ret HaltThread)). -Proof. reflexivity. Qed. - -Lemma yfork_parent_falls_through body : - observe (yfork_body_fork_continuation body false) = RetF tt. -Proof. solve_visible_regression. Qed. - -Definition yseq_yfork_body_rest_fork_continuation - (body rest : YStmt) (in_child : bool) : thread Mem := - ICtree.subst' - (fun _ : YStmtFlow => Ret tt) - (observe - (ICtree.subst' - (fun flow : YStmtFlow => - match flow with - | Fallthrough => denote_stmt_flow rest - | HaltThread => Ret HaltThread - end) - (observe - (ICtree.subst' - (fun branch : bool => - if branch then - denote_stmt_flow body;; Ret HaltThread - else - Ret Fallthrough) - (RetF in_child))))). - -Lemma scheduled_visible_yseq_yfork_body_rest_one_step : forall body rest, - observe (scheduled_visible (YSeq (YFork body) rest)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) - (fun _ => - schedule 2 - ((yseq_yfork_body_rest_fork_continuation body rest true :: - ([denote_stmt (YSeq (YFork body) rest)]%vector - @ Fin.F1 := - (yseq_yfork_body_rest_fork_continuation body rest false)))%vector) - (Some (Fin.FS Fin.F1))). -Proof. - intros body rest. - unfold scheduled_visible. - apply (@schedule_focused_fork Mem _ 0 - [denote_stmt (YSeq (YFork body) rest)]%vector - Fin.F1 - (yseq_yfork_body_rest_fork_continuation body rest)). - solve_visible_regression. -Qed. - -Lemma yseq_yfork_body_rest_parent_runs_rest body rest : - observe (yseq_yfork_body_rest_fork_continuation body rest false) = - observe (denote_stmt rest). -Proof. solve_visible_regression. Qed. - -Definition yfork_yield_fork_continuation (in_child : bool) : thread Mem := - ICtree.subst' - (fun _ : YStmtFlow => Ret tt) - (observe - (ICtree.subst' - (fun branch : bool => - if branch then - denote_stmt_flow YYield;; Ret HaltThread - else - Ret Fallthrough) - (RetF in_child))). - -Lemma scheduled_visible_yfork_yield_one_step : - observe (scheduled_visible (YFork YYield)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) - (fun _ => - schedule 2 - ((yfork_yield_fork_continuation true :: - ([denote_stmt (YFork YYield)]%vector - @ Fin.F1 := (yfork_yield_fork_continuation false)))%vector) - (Some (Fin.FS Fin.F1))). -Proof. - unfold scheduled_visible. - apply (@schedule_focused_fork Mem _ 0 - [denote_stmt (YFork YYield)]%vector - Fin.F1 - yfork_yield_fork_continuation). - solve_visible_regression. -Qed. - -Definition yseq_yfork_skip_yield_fork_continuation - (in_child : bool) : thread Mem := - ICtree.subst' - (fun _ : YStmtFlow => Ret tt) - (observe - (ICtree.subst' - (fun flow : YStmtFlow => - match flow with - | Fallthrough => denote_stmt_flow YYield - | HaltThread => Ret HaltThread - end) - (observe - (ICtree.subst' - (fun branch : bool => - if branch then - denote_stmt_flow YSkip;; Ret HaltThread - else - Ret Fallthrough) - (RetF in_child))))). - -Lemma yseq_yfork_skip_yield_child_done : - observe (yseq_yfork_skip_yield_fork_continuation true) = RetF tt. -Proof. solve_visible_regression. Qed. - -Lemma yseq_yfork_skip_yield_parent_yields : - observe (yseq_yfork_skip_yield_fork_continuation false) = - VisF ((inl Yield) : YEff) (fun _ : unit => denote_stmt YSkip). -Proof. solve_visible_regression. Qed. - -Lemma scheduled_visible_yseq_yfork_skip_yield_one_step : - observe (scheduled_visible (YSeq (YFork YSkip) YYield)) = - VisF ((inr (inl Spawn)) : yieldE + (spawnE + Mem)) - (fun _ => - schedule 2 - ((yseq_yfork_skip_yield_fork_continuation true :: - ([denote_stmt (YSeq (YFork YSkip) YYield)]%vector - @ Fin.F1 := - (yseq_yfork_skip_yield_fork_continuation false)))%vector) - (Some (Fin.FS Fin.F1))). -Proof. - unfold scheduled_visible. - apply (@schedule_focused_fork Mem _ 0 - [denote_stmt (YSeq (YFork YSkip) YYield)]%vector - Fin.F1 - yseq_yfork_skip_yield_fork_continuation). - solve_visible_regression. -Qed. - -(** * Compatibility aliases are erased APIs *) -Lemma interp_scheduled_erased_unfold s : - interp_scheduled_erased s = interp_yield (interp_spawn (scheduled_visible s)). -Proof. reflexivity. Qed. - -Lemma scheduled_alias s : scheduled s = scheduled_visible s. -Proof. reflexivity. Qed. - -Lemma interp_scheduled_alias_erased s : interp_scheduled s = interp_scheduled_erased s. -Proof. reflexivity. Qed. - -Lemma instr_exp_alias_erased e ctx : instr_exp e ctx = instr_exp_erased e ctx. -Proof. reflexivity. Qed. - -Lemma instr_stmt_alias_erased s ctx : instr_stmt s ctx = instr_stmt_erased s ctx. -Proof. reflexivity. Qed. diff --git a/theories/Utils/Execution.v b/theories/Utils/Execution.v index d49b948..06e53b4 100644 --- a/theories/Utils/Execution.v +++ b/theories/Utils/Execution.v @@ -104,21 +104,6 @@ Section RunTurns. intros Hleft Hright; rewrite run_turns_append, Hleft, Hright; reflexivity. Qed. - Lemma run_turns_append_inv left right s last ws : - run_turns (left ++ right) s = Some (last,ws) -> - exists middle first second, - run_turns left s = Some (middle,first) /\ - run_turns right middle = Some (last,second) /\ - ws = first ++ second. - Proof. - rewrite run_turns_append; intro Hrun. - destruct (run_turns left s) as [[middle first]|] eqn:Hleft; [|discriminate]. - destruct (run_turns right middle) as [[last' second]|] eqn:Hright; - [|discriminate]. - inversion Hrun; subst. - exists middle, first, second; repeat split; assumption || reflexivity. - Qed. - (** An invariant preserved by one transition is preserved by a whole run. *) Lemma run_turns_preserves_inv (Inv : St -> Prop) (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s') : @@ -134,21 +119,6 @@ Section RunTurns. eapply IH; [eapply preserves; eauto|exact Hrest]. Qed. - (** A total, invariant-preserving transition never faults on any script. *) - Lemma run_turns_total (Inv : St -> Prop) - (total : forall a s, Inv s -> exists r, step a s = Some r) - (preserves : forall a s s' o, Inv s -> step a s = Some (s',o) -> Inv s') : - forall script s, Inv s -> exists last ws, run_turns script s = Some (last,ws). - Proof. - induction script as [|who rest IH]; intros s Hinv. - - exists s, []; reflexivity. - - cbn [run_turns]. - destruct (total who s Hinv) as ([next output] & Hstep). - rewrite Hstep. - destruct (IH next (preserves who s next output Hinv Hstep)) - as (last & tail & Hrest). - rewrite Hrest; exists last, (logs output ++ tail); reflexivity. - Qed. End RunTurns. Arguments run_turns {St Act Out W} step logs script s. @@ -174,14 +144,6 @@ Section RunTurnsProper. exists t'; split; [reflexivity|exact Hnext]. Qed. - Lemma step_none_compatible a s t : - R s t -> (step a s = None <-> step a t = None). - Proof. - intro Hst; pose proof (Hstep a a eq_refl s t Hst) as H. - destruct (step a s); destruct (step a t); inversion H; - split; intro Hnone; congruence. - Qed. - Lemma run_turns_proper script : Proper (R ==> Roption (RelProd R eq)) (run_turns step logs script). Proof. @@ -219,14 +181,6 @@ Section RunTurnsProper. exists last'; split; [reflexivity|exact Hlast]. Qed. - Corollary run_turns_none_compatible script s t : - R s t -> - (run_turns step logs script s = None <-> run_turns step logs script t = None). - Proof. - intro Hst; pose proof (run_turns_proper script s t Hst) as H. - destruct (run_turns step logs script s); destruct (run_turns step logs script t); - inversion H; split; intro Hnone; congruence. - Qed. End RunTurnsProper. (** ** Constructing an infinite execution from a choice sequence. @@ -286,23 +240,6 @@ Section OfChoices. selected (execution_of_choices s0 H0 picks) k = picks k. Proof. reflexivity. Qed. - (** A strict prefix of the choice sequence determines a prefix of states. *) - Lemma execution_of_choices_prefix s0 H0 picks picks' k : - (forall j, j < k -> picks j = picks' j) -> - states (execution_of_choices s0 H0 picks) k = - states (execution_of_choices s0 H0 picks') k. - Proof. - pose proof (execution_of_choices_valid s0 H0 picks) as [Hi Hs]. - pose proof (execution_of_choices_valid s0 H0 picks') as [Hi' Hs']. - induction k as [|k IH]; intro Hagree. - - reflexivity. - - specialize (Hs k); specialize (Hs' k). - change (selected (execution_of_choices s0 H0 picks) k) with (picks k) in Hs. - change (selected (execution_of_choices s0 H0 picks') k) with (picks' k) in Hs'. - rewrite (IH ltac:(intros j Hj; apply Hagree; lia)) in Hs. - rewrite (Hagree k ltac:(lia)) in Hs. - rewrite Hs in Hs'; now inversion Hs'. - Qed. End OfChoices. Arguments next_valid {St Act Out} step Inv total preserves a s Hinv. @@ -332,11 +269,6 @@ Section ExecutionFacts. Qed. End ExecutionFacts. -(** The flattened observation window of a half-open interval. *) -Definition execution_log_window {St Act Out W} - (logs : Out -> list W) (e : Execution St Act Out) (lo len : nat) : list W := - List.flat_map (fun k => logs (emitted e k)) (List.seq lo len). - Section ExecutionRun. Context {St Act Out W : Type} (step : Act -> St -> option (St * Out)) @@ -390,6 +322,49 @@ Section ExecutionWindow. eapply step_some_compatible; [exact Hstep|exact Hs|]. eapply execution_step; exact Hvalid. Qed. + + (** A window whose script is fixed pointwise: the endpoint state after + replaying it, and the state and output at any position inside it. *) + Lemma execution_script_state (e : Execution St Act Out) lo script s last ws : + valid e -> R (states e lo) s -> + List.map (selected e) (List.seq lo (List.length script)) = script -> + run_turns step logs script s = Some (last,ws) -> + R (states e (lo + List.length script)) last. + Proof. + intros Hvalid Hs Hscript Hrun. + destruct (execution_window_state e lo (List.length script) s Hvalid Hs) + as (actual & Hactual & Hstate). + rewrite Hscript, Hrun in Hactual. + assert (Elast : actual = last) by congruence; subst actual; exact Hstate. + Qed. + + Lemma execution_script_emitted (e : Execution St Act Out) lo script i d + s middle ws next out : + valid e -> R (states e lo) s -> + List.map (selected e) (List.seq lo (List.length script)) = script -> + i < List.length script -> + run_turns step logs (List.firstn i script) s = Some (middle,ws) -> + step (List.nth i script d) middle = Some (next,out) -> + R (states e (lo + i)) middle /\ emitted e (lo + i) = out. + Proof. + intros Hvalid Hs Hscript Hi Hrun Hturn. + assert (Hpre : List.map (selected e) (List.seq lo i) = List.firstn i script). + { rewrite <- (map_seq_firstn (selected e) lo (List.length script) i + ltac:(lia)); rewrite Hscript; reflexivity. } + assert (Hsel : selected e (lo + i) = List.nth i script d). + { rewrite <- Hscript. + rewrite (List.nth_indep _ d (selected e lo)) + by (rewrite List.length_map, List.length_seq; exact Hi). + rewrite List.map_nth, (List.seq_nth lo lo Hi); reflexivity. } + destruct (execution_window_state e lo i s Hvalid Hs) + as (actual & Hactual & Hstate). + rewrite Hpre, Hrun in Hactual. + assert (Emiddle : actual = middle) by congruence; subst actual. + split; [exact Hstate|]. + destruct (execution_turn_observation e (lo + i) middle Hvalid Hstate) + as (next' & Hturn' & _). + rewrite Hsel, Hturn in Hturn'; congruence. + Qed. End ExecutionWindow. (** ** Counters and observation indices. @@ -443,50 +418,12 @@ Section ExecutionCounter. Qed. End ExecutionCounter. -(** The finite-run counter law, from the per-step increment. *) -Section RunCounter. - Context {St Act Out W : Type} - (step : Act -> St -> option (St * Out)) - (logs : Out -> list W) - (counter : St -> nat) - (Hcounter : forall a s s' o, step a s = Some (s',o) -> - counter s' = counter s + length (logs o)). - - Lemma run_turns_counter script s last ws : - run_turns step logs script s = Some (last,ws) -> - counter last = counter s + length ws. - Proof. - revert s last ws; induction script as [|who rest IH]; intros s last ws Hrun. - - cbn [run_turns] in Hrun; inversion Hrun; subst; cbn; lia. - - cbn [run_turns] in Hrun. - destruct (step who s) as [[next output]|] eqn:Hstep; [|discriminate]. - destruct (run_turns step logs rest next) as [[last' tail]|] eqn:Hrest; - [|discriminate]. - inversion Hrun; subst; clear Hrun. - pose proof (IH next _ _ Hrest) as Hsuffix. - pose proof (Hcounter who s next output Hstep) as Hone. - rewrite length_app; lia. - Qed. -End RunCounter. - (** ** Reachability, through the Stdlib closure. *) Definition reachable {St Act Out} (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) (s : St) : Prop := exists s0, initial s0 /\ clos_refl_trans_1n St (fun x y => exists a o, step a x o y) s0 s. -Lemma execution_reachable {St Act Out} - (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) - (e : Execution St Act Out) k : - execution_valid step initial e -> reachable step initial (states e k). -Proof. - intros [Hinit Hstep]; exists (states e 0); split; [exact Hinit|]. - apply clos_rt_rt1n. - induction k as [|k IH]; [apply rt_refl|]. - eapply rt_trans; [exact IH|]. - apply rt_step; exists (selected e k), (emitted e k); apply Hstep. -Qed. - Lemma reachable_inv {St Act Out} (step : Act -> St -> Out -> St -> Prop) (initial : St -> Prop) (Inv : St -> Prop) From 84173bac93156d1ba6389505c47146299d9a89c3 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 25 Sep 2026 21:28:04 +0000 Subject: [PATCH 10/14] chore: ignore .omp and graphify-out tool artifacts --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 067460f..effb9e0 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ _build .vok .vo main.html +.omp +graphify-out From 14c79345bf69f080d16086d8c7a9600d4c6e54e6 Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Thu, 1 Oct 2026 23:29:01 +0000 Subject: [PATCH 11/14] refactor(csl): consolidate interpreter and language, add whole-block free ICTree/Interp/CSL/Mod.v is the one CSL interpreter (sE, SSig, the payload-polymorphic sh, CEff, raw free and select rules) and Lang/CSL/Mod.v the one CSL language (CProg, denotation, execution equations, exact segment rules, structural matrix). The split Lang/CSL/{Heap,Syntax,Denote,Interp,Segments,Ticl}.v modules and the Lang/CSL.v facade are removed; the queue development moves to examples/CSL/Queue, and h_qE/Sig give way to sh (A:=nat)/SSig. Memory carries allocation provenance: ManagedHeap pairs the data heap with an extent table, and ProductPCM gives it separation. heap_handler records each malloc extent; HFree/CFree releases exactly a recorded block, free 0 is a no-op, and interior, unknown and double frees are stuck. The CSL matrix gains ten *_free rules (140 in total), and examples/CSL/Memory.v pins the lifecycle, reuse and fault behavior. Adds AGENTS.md and the examples load path to _CoqProject. --- AGENTS.md | 39 + _CoqProject | 3 +- examples/CSL/Allocator/Counterexamples.v | 12 +- examples/CSL/Allocator/Execution.v | 194 +- examples/CSL/Allocator/Liveness.v | 39 +- examples/CSL/Allocator/Model.v | 10 +- examples/CSL/Allocator/Program.v | 2 +- examples/CSL/Memory.v | 238 ++ examples/CSL/Overlap.v | 4 +- examples/CSL/Queue.v | 6 + .../Lang => examples}/CSL/Queue/Alternating.v | 38 +- .../Lang => examples}/CSL/Queue/Composition.v | 88 +- {theories/Lang => examples}/CSL/Queue/Frame.v | 32 +- .../Lang => examples}/CSL/Queue/Layout.v | 3 +- .../Lang => examples}/CSL/Queue/Operations.v | 33 +- .../Lang => examples}/CSL/Queue/Program.v | 163 +- .../Lang => examples}/CSL/Queue/Recurrence.v | 111 +- .../CSL/Queue/Representation.v | 8 +- .../Lang => examples}/CSL/Queue/Separation.v | 4 +- .../Lang => examples}/CSL/Queue/Sequential.v | 30 +- {theories/Lang => examples}/CSL/Queue/Ticl.v | 74 +- {theories/Lang => examples}/CSL/Queue/Trace.v | 24 +- examples/CSL/README.md | 245 +- theories/Events/HeapModel.v | 231 +- theories/ICTree/Interp/CSL/Mod.v | 480 +++ theories/ICTree/Interp/Heap.v | 248 +- theories/ICTree/Logic/Heap.v | 10 +- theories/Lang/CSL.v | 3 - theories/Lang/CSL/Denote.v | 106 - theories/Lang/CSL/Heap.v | 65 - theories/Lang/CSL/Interp.v | 807 ----- theories/Lang/CSL/Mod.v | 3027 +++++++++++++++++ theories/Lang/CSL/Queue.v | 6 - theories/Lang/CSL/Segments.v | 198 -- theories/Lang/CSL/Syntax.v | 14 - theories/Lang/CSL/Ticl.v | 1931 ----------- theories/Utils/Pcm.v | 26 + 37 files changed, 4759 insertions(+), 3793 deletions(-) create mode 100644 AGENTS.md create mode 100644 examples/CSL/Memory.v create mode 100644 examples/CSL/Queue.v rename {theories/Lang => examples}/CSL/Queue/Alternating.v (81%) rename {theories/Lang => examples}/CSL/Queue/Composition.v (85%) rename {theories/Lang => examples}/CSL/Queue/Frame.v (93%) rename {theories/Lang => examples}/CSL/Queue/Layout.v (99%) rename {theories/Lang => examples}/CSL/Queue/Operations.v (75%) rename {theories/Lang => examples}/CSL/Queue/Program.v (83%) rename {theories/Lang => examples}/CSL/Queue/Recurrence.v (76%) rename {theories/Lang => examples}/CSL/Queue/Representation.v (99%) rename {theories/Lang => examples}/CSL/Queue/Separation.v (98%) rename {theories/Lang => examples}/CSL/Queue/Sequential.v (84%) rename {theories/Lang => examples}/CSL/Queue/Ticl.v (67%) rename {theories/Lang => examples}/CSL/Queue/Trace.v (83%) create mode 100644 theories/ICTree/Interp/CSL/Mod.v delete mode 100644 theories/Lang/CSL.v delete mode 100644 theories/Lang/CSL/Denote.v delete mode 100644 theories/Lang/CSL/Heap.v delete mode 100644 theories/Lang/CSL/Interp.v create mode 100644 theories/Lang/CSL/Mod.v delete mode 100644 theories/Lang/CSL/Queue.v delete mode 100644 theories/Lang/CSL/Segments.v delete mode 100644 theories/Lang/CSL/Syntax.v delete mode 100644 theories/Lang/CSL/Ticl.v diff --git a/AGENTS.md b/AGENTS.md new file mode 100644 index 0000000..f200017 --- /dev/null +++ b/AGENTS.md @@ -0,0 +1,39 @@ +# Ticl repository guidance + +## Purpose + +Ticl is Temporal Interaction and Choice Logic: a Rocq development for structural verification of arbitrary temporal properties over interaction-and-choice trees. Nested properties such as `AG AF` are supported by the same reusable program-structure lemmas as simpler safety and liveness properties. + +## Proof dependency ladder + +Keep dependencies directed from reusable foundations toward applications: + +1. General semantics and temporal reasoning: `theories/Logic/` defines the temporal logic and worlds; `theories/ICTree/` defines trees, equality, bisimulation, transitions, and the general modality-by-program-structure lemmas in `theories/ICTree/Logic/`. +2. Interpretation: `theories/ICTree/Interp/` defines effect handlers/interpreters and reusable reasoning about interpreted trees. Reuse `Core.v`, `State/Mod.v`, `Heap.v`, and the existing generic state/iteration lifting lemmas in `theories/ICTree/Logic/State.v`. A theorem that does not mention language syntax belongs at this reusable layer, not in an example or language implementation. +3. Languages: `theories/Lang/` owns syntax, denotation into trees, and structural Ticl lemmas stated over language programs. `MeQ.v` is the queue language, `MeS.v` is tagged secure memory, and `StImp.v` is the general imperative-language example. Language proofs specialize reusable interpretation lemmas. +4. Examples: `examples/` defines concrete programs, invariants, variants, representations, and their correctness proofs. Example proofs should apply language structural lemmas; do not reproduce interpreter unfolding, transition inversion, induction/coinduction, or scheduler machinery here when a reusable lower-layer lemma can express the argument. + +Read `examples/Queue.v` and `theories/Lang/MeQ.v` as the reference pattern. The queue theorem `rotate_agaf_pop` proves `AG AF` by applying `ag_qprog_invariance`, `aul_qprog_eventually`, and the queue operation/bind lemmas. Domain-specific list facts stay in the example; general temporal reasoning stays below it. + +## CSL ownership + +- `theories/Lang/CSL/Mod.v` is the sole CSL language implementation: its memory commands, program syntax, and denotation. Reuse the shared heap model and PCM/separation support instead of defining competing heaps or resource algebras. +- `theories/ICTree/Interp/CSL/Mod.v` is the sole CSL interpreter implementation. It interprets effects/trees, not CSL syntax, and must not import `theories/Lang/` or `examples/`. +- CSL language structural theorems specialize interpreter theorems; queue and allocator programs remain clients. Support files are allowed, but they must not define a second CSL language/interpreter or retain an obsolete forwarding facade. +- Queue-specific programs, representations, and recurrence/framing/composition proofs belong in `examples/CSL/Queue/`; allocator programs belong in `examples/CSL/Allocator/`. +- The canonical memory state carries data cells and live allocation extents. `CAlloc` is malloc; `CFree` releases the recorded whole block. `CFree 0` does nothing, and invalid nonzero frees are stuck. Allocator `remote_free` is free-list publication, not physical heap deallocation. +- Heap models, events, and resource algebras are below both interpreters and languages. Keep them independent of example layouts and program syntax. + +## Refactoring and proof rules + +Preserve the modality-by-program-structure theorem family, its coverage, theorem strength, and nondeterministic/round-robin distinctions. An exported structural theorem or standalone verification theorem is not dead merely because a search finds no callers. Generalize and deduplicate proof machinery underneath these APIs rather than replacing them with manual rewrite instructions. + +Put a new reusable fact at the lowest layer that can state it without importing a higher layer. Before writing a new handler, interpreter, heap operation, temporal proof, or separation law, look for an existing equivalent and reuse it. Do not add new axioms, `Admitted`, fake semantics, bounded allocation fallbacks, or compatibility aliases to make a refactor compile; Stdlib UIP and functional extensionality are always allowed and need no audit or caveat prose in documentation. Migrate every caller when moving an API, and delete the superseded implementation only after its replacement exists. + +Preserve existing operational behavior, visible observations, fault behavior, scheduling semantics, separation laws, and theorem hypotheses during organizational changes. Examples must not become the source of reusable interpretation facts. + +## Building and checking + +Run from the repository root with the project's Rocq/opam environment active. `make` invokes `dune build`; `make doc` invokes `dune build @doc`; `make install` builds and installs the package. The documented compiler baseline is Rocq 9.0.0; the Dune project requires Dune 3.21 and the ExtLib, Equations, and Coinduction theories. `theories/dune` uses qualified subdirectories and the logical theory name `TICL`; `_CoqProject` maps `_build/default/theories` to `TICL` and `_build/default/examples` to `examples`; CSL example modules import each other through `From examples`. + +Validate changed behavior with concrete operation/program proofs as well as compiling the affected examples. Keep existing liveness and counterexample theorems, especially nested `AG AF` and scheduler-specific results. Do not treat graphify reports, generated `_build/` files, or historical zero-caller lists as authoritative source code or proof of safe deletion. diff --git a/_CoqProject b/_CoqProject index dbb2699..d3d6383 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1 +1,2 @@ --Q _build/default/theories TICL \ No newline at end of file +-Q _build/default/theories TICL +-Q _build/default/examples examples diff --git a/examples/CSL/Allocator/Counterexamples.v b/examples/CSL/Allocator/Counterexamples.v index 8e761a6..0e7a816 100644 --- a/examples/CSL/Allocator/Counterexamples.v +++ b/examples/CSL/Allocator/Counterexamples.v @@ -17,7 +17,7 @@ From Stdlib Require Import List Lia Arith.PeanoNat. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace ICTree.Interp.Yield.Execution. From TICL Require Import Utils.Relations Utils.Lists Utils.Execution. @@ -338,7 +338,8 @@ Theorem fair_starvation_exists : exists e, infinitely (fun k => block_event tag_retire 6 (emitted e k)) /\ infinitely (fun k => block_event tag_reclaim 6 (emitted e k)) /\ infinitely (fun k => block_event tag_alloc 6 (emitted e k)) /\ - realizes (fun j => turn_labels (emitted e j)) 0 (run_nd (allocator_program 2) hemp 0). + realizes (fun j => turn_labels (emitted e j)) 0 + (run_nd (allocator_program 2) managed_empty 0). Proof. exists starvation_execution. split; [exact starvation_execution_valid|]. @@ -359,7 +360,7 @@ Theorem starvation_chained_cycle_actual_source : exists last labels residual, Some (last,starve_prefix_logs 0 ++ starve_cycle_logs 6) /\ label_logs labels = starve_prefix_logs 0 ++ starve_cycle_logs 6 /\ label_taus labels = 32 /\ - finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. @@ -595,7 +596,7 @@ Theorem stalled_prefix_source : exists last labels residual, state_equiv last (stalled_boundary 4) /\ label_logs labels = stalled_prefix_logs 0 /\ label_taus labels = 13 /\ - finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. @@ -629,7 +630,8 @@ Theorem owner_stall_prevents_reclamation : exists e, infinitely (fun k => selected e k = Remote1) /\ emitted e 8 = Some (stamp (tag_retire,6) 2) /\ (forall k, ~ block_event tag_reclaim 6 (emitted e k)) /\ - realizes (fun j => turn_labels (emitted e j)) 0 (run_nd (allocator_program 2) hemp 0). + realizes (fun j => turn_labels (emitted e j)) 0 + (run_nd (allocator_program 2) managed_empty 0). Proof. exists owner_stall_execution; split; [exact owner_stall_execution_valid|]. split; [exact stalled_no_owner|]. diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v index da37a4d..c87a028 100644 --- a/examples/CSL/Allocator/Execution.v +++ b/examples/CSL/Allocator/Execution.v @@ -2,11 +2,11 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. From TICL Require Import ICTree.Interp.Yield.Execution. From TICL Require Import Utils.Execution. From Stdlib Require Import Classes.Morphisms. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin Utils.Vectors. -From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Queue.Representation. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model. @@ -87,11 +87,11 @@ Definition source_pool0 base : pool sE 3 := [denote (remote_client base true); denote (remote_client base false); denote (CUntilNone (owner_round base))]%vector. Definition state_agrees (sigma : SSig) (s : AState) : Prop := - heq (fst sigma) (aheap s) /\ snd sigma = acount s. + heq (fst (fst sigma)) (aheap s) /\ snd sigma = acount s. Definition source_reheap (sigma : SSig) (s : AState) : AState := - {| aheap := fst sigma; acount := snd sigma; + {| aheap := fst (fst sigma); acount := snd sigma; owner_state := owner_state s; remote0_state := remote0_state s; remote1_state := remote1_state s |}. @@ -109,13 +109,13 @@ Proof. apply pool_equ_refl. Qed. Lemma interp_rr_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) - first count (K : option unit -> thread sE) m h c : + first count (K : option unit -> thread sE) m h allocs c : (forall offset, Nat.lt offset (2 * count) -> h (first + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (init_links_heap first count h,c). + (Some i) m ((init_links_heap first count h,allocs),c). Proof. revert first h; induction count as [|count IH]; intros first h Allocated. - cbn [init_links init_links_heap]; rewrite interp_rr_ret; reflexivity. @@ -130,13 +130,13 @@ Proof. Qed. Lemma interp_nd_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) - first count (K : option unit -> thread sE) h c : + first count (K : option unit -> thread sE) h allocs c : (forall offset, Nat.lt offset (2 * count) -> h (first + offset)%nat <> None) -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) (h,c) ~ + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) ((h,allocs),c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) (init_links_heap first count h,c). + (Some i) ((init_links_heap first count h,allocs),c). Proof. revert first h; induction count as [|count IH]; intros first h Allocated. - cbn [init_links init_links_heap]; rewrite interp_nd_source_ret; reflexivity. @@ -154,12 +154,12 @@ Qed. five metadata writes and every link write are checked against allocated cells, and the untouched payloads retain the allocation's zeroes. *) Lemma interp_rr_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - base capacity (K : option unit -> thread sE) m h c : + base capacity (K : option unit -> thread sE) m h allocs c : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (init_page base capacity) >>= K)) - (Some i) m (hunion (hblock base (page_size capacity)) h,c) ~ + (Some i) m ((hunion (hblock base (page_size capacity)) h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (page_heap base capacity h,c). + (Some i) m ((page_heap base capacity h,allocs),c). Proof. unfold init_page, page_heap. do 5 (rewrite interp_rr_bind; etransitivity; @@ -174,12 +174,12 @@ Proof. Qed. Lemma interp_nd_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - base capacity (K : option unit -> thread sE) h c : + base capacity (K : option unit -> thread sE) h allocs c : interp_schedule_nd sh (S n) (ts @ i := (denote_flow (init_page base capacity) >>= K)) - (Some i) (hunion (hblock base (page_size capacity)) h,c) ~ + (Some i) ((hunion (hblock base (page_size capacity)) h,allocs),c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) (page_heap base capacity h,c). + (Some i) ((page_heap base capacity h,allocs),c). Proof. unfold init_page, page_heap. do 5 (rewrite interp_nd_source_bind; etransitivity; @@ -194,16 +194,17 @@ Proof. Qed. (** A first-fit equation is separated from the finite-heap existence proof, - so concrete initialized source programs can use a known fresh base. *) + so concrete initialized source programs can use a known fresh base. The + allocation records the page's whole extent in the allocation table. *) Lemma interp_rr_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity base (K : option nat -> thread sE) m h c : + capacity base (K : option nat -> thread sE) m h allocs c : Nat.lt 0 base -> block_free h base (page_size capacity) -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j (page_size capacity)) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some base)) - (Some i) m (page_heap base capacity h,c). + (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),c). Proof. intros Positive Free First. unfold new_page; rewrite interp_rr_bind. @@ -215,14 +216,14 @@ Proof. Qed. Lemma interp_nd_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity base (K : option nat -> thread sE) h c : + capacity base (K : option nat -> thread sE) h allocs c : Nat.lt 0 base -> block_free h base (page_size capacity) -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j (page_size capacity)) -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some base)) - (Some i) (page_heap base capacity h,c). + (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),c). Proof. intros Positive Free First. unfold new_page; rewrite interp_nd_source_bind. @@ -234,7 +235,7 @@ Proof. Qed. Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) m h c : + capacity (K : option nat -> thread sE) m h allocs c : heap_finite h -> exists base, Nat.lt 0 base /\ block_free h base (page_size capacity) /\ @@ -243,12 +244,12 @@ Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) heap_finite (page_heap base capacity h) /\ (forall x, h x <> None -> page_heap base capacity h x = h x) /\ interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some base)) - (Some i) m (page_heap base capacity h,c). + (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),c). Proof. intro Finite. - destruct (heap_handler_alloc_finite h (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h allocs (page_size capacity) c Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -257,7 +258,7 @@ Proof. Qed. Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) h c : + capacity (K : option nat -> thread sE) h allocs c : heap_finite h -> exists base, Nat.lt 0 base /\ block_free h base (page_size capacity) /\ @@ -266,12 +267,12 @@ Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) heap_finite (page_heap base capacity h) /\ (forall x, h x <> None -> page_heap base capacity h x = h x) /\ interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (h,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some base)) - (Some i) (page_heap base capacity h,c). + (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),c). Proof. intro Finite. - destruct (heap_handler_alloc_finite h (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h allocs (page_size capacity) c Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -285,9 +286,9 @@ Qed. Lemma interp_rr_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (K : option nat -> thread sE) m c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (hemp,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (managed_empty,c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) - (Some i) m (page_heap 1 capacity hemp,c). + (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. apply interp_rr_new_page_first. - lia. @@ -298,9 +299,9 @@ Qed. Lemma interp_nd_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) capacity (K : option nat -> thread sE) c : interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (hemp,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (managed_empty,c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some 1)) - (Some i) (page_heap 1 capacity hemp,c). + (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. apply interp_nd_new_page_first. - lia. @@ -317,9 +318,9 @@ Lemma interp_rr_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) page_heap 1 capacity hemp (address 1) = Some value -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some value)) - (Some i) m (page_heap 1 capacity hemp,c). + (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. intro Lookup; rewrite interp_rr_bind, interp_rr_new_page_hemp. apply interp_rr_read_value; exact Lookup. @@ -330,9 +331,9 @@ Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) page_heap 1 capacity hemp (address 1) = Some value -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,c) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some value)) - (Some i) (page_heap 1 capacity hemp,c). + (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. apply interp_nd_source_read_value; exact Lookup. @@ -344,7 +345,7 @@ Lemma interp_rr_new_page_read_missing n page_heap 1 capacity hemp (address 1) = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) m (hemp,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,c) ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp. @@ -357,7 +358,7 @@ Lemma interp_nd_new_page_read_missing n page_heap 1 capacity hemp (address 1) = None -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) (hemp,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,c) ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. @@ -368,67 +369,75 @@ Qed. terminates rather than running the parent's remaining initialization. Parent focus advances twice, but its cursor is unchanged until selection. *) Theorem run_rr_allocator_initialized capacity c : - run_rr (allocator_program capacity) hemp c ~ + run_rr (allocator_program capacity) managed_empty c ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - (page_heap 1 capacity hemp,c). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. unfold run_rr. change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (hemp,c) ~ + (Some Fin.F1) 0 (managed_empty,c) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - (page_heap 1 capacity hemp,c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). unfold allocator_program; rewrite interp_rr_bind, interp_rr_new_page_hemp. rewrite interp_rr_bind, interp_rr_fork. change (interp_schedule_rr sh 2 ([denote (remote_client 1 false); Ret tt]%vector @ Fin.FS Fin.F1 := (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) 0 (page_heap 1 capacity hemp,c) ~ + (Some (Fin.FS Fin.F1)) 0 + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - (page_heap 1 capacity hemp,c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). rewrite interp_rr_bind, interp_rr_fork. change (interp_schedule_rr sh 3 ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector @ Fin.FS (Fin.FS Fin.F1) := (denote_flow (owner 1) >>= fun _ => Ret tt)) - (Some (Fin.FS (Fin.FS Fin.F1))) 0 (page_heap 1 capacity hemp,c) ~ + (Some (Fin.FS (Fin.FS Fin.F1))) 0 + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - (page_heap 1 capacity hemp,c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). unfold owner; rewrite interp_rr_bind, interp_rr_yield; reflexivity. Qed. Theorem run_nd_allocator_initialized capacity c : - run_nd (allocator_program capacity) hemp c ~ - interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c). + run_nd (allocator_program capacity) managed_empty c ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). Proof. unfold run_nd. change (interp_schedule_nd sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) - (Some Fin.F1) (hemp,c) ~ - interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + (Some Fin.F1) (managed_empty,c) ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). unfold allocator_program; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. rewrite interp_nd_source_bind, interp_nd_source_fork. change (interp_schedule_nd sh 2 ([denote (remote_client 1 false); Ret tt]%vector @ Fin.FS Fin.F1 := (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) >>= fun _ => Ret tt)) - (Some (Fin.FS Fin.F1)) (page_heap 1 capacity hemp,c) ~ - interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + (Some (Fin.FS Fin.F1)) + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). rewrite interp_nd_source_bind, interp_nd_source_fork. change (interp_schedule_nd sh 3 ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector @ Fin.FS (Fin.FS Fin.F1) := (denote_flow (owner 1) >>= fun _ => Ret tt)) - (Some (Fin.FS (Fin.FS Fin.F1))) (page_heap 1 capacity hemp,c) ~ - interp_schedule_nd sh 3 (source_pool0 1) None (page_heap 1 capacity hemp,c)). + (Some (Fin.FS (Fin.FS Fin.F1))) + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). unfold owner; rewrite interp_nd_source_bind, interp_nd_source_yield; reflexivity. Qed. From Stdlib Require Import List Program.Equality Classes.RelationClasses. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin @@ -532,11 +541,14 @@ Ltac allocator_segment_steps := heap extensionality, freshness assumption, or unchecked CAS is used here. *) Local Opaque denote_flow ICtree.iter ICtree.bind. -Lemma turn_source_exact_segment base who s t event : +(** Every allocator round accesses linked-list cells only (read/write/CAS, + emit, yield), so an arbitrary allocation table [allocs] is carried through + the segment unchanged. *) +Lemma turn_source_exact_segment base who s t event allocs : turn base who s = Some (t,event) -> exists residual, (ThreadSegment sh csl_equ) ((allocator_pool base s) $ slot_of_actor who) - (aheap s,acount s) (event_obs event) residual (aheap t,acount t) /\ + ((aheap s,allocs),acount s) (event_obs event) residual ((aheap t,allocs),acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. destruct s as [h c op r0 r1]; destruct who; @@ -615,13 +627,13 @@ Proof. pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. destruct (step_some_compatible (turn base) state_equiv (turn_proper base) who s (source_reheap sigma s) s' event Hreheap Hturn) as (actual & Hactual & Hnext). + destruct sigma as [[h allocs] c]. destruct (turn_source_exact_segment base who - (source_reheap sigma s) actual event Hactual) + (source_reheap ((h,allocs),c) s) actual event allocs Hactual) as (residual & Hseg & Htail). - destruct sigma as [h c]. cbn [source_reheap aheap acount owner_state remote0_state remote1_state allocator_pool fst snd] in Hseg, Htail |- *. - exists residual, (aheap actual,acount actual). + exists residual, ((aheap actual,allocs),acount actual). split; [exact Hseg |]. split. + destruct Hnext as [Hheap [Hcount _]]. @@ -633,7 +645,7 @@ Proof. (slot_of_actor who)). * intros j Hj. etransitivity; - [exact (turn_other_slots base who (source_reheap (h,c) s) actual event + [exact (turn_other_slots base who (source_reheap ((h,allocs),c) s) actual event Hactual j Hj) |]. symmetry; exact (allocator_pool_state_equiv base s' actual Hnext j). Qed. @@ -654,48 +666,49 @@ Qed. (** Each equation encompasses every branch of the phase table. The result retains the actual residual at None focus: guard_equ is not silently promoted to an unfocused-pool congruence. At the canonical state the - handler state after the turn is EXACTLY the model's heap and counter. *) -Theorem turn_interp_nd base capacity who s t event : + handler state after the turn is EXACTLY the model's heap and counter, + with the allocation table unchanged. *) +Theorem turn_interp_nd base capacity who s t event allocs : allocator_inv base capacity s -> turn base who s = Some (t,event) -> exists residual, guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_nd sh 3 (allocator_pool base s) (Some (slot_of_actor who)) - (aheap s,acount s) ~ + ((aheap s,allocs),acount s) ~ emit_list (event_obs event) (interp_schedule_nd sh 3 (allocator_pool base t @ slot_of_actor who := residual) - None (aheap t,acount t)). + None ((aheap t,allocs),acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_exact_segment base who s t event Hturn) + destruct (turn_source_exact_segment base who s t event allocs Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) (aheap s,acount s) - (event_obs event) residual (aheap t,acount t) Hseg). + 2 (allocator_pool base s) (slot_of_actor who) ((aheap s,allocs),acount s) + (event_obs event) residual ((aheap t,allocs),acount t) Hseg). - apply emit_list_sbisim, equ_sbisim, (interp_schedule_nd_equ sh). exact (source_replace_turn base who s t event residual Hturn). Qed. -Theorem turn_interp_rr base capacity who s t event cursor : +Theorem turn_interp_rr base capacity who s t event allocs cursor : allocator_inv base capacity s -> turn base who s = Some (t,event) -> exists residual, guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_rr sh 3 (allocator_pool base s) (Some (slot_of_actor who)) - cursor (aheap s,acount s) ~ + cursor ((aheap s,allocs),acount s) ~ emit_list (event_obs event) (interp_schedule_rr sh 3 (allocator_pool base t @ slot_of_actor who := residual) - None cursor (aheap t,acount t)). + None cursor ((aheap t,allocs),acount t)). Proof. intros Hinv Hturn. - destruct (turn_source_exact_segment base who s t event Hturn) + destruct (turn_source_exact_segment base who s t event allocs Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) cursor (aheap s,acount s) - (event_obs event) residual (aheap t,acount t) Hseg). + 2 (allocator_pool base s) (slot_of_actor who) cursor ((aheap s,allocs),acount s) + (event_obs event) residual ((aheap t,allocs),acount t) Hseg). - apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. exact (source_replace_turn base who s t event residual Hturn). Qed. @@ -751,52 +764,55 @@ Qed. From Coinduction Require Import coinduction rel tactics. Local Open Scope nat_scope. -Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event : +Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event allocs : pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> exists residual, - (ThreadSegment sh csl_equ) (ts $ slot_of_actor who) (aheap s,acount s) - (event_obs event) residual (aheap t,acount t) /\ + (ThreadSegment sh csl_equ) (ts $ slot_of_actor who) ((aheap s,allocs),acount s) + (event_obs event) residual ((aheap t,allocs),acount t) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hturn. - destruct (turn_source_exact_segment base who s t event Hturn) as (residual & Hseg & Htail). + destruct (turn_source_exact_segment base who s t event allocs Hturn) + as (residual & Hseg & Htail). exists residual; split; [|exact Htail]. apply (proj2 ((guard_equ_segment_iff sh csl_equ) (ts $ slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) - (Hpool (slot_of_actor who)) (aheap s,acount s) (event_obs event) - residual (aheap t,acount t))); exact Hseg. + (Hpool (slot_of_actor who)) ((aheap s,allocs),acount s) (event_obs event) + residual ((aheap t,allocs),acount t))); exact Hseg. Qed. Theorem run_rr_allocator_bisim capacity c : - run_rr (allocator_program capacity) hemp c ~ + run_rr (allocator_program capacity) managed_empty c ~ (model_rr 2 actor_of_slot (turn 1) (initial_state capacity c) 0 : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_allocator_initialized. exact (pool_simulation_rr_bisim actor_of_slot slot_of_actor_of_slot (allocator_simulation 1 capacity) - (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) 0 + (initial_state capacity c) (source_pool0 1) + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) 0 (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). Qed. Theorem run_nd_allocator_bisim capacity c : - run_nd (allocator_program capacity) hemp c ~ + run_nd (allocator_program capacity) managed_empty c ~ (model_nd 2 actor_of_slot (turn 1) (initial_state capacity c) : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. rewrite run_nd_allocator_initialized. exact (pool_simulation_nd_bisim actor_of_slot slot_of_actor_of_slot (allocator_simulation 1 capacity) - (initial_state capacity c) (source_pool0 1) (page_heap 1 capacity hemp,c) + (initial_state capacity c) (source_pool0 1) + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). Qed. (** The one program-specific validity entry point for raw source executions: the library's pool validity at the allocator handler, slot map, initial - source pool, and initialized page. *) + source pool, and initialized page with its recorded extent. *) Definition allocator_source_valid (capacity c : nat) (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) : Prop := pool_execution_valid 2 sh slot_of_actor - (source_pool0 1) (page_heap 1 capacity hemp,c) se. + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) se. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v index 6df4604..401c3ac 100644 --- a/examples/CSL/Allocator/Liveness.v +++ b/examples/CSL/Allocator/Liveness.v @@ -1,7 +1,7 @@ From Stdlib Require Import List Lia Arith.PeanoNat. From TICL Require Import ICTree.Interp.Yield.Execution. From TICL Require Import Utils.Execution. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield ICTree.Logic.Trace Utils.Relations. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Program CSL.Allocator.Model CSL.Allocator.Execution. @@ -44,8 +44,8 @@ Proof. Qed. From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL. -From TICL Require Import Lang.CSL.Queue.Representation. +From TICL Require Import Lang.CSL.Mod. +From examples Require Import CSL.Queue.Representation. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Model. Import ListNotations. @@ -335,7 +335,7 @@ Proof. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Program.Equality. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Refine Utils.Vectors. @@ -366,7 +366,8 @@ Qed. an infinite schedule is supplied: every physical slot remains selectable. *) Theorem every_reachable_source_slot_yields capacity c ts sigma (i : Fin.t 3) : reachable (pool_step 2 sh slot_of_actor) - (fun p => pool_equ (fst p) (source_pool0 1) /\ snd p = (page_heap 1 capacity hemp,c)) + (fun p => pool_equ (fst p) (source_pool0 1) /\ + snd p = ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)) (ts,sigma) -> BranchFree (ts $ i) /\ (exists logs residual sigma', (ThreadSegment sh csl_sb) (ts $ i) sigma logs residual sigma') /\ @@ -387,7 +388,8 @@ Proof. Hstep H). } split; [apply Hbf|]. destruct (pool_simulation_reachable (allocator_simulation 1 capacity) - (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (initial_state capacity c) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) ts sigma Hreach) as (s & Hinv & Hagree & Hpool). @@ -413,7 +415,7 @@ Qed. Theorem valid_execution_realizes_source capacity c e : allocator_valid capacity c e -> realizes (fun j => turn_labels (emitted e j)) 0 - (run_nd (allocator_program capacity) hemp c). + (run_nd (allocator_program capacity) managed_empty c). Proof. intro Hvalid. apply (valid_execution_realizes_model 2 actor_of_slot (turn 1) slot_of_actor @@ -429,7 +431,7 @@ Theorem run_turns_realizes_source capacity c script last logs : option_map snd (run_turns (turn 1) turn_labels script (initial_state capacity c)) = Some labels /\ label_logs labels = logs /\ label_taus labels = List.length script /\ - finite_steps (run_nd (allocator_program capacity) hemp c) labels residual /\ + finite_steps (run_nd (allocator_program capacity) managed_empty c) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. @@ -529,7 +531,8 @@ Proof. assert (Hmodel : allocator_valid capacity c (allocator_execution capacity c (selected se))) by apply execution_of_choices_valid. destruct (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se (allocator_execution capacity c (selected se)) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (initial_state capacity c) se (allocator_execution capacity c (selected se)) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel (execution_of_choices_selected _ _ _ _ _ _ (selected se)) k) @@ -550,7 +553,8 @@ Proof. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. pose proof (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. @@ -566,8 +570,8 @@ Proof. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. -From TICL Require Import Lang.CSL. -From TICL Require Import Lang.CSL.Queue.Representation. +From TICL Require Import Lang.CSL.Mod. +From examples Require Import CSL.Queue.Representation. From examples Require Import CSL.Allocator.Layout CSL.Allocator.Model CSL.Allocator.Execution. Import ListNotations. @@ -1046,7 +1050,8 @@ Proof. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. pose proof (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) (page_heap 1 capacity hemp,c) (initial_state capacity c) se e + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. @@ -1066,7 +1071,7 @@ Qed. From Stdlib Require Import List Lia Arith.PeanoNat. From Coinduction Require Import coinduction rel tactics. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Eq.Bind ICTree.Logic.AF ICTree.Logic.AG ICTree.Logic.AX ICTree.Logic.Bind ICTree.Logic.Iter ICTree.Logic.State ICTree.Logic.Trace ICTree.Logic.Yield Logic.Core. @@ -1161,7 +1166,7 @@ Proof. intros n _; unfold demo_cycle_logs; discriminate. Qed. (** The actual source is the 57-turn prefix followed by the repeating cycle, each cycle a genuine 42-turn round-robin run from the actual state. *) Theorem run_rr_allocator_demo_bisim c : - run_rr (allocator_program 2) hemp c ~ + run_rr (allocator_program 2) managed_empty c ~ emit_list (demo_prefix c) (emit_batches demo_cycle_logs (fun n => n+7) (c+9) : ictreeW (indexed (nat * nat)) (unit * SSig)). @@ -1184,7 +1189,7 @@ Qed. predicates, but this proof must not claim recurrence of arbitrary tags. *) Theorem allocator_demo_agaf_fresh c kind kb : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> - <( {run_rr (allocator_program 2) hemp c}, Pure + <( {run_rr (allocator_program 2) managed_empty c}, Pure |= AG (AF visW {fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o}) )>. Proof. intro Hkind. @@ -1268,7 +1273,7 @@ Theorem aba_actual_source_no_loss : exists last labels residual, allocator_inv 1 2 last /\ aheap last (remote_head 1) = Some 8 /\ linked (fun a next => aheap last a = Some next) [8;6] 0 /\ label_logs labels = aba_logs /\ label_taus labels = 23 /\ - finite_steps (run_nd (allocator_program 2) hemp 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v index fd841ee..d562e97 100644 --- a/examples/CSL/Allocator/Model.v +++ b/examples/CSL/Allocator/Model.v @@ -1,9 +1,9 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Sorting.Permutation. From TICL Require Import Utils.Execution. From TICL Require Import ICTree.Interp.Yield.Execution. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.Refine. -From TICL Require Import Lang.CSL.Queue.Representation. +From examples Require Import CSL.Queue.Representation. From examples Require Import CSL.Allocator.Layout. Import ICtree ICTreeNotations ListNotations. @@ -233,7 +233,7 @@ From Stdlib Require Import List Lia Arith.PeanoNat Fin Classes.RelationClasses Classes.RelationPairs Program.Equality. From ExtLib Require Import Data.Option. From Coinduction Require Import coinduction rel tactics. -From TICL Require Import Lang.CSL ICTree.Core ICTree.Equ ICTree.SBisim +From TICL Require Import Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Interp.Refine. Import ICtree ICTreeNotations ListNotations. @@ -334,8 +334,8 @@ Proof. Qed. From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. -From TICL Require Import Lang.CSL. -From TICL Require Import Lang.CSL.Queue.Representation. +From TICL Require Import Lang.CSL.Mod. +From examples Require Import CSL.Queue.Representation. From examples Require Import CSL.Allocator.Layout. Import ListNotations. diff --git a/examples/CSL/Allocator/Program.v b/examples/CSL/Allocator/Program.v index 9854ed7..c641104 100644 --- a/examples/CSL/Allocator/Program.v +++ b/examples/CSL/Allocator/Program.v @@ -1,5 +1,5 @@ From Stdlib Require Import Arith.PeanoNat. -From TICL Require Import Lang.CSL.Syntax. +From TICL Require Import Lang.CSL.Mod. From examples Require Import CSL.Allocator.Layout. (* Link-first remote frees and owner collection, scoped from mimalloc v2.5.2: diff --git a/examples/CSL/Memory.v b/examples/CSL/Memory.v new file mode 100644 index 0000000..2e5e19b --- /dev/null +++ b/examples/CSL/Memory.v @@ -0,0 +1,238 @@ +(** * Malloc/free lifecycle of the canonical CSL language. + + Concrete single-thread programs run through the real round-robin + interpreter. They pin the observable allocation discipline: first-fit + zero-initialized malloc with recorded extents, whole-block free, reuse of a + released block, the null-free no-op, and faults on interior-pointer, + double, and use-after-free accesses. *) + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin Lang.CSL.Mod Utils.Vectors. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +(** ** Fixtures *) + +Definition lifecycle : CProg unit := + CBind (CAlloc 3) (fun first => + CBind (CAlloc 2) (fun second => + CBind (CWrite first 7) (fun _ => + CBind (CWrite (first + 2) 9) (fun _ => + CBind (CWrite second 11) (fun _ => + CBind (CCAS first 7 8) (fun succeeded => + CBind (CCAS first 7 99) (fun failed => + CBind (CEmit 80 (if succeeded then 1 else 0)) (fun _ => + CBind (CEmit 81 (if failed then 1 else 0)) (fun _ => + CBind (CFree first) (fun _ => + CBind (CRead second) (fun value => + CBind (CEmit 82 value) (fun _ => CRet tt)))))))))))). + +Definition reallocate : CProg unit := + CBind (CAlloc 3) (fun first => + CBind (CFree first) (fun _ => + CBind (CAlloc 3) (fun next => + CBind (CEmit 83 next) (fun _ => CRet tt)))). + +Definition invalid_interior : CProg unit := + CBind (CAlloc 3) (fun base => CFree (S base)). + +Definition invalid_double : CProg unit := + CBind (CAlloc 3) (fun base => + CBind (CFree base) (fun _ => CFree base)). + +Definition use_after_free_read : CProg unit := + CBind (CAlloc 3) (fun base => + CBind (CFree base) (fun _ => + CBind (CRead (base + 2)) (fun _ => CRet tt))). + +Definition use_after_free_write : CProg unit := + CBind (CAlloc 3) (fun base => + CBind (CFree base) (fun _ => CWrite (base + 2) 17)). + +Definition use_after_free_cas : CProg unit := + CBind (CAlloc 3) (fun base => + CBind (CFree base) (fun _ => + CBind (CCAS (base + 2) 0 17) (fun _ => CRet tt))). + +(** ** Driving the single-thread round-robin run + + Each step applies one source execution rule of [Lang.CSL.Mod] at the + focused thread; concrete heap facts are discharged by computation. *) + +Lemma run_rr_focus p memory c : + run_rr p memory c ≅ + interp_schedule_rr sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := (denote_flow p >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (memory,c). +Proof. reflexivity. Qed. + +Ltac first_fit := + let j := fresh "j" in + let Pos := fresh "Pos" in + let Lt := fresh "Lt" in + let Free := fresh "Free" in + intros j Pos Lt Free; apply block_freeb_spec in Free; + repeat (lia || (destruct j as [|j]; + [solve [lia | vm_compute in Free; discriminate] |])). + +Ltac block_is_free := apply block_freeb_spec; vm_compute; reflexivity. + +Ltac rr_step := + cbn beta iota zeta; + lazymatch goal with + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CBind _ _) >>= _)) _ _ _ ~ _ => + rewrite interp_rr_bind + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CRet _) >>= _)) _ _ _ ~ _ => + rewrite interp_rr_ret + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CWrite _ _) >>= _)) _ _ _ ~ _ => + rewrite interp_rr_write_present by (vm_compute; congruence) + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CRead _) >>= _)) _ _ _ ~ _ => + erewrite interp_rr_read_value by reflexivity + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CCAS _ _ _) >>= _)) _ _ _ ~ _ => + erewrite interp_rr_cas_value by reflexivity; cbn [Nat.eqb] + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CFree _) >>= _)) _ _ _ ~ _ => + erewrite interp_rr_free by reflexivity + | |- interp_schedule_rr _ _ (_ @ _ := (denote_flow (CEmit _ _) >>= _)) _ _ _ ~ _ => + rewrite interp_rr_emit_log + end. + +(** Allocation chooses its first-fit base explicitly. *) +Ltac rr_alloc base := + cbn beta iota zeta; try unfold managed_empty; + rewrite (interp_rr_alloc_first _ _ _ _ base) by + (first [lia | block_is_free | first_fit]); + unfold managed_alloc, managed_empty; cbn [fst snd]. + +Ltac rr_finish := + cbn beta iota zeta; + rewrite interp_schedule_rr_ret by reflexivity; + lazymatch goal with + | |- interp_schedule_rr _ _ (?v -- _) _ _ _ ~ _ => + let v' := eval cbn in v in change v with v' + end; + rewrite vector_remove_head; + apply interp_schedule_rr_empty. + +(** ** Behavior *) + +(** Both CAS outcomes, the adjacent allocation, release of the whole first + extent, and the observation stamps. *) +Theorem lifecycle_scope : + exists memory : ManagedHeap, + run_rr lifecycle managed_empty 0 ~ + emit_list [stamp (80,1) 0; stamp (81,0) 1; stamp (82,11) 2]%list + (Ret (tt,(memory,3))) /\ + fst memory 1 = None /\ fst memory 2 = None /\ fst memory 3 = None /\ + fst memory 4 = Some 11 /\ fst memory 5 = Some 0 /\ + snd memory 1 = None /\ snd memory 4 = Some 2. +Proof. + eexists; split. + - rewrite run_rr_focus; unfold lifecycle. + rr_step; rr_alloc 1. + rr_step; rr_alloc 4. + (* three checked writes, then both CAS outcomes *) + do 6 rr_step. + do 4 rr_step. + unfold emit_list; cbn [List.fold_right]. + rr_step; rr_step. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + rr_step; rr_step. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + (* free the first block, read the adjacent one, emit it *) + do 6 rr_step. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + rr_step. + rr_finish. + - repeat split; vm_compute; reflexivity. +Qed. + +(** A released block is reused by the next first-fit malloc, with its whole + extent recorded and zero-initialized again. *) +Theorem reuse_first_fit : + exists memory : ManagedHeap, + run_rr reallocate managed_empty 0 ~ + emit_list [stamp (83,1) 0]%list (Ret (tt,(memory,1))) /\ + snd memory 1 = Some 3 /\ + fst memory 1 = Some 0 /\ fst memory 2 = Some 0 /\ fst memory 3 = Some 0. +Proof. + eexists; split. + - rewrite run_rr_focus; unfold reallocate. + rr_step; rr_alloc 1. + rr_step; rr_step. + rr_step; rr_alloc 1. + unfold emit_list; cbn [List.fold_right]. + rr_step; rr_step. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + rr_step. + rr_finish. + - repeat split; vm_compute; reflexivity. +Qed. + +(** Freeing null leaves every component of the state unchanged. *) +Theorem free_null_unchanged (memory : ManagedHeap) c : + run_rr (CFree 0) memory c ~ Ret (tt,(memory,c)). +Proof. + rewrite run_rr_focus. + rewrite (interp_rr_free _ _ _ 0 _ _ memory memory c eq_refl). + rr_finish. +Qed. + +(** ** Faults *) + +Theorem invalid_interior_stuck : + run_rr invalid_interior managed_empty 0 ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_focus; unfold invalid_interior. + rr_step; rr_alloc 1. + cbn beta iota zeta. + apply interp_rr_free_invalid; vm_compute; reflexivity. +Qed. + +Theorem invalid_double_stuck : + run_rr invalid_double managed_empty 0 ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_focus; unfold invalid_double. + rr_step; rr_alloc 1. + rr_step; rr_step. + cbn beta iota zeta. + apply interp_rr_free_invalid; vm_compute; reflexivity. +Qed. + +Theorem use_after_free_read_stuck : + run_rr use_after_free_read managed_empty 0 ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_focus; unfold use_after_free_read. + rr_step; rr_alloc 1. + rr_step; rr_step. + rr_step; cbn beta iota zeta. + apply interp_rr_read_missing; vm_compute; reflexivity. +Qed. + +Theorem use_after_free_write_stuck : + run_rr use_after_free_write managed_empty 0 ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_focus; unfold use_after_free_write. + rr_step; rr_alloc 1. + rr_step; rr_step. + cbn beta iota zeta. + apply interp_rr_write_missing; vm_compute; reflexivity. +Qed. + +Theorem use_after_free_cas_stuck : + run_rr use_after_free_cas managed_empty 0 ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_focus; unfold use_after_free_cas. + rr_step; rr_alloc 1. + rr_step; rr_step. + rr_step; cbn beta iota zeta. + apply interp_rr_cas_missing; vm_compute; reflexivity. +Qed. diff --git a/examples/CSL/Overlap.v b/examples/CSL/Overlap.v index cd43d45..98b5052 100644 --- a/examples/CSL/Overlap.v +++ b/examples/CSL/Overlap.v @@ -21,8 +21,8 @@ From Stdlib Require Import Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace - Lang.CSL.Queue.Frame Lang.CSL.Queue.Layout. +From examples Require Import CSL.Queue.Representation CSL.Queue.Trace + CSL.Queue.Frame CSL.Queue.Layout. Import ListNotations. Local Open Scope list_scope. diff --git a/examples/CSL/Queue.v b/examples/CSL/Queue.v new file mode 100644 index 0000000..c8f6f0b --- /dev/null +++ b/examples/CSL/Queue.v @@ -0,0 +1,6 @@ +From TICL Require Export Lang.CSL.Mod. +From examples Require Export + CSL.Queue.Representation CSL.Queue.Layout CSL.Queue.Operations + CSL.Queue.Sequential CSL.Queue.Recurrence CSL.Queue.Trace + CSL.Queue.Frame CSL.Queue.Separation CSL.Queue.Alternating + CSL.Queue.Composition CSL.Queue.Program CSL.Queue.Ticl. diff --git a/theories/Lang/CSL/Queue/Alternating.v b/examples/CSL/Queue/Alternating.v similarity index 81% rename from theories/Lang/CSL/Queue/Alternating.v rename to examples/CSL/Queue/Alternating.v index 3dc59e3..e20a4b1 100644 --- a/theories/Lang/CSL/Queue/Alternating.v +++ b/examples/CSL/Queue/Alternating.v @@ -24,8 +24,8 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Export Lang.CSL.Heap. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Operations. +From TICL Require Export ICTree.Interp.CSL.Mod. +From examples Require Import CSL.Queue.Representation CSL.Queue.Operations. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -49,13 +49,13 @@ Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). Instantiate [Operations.queue_turn_spec] with tagged observations. The arbitrary tail reuses the same heap operation proof as sequential rotation. *) -Theorem turnk_spec {X}: forall q hdr a ns pv vs h c (kt: ictree sE X), +Theorem turnk_spec {X}: forall q hdr a ns pv vs h allocs c (kt: ictree sE X), qrep hdr (a :: ns) (pv :: vs) h -> - interp_state sh (turnk q hdr kt) (h, c) + interp_state sh (turnk q hdr kt) ((h, allocs), c) ~ (log (stamp (q,pv) c) ;; - interp_state sh kt (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c)). + interp_state sh kt ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c)). Proof. - intros q hdr a ns pv vs h c kt Hq; unfold turnk. + intros q hdr a ns pv vs h allocs c kt Hq; unfold turnk. eapply (queue_turn_spec h_indexed (semit q) (fun value index => stamp (q,value) index)). - intros; unfold semit; apply (interp_indexed_emit heap_handler). @@ -78,27 +78,29 @@ Definition sbody (u v: nat) (n: nat) : ictree sE (nat + unit) := Definition sched (u v n: nat) : ictree sE unit := ICtree.iter (sbody u v) n. -Definition srun (u v n: nat) (h: Heap) (c: nat) : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_state sh (sched u v n) (h, c). +Definition srun (u v n: nat) (memory: ManagedHeap) (c: nat) + : ictreeW (indexed (nat * nat)) (unit * SSig) := + interp_state sh (sched u v n) (memory, c). (** One scheduler turn, for EITHER phase, in one statement. [hdrof]/[tagof] are what let the phase case analysis happen once, in the temporal proof, rather than twice in the language layer. *) -Theorem sbody_spec: forall u v n a ns pv vs h c, +Theorem sbody_spec: forall u v n a ns pv vs h allocs c, qrep (hdrof u v n) (a :: ns) (pv :: vs) h -> - interp_state sh (sbody u v n) (h, c) + interp_state sh (sbody u v n) ((h, allocs), c) ~ (log (stamp ((tagof n),pv) c) ;; Ret (@inl nat unit (S n), - (rot_heap (hdrof u v n) a (List.hd 0 ns) (zof (hdrof u v n) ns) h, S c))). + ((rot_heap (hdrof u v n) a (List.hd 0 ns) (zof (hdrof u v n) ns) h, allocs), + S c))). Proof. - intros u v n a ns pv vs h c Hq. + intros u v n a ns pv vs h allocs c Hq. unfold sbody, hdrof, tagof in *. destruct (Nat.even n). - - rewrite (turnk_spec 1 u a ns pv vs h c + - rewrite (turnk_spec 1 u a ns pv vs h allocs c (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_state_ret; reflexivity. - - rewrite (turnk_spec 2 v a ns pv vs h c + - rewrite (turnk_spec 2 v a ns pv vs h allocs c (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_state_ret; reflexivity. @@ -144,10 +146,10 @@ Proof. apply queue_turn_equ; symmetry; apply bind_ret_l. Qed. -Lemma srun_turn u v n h c : - srun u v n h c ~ - (interp_state sh (turn (tagof n) (hdrof u v n)) (h,c) >>= - fun '(_, (h',c')) => srun u v (S n) h' c'). +Lemma srun_turn u v n memory c : + srun u v n memory c ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) (memory,c) >>= + fun '(_, (memory',c')) => srun u v (S n) memory' c'). Proof. unfold srun, sched. rewrite interp_state_unfold_iter. diff --git a/theories/Lang/CSL/Queue/Composition.v b/examples/CSL/Queue/Composition.v similarity index 85% rename from theories/Lang/CSL/Queue/Composition.v rename to examples/CSL/Queue/Composition.v index 6976317..dc192b8 100644 --- a/theories/Lang/CSL/Queue/Composition.v +++ b/examples/CSL/Queue/Composition.v @@ -51,10 +51,11 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Import - Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace Lang.CSL.Queue.Layout - Lang.CSL.Queue.Frame Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Separation - Lang.CSL.Queue.Alternating Utils.Relations. +From examples Require Import + CSL.Queue.Representation CSL.Queue.Trace CSL.Queue.Layout + CSL.Queue.Frame CSL.Queue.Recurrence CSL.Queue.Separation + CSL.Queue.Alternating. +From TICL Require Import Utils.Relations. From Coinduction Require Import coinduction. @@ -155,7 +156,7 @@ Section Composition. Definition Ig (nlf nlg kb: nat) (m: nat * (nat * nat)) (n: nat) (s: SSig) : Prop := exists nsf vsf nsg vsg df dg, - qrep fh nsf vsf (fst s) /\ qrep gh nsg vsg (fst s) /\ Disj fh nsf gh nsg + qrep fh nsf vsf (fst (fst s)) /\ qrep gh nsg vsg (fst (fst s)) /\ Disj fh nsf gh nsg /\ find_index Nat.eqb nlf vsf = Some df /\ find_index Nat.eqb nlg vsg = Some dg /\ m = (kb - snd s, (df, if fturn n then 0 else 1)). @@ -165,28 +166,28 @@ Section Composition. Context (nlf nlg kb: nat) (P: (indexed (nat * nat)) -> Prop) (HP: forall j, Nat.le kb j -> P (stamp (fq,nlf) j)). - Lemma inner_af: forall n h c w, + Lemma inner_af: forall n h allocs c w, not_done w -> Iq nlf nlg h -> - <( {interp_state sh (sched u v n) (h, c)}, w |= AF visW {P} )>. + <( {interp_state sh (sched u v n) ((h, allocs), c)}, w |= AF visW {P} )>. Proof. - intros n h c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). + intros n h allocs c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). unfold sched. apply (aul_state_iter_ghost sh rank3 (Ig nlf nlg kb) (sbody u v) _ _ - rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n (h, c) w Hd). + rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n ((h, allocs), c) w Hd). - exists nsf, vsf, nsg, vsg, df, dg; cbn. split; [exact Hqf |]; split; [exact Hqg |]; split; [exact Hdj |]; split; [exact Hff |]; split; [exact Hfg | reflexivity]. - - clear n h c w Hd nsf vsf nsg vsg df dg Hqf Hqg Hdj Hff Hfg. + - clear n h allocs c w Hd nsf vsf nsg vsg df dg Hqf Hqg Hdj Hff Hfg. intros m n s w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg & Hm). - destruct s as (h, c); cbn in Hqf, Hqg, Hm. + destruct s as ((h, allocs), c); cbn in Hqf, Hqg, Hm. destruct (fturn n) eqn:Eph. + (* --- the FOCUSED queue's turn --- *) destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. destruct nsf as [| a nsf']; [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. - pose proof (sbody_spec u v n a nsf' pv vsf' h c) as Hspec. + pose proof (sbody_spec u v n a nsf' pv vsf' h allocs c) as Hspec. rewrite (Hfh n Eph), (Hft n Eph) in Hspec. specialize (Hspec Hqf). destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) @@ -196,13 +197,13 @@ Section Composition. rank3 (kb - S c, (df', 1)) m -> (exists g' i' s' w', not_done w' - /\ <[ {interp_state sh ((sbody u v) n) (h, c)}, w + /\ <[ {interp_state sh ((sbody u v) n) ((h, allocs), c)}, w |= ⊤ AU AX done= {(@inl nat unit i', s')} w' ]> /\ Ig nlf nlg kb g' i' s' /\ rank3 g' m)). { intros df' Hdf' Hlex. exists (kb - S c, (df', 1)), (S n), - (rot_heap fh a (List.hd 0 nsf') (zof fh nsf') h, S c), + ((rot_heap fh a (List.hd 0 nsf') (zof fh nsf') h, allocs), S c), (Obs (Log (stamp (fq,pv) c)) tt). split; [constructor |]. split. @@ -240,7 +241,7 @@ Section Composition. destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. destruct nsg as [| b nsg']; [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. - pose proof (sbody_spec u v n b nsg' pw vsg' h c) as Hspec. + pose proof (sbody_spec u v n b nsg' pw vsg' h allocs c) as Hspec. rewrite (Hgh n Eph) in Hspec. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) @@ -249,7 +250,7 @@ Section Composition. rewrite rotl_cons in Hdg'. right. exists (kb - S c, (df, 0)), (S n), - (rot_heap gh b (List.hd 0 nsg') (zof gh nsg') h, S c), + ((rot_heap gh b (List.hd 0 nsg') (zof gh nsg') h, allocs), S c), (Obs (Log (stamp ((tagof n),pw) c)) tt). split; [constructor |]. split. @@ -268,19 +269,20 @@ Section Composition. Qed. (** ** The recurrence theorem for the focused queue *) - Theorem sched_agaf: forall n h c w, + Theorem sched_agaf: forall n h allocs c w, not_done w -> Iq nlf nlg h -> - <( {interp_state sh (sched u v n) (h, c)}, w |= AG (AF visW {P}) )>. + <( {interp_state sh (sched u v n) ((h, allocs), c)}, w |= AG (AF visW {P}) )>. Proof. - intros n h c w Hd HI. + intros n h allocs c w Hd HI. unfold sched. - apply (ag_state_iter sh (h, c) - (fun (_: nat) (s: SSig) (_: WorldW (indexed (nat * nat))) => Iq nlf nlg (fst s)) + apply (ag_state_iter sh ((h, allocs), c) + (fun (_: nat) (s: SSig) (_: WorldW (indexed (nat * nat))) => + Iq nlf nlg (fst (fst s))) n w); [assumption | exact HI |]. - clear n h c w Hd HI. + clear n h allocs c w Hd HI. intros n s w Hd HI. - destruct s as (h, c); cbn in HI. + destruct s as ((h, allocs), c); cbn in HI. split; [now apply inner_af |]. destruct HI as (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). @@ -289,7 +291,7 @@ Section Composition. destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. destruct nsf as [| a nsf']; [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. - pose proof (sbody_spec u v n a nsf' pv vsf' h c) as Hspec. + pose proof (sbody_spec u v n a nsf' pv vsf' h allocs c) as Hspec. rewrite (Hfh n Eph), (Hft n Eph) in Hspec. specialize (Hspec Hqf). destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) @@ -308,7 +310,7 @@ Section Composition. destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. destruct nsg as [| b nsg']; [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. - pose proof (sbody_spec u v n b nsg' pw vsg' h c) as Hspec. + pose proof (sbody_spec u v n b nsg' pw vsg' h allocs c) as Hspec. rewrite (Hgh n Eph) in Hspec. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) @@ -338,38 +340,40 @@ End Composition. Theorem sched_agaf_q1_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), (forall j, Nat.le kb j -> P (stamp (1,nl1) j)) -> - forall n h c ns1 vs1 ns2 vs2 d1 d2, + forall n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. + <( {srun u v n (h, allocs) c}, Pure |= AG (AF visW {P}) )>. Proof. - intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + intros u v nl1 nl2 kb P HP n h allocs c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. unfold srun. apply (sched_agaf u v 1 u v Nat.even (fun n H => hdrof_even u v n H) (fun n H => hdrof_odd u v n H) (fun n H => tagof_even n H) - even_flip nl1 nl2 kb P HP n h c Pure); + even_flip nl1 nl2 kb P HP n h allocs c Pure); [constructor |]. exists ns1, vs1, ns2, vs2, d1, d2. split; [exact Hq1 |]; split; [exact Hq2 |]; split; [exact Hdj |]; split; [exact Hf1 | exact Hf2]. Qed. -Theorem sched_agaf_q1: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q1: forall u v nl1 nl2 n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. + <( {srun u v n (h, allocs) c}, Pure + |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros. eapply (sched_agaf_q1_gen u v nl1 nl2 0 ((fun o => indexed_value o = (1,nl1)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. -Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. + <( {srun u v n (h, allocs) c}, Pure + |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros. eapply (sched_agaf_q1_gen u v nl1 nl2 k ((indexed_after (fun x => x = (1,nl1)) k))); @@ -381,38 +385,40 @@ Qed. Theorem sched_agaf_q2_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), (forall j, Nat.le kb j -> P (stamp (2,nl2) j)) -> - forall n h c ns1 vs1 ns2 vs2 d1 d2, + forall n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {P}) )>. + <( {srun u v n (h, allocs) c}, Pure |= AG (AF visW {P}) )>. Proof. - intros u v nl1 nl2 kb P HP n h c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + intros u v nl1 nl2 kb P HP n h allocs c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. unfold srun. apply (sched_agaf u v 2 v u (fun n => negb (Nat.even n)) (fun n H => hdrof_odd u v n (proj1 (negb_true_iff _) H)) (fun n H => hdrof_even u v n (proj1 (negb_false_iff _) H)) (fun n H => tagof_odd n (proj1 (negb_true_iff _) H)) - (fun n => f_equal negb (even_flip n)) nl2 nl1 kb P HP n h c Pure); + (fun n => f_equal negb (even_flip n)) nl2 nl1 kb P HP n h allocs c Pure); [constructor |]. exists ns2, vs2, ns1, vs1, d2, d1. split; [exact Hq2 |]; split; [exact Hq1 |]; split; [now apply Disj_sym | split; [exact Hf2 | exact Hf1]]. Qed. -Theorem sched_agaf_q2: forall u v nl1 nl2 n h c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q2: forall u v nl1 nl2 n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. + <( {srun u v n (h, allocs) c}, Pure + |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. intros. eapply (sched_agaf_q2_gen u v nl1 nl2 0 ((fun o => indexed_value o = (2,nl2)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. -Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. + <( {srun u v n (h, allocs) c}, Pure + |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros. eapply (sched_agaf_q2_gen u v nl1 nl2 k ((indexed_after (fun x => x = (2,nl2)) k))); diff --git a/theories/Lang/CSL/Queue/Frame.v b/examples/CSL/Queue/Frame.v similarity index 93% rename from theories/Lang/CSL/Queue/Frame.v rename to examples/CSL/Queue/Frame.v index f28d446..27fc284 100644 --- a/theories/Lang/CSL/Queue/Frame.v +++ b/examples/CSL/Queue/Frame.v @@ -44,9 +44,9 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Import - Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential Lang.CSL.Queue.Recurrence - Lang.CSL.Queue.Trace Lang.CSL.Queue.Layout. +From examples Require Import + CSL.Queue.Representation CSL.Queue.Sequential CSL.Queue.Recurrence + CSL.Queue.Trace CSL.Queue.Layout. From Coinduction Require Import coinduction. @@ -215,53 +215,55 @@ Qed. Apply [Recurrence.v] with framed representation premises. The shared [aul_state_iter_ghost] rule and queue invariants are reused unchanged. *) -Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f c, +Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f allocs c, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> find_index Nat.eqb nlv vs = Some d -> - <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {(fun o => indexed_value o = nlv)}) )>. + <( {run hdr (hunion h f, allocs) c}, Pure + |= AG (AF visW {(fun o => indexed_value o = nlv)}) )>. Proof. - intros hdr nlv ns vs d h f c Hx Hd Hf Hfind. + intros hdr nlv ns vs d h f allocs c Hx Hd Hf Hfind. eapply rotate_agaf_pop_heap; [eapply qrepX_frame; eassumption | exact Hfind]. Qed. -Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f c k, +Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f allocs c k, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> find_index Nat.eqb nlv vs = Some d -> - <( {run hdr (hunion h f) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nlv) k)}) )>. + <( {run hdr (hunion h f, allocs) c}, Pure + |= AG (AF visW {(indexed_after (fun x => x = nlv) k)}) )>. Proof. - intros hdr nlv ns vs d h f c k Hx Hd Hf Hfind. + intros hdr nlv ns vs d h f allocs c k Hx Hd Hf Hfind. eapply rotate_agaf_pop_fresh; [eapply qrepX_frame; eassumption | exact Hfind]. Qed. (** The control that separates "the payload is somewhere in the global heap" from "the payload is popped": an element absent from the OWNED queue is never observed, no matter what the frame stores. *) -Theorem absent_never_observed_framed: forall hdr ns vs nlv h f c, +Theorem absent_never_observed_framed: forall hdr ns vs nlv h f allocs c, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> ns <> [] -> ~ In nlv vs -> - <( {run hdr (hunion h f) c}, Pure |= AG (now {obs_sat (fun x => x <> nlv)}) )>. + <( {run hdr (hunion h f, allocs) c}, Pure |= AG (now {obs_sat (fun x => x <> nlv)}) )>. Proof. - intros hdr ns vs nlv h f c Hx Hd Hf Hne Hnin. + intros hdr ns vs nlv h f allocs c Hx Hd Hf Hne Hnin. eapply absent_never_observed; [eapply qrepX_frame; eassumption | exact Hne | exact Hnin]. Qed. (** The stuck control transports too: an empty owned queue is stuck even when the frame is a large populated heap. *) -Theorem empty_queue_no_ag_framed: forall hdr vs h f c w phi, +Theorem empty_queue_no_ag_framed: forall hdr vs h f allocs c w phi, qrepX hdr [] vs h -> hdisj h f -> f 0 = None -> - ~ <( {run hdr (hunion h f) c}, w |= AG phi )>. + ~ <( {run hdr (hunion h f, allocs) c}, w |= AG phi )>. Proof. - intros hdr vs h f c w phi Hx Hd Hf. + intros hdr vs h f allocs c w phi Hx Hd Hf. eapply empty_queue_no_ag; eapply qrepX_frame; eassumption. Qed. diff --git a/theories/Lang/CSL/Queue/Layout.v b/examples/CSL/Queue/Layout.v similarity index 99% rename from theories/Lang/CSL/Queue/Layout.v rename to examples/CSL/Queue/Layout.v index 9e78b21..2460f2f 100644 --- a/theories/Lang/CSL/Queue/Layout.v +++ b/examples/CSL/Queue/Layout.v @@ -1,5 +1,6 @@ From Stdlib Require Import List Lia Arith.PeanoNat. -From TICL Require Import Events.HeapModel Lang.CSL.Queue.Representation. +From TICL Require Import Events.HeapModel. +From examples Require Import CSL.Queue.Representation. Import ListNotations. Local Open Scope list_scope. diff --git a/theories/Lang/CSL/Queue/Operations.v b/examples/CSL/Queue/Operations.v similarity index 75% rename from theories/Lang/CSL/Queue/Operations.v rename to examples/CSL/Queue/Operations.v index 38f102e..7fd310c 100644 --- a/theories/Lang/CSL/Queue/Operations.v +++ b/examples/CSL/Queue/Operations.v @@ -1,6 +1,7 @@ From Stdlib Require Import List Arith.PeanoNat. +From examples Require Import CSL.Queue.Representation. From TICL Require Import - Lang.CSL.Queue.Representation ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Heap ICTree.Events.Writer ICTree.Interp.State.Mod. Import ICtree ICTreeNotations ListNotations. @@ -45,18 +46,18 @@ Qed. Lemma queue_turn_spec {E W : Type} {HE : Encode E} {X} (other : E ~> stateT SSig (ictreeW W)) (emit_value : nat -> ictree (heapE + E) unit) (observe_value : nat -> nat -> W) : - (forall value h c (tail : ictree (heapE + E) X), - interp_state (h_sum heap_handler other) (emit_value value;; tail) (h,c) ~ + (forall value h allocs c (tail : ictree (heapE + E) X), + interp_state (h_sum heap_handler other) (emit_value value;; tail) ((h,allocs),c) ~ (log (observe_value value c);; - interp_state (h_sum heap_handler other) tail (h,S c))) -> - forall hdr a ns value values h c (tail : ictree (heapE + E) X), + interp_state (h_sum heap_handler other) tail ((h,allocs),S c))) -> + forall hdr a ns value values h allocs c (tail : ictree (heapE + E) X), qrep hdr (a :: ns) (value :: values) h -> - interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) (h,c) ~ + interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) ((h,allocs),c) ~ (log (observe_value value c);; interp_state (h_sum heap_handler other) tail - (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,S c)). + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,allocs),S c)). Proof. - intros Emit hdr a ns value values h c tail Hq. + intros Emit hdr a ns value values h allocs c tail Hq. pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). cbn in Hhd, Htl. apply chain_cons in Hch as (Ha & Hsa & Hch). @@ -68,22 +69,22 @@ Proof. assert (Hread_hdr : upd h (S hdr) (List.hd 0 ns) hdr = Some (last (a :: ns) 0)) by (rewrite upd_neq by congruence; exact Htl). unfold queue_turn. - etransitivity; [apply (interp_heap_rd other (S hdr) h c a _ Hhd)|]. - etransitivity; [apply (interp_heap_rd other a h c value _ Ha)|]. + etransitivity; [apply (interp_heap_rd other (S hdr) h allocs c a _ Hhd)|]. + etransitivity; [apply (interp_heap_rd other a h allocs c value _ Ha)|]. etransitivity; [apply Emit|]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. - etransitivity; [apply (interp_heap_rd other (S a) h (S c) (List.hd 0 ns) _ Hsa)|]. + etransitivity; [apply (interp_heap_rd other (S a) h allocs (S c) (List.hd 0 ns) _ Hsa)|]. etransitivity; - [apply (interp_heap_wr_present other (S hdr) h (S c) (List.hd 0 ns) _ Hshdrdom)|]. - etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (List.hd 0 ns)) (S c) + [apply (interp_heap_wr_present other (S hdr) h allocs (S c) (List.hd 0 ns) _ Hshdrdom)|]. + etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (List.hd 0 ns)) allocs (S c) (last (a :: ns) 0) _ Hread_hdr)|]. cbn beta iota. rewrite (zof_compute hdr a ns Hwf). - etransitivity; [apply (interp_heap_wr_present other (S (zof hdr ns)) _ (S c) a _ + etransitivity; [apply (interp_heap_wr_present other (S (zof hdr ns)) _ allocs (S c) a _ (upd_mono _ _ _ _ Hzdom))|]. - etransitivity; [apply (interp_heap_wr_present other (S a) _ (S c) 0 _ + etransitivity; [apply (interp_heap_wr_present other (S a) _ allocs (S c) 0 _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom)))|]. - etransitivity; [apply (interp_heap_wr_present other hdr _ (S c) a _ + etransitivity; [apply (interp_heap_wr_present other hdr _ allocs (S c) a _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom))))|]. reflexivity. Qed. diff --git a/theories/Lang/CSL/Queue/Program.v b/examples/CSL/Queue/Program.v similarity index 83% rename from theories/Lang/CSL/Queue/Program.v rename to examples/CSL/Queue/Program.v index 1dddccd..8087a00 100644 --- a/theories/Lang/CSL/Queue/Program.v +++ b/examples/CSL/Queue/Program.v @@ -1,11 +1,11 @@ From Stdlib Require Import Arith.PeanoNat Fin Vector List Lia. From TICL Require Import - ICTree.Core ICTree.Equ ICTree.Events.Yield Lang.CSL + ICTree.Core ICTree.Equ ICTree.Events.Yield Lang.CSL.Mod ICTree.Events.Writer ICTree.SBisim ICTree.Interp.State.Mod ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.SBisim Utils.Vectors. -From TICL Require Import Lang.CSL.Queue.Alternating Lang.CSL.Queue.Representation - Lang.CSL.Queue.Separation Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame - Lang.CSL.Queue.Operations Lang.CSL.Queue.Trace. +From examples Require Import CSL.Queue.Alternating CSL.Queue.Representation + CSL.Queue.Separation CSL.Queue.Layout CSL.Queue.Frame + CSL.Queue.Operations CSL.Queue.Trace. Import ICtree ICTreeNotations ListNotations VectorNotations. Local Open Scope ictree_scope. @@ -140,12 +140,12 @@ Local Ltac rotate_effect law := apply sbisim_clo_bind_eq; [reflexivity | intros [? [? ?]]]. Lemma interp_rr_rotate_once n (ts : pool sE (S n)) - (i : Fin.t (S n)) q hdr (K : option unit -> thread sE) m h c : + (i : Fin.t (S n)) q hdr (K : option unit -> thread sE) m memory c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (rotate_once q hdr) >>= K)) (Some i) m (h,c) ~ - (interp_state sh (turn q hdr) (h,c) >>= - fun '(_, (h',c')) => - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (h',c')). + (ts @ i := (denote_flow (rotate_once q hdr) >>= K)) (Some i) m (memory,c) ~ + (interp_state sh (turn q hdr) (memory,c) >>= + fun '(_, (memory',c')) => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (memory',c')). Proof. unfold rotate_once, turn, turnk, queue_turn. rotate_effect interp_rr_read. @@ -185,10 +185,10 @@ Proof. Qed. Local Lemma interp_rr_worker n (ts : pool sE (S n)) - (i : Fin.t (S n)) q hdr m h c : - interp_schedule_rr sh (S n) (ts @ i := denote (worker q hdr)) (Some i) m (h,c) ~ - (interp_state sh (turn q hdr) (h,c) >>= fun '(_, (h',c')) => - interp_schedule_rr sh (S n) (ts @ i := Guard (denote (worker q hdr))) None m (h',c')). + (i : Fin.t (S n)) q hdr m memory c : + interp_schedule_rr sh (S n) (ts @ i := denote (worker q hdr)) (Some i) m (memory,c) ~ + (interp_state sh (turn q hdr) (memory,c) >>= fun '(_, (memory',c')) => + interp_schedule_rr sh (S n) (ts @ i := Guard (denote (worker q hdr))) None m (memory',c')). Proof. set (again := fun r : option (option unit) => match r with @@ -204,11 +204,11 @@ Proof. (ts @ i := (denote_flow (CBind (rotate_once q hdr) (fun _ => CBind CYield (fun _ => CRet (Some tt)))) >>= again)) - (Some i) m (h,c) ~ rhs) + (Some i) m (memory,c) ~ rhs) end. rewrite interp_rr_bind. etransitivity; [apply interp_rr_rotate_once|]. - apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. rewrite interp_rr_bind, interp_rr_yield. assert (Hpark : pool_equ (ts @ i := (denote_flow (CRet (Some tt)) >>= again)) @@ -219,19 +219,19 @@ Proof. etransitivity; [exact (bind_ret_l (Some (Some tt)) again)|]. reflexivity. } - pose proof (interp_schedule_rr_equ sh (S n) _ _ None m (h',c') Hpark) as Hdone. + pose proof (interp_schedule_rr_equ sh (S n) _ _ None m (memory',c') Hpark) as Hdone. eapply equ_clos_sbisim_goal; [exact Hdone | reflexivity | reflexivity]. Qed. -Lemma queue_pool_turn u v n g2 g1 h c : +Lemma queue_pool_turn u v n g2 g1 memory c : interp_schedule_rr sh 2 (queue_workers u v g2 g1) - (Some (queue_slot n)) n (h,c) ~ - (interp_state sh (turn (tagof n) (hdrof u v n)) (h,c) >>= - fun '(_, (h',c')) => + (Some (queue_slot n)) n (memory,c) ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) (memory,c) >>= + fun '(_, (memory',c')) => interp_schedule_rr sh 2 (queue_workers u v (if Nat.even n then g2 else true) (if Nat.even n then true else g1)) - (Some (queue_slot (S n))) (S n) (h',c')). + (Some (queue_slot (S n))) (S n) (memory',c')). Proof. unfold queue_slot at 1; unfold tagof, hdrof. destruct (Nat.even n) eqn:Hphase. @@ -241,10 +241,10 @@ Proof. | |- _ ~ ?rhs => change (interp_schedule_rr sh 2 (queue_workers u v g2 false @ Fin.FS Fin.F1 := denote (worker 1 u)) - (Some (Fin.FS Fin.F1)) n (h,c) ~ rhs) + (Some (Fin.FS Fin.F1)) n (memory,c) ~ rhs) end. all: etransitivity; [apply interp_rr_worker|]. - all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. all: etransitivity; [apply interp_schedule_rr_select|]. all: rewrite queue_pick_next; reflexivity. - destruct g2; @@ -253,10 +253,10 @@ Proof. | |- _ ~ ?rhs => change (interp_schedule_rr sh 2 (queue_workers u v false g1 @ Fin.F1 := denote (worker 2 v)) - (Some Fin.F1) n (h,c) ~ rhs) + (Some Fin.F1) n (memory,c) ~ rhs) end. all: etransitivity; [apply interp_rr_worker|]. - all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [h' c']]]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. all: etransitivity; [apply interp_schedule_rr_select|]. all: rewrite queue_pick_next; reflexivity. Qed. @@ -280,32 +280,34 @@ Local Ltac queue_prefix R law := Local Ltac queue_fault Hnone := cbv beta; lazymatch goal with - | |- interp_state ?H (ICtree.bind (heap_read (E:=sE) ?a) ?next) (?h,?c) ~ _ => + | |- interp_state ?H (ICtree.bind (heap_read (E:=sE) ?a) ?next) ((?h,?allocs),?c) ~ _ => let Hfault := fresh "Hfault" in - assert (Hfault : interp_state H (heap_read (E:=sE) a >>= next) (h,c) ≅ stuck) by + assert (Hfault : interp_state H (heap_read (E:=sE) a >>= next) ((h,allocs),c) ≅ stuck) by (etransitivity; [apply interp_state_bind|]; etransitivity; [ apply equ_clo_bind with (S := eq) (k2 := fun '(x,s') => interp_state H (next x) s'); - [exact ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c Hnone) | intros x y <-; reflexivity] + [exact ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a h allocs c Hnone) + | intros x y <-; reflexivity] | apply bind_stuck_equ ]); eapply equ_clos_sbisim_goal; [exact Hfault | reflexivity | reflexivity] end. -Lemma queue_pool_bisim : forall u v n g2 g1 h c, +Lemma queue_pool_bisim : forall u v n g2 g1 h allocs c, interp_schedule_rr sh 2 (queue_workers u v g2 g1) - (Some (queue_slot n)) n (h,c) ~ srun u v n h c. + (Some (queue_slot n)) n ((h,allocs),c) ~ srun u v n (h,allocs) c. Proof. - coinduction R CIH; intros u v n g2 g1 h c. + coinduction R CIH; intros u v n g2 g1 h allocs c. etransitivity; [apply (coinduction.gfp_bt (sb eq) R), queue_pool_turn|]. etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; apply srun_turn]. unfold turn, turnk, queue_turn. destruct (h (S (hdrof u v n))) as [a|] eqn:Hhead. - - queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))); exact Hhead). + - queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))); exact Hhead). destruct (h a) as [payload|] eqn:Hpayload. - + queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))); exact Hpayload). + + queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))); exact Hpayload). queue_prefix R ltac:(unfold semit; apply (interp_indexed_emit heap_handler)). eapply equ_sbt_closed_goal; [apply bind_bind | apply bind_bind |]. unfold log, ICtree.trigger. @@ -313,10 +315,10 @@ Proof. apply step_sb_vis. * intros []; exists tt; split; [|reflexivity]. eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. - apply st_clo_bind_eq; [reflexivity | intros [ignored [h' c']]; apply CIH]. + apply st_clo_bind_eq; [reflexivity | intros [ignored [[h' allocs'] c']]; apply CIH]. * intros []; exists tt; split; [|reflexivity]. eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. - apply st_clo_bind_eq; [reflexivity | intros [ignored [h' c']]; apply CIH]. + apply st_clo_bind_eq; [reflexivity | intros [ignored [[h' allocs'] c']]; apply CIH]. + queue_prefix R ltac:(queue_fault Hpayload). eapply equ_sbt_closed_goal; [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. @@ -325,12 +327,13 @@ Proof. [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. Qed. -Theorem run_rr_parallel_bisim u v h c : - run_rr (parallel_queues u v) h c ~ srun u v 0 h c. +Theorem run_rr_parallel_bisim u v memory c : + run_rr (parallel_queues u v) memory c ~ srun u v 0 memory c. Proof. + destruct memory as [h allocs]. unfold parallel_queues; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 (queue_workers u v false false) - (Some (queue_slot 0)) 0 (h,c) ~ srun u v 0 h c). + (Some (queue_slot 0)) 0 ((h,allocs),c) ~ srun u v 0 (h,allocs) c). apply queue_pool_bisim. Qed. @@ -339,8 +342,8 @@ Local Ltac srun_pop_turn Hq := lazymatch type of Hq with | qrep ?hdr (?a :: ?ns) (?pv :: ?vs) ?h => lazymatch goal with - | |- srun ?u ?v ?n h ?c ~ ?rhs => - let Hbody := constr:(sbody_spec u v n a ns pv vs h c Hq) in + | |- srun ?u ?v ?n (h, ?allocs) ?c ~ ?rhs => + let Hbody := constr:(sbody_spec u v n a ns pv vs h allocs c Hq) in unfold srun, sched at 1; rewrite interp_state_unfold_iter; cbv beta; @@ -356,7 +359,7 @@ Local Ltac srun_pop_turn Hq := rewrite bind_ret_l, sb_guard; lazymatch goal with | |- _ ~ ?tail => - change (srun u v (S n) (qstep hdr (a :: ns) h) (S c) ~ tail) + change (srun u v (S n) (qstep hdr (a :: ns) h, allocs) (S c) ~ tail) end end end. @@ -364,16 +367,16 @@ Local Ltac srun_pop_turn Hq := (** The first four pops of two disjoint queues under the shared source round-robin scheduler: queue 1 rotates [a;b], queue 2 its singleton [d], alternating, with the observation counter advancing once per pop. *) -Lemma parallel_queues_four_pop_bisim u a b v d h x y z c : +Lemma parallel_queues_four_pop_bisim u a b v d h allocs x y z c : qrep u [a;b] [x;y] h -> qrep v [d] [z] h -> Disj u [a;b] v [d] -> let h1 := qstep u [a;b] h in let h2 := qstep v [d] h1 in let h3 := qstep u [b;a] h2 in let h4 := qstep v [d] h3 in - run_rr (parallel_queues u v) h c ~ + run_rr (parallel_queues u v) (h,allocs) c ~ (log (stamp (1,x) c);; log (stamp (2,z) (S c));; log (stamp (1,y) (S (S c)));; log (stamp (2,z) (S (S (S c))));; - srun u v 4 h4 (S (S (S (S c))))). + srun u v 4 (h4,allocs) (S (S (S (S c))))). Proof. intros H1 H2 Hd; cbv zeta. pose proof (qstep_qrep u [a;b] [x;y] h H1 ltac:(discriminate)) as H1a. @@ -390,7 +393,7 @@ Proof. change (qrep v [d] [z] (qstep v [d] (qstep u [a;b] h))) in H2b. pose proof (foreign_pres u [b;a] [y;x] v [d] [z] (qstep v [d] (qstep u [a;b] h)) H1b ltac:(discriminate) H2b Hda) as H2c. - etransitivity; [exact (run_rr_parallel_bisim u v h c) |]. + etransitivity; [exact (run_rr_parallel_bisim u v (h,allocs) c) |]. srun_pop_turn H1. srun_pop_turn H2a. srun_pop_turn H1b. @@ -399,16 +402,16 @@ Proof. Qed. (** Queue 1 takes the first source turn; a fault there faults the whole run. *) -Local Lemma parallel_queues_first_turn_stuck u v h c : - interp_state sh (turn 1 u) (h,c) ~ +Local Lemma parallel_queues_first_turn_stuck u v memory c : + interp_state sh (turn 1 u) (memory,c) ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)) -> - run_rr (parallel_queues u v) h c ~ + run_rr (parallel_queues u v) memory c ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. intro Hfault. unfold parallel_queues; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 (queue_workers u v false false) - (Some (queue_slot 0)) 0 (h,c) ~ + (Some (queue_slot 0)) 0 (memory,c) ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig))). etransitivity; [apply queue_pool_turn |]. lazymatch goal with @@ -421,25 +424,25 @@ Proof. Qed. Lemma parallel_queues_hemp_stuck u v c : - run_rr (parallel_queues u v) hemp c ~ + run_rr (parallel_queues u v) managed_empty c ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. apply parallel_queues_first_turn_stuck. assert (Hhead : hemp (S u) = None) by reflexivity. - unfold turn, turnk, queue_turn; queue_fault Hhead. + unfold turn, turnk, queue_turn, managed_empty; queue_fault Hhead. Qed. (** Silent initialization in the real shared source scheduler. *) Lemma interp_rr_fill_nodes n (ts : pool sE (S n)) (i : Fin.t (S n)) - first values (K : option unit -> thread sE) m h c : + first values (K : option unit -> thread sE) m h allocs c : (forall offset, Nat.lt offset (2 * length values) -> h (first + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (fill_nodes_heap first values h,c). + (Some i) m ((fill_nodes_heap first values h,allocs),c). Proof. revert first h; induction values as [|value values IH]; intros first h Allocated. - cbn [fill_nodes fill_nodes_heap]; rewrite interp_rr_ret; reflexivity. @@ -457,13 +460,13 @@ Proof. Qed. Lemma interp_rr_init_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) - hdr values (K : option unit -> thread sE) m h c : + hdr values (K : option unit -> thread sE) m h allocs c : (forall offset, Nat.lt offset (2 * S (length values)) -> h (hdr + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (init_queue_heap hdr values h,c). + (Some i) m ((init_queue_heap hdr values h,allocs),c). Proof. intro Allocated; unfold init_queue, init_queue_heap; rewrite interp_rr_bind. etransitivity. @@ -479,18 +482,20 @@ Proof. Qed. Lemma interp_rr_new_queue_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - values hdr (K : option nat -> thread sE) m h c : + values hdr (K : option nat -> thread sE) m h allocs c : Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> (forall j, Nat.lt 0 j -> Nat.lt j hdr -> ~ block_free h j (2 * S (length values))) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) - (Some i) m (new_queue_heap hdr values h,c). + (Some i) m ((new_queue_heap hdr values h, + upd allocs hdr (2 * S (length values))),c). Proof. intros Positive Free First. unfold new_queue; rewrite interp_rr_bind. rewrite interp_rr_alloc_first with (base:=hdr) by (try lia; assumption). + unfold managed_alloc; cbn [fst snd]. rewrite interp_rr_bind; etransitivity. - apply interp_rr_init_queue; intros offset O. unfold hunion; rewrite (hblock_in hdr (2 * S (length values)) offset O). @@ -501,16 +506,17 @@ Qed. Lemma interp_rr_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) values (K : option nat -> thread sE) m c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (hemp,c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (managed_empty,c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) - (Some i) m (new_queue_heap 1 values hemp,c). + (Some i) m ((new_queue_heap 1 values hemp, + upd hemp 1 (2 * S (length values))),c). Proof. apply interp_rr_new_queue_first; [lia | intros offset Hlt; reflexivity | intros j Hj Hfirst; lia]. Qed. Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) - values (K : option nat -> thread sE) m h c : + values (K : option nat -> thread sE) m h allocs c : heap_finite h -> exists hdr, Nat.lt 0 hdr /\ block_free h hdr (2 * S (length values)) /\ @@ -518,12 +524,14 @@ Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) asep (qrepX hdr (queue_nodes hdr (length values)) values) (fun frame => heq frame h) (new_queue_heap hdr values h) /\ interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (h,c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),c) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) - (Some i) m (new_queue_heap hdr values h,c). + (Some i) m ((new_queue_heap hdr values h, + upd allocs hdr (2 * S (length values))),c). Proof. intro Finite. - destruct (heap_handler_alloc_finite h (2 * S (length values)) c Finite ltac:(lia)) + destruct (heap_handler_alloc_finite (F:=writerE (indexed (nat * nat))) + h allocs (2 * S (length values)) c Finite ltac:(lia)) as (hdr & Positive & Free & First & _). exists hdr; split; [exact Positive |]; split; [exact Free |]; split. - now apply new_queue_heap_finite. @@ -532,12 +540,12 @@ Proof. Qed. Theorem run_rr_allocated_parallel : forall values1 values2 c, - exists u v h, + exists u v h allocs, heap_finite h /\ asep (qrepX u (queue_nodes u (length values1)) values1) (qrepX v (queue_nodes v (length values2)) values2) h /\ - run_rr (allocated_parallel_queues values1 values2) hemp c ~ - run_rr (parallel_queues u v) h c. + run_rr (allocated_parallel_queues values1 values2) managed_empty c ~ + run_rr (parallel_queues u v) (h,allocs) c. Proof. intros values1 values2 c. set (done := fun _ : option unit => (Ret tt : thread sE)). @@ -547,17 +555,19 @@ Proof. | Some u => denote_flow (CBind (new_queue values2) (fun v => parallel_queues u v)) >>= done end). - destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values1 after1 0 hemp c + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values1 after1 0 hemp hemp c heap_finite_hemp) as (u & Upos & Ufree & Finite1 & Own1 & Run1). set (h1 := new_queue_heap u values1 hemp). + set (allocs1 := upd hemp u (2 * S (length values1))). set (after2 := fun r : option nat => match r with | None => done None | Some v => denote_flow (parallel_queues u v) >>= done end). - destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values2 after2 0 h1 c + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values2 after2 0 h1 allocs1 c Finite1) as (v & Vpos & Vfree & Finite2 & Own2 & Run2). - exists u, v, (new_queue_heap v values2 h1); split; [exact Finite2 |]; split. + exists u, v, (new_queue_heap v values2 h1), (upd allocs1 v (2 * S (length values2))). + split; [exact Finite2 |]; split. - set (q1 := qheap u (queue_nodes u (length values1)) values1). set (q2 := qheap v (queue_nodes v (length values2)) values2). assert (E1 : heq h1 q1). @@ -579,8 +589,9 @@ Proof. ([Ret tt]%vector @ Fin.F1 := (denote_flow (CBind (new_queue values1) (fun u => CBind (new_queue values2) (fun v => parallel_queues u v))) >>= done)) - (Some Fin.F1) 0 (hemp,c) ~ - run_rr (parallel_queues u v) (new_queue_heap v values2 h1) c). + (Some Fin.F1) 0 ((hemp,hemp),c) ~ + run_rr (parallel_queues u v) + (new_queue_heap v values2 h1, upd allocs1 v (2 * S (length values2))) c). rewrite interp_rr_bind. etransitivity; [exact Run1 |]. cbn [after1]; rewrite interp_rr_bind. @@ -591,11 +602,11 @@ Qed. (** An allocated empty first queue has head pointer [0], and the null cell is unallocated: the first source turn faults, whatever the second queue is. *) Lemma allocated_parallel_queues_empty_stuck values c : - run_rr (allocated_parallel_queues [] values) hemp c ~ + run_rr (allocated_parallel_queues [] values) managed_empty c ~ (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). Proof. destruct (run_rr_allocated_parallel [] values c) - as (u & v & h & _ & Owned & Run). + as (u & v & h & allocs & _ & Owned & Run). destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as ((_ & Hhead & _ & _ & Hnull & _) & _ & _). change (h (S u) = Some 0) in Hhead. diff --git a/theories/Lang/CSL/Queue/Recurrence.v b/examples/CSL/Queue/Recurrence.v similarity index 76% rename from theories/Lang/CSL/Queue/Recurrence.v rename to examples/CSL/Queue/Recurrence.v index 4d66fc8..ccf7582 100644 --- a/theories/Lang/CSL/Queue/Recurrence.v +++ b/examples/CSL/Queue/Recurrence.v @@ -44,8 +44,9 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential - Lang.CSL.Queue.Operations Utils.Relations. +From examples Require Import CSL.Queue.Representation CSL.Queue.Sequential + CSL.Queue.Operations. +From TICL Require Import Utils.Relations. From Coinduction Require Import coinduction. @@ -85,23 +86,23 @@ Section Recurrence. (** The [AG] invariant: the state is a valid representation of SOME queue that still contains [nl]. The abstract queue is existentially quantified -- no extraction function from heaps to lists is needed. *) - Definition Rq (_: unit) (s: Sig) (_: WorldW (indexed nat)) : Prop := - exists ns vs d, qrep hdr ns vs (fst s) /\ find_index Nat.eqb nl vs = Some d. + Definition Rq (_: unit) (s: SSig) (_: WorldW (indexed nat)) : Prop := + exists ns vs d, qrep hdr ns vs (fst (fst s)) /\ find_index Nat.eqb nl vs = Some d. (** *** One iteration, as a deterministic suffix formula. This is the only place the body is opened, and it is opened through [rot_body_spec] -- a bisimulation -- not by unfolding [auc]. *) - Lemma body_det: forall ns vs a v h c w, + Lemma body_det: forall ns vs a v h allocs c w, qrep hdr (a :: ns) (v :: vs) h -> not_done w -> - <[ {interp_state h_qE (rot_body hdr) (h, c)}, w + <[ {interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), c)}, w |= ⊤ AU AX done= {(@inl unit unit tt, - (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c))} + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c))} {Obs (Log (stamp v c)) tt} ]>. Proof. - intros ns vs a v h c w Hq Hd. - rewrite (rot_body_spec hdr a ns v vs h c Hq). + intros ns vs a v h allocs c w Hq Hd. + rewrite (rot_body_spec hdr a ns v vs h allocs c Hq). apply aur_log. - cleft; apply axr_ret; [constructor | split; reflexivity]. - apply ticll_top; assumption. @@ -113,25 +114,25 @@ Section Recurrence. counter and [d] is the position of [nl] in the abstract queue. Neither the heap nor the world appears in it. The whole proof is ONE application of [aul_state_iter_ghost] plus a body case analysis. *) - Definition InvQ (m: nat * nat) (_: unit) (s: Sig) : Prop := - exists ns vs d, qrep hdr ns vs (fst s) + Definition InvQ (m: nat * nat) (_: unit) (s: SSig) : Prop := + exists ns vs d, qrep hdr ns vs (fst (fst s)) /\ find_index Nat.eqb nl vs = Some d /\ m = (kb - snd s, d). - Lemma inner_af: forall h c ns vs d w, + Lemma inner_af: forall h allocs c ns vs d w, not_done w -> qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AF visW {P} )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AF visW {P} )>. Proof. - intros h c ns vs d w Hd Hq Hf. + intros h allocs c ns vs d w Hd Hq Hf. unfold rotate. - apply (aul_state_iter_ghost h_qE lexnat InvQ (fun _: unit => rot_body hdr) - _ _ lexnat_wf (kb - c, d) tt (h, c) w Hd). + apply (aul_state_iter_ghost (sh (A:=nat)) lexnat InvQ (fun _: unit => rot_body hdr) + _ _ lexnat_wf (kb - c, d) tt ((h, allocs), c) w Hd). - exists ns, vs, d; split; [exact Hq | split; [exact Hf | reflexivity]]. - - clear h c ns vs d w Hd Hq Hf. + - clear h allocs c ns vs d w Hd Hq Hf. intros m [] s w Hd (ns & vs & d & Hq & Hf & Hm). - destruct s as (h, c); cbn in Hq, Hm. + destruct s as ((h, allocs), c); cbn in Hq, Hm. destruct vs as [| v vs']; [cbn in Hf; discriminate |]. destruct ns as [| a ns']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. (* the shared "rotate once" step *) @@ -139,14 +140,14 @@ Section Recurrence. lexnat (kb - S c, d') m -> (exists g' i' s' w', not_done w' - /\ <[ {interp_state h_qE - ((fun _: unit => rot_body hdr) tt) (h, c)}, w + /\ <[ {interp_state (sh (A:=nat)) + ((fun _: unit => rot_body hdr) tt) ((h, allocs), c)}, w |= ⊤ AU AX done= {(@inl unit unit i', s')} w' ]> /\ InvQ g' i' s' /\ lexnat g' m)). { intros d' Hd' Hlex. exists (kb - S c, d'), tt, - (rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, S c), + ((rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, allocs), S c), (Obs (Log (stamp v c)) tt). split; [constructor |]. split; [eapply body_det; eassumption |]. @@ -160,7 +161,7 @@ Section Recurrence. destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. * (* and the occurrence bound is already met: observe it now *) left. - rewrite (rot_body_spec hdr a ns' nl vs' h c Hq). + rewrite (rot_body_spec hdr a ns' nl vs' h allocs c Hq). apply afl_log; [assumption |]. cleft; apply ticll_vis; constructor; now apply HP. * (* the bound is not met yet: rotate, the bound gets closer *) @@ -176,24 +177,24 @@ Section Recurrence. Qed. (** *** The recurrence theorem. *) - Theorem rotate_agaf_core: forall h c ns vs d w, + Theorem rotate_agaf_core: forall h allocs c ns vs d w, not_done w -> qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AG (AF visW {P}) )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AG (AF visW {P}) )>. Proof. - intros h c ns vs d w Hd Hq Hf. + intros h allocs c ns vs d w Hd Hq Hf. unfold rotate. - apply (ag_state_iter h_qE (h, c) Rq tt w); [assumption | |]. + apply (ag_state_iter (sh (A:=nat)) ((h, allocs), c) Rq tt w); [assumption | |]. - exists ns, vs, d; split; assumption. - intros [] s w' Hd' (ns1 & vs1 & d1 & Hq1 & Hf1). - destruct s as (h1, c1); cbn in Hq1. + destruct s as ((h1, allocs1), c1); cbn in Hq1. destruct vs1 as [| v1 vs1']; [cbn in Hf1; discriminate |]. destruct ns1 as [| a1 ns1']; [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. split. + eapply inner_af; [exact Hd' | exact Hq1 | exact Hf1]. - + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 c1 Hq1). + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 c1 Hq1). apply anr_log; [| apply ticll_top; assumption]. cleft; apply axr_ret; [constructor |]. exists tt; split; [reflexivity | split; [constructor |]]. @@ -214,25 +215,25 @@ End Recurrence. every occurrence bound [k], every reachable state still eventually produces a pop of [nl] whose index is at least [k]. Since indices are strictly increasing and each observation carries its own, this cannot be - discharged by a retained world ([fresh_excludes_retained]). *) + discharged by a retained world ([indexed_excludes_retained]). *) -Theorem rotate_agaf_pop_heap: forall hdr nl h c ns vs d, +Theorem rotate_agaf_pop_heap: forall hdr nl h allocs c ns vs d, qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {run hdr h c}, Pure |= AG (AF visW {(fun o => indexed_value o = nl)}) )>. + <( {run hdr (h, allocs) c}, Pure |= AG (AF visW {(fun o => indexed_value o = nl)}) )>. Proof. - intros hdr nl h c ns vs d Hq Hf. + intros hdr nl h allocs c ns vs d Hq Hf. unfold run. eapply (rotate_agaf_core hdr nl 0 ((fun o => indexed_value o = nl))); [ intros j _; reflexivity | constructor | exact Hq | exact Hf ]. Qed. -Theorem rotate_agaf_pop_fresh: forall hdr nl h c ns vs d k, +Theorem rotate_agaf_pop_fresh: forall hdr nl h allocs c ns vs d k, qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {run hdr h c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nl) k)}) )>. + <( {run hdr (h, allocs) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nl) k)}) )>. Proof. - intros hdr nl h c ns vs d k Hq Hf. + intros hdr nl h allocs c ns vs d k Hq Hf. unfold run. eapply (rotate_agaf_core hdr nl k ((indexed_after (fun x => x = nl) k))); [ intros j Hj; split; [reflexivity | exact Hj] | constructor | exact Hq | exact Hf ]. @@ -251,19 +252,19 @@ Qed. hence NO [AG] formula holds of it -- in particular not the recurrence formula. This is what the hypothesis [find_index Nat.eqb nl vs = Some d] (which forces a non-empty queue) buys. *) -Theorem empty_queue_no_ag: forall hdr h c vs w phi, - qrep hdr [] vs h -> ~ <( {run hdr h c}, w |= AG phi )>. +Theorem empty_queue_no_ag: forall hdr h allocs c vs w phi, + qrep hdr [] vs h -> ~ <( {run hdr (h, allocs) c}, w |= AG phi )>. Proof. - intros hdr h c vs w phi Hq H. + intros hdr h allocs c vs w phi Hq H. pose proof Hq as (Hwf & Hhd & _ & _ & _); cbn in Hhd. pose proof (qrep_null _ _ _ _ Hq) as H0. - assert (Hns: ~ can_step (run hdr h c) w). - { unfold run, rotate, h_qE; rewrite interp_state_unfold_iter. + assert (Hns: ~ can_step (run hdr (h, allocs) c) w). + { unfold run, rotate, sh; rewrite interp_state_unfold_iter. apply nostep_bind. unfold rot_body, queue_turn. - rewrite (interp_heap_rd (h_indexed (A:=nat) (Sigma:=Heap)) - (S hdr) h c 0 _ Hhd). - now apply (interp_heap_rd_nostep (h_indexed (A:=nat) (Sigma:=Heap))). } + rewrite (interp_heap_rd (h_indexed (A:=nat) (Sigma:=ManagedHeap)) + (S hdr) h allocs c 0 _ Hhd). + now apply (interp_heap_rd_nostep (h_indexed (A:=nat) (Sigma:=ManagedHeap))). } cdestruct H; now apply Hns. Qed. @@ -278,32 +279,32 @@ Qed. Definition obs_sat (Q: nat -> Prop) : WorldW (indexed nat) -> Prop := fun w => forall o, w = Obs (Log o) tt -> Q (indexed_value o). -Theorem rotate_ag_obs: forall hdr h c ns vs w (Q: nat -> Prop), +Theorem rotate_ag_obs: forall hdr h allocs c ns vs w (Q: nat -> Prop), (forall x, In x vs -> Q x) -> not_done w -> qrep hdr ns vs h -> ns <> [] -> obs_sat Q w -> - <( {interp_state h_qE (rotate hdr) (h, c)}, w |= AG (now {obs_sat Q}) )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AG (now {obs_sat Q}) )>. Proof. - intros hdr h c ns vs w Q HQ Hd Hq Hne Hw. + intros hdr h allocs c ns vs w Q HQ Hd Hq Hne Hw. unfold rotate. - apply (ag_state_iter h_qE (h, c) - (fun (_: unit) (s: Sig) (w: WorldW (indexed nat)) => - (exists ns' vs', qrep hdr ns' vs' (fst s) /\ ns' <> [] + apply (ag_state_iter (sh (A:=nat)) ((h, allocs), c) + (fun (_: unit) (s: SSig) (w: WorldW (indexed nat)) => + (exists ns' vs', qrep hdr ns' vs' (fst (fst s)) /\ ns' <> [] /\ (forall x, In x vs' -> Q x)) /\ obs_sat Q w) tt w); [assumption | |]. - split; [exists ns, vs; split; [exact Hq | split; [exact Hne | exact HQ]] | exact Hw]. - intros [] s w' Hd' ((ns1 & vs1 & Hq1 & Hne1 & Hin1) & Hw'). - destruct s as (h1, c1); cbn in Hq1. + destruct s as ((h1, allocs1), c1); cbn in Hq1. destruct ns1 as [| a1 ns1']; [contradiction |]. destruct vs1 as [| v1 vs1']; [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. assert (Hv1: Q v1) by (apply Hin1, in_eq). split. + apply ticll_now; split; assumption. - + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 c1 Hq1). + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 c1 Hq1). apply anr_log; [| apply ticll_top; assumption]. cleft; apply axr_ret; [constructor |]. exists tt; split; [reflexivity | split; [constructor |]]. @@ -318,15 +319,15 @@ Qed. (** The control itself: an element outside the initial queue is never the payload of any observation. *) -Corollary absent_never_observed: forall hdr h c ns vs nl, +Corollary absent_never_observed: forall hdr h allocs c ns vs nl, qrep hdr ns vs h -> ns <> [] -> ~ In nl vs -> - <( {run hdr h c}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. + <( {run hdr (h, allocs) c}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. Proof. - intros hdr h c ns vs nl Hq Hne Hnin. + intros hdr h allocs c ns vs nl Hq Hne Hnin. unfold run. - apply (rotate_ag_obs hdr h c ns vs Pure (fun x => x <> nl)); + apply (rotate_ag_obs hdr h allocs c ns vs Pure (fun x => x <> nl)); [ intros x Hx C; subst; contradiction | constructor | exact Hq | exact Hne | intros o Ho; discriminate ]. diff --git a/theories/Lang/CSL/Queue/Representation.v b/examples/CSL/Queue/Representation.v similarity index 99% rename from theories/Lang/CSL/Queue/Representation.v rename to examples/CSL/Queue/Representation.v index acc803c..78b9447 100644 --- a/theories/Lang/CSL/Queue/Representation.v +++ b/examples/CSL/Queue/Representation.v @@ -23,7 +23,7 @@ predicate is independent of the allocator used to obtain those cells. - The tail pointer is constrained only when the queue is non-empty. That - is what makes the intermediate ownership split of [Rotate.v] uniform: at + is what makes the intermediate ownership split ([rot_detach_split]) uniform: at the instant the head node is detached, the remaining queue is a genuine [qrep] even when it has become empty and the tail pointer is stale. *) @@ -40,7 +40,7 @@ Import ListNotations. (** ** The resource model *) -From TICL Require Export Lang.CSL.Heap Utils.Lists. +From TICL Require Export ICTree.Interp.CSL.Mod Utils.Lists. (** ** Footprints and well-formedness @@ -651,10 +651,10 @@ Proof. assert (Hz: zof hdr ns = zz) by (rewrite Hns; apply zof_snoc). assert (Hvne: vs <> []). { intro C; rewrite C in Hch; apply chain_len in Hch; - rewrite Hns, app_length in Hch; cbn in Hch; lia. } + rewrite Hns, length_app in Hch; cbn in Hch; lia. } destruct (exists_last Hvne) as (vs0 & vz & Hvs). assert (Hlen: length ns0 = length vs0). - { apply chain_len in Hch; rewrite Hns, Hvs, !app_length in Hch; cbn in Hch; lia. } + { apply chain_len in Hch; rewrite Hns, Hvs, !length_app in Hch; cbn in Hch; lia. } rewrite Hns, Hvs in Hch. apply chain_split in Hch as (Hch0 & Hchz); [| exact Hlen]. cbn [List.hd] in Hch0; apply chain_cons in Hchz as (Hzv & Hszv & _). diff --git a/theories/Lang/CSL/Queue/Separation.v b/examples/CSL/Queue/Separation.v similarity index 98% rename from theories/Lang/CSL/Queue/Separation.v rename to examples/CSL/Queue/Separation.v index c074886..6b89e9a 100644 --- a/theories/Lang/CSL/Queue/Separation.v +++ b/examples/CSL/Queue/Separation.v @@ -34,8 +34,8 @@ From Stdlib Require Import Lia Arith.PeanoNat. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Trace - Lang.CSL.Queue.Layout Lang.CSL.Queue.Frame. +From examples Require Import CSL.Queue.Representation CSL.Queue.Trace + CSL.Queue.Layout CSL.Queue.Frame. Import ListNotations. Local Open Scope list_scope. diff --git a/theories/Lang/CSL/Queue/Sequential.v b/examples/CSL/Queue/Sequential.v similarity index 84% rename from theories/Lang/CSL/Queue/Sequential.v rename to examples/CSL/Queue/Sequential.v index 64658cd..b4f005d 100644 --- a/theories/Lang/CSL/Queue/Sequential.v +++ b/examples/CSL/Queue/Sequential.v @@ -52,9 +52,9 @@ From TICL Require Import ICTree.Logic.Iter ICTree.Logic.State Logic.Core - Lang.CSL.Heap. + ICTree.Interp.CSL.Mod. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Operations. +From examples Require Import CSL.Queue.Representation CSL.Queue.Operations. From Coinduction Require Import coinduction. @@ -83,15 +83,6 @@ Definition qE : Type := (heapE + writerE nat)%type. Definition emit (v: nat) : ictree qE unit := @ICtree.trigger (writerE nat) qE _ _ ReSum_inr ReSumRet_inr (Log v). -(** The interpretation state: the OWNED heap and the PRIVATE occurrence - counter. The counter is not part of the heap and no heap operation reads - it; it exists to index the observations. *) -Notation Sig := (Heap * nat)%type. - -(** ** The safe handler *) -Definition h_qE: qE ~> stateT Sig (ictreeW (indexed nat)) := - h_sum heap_handler h_indexed. - (** ** The rotating queue program. One iteration: read the head pointer, read and EMIT the head payload, read @@ -104,8 +95,13 @@ Definition rot_body (hdr: nat) : ictree qE (unit + unit) := Definition rotate (hdr: nat) : ictree qE unit := ICtree.iter (fun _: unit => rot_body hdr) tt. -Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW (indexed nat) (unit * Sig) := - interp_state h_qE (rotate hdr) (h, c). +(** [run] interprets the rotation with the one CSL handler [sh] at the unary + payload [nat]. Its state is the shared CSL state [SSig]: the managed + memory [(h,allocs)] and the PRIVATE occurrence counter. The rotation never + allocates or frees, so [allocs] is carried through unchanged; no heap + operation reads the counter, which only indexes the observations. *) +Definition run (hdr: nat) (memory: ManagedHeap) (c: nat) : ictreeW (indexed nat) (unit * SSig) := + interp_state (sh (A:=nat)) (rotate hdr) (memory, c). (** ** The body correspondence. @@ -125,13 +121,13 @@ Definition run (hdr: nat) (h: Heap) (c: nat) : ictreeW (indexed nat) (unit * Sig - **the observation.** The single event is [stamp v c] where [v] is the payload READ OUT OF the head node's cell and [c] is the occurrence counter before the pop. *) -Theorem rot_body_spec: forall hdr a ns v vs h c, +Theorem rot_body_spec: forall hdr a ns v vs h allocs c, qrep hdr (a :: ns) (v :: vs) h -> - interp_state h_qE (rot_body hdr) (h, c) + interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), c) ~ (log (stamp v c) ;; - Ret (@inl unit unit tt, (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, S c))). + Ret (@inl unit unit tt, ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c))). Proof. - intros hdr a ns v vs h c Hq; unfold rot_body. + intros hdr a ns v vs h allocs c Hq; unfold rot_body. etransitivity. - eapply (queue_turn_spec h_indexed emit stamp). + intros; apply (interp_indexed_emit heap_handler). diff --git a/theories/Lang/CSL/Queue/Ticl.v b/examples/CSL/Queue/Ticl.v similarity index 67% rename from theories/Lang/CSL/Queue/Ticl.v rename to examples/CSL/Queue/Ticl.v index 9048836..e152eab 100644 --- a/theories/Lang/CSL/Queue/Ticl.v +++ b/examples/CSL/Queue/Ticl.v @@ -1,10 +1,10 @@ From Stdlib Require Import List. From TICL Require Import - Lang.CSL ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim + Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim ICTree.Logic.Trans ICTree.Logic.State ICTree.Logic.AG Logic.Core. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout - Lang.CSL.Queue.Frame Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating - Lang.CSL.Queue.Composition Lang.CSL.Queue.Program. +From examples Require Import CSL.Queue.Representation CSL.Queue.Layout + CSL.Queue.Frame CSL.Queue.Separation CSL.Queue.Alternating + CSL.Queue.Composition CSL.Queue.Program. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -12,67 +12,67 @@ Local Open Scope ticl_scope. Local Typeclasses Transparent equ sbisim. Theorem rotate_agaf_pop_rr : - forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) h c}, Pure + <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. - intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v h c). - exact (Composition.sched_agaf_q1 u v nl1 nl2 0 h c + intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v (h,allocs) c). + exact (Composition.sched_agaf_q1 u v nl1 nl2 0 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_q2 : - forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) h c}, Pure + <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. - intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v h c). - exact (Composition.sched_agaf_q2 u v nl1 nl2 0 h c + intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v (h,allocs) c). + exact (Composition.sched_agaf_q2 u v nl1 nl2 0 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_fresh : - forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) h c}, Pure + <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. - intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v h c). - exact (Composition.sched_agaf_q1_fresh u v nl1 nl2 k 0 h c + intros u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v (h,allocs) c). + exact (Composition.sched_agaf_q1_fresh u v nl1 nl2 k 0 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_q2_fresh : - forall u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) h c}, Pure + <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. - intros u v nl1 nl2 k h c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v h c). + intros u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v (h,allocs) c). From Coinduction Require Import coinduction. - exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h c + exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_owned : - forall u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, owned_queues u ns1 vs1 v ns2 vs2 h -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) h c}, Pure + <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. - intros u v nl1 nl2 h c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. + intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. destruct (owned_queues_sound u ns1 vs1 v ns2 vs2 h Hown) as (H1 & H2 & Hd). eapply rotate_agaf_pop_rr; eassumption. Qed. @@ -80,12 +80,12 @@ Qed. Theorem rotate_agaf_pop_alloc : forall values1 values2 nl1 nl2 c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. Proof. intros values1 values2 nl1 nl2 c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) - as (u & v & h & Finite & Owned & Run). + as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). @@ -95,12 +95,12 @@ Qed. Theorem rotate_agaf_pop_alloc_q2 : forall values1 values2 nl1 nl2 c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. Proof. intros values1 values2 nl1 nl2 c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) - as (u & v & h & Finite & Owned & Run). + as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). @@ -110,12 +110,12 @@ Qed. Theorem rotate_agaf_pop_alloc_fresh : forall values1 values2 nl1 nl2 k c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) - as (u & v & h & Finite & Owned & Run). + as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). @@ -125,12 +125,12 @@ Qed. Theorem rotate_agaf_pop_alloc_q2_fresh : forall values1 values2 nl1 nl2 k c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) hemp c}, Pure + <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. destruct (run_rr_allocated_parallel values1 values2 c) - as (u & v & h & Finite & Owned & Run). + as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as (H1 & H2 & Hd). @@ -138,10 +138,10 @@ Proof. Qed. Lemma parallel_queues_hemp_no_ag u v c (phi : ticllW (indexed (nat * nat))) w : - ~ <( {run_rr (parallel_queues u v) hemp c}, {w} |= AG phi )>. + ~ <( {run_rr (parallel_queues u v) managed_empty c}, {w} |= AG phi )>. Proof. rewrite (parallel_queues_hemp_stuck u v c); apply ag_stuck. Qed. Lemma allocated_parallel_queues_empty_no_ag values c (phi : ticllW (indexed (nat * nat))) w : - ~ <( {run_rr (allocated_parallel_queues [] values) hemp c}, {w} |= AG phi )>. + ~ <( {run_rr (allocated_parallel_queues [] values) managed_empty c}, {w} |= AG phi )>. Proof. rewrite (allocated_parallel_queues_empty_stuck values c); apply ag_stuck. Qed. diff --git a/theories/Lang/CSL/Queue/Trace.v b/examples/CSL/Queue/Trace.v similarity index 83% rename from theories/Lang/CSL/Queue/Trace.v rename to examples/CSL/Queue/Trace.v index 9017721..3b55013 100644 --- a/theories/Lang/CSL/Queue/Trace.v +++ b/examples/CSL/Queue/Trace.v @@ -27,7 +27,7 @@ From TICL Require Import ICTree.Logic.State Logic.Core. -From TICL Require Import Lang.CSL.Queue.Representation Lang.CSL.Queue.Sequential. +From examples Require Import CSL.Queue.Representation CSL.Queue.Sequential. Import ICtree ICTreeNotations TiclNotations ListNotations. Local Open Scope ictree_scope. @@ -41,16 +41,17 @@ Local Typeclasses Transparent sbisim. the rotated heap. This is [Sequential.rot_body_spec] lifted through the iteration; the [Guard] is discharged by [sb_guard], so no stuttering theory is needed. *) -Lemma run_step: forall hdr a ns v vs h c, +Lemma run_step: forall hdr a ns v vs h allocs c, qrep hdr (a :: ns) (v :: vs) h -> - run hdr h c - ~ (log (stamp v c) ;; run hdr (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h) (S c)). + run hdr (h, allocs) c + ~ (log (stamp v c) ;; + run hdr (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs) (S c)). Proof. - intros hdr a ns v vs h c Hq. + intros hdr a ns v vs h allocs c Hq. unfold run, rotate. rewrite interp_state_unfold_iter. cbv beta. - rewrite (rot_body_spec hdr a ns v vs h c Hq). + rewrite (rot_body_spec hdr a ns v vs h allocs c Hq). rewrite bind_bind. apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite bind_ret_l. @@ -76,7 +77,7 @@ Fixpoint qstepN (hdr: nat) (n: nat) (ns: list nat) (h: Heap) : Heap := (** The observation prefix of [n] rotations, with the continuation threaded so that no [bind]-associativity reasoning is needed. *) Fixpoint runN (hdr: nat) (n: nat) (ns vs: list nat) (h: Heap) (c: nat) - (k: ictreeW (indexed nat) (unit * Sig)) : ictreeW (indexed nat) (unit * Sig) := + (k: ictreeW (indexed nat) (unit * SSig)) : ictreeW (indexed nat) (unit * SSig) := match n with | 0 => k | S m => log (stamp (hd 0 vs) c) ;; @@ -107,16 +108,17 @@ Qed. (** [n] rotations of the run are [n] logged pops followed by the run from the [n]-times-rotated heap. *) -Theorem run_stepN: forall n hdr ns vs h c, +Theorem run_stepN: forall n hdr ns vs h allocs c, qrep hdr ns vs h -> ns <> [] -> - run hdr h c ~ runN hdr n ns vs h c (run hdr (qstepN hdr n ns h) (c + n)). + run hdr (h, allocs) c + ~ runN hdr n ns vs h c (run hdr (qstepN hdr n ns h, allocs) (c + n)). Proof. - induction n as [| n IH]; intros hdr ns vs h c Hq Hne. + induction n as [| n IH]; intros hdr ns vs h allocs c Hq Hne. - cbn [runN qstepN]; rewrite Nat.add_0_r; reflexivity. - destruct ns as [| a ns']; [contradiction |]. destruct vs as [| v vs']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. cbn [runN qstepN qstep hd]. - rewrite (run_step hdr a ns' v vs' h c Hq). + rewrite (run_step hdr a ns' v vs' h allocs c Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite <- Nat.add_succ_comm. apply (IH hdr (rotl (a :: ns')) (rotl (v :: vs'))). diff --git a/examples/CSL/README.md b/examples/CSL/README.md index 410a9f1..b7d6246 100644 --- a/examples/CSL/README.md +++ b/examples/CSL/README.md @@ -1,18 +1,23 @@ # Cooperative heap queues -`TICL.Lang.CSL` is a typed cooperative fork/yield language over a disjoint heap -PCM. `Lang.CSL.Queue.Program.allocated_parallel_queues values1 values2` constructs two linked -queues by source execution on `hemp`, then starts their workers. The lower-level -`Lang.CSL.Queue.Program.parallel_queues u v` remains available for preallocated heaps. Both +`TICL.Lang.CSL.Mod` is a typed cooperative fork/yield language over a disjoint heap +PCM. `examples.CSL.Queue.Program.allocated_parallel_queues values1 values2` constructs two linked +queues by source execution on `managed_empty`, then starts their workers. The lower-level +`examples.CSL.Queue.Program.parallel_queues u v` remains available for preallocated heaps. Both workers own **different queues in one shared heap**; they do not concurrently modify one queue, and the facade does not assert a general CSL parallel rule. ## Library ownership -Import `Lang.CSL` for the language, interpreter, source segments, and structural -TICL matrix. Import `Lang.CSL.Queue` for the reusable queue development. The old -example-local implementation modules were moved, not retained as compatibility -re-export files. +`ICTree.Interp.CSL.Mod` is the one CSL interpreter: the effect sum `sE`, the +state `SSig`, the payload-polymorphic handler `sh`, thread effects, the raw +physical-free laws, and the effect-level select/heap-free Ticl rules. It +imports no language or example. `Lang.CSL.Mod` is the one CSL language: `CProg`, +its denotation, source execution equations, exact first-yield segment rules, +and the structural Ticl matrix; it re-exports the interpreter. Import +`examples.CSL.Queue` for the queue development and `examples.CSL.Allocator.*` +for the allocator. The previous split implementation modules were removed, not +retained as compatibility re-export files. | Layer | Canonical reusable content | | --- | --- | @@ -24,9 +29,9 @@ re-export files. | `Utils.Relations` | Lexicographic ranks, bounded predicate search, interval counts, and infinite-occurrence facts | | `Utils.Lists` | Comparator-parametric first-match search and shared list-rotation lemmas | | `Utils.Vectors` | Pointwise update/removal/cons laws shared by pool equivalence and bisimulation | -| `Lang.CSL.Heap` | Checked heap laws shared by both observation alphabets | -| `Lang.CSL.Segments` | Exact and bisimilar first-yield segments, guard transport, arbitrary-pool ND/RR equations | -| `Lang.CSL.Queue` | Queue representation/layout, one polymorphic rotation implementation and proof, framing, composition, source programs, and recurrence | +| `ICTree.Interp.CSL.Mod` | CSL effects, managed state, the shared handler instance, raw free and select rules | +| `ICTree.Interp.Yield.Segments` | Exact and bisimilar first-yield segments, guard transport, arbitrary-pool ND/RR equations | +| `Lang.CSL.Mod` | CSL syntax, denotation, source execution equations, source segment rules, structural matrix | Concrete address layouts, overlap counterexamples, allocator-specific state machines and their fairness/rank arguments, and regression consumers remain in @@ -52,7 +57,7 @@ helpers were removed in favor of `inversion_0` and Stdlib's `wf_inverse_image`. Scheduler parity and allocator cursor proofs share `rr_pick_mod_congr`. Obsolete allocator transport/specialization helpers were removed, but unused public structural rules and substantive verification goals remain intentional -proof roots. In particular, the 130 CSL rules, `aur_schedule_update`, +proof roots. In particular, the 140 CSL rules, `aur_schedule_update`, `free_local_disj`, `free_local_frame`, and allocator safety/liveness results are not classified as dead merely because no other theorem references them. @@ -72,7 +77,7 @@ raw source denotations `BranchFree` predicate and closure proofs, and parity picker facts. `ICTree.Interp.Yield.RoundRobin` owns the handler-parametric pool interpreter and its eight execution equations. Neither module imports a language or example. -`Lang.CSL.Interp` instantiates that API with `sh`; it owns source-constructor +`Lang.CSL.Mod` instantiates that API with `sh`; it owns source-constructor execution equations and scoped-fork startup. No example-local pool interpreter or bridge module is used. @@ -96,18 +101,19 @@ primitive and no output generated from ghost payload lists. `Program.interp_rr_rotate_once` composes the source constructor rules for those instructions, preserving fault behavior and the entire post-emit heap suffix. `queue_pool_bisim` matches both failed-read cases and takes its coinductive step -at a real `Log (SPop ...)` transition, not at an administrative guard. +at a real `Log (stamp ...)` transition, not at an administrative guard. `Program.run_rr_parallel_bisim` proves equivalence of the actual `run_rr` source execution to the tagged cyclic reference for any heap, without unused queue representation premises. The reference alone is not evidence of source execution. `Program.run_rr_allocated_parallel` proves that actual silent allocation and -checked initialization from `hemp` reach a finite heap with two PCM-separated -queues and the original worker execution, at the same observation counter. +checked initialization from `managed_empty` reach a finite heap with two +PCM-separated queues, an allocation table recording both actual blocks, and the +original worker execution, at the same observation counter. It also covers empty input lists. No initialized heap is assumed. -`Lang.CSL.Queue.Ticl` exposes recurrence directly for -`run_rr (allocated_parallel_queues values1 values2) hemp c`: +`examples.CSL.Queue.Ticl` exposes recurrence directly for +`run_rr (allocated_parallel_queues values1 values2) managed_empty c`: - `rotate_agaf_pop_alloc`: queue 1 ordinary recurrence. - `rotate_agaf_pop_alloc_q2`: queue 2 ordinary recurrence. @@ -125,51 +131,61 @@ bisimulation. The lower-level statements remain: - `rotate_agaf_pop_rr_q2_fresh`: queue 2 recurrence at every inclusive index bound. - `rotate_agaf_pop_rr_owned`: queue 1 recurrence from actual PCM separation. -Each lower-level conclusion is `AG (AF visW {...})` over `run_rr (parallel_queues u v) h c`. +Each lower-level conclusion is `AG (AF visW {...})` over +`run_rr (parallel_queues u v) (h,allocs) c` for an arbitrary extent table `allocs`. Both membership premises remain: both workers must be nonempty and productive for recurrence. The internal execution bisimulation also covers faulty heaps. -Freshness means `k <= sidx`; `sfresh_excludes_retained` prevents counting an old -observation at index `j` toward the bound `S j`. +Freshness is `indexed_after P k`: the payload satisfies `P` and its occurrence +index is at least `k`. `ICTree.Logic.Trace.indexed_excludes_retained` prevents +counting an old observation at index `j` toward the bound `S j`. ## Heap and ownership contract -The canonical heap is `nat -> option nat`, with pointwise `heq`, pointwise +The canonical data heap is `nat -> option nat`, with pointwise `heq`, pointwise `hdisj`, and left-biased `hunion`. This representation does **not** impose finite support. `heap_finite` is an existential proof bound, not a new carrier or runtime -field. `SSig` remains `(Heap * nat)%type`; results remain `(result, SSig)`. +field. The managed memory `ManagedHeap := Heap * AllocationTable` pairs the data +heap with the live malloc extents (base to positive length, same partial-map +representation); `ProductPCM` gives it componentwise separation, so an extent +record is an owned resource. `SSig` is `(ManagedHeap * nat)%type`, a state is +`((h,allocs),c)`, and results remain `(result, SSig)`. Runners start at +`managed_empty` or an explicit `(h,allocs)`; preallocated data uses `(h,hemp)`. `Events.HeapE` supplies the single shared command algebra: `HRead`, `HWrite`, `HAlloc`, `HFree`, and `HCAS`. `ICTree.Events.Heap` supplies the polymorphic `heap_read`, `heap_write`, `heap_alloc`, `heap_free`, and `heap_cas` triggers. Neither module imports a language, concrete heap, allocator, or observation type. -CSL uses `sE := heapE + writerE (nat * nat)`; QLang uses -`qE := heapE + writerE nat`. Their observation handlers are separate from the -shared checked `heap_handler`, whose allocation search is polymorphic in the -observation alphabet. +CSL uses `sE := heapE + writerE (nat * nat)`; the sequential queue model uses +`qE := heapE + writerE nat`. Both are interpreted by the one payload-polymorphic +`sh := h_sum heap_handler h_indexed`, at payloads `nat * nat` and `nat`. `CAlloc size` uses `heap_alloc`/`HAlloc` and a guarded, constructive search inside the shared handler. It returns the least positive base whose entire interval is free and initializes exactly `size` cells to zero, preserving every old allocated value and address zero. It neither emits nor yields, and advances neither the observation counter nor the scheduler cursor. There is no runtime fuel, -caller-selected base, heap-wide maximum, classical choice, or allocation log. +caller-selected base, heap-wide maximum, classical choice, or separate allocation +log; success records exactly `upd allocs base size` in the extent table. Size zero is `stuck`. Positive requests terminate on every finite heap; an infinite heap with no suitable interval silently diverges, as proved by `alloc_search_no_space`. This is not a finite-memory exhaustion policy. Reads and writes remain checked; writes never allocate implicitly. Emit records -`SPop tag value c`, preserves the heap, and increments the global observation -counter. CAS faults on an absent cell, updates and returns `true` on a matching -value, and otherwise returns `false` without changing the heap. It does not log. -The scheduler cursor is separate. There is no variable store, lock, or implicit -read/write yield. - -`HFree a` removes exactly one cell via `Pcm.hfree`, without a presence check, -observation, or counter change. An absent free succeeds; a subsequent read of -that address faults. `free_local_frame` still requires ownership of the removed -cell. Physical free is available to raw CSL threads, not a new `CFree` syntax -constructor; the allocator example's `remote_free` remains CAS-based free-list -publication, not heap deletion. +`stamp (tag,value) c`, preserves the managed memory, and increments the global +observation counter. CAS faults on an absent cell, updates and returns `true` on +a matching value, and otherwise returns `false` without changing the heap. It +does not log. The scheduler cursor is separate. There is no variable store, +lock, or implicit read/write yield. + +`CFree base` (`HFree base`) is whole-block free through `managed_free`: at a +live recorded base it removes every cell of exactly that extent and its extent +record. `CFree 0` is a no-op even if address zero holds data. Every other free — +an interior pointer, an unknown base, or a second free of the same base — is +`stuck`, as are later reads, writes, and CAS on released cells. Free neither +emits nor yields, and changes neither the counter nor the cursor. +`managed_free_frame` releases exactly an owned `block_owned` resource while +preserving any disjoint frame. The allocator example's `remote_free` remains +CAS-based free-list publication, not heap deletion. HeapImp lowers the same five commands to its existing `Get`/`Put` effects. Its association-list policies remain different: writes may create a cell, @@ -191,28 +207,30 @@ functions by Leibniz equality. ## Structural temporal interface -`From TICL Require Import Lang.CSL.` exports `Lang.CSL.Ticl`. Its 100 source rules -are the full name product -`{anl,anr,aul,aur,ag}_csl_{nd,rr}_{read,write,emit,yield,fork,ret,bind,until_none,alloc,cas}`. +`From TICL Require Import Lang.CSL.Mod.` exports the full matrix. Its 110 +source rules are the name product +`{anl,anr,aul,aur,ag}_csl_{nd,rr}_{read,write,emit,yield,fork,ret,bind,until_none,alloc,cas,free}`. They apply to arbitrary nonempty focused pools and continuations, not only queue -or allocator fixtures. Another 30 rules use suffixes `select`, `alloc_finite`, -and `heap_free`, giving 130 independently named equivalences. +or allocator fixtures. Another 30 rules use suffixes `select` and `heap_free` +(effect level, in `ICTree.Interp.CSL.Mod`) and `alloc_finite`, giving 140 +independently named equivalences. Silent rules transport the interpreted residual in the same world. Emit rules keep the current-prefix obligation in the old world and place only the successor -in `Obs (Log (SPop tag value c)) tt`. ND yield checks every branch, including the +in `Obs (Log (stamp (tag,value) c)) tt`. ND yield checks every branch, including the single branch of a singleton pool; RR yield selects `rr_pick n m` and advances only the cursor. Fork prepends its child but keeps the parent focused. Bind and until preserve the pool and the outer `None` halt flow. These rules assert no fairness or unconditional loop termination. `interp_nd_source_` and `interp_rr_` expose the checked success and fault normal -forms in `Lang.CSL.Interp`; the promoted read/write helpers are public there. -Finite-allocation rules quantify over the first-fit witness supplied by -`heap_finite`, rather than requiring a caller-chosen address. Raw `heap_free` -rules take a `unit` continuation and preserve focus, pool size, cursor, counter, -and observation world. Fault rules compose with the generic stuck rules: -strong AN and AG are false, while AU may match its target immediately. +forms in `Lang.CSL.Mod`, including `*_free`/`*_free_invalid` and the +read/write/CAS `*_missing` faults. Finite-allocation rules quantify over the +first-fit witness supplied by `heap_finite`, rather than requiring a +caller-chosen address. Free rules require `managed_free memory base = Some +memory'` and preserve focus, pool size, cursor, counter, and observation world. +Fault rules compose with the generic stuck rules: strong AN and AG are false, +while AU may match its target immediately. ## Runtime queue construction @@ -247,17 +265,17 @@ S = /home/eioannidis/ticl-sl/spark_submission/experiments/separate-active-compos | Source | Current owner | | --- | --- | | `P/Pcm.v`, complete | `theories/Utils/Pcm.v` (interface), `theories/Events/HeapModel.v` (heap model) | -| `S/SLang.v`, heap prefix | `theories/Lang/CSL/Heap.v` | -| `Q/HeapQ.v` | `theories/Lang/CSL/Queue/Representation.v` | -| `Q/QLang.v` | `theories/Lang/CSL/Queue/Sequential.v`, shared `Operations.v` | -| `Q/Recurrence.v` | `theories/Lang/CSL/Queue/Recurrence.v`, `ICTree/Logic/State.v`, `Utils/Relations.v` | -| `Q/Trace.v` | `theories/Lang/CSL/Queue/Trace.v` | -| `Q/Layout.v` | `theories/Lang/CSL/Queue/Layout.v`; stride-two node geometry in `theories/Events/HeapModel.v` | -| `Q/Frame.v` | `theories/Lang/CSL/Queue/Frame.v` | -| `S/Sep2.v` | `theories/Lang/CSL/Queue/Separation.v` | -| `S/SLang.v`, turn/scheduler suffix | `theories/Lang/CSL/Queue/Alternating.v`, shared `Operations.v` | +| `S/SLang.v`, heap prefix | `theories/ICTree/Interp/CSL/Mod.v` | +| `Q/HeapQ.v` | `examples/CSL/Queue/Representation.v` | +| `Q/QLang.v` | `examples/CSL/Queue/Sequential.v`, shared `Operations.v` | +| `Q/Recurrence.v` | `examples/CSL/Queue/Recurrence.v`, `ICTree/Logic/State.v`, `Utils/Relations.v` | +| `Q/Trace.v` | `examples/CSL/Queue/Trace.v` | +| `Q/Layout.v` | `examples/CSL/Queue/Layout.v`; stride-two node geometry in `theories/Events/HeapModel.v` | +| `Q/Frame.v` | `examples/CSL/Queue/Frame.v` | +| `S/Sep2.v` | `examples/CSL/Queue/Separation.v` | +| `S/SLang.v`, turn/scheduler suffix | `examples/CSL/Queue/Alternating.v`, shared `Operations.v` | | `S/Lex.v` | `theories/Utils/Relations.v` | -| `S/Compose.v` | `theories/Lang/CSL/Queue/Composition.v` | +| `S/Compose.v` | `examples/CSL/Queue/Composition.v` | | `Q/Overlap.v` | `examples/CSL/Overlap.v` | The initial donor integration preserved the resource and observable contracts. @@ -284,25 +302,31 @@ donor dependency and changes no generic scheduler or refiner API. ## Behavioral verification -Verification uses the actual proof development and its source programs; there -are no separate test, smoke, or fixture modules. The former regression -consumers were reduced to general statements in their semantic owners: +Verification uses the actual proof development and its source programs. The +regression consumers are general statements in their semantic owners, plus one +lifecycle consumer of the source language: - `Events.HeapModel`: `block_pto_overlap_false` (a block and an overlapping - points-to cannot separate) and `hfree_absent_noop` (freeing an absent cell is - pointwise the identity). + points-to cannot separate), `hfree_absent_noop` (deleting an absent key of a + partial map is pointwise the identity; a CSL `CFree` of a non-base address is + `stuck` instead), and `managed_free_frame` (whole-block free releases exactly + an owned `block_owned` resource and preserves a disjoint frame). - `Lang.HeapImp.HeapImp`: the five `instr_heapimp_*` equations for zero allocation, free, write, and successful/failed CAS. Same-value CAS still logs; a mismatching CAS does not. - `ICTree.Eq.Bind.equ_guard_stuck`: a tree raw-equivalent to its own guard is raw-equivalent to `stuck`. -- `Lang.CSL.Ticl`: `run_{nd,rr}_emit_loop_ag` (a productive `CUntilNone` loop +- `Lang.CSL.Mod`: `run_{nd,rr}_emit_loop_ag` (a productive `CUntilNone` loop satisfies `AG ⊤` in every not-done world) and `run_{nd,rr}_silent_loop_no_ag` - (a silent loop is `stuck`, hence fails `AG ⊤`), beside the unchanged 130 rules. -- `Lang.CSL.Queue.Program`: `parallel_queues_four_pop_bisim` (the exact first + (a silent loop is `stuck`, hence fails `AG ⊤`), beside the structural matrix. +- `examples/CSL/Memory.v`: `lifecycle_scope` (both CAS outcomes, adjacent + first-fit blocks, whole-extent release, and the exact stamp sequence), + `reuse_first_fit`, `free_null_unchanged`, and the `*_stuck` faults for + interior-pointer free, double free, and read/write/CAS after free. +- `examples.CSL.Queue.Program`: `parallel_queues_four_pop_bisim` (the exact first four pops of any two represented, disjoint queues, then the reference loop; payloads may repeat), `parallel_queues_hemp_stuck`, and - `allocated_parallel_queues_empty_stuck`; `Lang.CSL.Queue.Ticl` derives the two + `allocated_parallel_queues_empty_stuck`; `examples.CSL.Queue.Ticl` derives the two corresponding `*_no_ag` results for an arbitrary formula. - `examples/CSL/Overlap.v` and `examples/CSL/Allocator/Counterexamples.v` keep their witness queue, heaps, scripts, and observation tables as section-local @@ -310,79 +334,8 @@ consumers were reduced to general statements in their semantic owners: `dune build` compiles all of them. -## Trust-base audit - -`coqtop -quiet -Q _build/default/theories TICL -Q _build/default/examples examples` -ran the post-build `Print Assumptions` audit for `sh_alloc_finite`, -`interp_rr_alloc`, `interp_rr_new_queue`, `run_rr_allocated_parallel`, -`run_rr_parallel_bisim`, and all four new dynamic recurrence theorems. -The changed `.v` files contain no `Admitted`, `admit`, `Axiom`, `Parameter`, -`Classical`, or choice declaration. Imports were checked for obsolete State -paths, HQ dependencies, donor runtime paths, and layer violations. - -The structural-rule audit separately checked `anl_csl_nd_yield`, -`anr_csl_rr_emit`, `aul_csl_nd_until_none`, `aur_csl_rr_cas`, -`ag_csl_rr_until_none`, `aur_csl_nd_alloc_finite`, `ag_csl_rr_alloc_finite`, -`anr_csl_nd_heap_free`, `ag_csl_rr_heap_free`, `run_nd_emit_loop_ag`, and -`run_rr_emit_loop_ag` through `rocq_assumptions`. Each reports only the inherited -`FunctionalExtensionality.functional_extensionality_dep` and -`Eqdep.Eq_rect_eq.eq_rect_eq`. No new axiom or unfinished proof command was -introduced; the new heap postconditions do not identify functions by -functional extensionality. - -The library extraction audit found `Utils.Relations.finite_first` closed under -the global context. `ICTree.Logic.State.aul_state_iter_ghost` and -`ICTree.Trace.rr_aligned_sbisim` use only inherited UIP. The generalized -`ICTree.Interp.Yield.Segments.segment_scheduler_steps` uses inherited UIP and -dependent functional extensionality. - -The list-search deduplication audit found `find_index_rotl_pres`, -`vector_replace_pointwise`, and `rr_pick_mod_congr` closed under the global -context. - -The previously recorded baseline `examples.Queue.Queue.rotate_agaf_pop` prints: +## Assumptions -```text -Axioms: -Eqdep.Eq_rect_eq.eq_rect_eq : - forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p), - x = eq_rect p Q x p h -MeQ.ME.T : Type -MeQ.ME.HDec : RelDec.RelDec eq -MeQ.ME.HCor : RelDec.RelDec_Correct MeQ.ME.HDec -``` - -`interp_schedule_rr_user` and `denote_branchfree` print only the same inherited -`Eqdep.Eq_rect_eq.eq_rect_eq` axiom. `run_rr_fork_bind`, -`run_rr_parallel_bisim`, and the five lower-level source recurrence theorems print: - -```text -Axioms: -FunctionalExtensionality.functional_extensionality_dep : - forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), - (forall x : A, f x = g x) -> f = g -Eqdep.Eq_rect_eq.eq_rect_eq : - forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p), - x = eq_rect p Q x p h -``` - -The dynamic audit found only the already accepted assumptions: - -| Audited theorem | Assumptions | -|---|---| -| `Heap.sh_alloc_finite` | `Eqdep.Eq_rect_eq.eq_rect_eq` (UIP) | -| `Interp.interp_rr_alloc` | UIP and dependent functional extensionality | -| `Program.interp_rr_new_queue` | UIP and dependent functional extensionality | -| `Program.run_rr_allocated_parallel` | UIP and dependent functional extensionality | -| `Program.run_rr_parallel_bisim` | UIP and dependent functional extensionality | -| All four `Queue.rotate_agaf_pop_alloc*` theorems | UIP and dependent functional extensionality | - -The functional-extensionality dependency is inherited from the **pre-existing** -`ICTree.Interp.Yield.SBisim.schedule_pool_proper`, whose `Print Assumptions` -reports those same two axioms. That scheduler proof was not changed. -`interp_schedule_rr_equ` consumes it as required by the pool-congruence API. -This is not an added heap-extensionality axiom: `HeapModel.HeapCancellative` and -`Queue.Separation.owned_queues_sound` each print `Closed under the global context`. -There is no new admitted constant, allocator-choice or finite-support oracle, -assumed initialization correctness, fairness or recurrence axiom, or assumed -program bisimulation. +The CSL development adds no `Axiom`, `Parameter`, `Admitted`, or `admit`. It +uses no allocator-choice or finite-support oracle and assumes no initialization +correctness, fairness, recurrence, or program bisimulation. diff --git a/theories/Events/HeapModel.v b/theories/Events/HeapModel.v index c5e8f80..a982a33 100644 --- a/theories/Events/HeapModel.v +++ b/theories/Events/HeapModel.v @@ -8,9 +8,11 @@ This module owns the *pure* heap: its PCM instance, its points-to and framing laws, the single update primitive [upd], the finite-block algebra - used by allocation, and the stride-two node geometry shared by the queue - and the allocator. It is deliberately distinct from [ICTree.Events.Heap], - which only builds [heapE] triggers. + used by allocation, the allocation table recording live malloc extents + (with whole-block release and its well-formedness/framing laws), and the + stride-two node geometry shared by the queue and the allocator. It is + deliberately distinct from [ICTree.Events.Heap], which only builds + [heapE] triggers. Heap equality stays POINTWISE ([heq]). Nothing here converts it to function equality or assumes extensionality. *) @@ -445,6 +447,229 @@ Proof. replace (S base + offset)%nat with (base + S offset)%nat by lia; apply F; lia. Qed. +(** ** Allocation provenance + + A managed heap pairs the data heap with an allocation table that records + each live malloc block by its base and positive length. The table reuses + the natural-keyed partial-map representation of [Heap]; its values are + block lengths, not memory contents. [ProductPCM] gives the pair its + componentwise equivalence and separation algebra, so the allocation token + is owned together with the cells it describes. *) + +Definition AllocationTable : Type := Heap. +Definition ManagedHeap : Type := (Heap * AllocationTable)%type. +Definition managed_empty : ManagedHeap := (hemp, hemp). + +Definition hfree_block (base size : nat) (h : Heap) : Heap := + fun x => if andb (Nat.leb base x) (Nat.ltb x (base + size)) + then None else h x. + +Definition managed_alloc (memory : ManagedHeap) (base size : nat) : ManagedHeap := + (hunion (hblock base size) (fst memory), upd (snd memory) base size). + +Definition managed_free (memory : ManagedHeap) (base : nat) : option ManagedHeap := + if Nat.eqb base 0 then Some memory else + match snd memory base with + | Some (S n) => Some (hfree_block base (S n) (fst memory), + hfree base (snd memory)) + | _ => None + end. + +Definition managed_wf (memory : ManagedHeap) : Prop := + (forall base size, snd memory base = Some size -> + 0 < base /\ 0 < size /\ + (forall x, base <= x /\ x < base + size -> fst memory x <> None)) /\ + (forall b1 n1 b2 n2, + snd memory b1 = Some n1 -> snd memory b2 = Some n2 -> b1 <> b2 -> + b1 + n1 <= b2 \/ b2 + n2 <= b1). + +Definition block_owned (base size : nat) : assn ManagedHeap := + fun memory => 0 < base /\ 0 < size /\ + heq (snd memory) (hsingle base size) /\ + (forall x, fst memory x <> None <-> base <= x /\ x < base + size). + +Lemma hfree_block_in base size (h : Heap) x : + base <= x /\ x < base + size -> hfree_block base size h x = None. +Proof. + intro H; unfold hfree_block. + destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); + cbn; try reflexivity; lia. +Qed. + +Lemma hfree_block_out base size (h : Heap) x : + x < base \/ base + size <= x -> hfree_block base size h x = h x. +Proof. + intro H; unfold hfree_block. + destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); + cbn; try reflexivity; lia. +Qed. + +Lemma hfree_block_finite base size (h : Heap) : + heap_finite h -> heap_finite (hfree_block base size h). +Proof. + intros [B HB]; exists B; intros x X; unfold hfree_block. + destruct (andb _ _); [reflexivity | now apply HB]. +Qed. + +Lemma managed_wf_empty : managed_wf managed_empty. +Proof. split; cbn; intros; discriminate. Qed. + +Lemma managed_wf_preallocated (h : Heap) : managed_wf (h,hemp). +Proof. split; cbn; intros; discriminate. Qed. + +Lemma managed_write_preserves_wf (h : Heap) (allocs : AllocationTable) a v : + managed_wf (h,allocs) -> managed_wf (upd h a v,allocs). +Proof. + intros [W D]; split; [| exact D]; cbn [fst snd] in *. + intros base size Hs; destruct (W base size Hs) as (Hb & Hn & C). + split; [exact Hb | split; [exact Hn |]]. + intros x Hx; apply upd_mono, C, Hx. +Qed. + +(** Two intervals, one free and one allocated in the same heap, cannot + overlap. Both must be nonempty for the overlap witness to exist. *) +Lemma block_free_allocated_disjoint (h : Heap) base size b n : + 0 < size -> 0 < n -> block_free h base size -> + (forall x, b <= x /\ x < b + n -> h x <> None) -> + base + size <= b \/ b + n <= base. +Proof. + intros Hs Hn F C. + destruct (Nat.le_gt_cases (base + size) b) as [L | L]; [now left |]. + destruct (Nat.le_gt_cases (b + n) base) as [R | R]; [now right |]. + exfalso; apply (C (Nat.max base b)); [lia |]. + replace (Nat.max base b) with (base + (Nat.max base b - base)) by lia. + apply F; lia. +Qed. + +Lemma managed_alloc_preserves_wf (memory : ManagedHeap) base size : + managed_wf memory -> 0 < base -> 0 < size -> + block_free (fst memory) base size -> + managed_wf (managed_alloc memory base size). +Proof. + destruct memory as [h allocs]; intros [W D] Hb Hs F. + unfold managed_alloc, managed_wf in *; cbn [fst snd] in *. + assert (Old : forall b n, b <> base -> upd allocs base size b = Some n -> + allocs b = Some n /\ 0 < b /\ 0 < n /\ + (forall x, b <= x /\ x < b + n -> h x <> None)). + { intros b n Hne Hl; rewrite upd_neq in Hl by exact Hne. + destruct (W b n Hl) as (? & ? & ?); auto. } + assert (Apart : forall b n, b <> base -> upd allocs base size b = Some n -> + base + size <= b \/ b + n <= base). + { intros b n Hne Hl; destruct (Old b n Hne Hl) as (_ & _ & Hn & C). + eapply block_free_allocated_disjoint; eauto. } + split. + - intros b n Hl; destruct (Nat.eq_dec b base) as [-> | Hne]. + + rewrite upd_eq in Hl; injection Hl as <-. + split; [exact Hb | split; [exact Hs |]]. + intros x Hx; unfold hunion. + replace x with (base + (x - base)) by lia. + rewrite hblock_in by lia; discriminate. + + destruct (Old b n Hne Hl) as (_ & Hb' & Hn & C). + split; [exact Hb' | split; [exact Hn |]]. + intros x Hx; unfold hunion; destruct (hblock base size x); [discriminate | now apply C]. + - intros b1 n1 b2 n2 H1 H2 Hne. + destruct (Nat.eq_dec b1 base) as [-> | N1]; + destruct (Nat.eq_dec b2 base) as [-> | N2]. + + contradiction. + + rewrite upd_eq in H1; injection H1 as <-. + destruct (Apart b2 n2 N2 H2); lia. + + rewrite upd_eq in H2; injection H2 as <-. + destruct (Apart b1 n1 N1 H1); lia. + + rewrite upd_neq in H1 by exact N1; rewrite upd_neq in H2 by exact N2. + exact (D b1 n1 b2 n2 H1 H2 Hne). +Qed. + +Lemma managed_free_preserves_wf (memory memory' : ManagedHeap) base : + managed_wf memory -> managed_free memory base = Some memory' -> + managed_wf memory'. +Proof. + destruct memory as [h allocs]; intros [W D] Hf; unfold managed_free in Hf. + cbn [fst snd] in *. + destruct (Nat.eqb_spec base 0) as [_ | Hb0]. + { injection Hf as <-; split; assumption. } + destruct (allocs base) as [[| n] |] eqn:Eb; try discriminate. + injection Hf as <-. + assert (Old : forall b s, hfree base allocs b = Some s -> b <> base /\ allocs b = Some s). + { intros b s Hl; unfold hfree in Hl. + destruct (Nat.eq_dec base b) as [_ | Hne]; [discriminate | auto]. } + unfold managed_wf; cbn [fst snd]; split. + - intros b s Hl; destruct (Old b s Hl) as [Hne Hl']. + destruct (W b s Hl') as (Hb & Hs & C). + split; [exact Hb | split; [exact Hs |]]. + intros x Hx; destruct (D b s base (S n) Hl' Eb Hne). + + rewrite hfree_block_out by lia; now apply C. + + rewrite hfree_block_out by lia; now apply C. + - intros b1 n1 b2 n2 H1 H2 Hne. + destruct (Old b1 n1 H1) as [_ H1']; destruct (Old b2 n2 H2) as [_ H2']. + exact (D b1 n1 b2 n2 H1' H2' Hne). +Qed. + +Lemma block_owned_proper base size : + @AProper ManagedHeap _ (block_owned base size). +Proof. + intros [h a] [h' a'] [Hh Ha] (Hb & Hs & Ht & Hd). + unfold block_owned in *; cbn [fst snd] in *. + split; [exact Hb | split; [exact Hs | split]]. + - eapply heq_trans; [apply heq_sym, Ha | exact Ht]. + - intro x; rewrite <- (Hh x); apply Hd. +Qed. + +Lemma managed_alloc_sep (memory : ManagedHeap) base size (P : assn ManagedHeap) : + 0 < base -> 0 < size -> block_free (fst memory) base size -> + snd memory base = None -> P memory -> + asep (block_owned base size) P (managed_alloc memory base size). +Proof. + destruct memory as [h allocs]; intros Hb Hs F Hn HP; cbn in F, Hn. + exists (hblock base size, hsingle base size), (h, allocs). + split; [| split; [| split; [| exact HP]]]; cbn. + - split; [apply block_free_disjoint, F |]. + intro x; unfold hsingle; destruct (Nat.eq_dec base x) as [-> | _]; auto. + - split; [apply heq_refl |]. + intro x; unfold upd, hunion, hsingle. + destruct (Nat.eqb_spec x base) as [E | Hne]; + destruct (Nat.eq_dec base x); subst; congruence. + - split; [exact Hb | split; [exact Hs | split; [apply heq_refl |]]]. + intro x; cbn [fst]; unfold hblock. + destruct (Nat.leb_spec0 base x); destruct (Nat.ltb_spec0 x (base + size)); + cbn; split; intro H; + first [ (intro C; discriminate) | lia + | (exfalso; apply H; reflexivity) | (exfalso; lia) ]. +Qed. + +Lemma managed_free_frame (owned frame : ManagedHeap) base size : + pdef owned frame -> block_owned base size owned -> + exists freed, managed_free (pop owned frame) base = Some freed /\ peq freed frame. +Proof. + destruct owned as [ho ao], frame as [hf af]. + intros [Dh Da] (Hb & Hs & Ha & Hd); cbn in *. + destruct size as [| n]; [lia |]. + assert (Ab : hunion ao af base = Some (S n)). + { unfold hunion; rewrite (Ha base); unfold hsingle. + destruct (Nat.eq_dec base base); [reflexivity | contradiction]. } + unfold managed_free; cbn [fst snd]. + destruct (Nat.eqb_spec base 0) as [E | _]; [lia |]. + rewrite Ab; eexists; split; [reflexivity |]. + cbn; split; intro x. + - destruct (Nat.le_gt_cases base x) as [L | L]; + [destruct (Nat.lt_ge_cases x (base + S n)) as [R | R] |]. + + rewrite hfree_block_in by lia. + destruct (ho x) as [v |] eqn:Ex. + * symmetry; eapply hdisj_none; eauto. + * exfalso; apply (proj2 (Hd x)); [lia | exact Ex]. + + rewrite hfree_block_out by lia; apply hunion_none. + destruct (ho x) eqn:Ex; [| reflexivity]. + exfalso; destruct (proj1 (Hd x)); [congruence | lia]. + + rewrite hfree_block_out by lia; apply hunion_none. + destruct (ho x) eqn:Ex; [| reflexivity]. + exfalso; destruct (proj1 (Hd x)); [congruence | lia]. + - unfold hfree; destruct (Nat.eq_dec base x) as [<- | Hne]. + + symmetry; eapply hdisj_none; [exact Da |]. + rewrite (Ha base); unfold hsingle. + destruct (Nat.eq_dec base base); [reflexivity | contradiction]. + + apply hunion_none; rewrite (Ha x); unfold hsingle. + destruct (Nat.eq_dec base x); [contradiction | reflexivity]. +Qed. + (** ** Stride-two node geometry. A node named [a] owns exactly two cells: [a] and [S a]. Stride two, null diff --git a/theories/ICTree/Interp/CSL/Mod.v b/theories/ICTree/Interp/CSL/Mod.v new file mode 100644 index 0000000..f03fe38 --- /dev/null +++ b/theories/ICTree/Interp/CSL/Mod.v @@ -0,0 +1,480 @@ +(** * The canonical CSL effect interpreter. + + This module owns the CSL effect sum, its interpretation state and the one + payload-polymorphic handler [sh] that pairs the shared checked heap with + the shared indexing writer. Everything here is stated over effects and + trees: it does not mention CSL syntax. The source language + ([Lang.CSL.Mod]) specializes these laws to its denotation. + + Generic checked heap access, allocation search, indexed observation and + the scheduler/segment machinery live one layer further down and are + re-exported from here. *) + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector. + +From ExtLib Require Import + Structures.MonadState + Data.Monads.StateMonad. + +From Coinduction Require Import coinduction lattice tactics. + +From TICL Require Export + Events.HeapModel + ICTree.Events.Heap + ICTree.Events.Writer + ICTree.Interp.Heap + ICTree.Logic.Heap + ICTree.Trace + ICTree.Interp.Refine + ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Yield.Segments. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Trans + ICTree.Events.State + ICTree.Events.Yield + ICTree.Interp.State.Mod + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin + ICTree.Logic.Trans + ICTree.Logic.CanStep + ICTree.Logic.AX + ICTree.Logic.AF + ICTree.Logic.AG + ICTree.Logic.Bind + ICTree.Logic.Iter + ICTree.Logic.State + Logic.World + Logic.Core + Utils.Vectors. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. + +(** ** Effects and interpretation state *) + +(** [sE] is a notation, not a definition: the payload-polymorphic handler + [sh] below is typed over [heapE + writerE A], so instantiating it at the + tagged payload yields this sum syntactically, and rewrites stated over + [sE] keep matching terms elaborated through [sh]. *) +Notation sE := (heapE + writerE (nat * nat))%type. + +Definition semit (q v : nat) : ictree sE unit := + ICtree.trigger (Log (q,v)). + +(** Interpretation state: the SHARED managed memory (data heap and live + allocation extents) and one GLOBAL occurrence counter. A state is + [((h,allocs),c)]. *) +Notation SSig := (ManagedHeap * nat)%type. + +(** The one CSL handler: the shared checked-heap handler summed with the + shared indexing handler. It is polymorphic in the observation payload; + the tagged source language uses [nat * nat], a unary reference model uses + [nat]. The occurrence index is supplied by [h_indexed], which owns the + counter and passes the managed memory through unchanged. *) +Definition sh {A : Type} : + (heapE + writerE A) ~> stateT SSig (ictreeW (indexed A)) := + h_sum heap_handler h_indexed. + +(** ** Thread effects *) + +Definition CEff := (yieldE + (forkE + sE))%type. +#[global] Instance ReSum_heap_CEff : ReSum heapE CEff := + fun e => inr (inr (inl e)). +#[global] Instance ReSumRet_heap_CEff : ReSumRet heapE CEff := + fun e response => response. +#[global] Instance ReSum_tagged_CEff : ReSum (writerE (nat * nat)) CEff := + fun e => inr (inr (inr e)). +#[global] Instance ReSumRet_tagged_CEff : ReSumRet (writerE (nat * nat)) CEff := + fun e response => response. +Definition source_yield : ictree CEff unit := + Vis (inl Yield) (fun _ => Ret tt). +Definition source_fork : ictree CEff bool := + Vis (inr (inl Fork)) (fun b => Ret b). + +(** ** The two response-relation instances of the generic segment theory. *) +Notation csl_sb := + (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ~ u). +Notation csl_equ := + (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ≅ u). + +(** ** Raw physical free through the shared heap event *) + +Lemma raw_heap_free_head a (K : unit -> thread sE) : + (heap_free (E:=CEff) a >>= K) ≅ + Vis (inr (inr (inl (HFree a)))) K. +Proof. + unfold heap_free, ICtree.trigger, resum, resum_ret, + ReSum_heap_CEff, ReSumRet_heap_CEff. + rewrite bind_vis; setoid_rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c : + managed_free memory base = Some memory' -> + interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c) ~ + interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c). +Proof. + intro Free. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree base)))) K) + (Some i) m (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user with (e:=inl (HFree base)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (heap_handler_free base memory memory' c Free) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_heap_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory : ManagedHeap) c : + managed_free memory base = None -> + interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Invalid. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree base)))) K) + (Some i) m (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_user with (e:=inl (HFree base)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (heap_handler_free_invalid base memory c Invalid) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c : + managed_free memory base = Some memory' -> + interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c) ~ + interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c). +Proof. + intro Free. + pose proof ((interp_schedule_nd_equ sh) (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree base)))) K) + (Some i) (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. + rewrite Hpool. + erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree base)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (heap_handler_free base memory memory' c Free) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_heap_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory : ManagedHeap) c : + managed_free memory base = None -> + interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Invalid. + pose proof ((interp_schedule_nd_equ sh) (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) + (ts @ i := Vis (inr (inr (inl (HFree base)))) K) + (Some i) (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. + rewrite Hpool. + erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree base)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (heap_handler_free_invalid base memory c Invalid) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Local Typeclasses Transparent equ sbisim. + +(** ** Selection from an unfocused nonempty pool *) + +Lemma anl_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + ts (None) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + ts (Some j) (memory,c)}, {w} |= ψ )>)). +Proof. + rewrite (interp_schedule_nd_select sh). + apply anl_br. +Qed. + +Lemma anr_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + ts (None) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + ts (Some j) (memory,c)}, {w} |= ψ ]>)). +Proof. + rewrite (interp_schedule_nd_select sh). + apply anr_br. +Qed. + +Lemma aul_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + ts (None) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= ψ )> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + ts (Some j) (memory,c)}, {w} |= φ AU ψ )>))). + +Proof. + rewrite (interp_schedule_nd_select sh). + symmetry; apply aul_br. +Qed. + +Lemma aur_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + ts (None) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= ψ ]> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + ts (Some j) (memory,c)}, {w} |= φ AU ψ ]>))). +Proof. + rewrite (interp_schedule_nd_select sh). + symmetry; apply aur_br. +Qed. + +Lemma ag_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + ts (None) (memory,c)}, {w} |= AG φ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + ts (Some j) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_schedule_nd_select sh). + symmetry; apply ag_br. +Qed. + +Lemma anl_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma anr_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma aul_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma aur_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +Lemma ag_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_schedule_rr_select; reflexivity. +Qed. + +(** ** Valid whole-block free through the shared raw heap event *) + +Lemma anl_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AN ψ )>). +Proof. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma anr_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + <[ {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AN ψ ]>). +Proof. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma aul_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AU ψ )>). +Proof. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma aur_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + <[ {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AU ψ ]>). +Proof. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma ag_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + <( {interp_schedule_nd sh (S n) + (ts @ i := K tt) (Some i) (memory',c)}, {w} |= AG φ )>). +Proof. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma anl_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AN ψ )>). +Proof. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. +Qed. + +Lemma anr_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AN ψ ]>). +Proof. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. +Qed. + +Lemma aul_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AU ψ )>). +Proof. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. +Qed. + +Lemma aur_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AU ψ ]>). +Proof. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. +Qed. + +Lemma ag_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + <( {interp_schedule_rr sh (S n) + (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= AG φ )>). +Proof. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. +Qed. diff --git a/theories/ICTree/Interp/Heap.v b/theories/ICTree/Interp/Heap.v index 0fece31..8753d11 100644 --- a/theories/ICTree/Interp/Heap.v +++ b/theories/ICTree/Interp/Heap.v @@ -1,17 +1,20 @@ -(** * Checked heap accesses and constructive allocation, in one handler. +(** * Checked heap accesses, malloc and whole-block free, in one handler. The handler is polymorphic in its OUTPUT effect [F] and in an untouched - auxiliary state [Sigma]; the heap itself is the first component of the + auxiliary state [Sigma]; the managed memory (data heap and live + allocation extents, [ManagedHeap]) is the first component of the interpretation state. Instrumented interpreters instantiate [F] with a writer effect and [Sigma] with their own bookkeeping; a pure client may instantiate [F := void] and [Sigma := unit]. The algorithm is fixed: allocation starts at address 1, rejects size 0, - searches the immutable snapshot for the first free positive block, keeps - rejected candidates silent, preserves [aux], propagates a missing - read/write/CAS as [stuck], leaves the whole state unchanged on a failed - CAS, and lets a free of an absent cell succeed. There is no least-address - axiom, no fuel, and no failure fallback. *) + searches the immutable data snapshot for the first free positive block, + keeps rejected candidates silent, records the allocated extent, and + preserves [aux]. A missing read/write/CAS is [stuck], and a failed CAS + leaves the whole state unchanged. Free releases exactly the recorded + block at a live base ([managed_free]): freeing [0] is a no-op, and every + other free (interior pointer, unknown base, double free) is [stuck]. + There is no least-address axiom, no fuel, and no failure fallback. *) From Stdlib Require Import List @@ -63,27 +66,35 @@ CoFixpoint alloc_search {F : Type} {HF : Encode F} {Sigma : Type} else Guard (alloc_search h size (S candidate) aux) end. +(** The state is [((h,allocs),aux)]: data heap, live extents, auxiliary + state. Allocation reuses the heap returned by [alloc_search] and only + adds the extent record; free is exactly [managed_free]. *) Definition heap_handler {F : Type} {HF : Encode F} {Sigma : Type} - : heapE ~> stateT (Heap * Sigma) (ictree F) := + : heapE ~> stateT (ManagedHeap * Sigma) (ictree F) := fun e => mkStateT (fun s => - match e return ictree F (encode e * (Heap * Sigma)) with - | HRead a => match fst s a with + match e return ictree F (encode e * (ManagedHeap * Sigma)) with + | HRead a => match fst (fst s) a with | Some v => Ret (v,s) | None => stuck end - | HWrite a v => match fst s a with - | Some _ => Ret (tt,(upd (fst s) a v,snd s)) + | HWrite a v => match fst (fst s) a with + | Some _ => Ret (tt,((upd (fst (fst s)) a v,snd (fst s)),snd s)) + | None => stuck + end + | HAlloc size => + alloc_search (fst (fst s)) size 1 (snd s) >>= fun '(base,(h',aux')) => + Ret (base,((h',upd (snd (fst s)) base size),aux')) + | HFree base => match managed_free (fst s) base with + | Some memory' => Ret (tt,(memory',snd s)) | None => stuck end - | HAlloc size => alloc_search (fst s) size 1 (snd s) - | HFree a => Ret (tt,(hfree a (fst s),snd s)) | HCAS a expected desired => - match fst s a with + match fst (fst s) a with | None => stuck | Some current => if Nat.eqb current expected - then Ret (true,(upd (fst s) a desired,snd s)) + then Ret (true,((upd (fst (fst s)) a desired,snd (fst s)),snd s)) else Ret (false,s) end end). @@ -95,52 +106,62 @@ Definition heap_handler {F : Type} {HF : Encode F} {Sigma : Type} Section HandlerEquations. Context {F : Type} {HF : Encode F} {Sigma : Type}. - Lemma heap_handler_rd_some : forall a h (aux : Sigma) v, + Lemma heap_handler_rd_some : forall a h allocs (aux : Sigma) v, h a = Some v -> - runStateT (heap_handler (F:=F) (HRead a)) (h,aux) ≅ Ret (v,(h,aux)). - Proof. intros a h aux v H; cbn; rewrite H; reflexivity. Qed. + runStateT (heap_handler (F:=F) (HRead a)) ((h,allocs),aux) ≅ + Ret (v,((h,allocs),aux)). + Proof. intros a h allocs aux v H; cbn; rewrite H; reflexivity. Qed. - Lemma heap_handler_rd_none : forall a h (aux : Sigma), + Lemma heap_handler_rd_none : forall a h allocs (aux : Sigma), h a = None -> - runStateT (heap_handler (F:=F) (HRead a)) (h,aux) ≅ stuck. - Proof. intros a h aux H; cbn; rewrite H; reflexivity. Qed. + runStateT (heap_handler (F:=F) (HRead a)) ((h,allocs),aux) ≅ stuck. + Proof. intros a h allocs aux H; cbn; rewrite H; reflexivity. Qed. - Lemma heap_handler_wr_some : forall a h (aux : Sigma) v w, + Lemma heap_handler_wr_some : forall a h allocs (aux : Sigma) v w, h a = Some w -> - runStateT (heap_handler (F:=F) (HWrite a v)) (h,aux) ≅ - Ret (tt,(upd h a v,aux)). - Proof. intros a h aux v w H; cbn; rewrite H; reflexivity. Qed. + runStateT (heap_handler (F:=F) (HWrite a v)) ((h,allocs),aux) ≅ + Ret (tt,((upd h a v,allocs),aux)). + Proof. intros a h allocs aux v w H; cbn; rewrite H; reflexivity. Qed. - Lemma heap_handler_wr_none : forall a h (aux : Sigma) v, + Lemma heap_handler_wr_none : forall a h allocs (aux : Sigma) v, h a = None -> - runStateT (heap_handler (F:=F) (HWrite a v)) (h,aux) ≅ stuck. - Proof. intros a h aux v H; cbn; rewrite H; reflexivity. Qed. + runStateT (heap_handler (F:=F) (HWrite a v)) ((h,allocs),aux) ≅ stuck. + Proof. intros a h allocs aux v H; cbn; rewrite H; reflexivity. Qed. - Lemma heap_handler_cas_success a expected desired h (aux : Sigma) : + Lemma heap_handler_cas_success a expected desired h allocs (aux : Sigma) : h a = Some expected -> - runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ - Ret (true,(upd h a desired,aux)). + runStateT (heap_handler (F:=F) (HCAS a expected desired)) ((h,allocs),aux) ≅ + Ret (true,((upd h a desired,allocs),aux)). Proof. intro H; cbn; rewrite H, Nat.eqb_refl; reflexivity. Qed. - Lemma heap_handler_cas_failure a expected desired current h (aux : Sigma) : + Lemma heap_handler_cas_failure a expected desired current h allocs (aux : Sigma) : h a = Some current -> current <> expected -> - runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ - Ret (false,(h,aux)). + runStateT (heap_handler (F:=F) (HCAS a expected desired)) ((h,allocs),aux) ≅ + Ret (false,((h,allocs),aux)). Proof. intros H N; cbn; rewrite H. apply Nat.eqb_neq in N; rewrite N; reflexivity. Qed. - Lemma heap_handler_cas_missing a expected desired h (aux : Sigma) : + Lemma heap_handler_cas_missing a expected desired h allocs (aux : Sigma) : h a = None -> - runStateT (heap_handler (F:=F) (HCAS a expected desired)) (h,aux) ≅ - (stuck : ictree F (bool * (Heap * Sigma))). + runStateT (heap_handler (F:=F) (HCAS a expected desired)) ((h,allocs),aux) ≅ + (stuck : ictree F (bool * (ManagedHeap * Sigma))). + Proof. intro H; cbn; rewrite H; reflexivity. Qed. + + (** A successful free releases exactly the recorded block. *) + Lemma heap_handler_free base (memory memory' : ManagedHeap) (aux : Sigma) : + managed_free memory base = Some memory' -> + runStateT (heap_handler (F:=F) (HFree base)) (memory,aux) ≅ + Ret (tt,(memory',aux)). Proof. intro H; cbn; rewrite H; reflexivity. Qed. - Lemma heap_handler_free a h (aux : Sigma) : - runStateT (heap_handler (F:=F) (HFree a)) (h,aux) ≅ - Ret (tt,(hfree a h,aux)). - Proof. reflexivity. Qed. + (** Interior-pointer, unknown-base and double frees are faults. *) + Lemma heap_handler_free_invalid base (memory : ManagedHeap) (aux : Sigma) : + managed_free memory base = None -> + runStateT (heap_handler (F:=F) (HFree base)) (memory,aux) ≅ + (stuck : ictree F (unit * (ManagedHeap * Sigma))). + Proof. intro H; cbn; rewrite H; reflexivity. Qed. End HandlerEquations. (** ** Allocation search *) @@ -194,29 +215,36 @@ Section AllocSearch. constructor; apply CIH; intros j J; apply Full; lia. Qed. - Lemma heap_handler_alloc_zero h (aux : Sigma) : - runStateT (heap_handler (F:=F) (HAlloc 0)) (h,aux) ≅ - (stuck : ictree F (nat * (Heap * Sigma))). - Proof. exact (unfold_alloc_search h 0 1 aux). Qed. + Lemma heap_handler_alloc_zero h allocs (aux : Sigma) : + runStateT (heap_handler (F:=F) (HAlloc 0)) ((h,allocs),aux) ≅ + (stuck : ictree F (nat * (ManagedHeap * Sigma))). + Proof. + cbn [runStateT heap_handler fst snd]. + rewrite (unfold_alloc_search h 0 1 aux). + apply bind_stuck_equ. + Qed. - Lemma heap_handler_alloc_first h size base (aux : Sigma) : + (** Malloc returns the first-fit base and records its extent. *) + Lemma heap_handler_alloc_first h allocs size base (aux : Sigma) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - runStateT (heap_handler (F:=F) (HAlloc size)) (h,aux) ~ - Ret (base, (hunion (hblock base size) h, aux)). + runStateT (heap_handler (F:=F) (HAlloc size)) ((h,allocs),aux) ~ + Ret (base, (managed_alloc (h,allocs) base size, aux)). Proof. intros Pos B Free First. - apply (alloc_search_first h size 1 base aux); try assumption; try lia. + cbn [runStateT heap_handler fst snd]. + rewrite (alloc_search_first h size 1 base aux); try assumption; try lia. + rewrite bind_ret_l; reflexivity. Qed. (** A finite heap always admits a first-fit witness. *) - Lemma heap_handler_alloc_finite h size (aux : Sigma) : + Lemma heap_handler_alloc_finite h allocs size (aux : Sigma) : heap_finite h -> Nat.lt 0 size -> exists base, Nat.lt 0 base /\ block_free h base size /\ (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) /\ - runStateT (heap_handler (F:=F) (HAlloc size)) (h,aux) ~ - Ret (base, (hunion (hblock base size) h, aux)). + runStateT (heap_handler (F:=F) (HAlloc size)) ((h,allocs),aux) ~ + Ret (base, (managed_alloc (h,allocs) base size, aux)). Proof. intros [B Bound] Pos. assert (Search : forall distance start, @@ -250,136 +278,164 @@ End AllocSearch. [other] is arbitrary. *) Section HeapInterp. Context {F G : Type} {HF : Encode F} {HG : Encode G} {Sigma : Type} - (other : G ~> stateT (Heap * Sigma) (ictree F)). + (other : G ~> stateT (ManagedHeap * Sigma) (ictree F)). - Lemma interp_heap_rd {X} : forall a h (aux : Sigma) v + Lemma interp_heap_rd {X} : forall a h allocs (aux : Sigma) v (k : nat -> ictree (heapE + G) X), h a = Some v -> - interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,aux) ~ - interp_state (h_sum heap_handler other) (k v) (h,aux). + interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) ((h,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k v) ((h,allocs),aux). Proof. - intros a h aux v k H. + intros a h allocs aux v k H. unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_rd_some (F:=F) a h aux v H), bind_ret_l. + rewrite (heap_handler_rd_some (F:=F) a h allocs aux v H), bind_ret_l. apply sb_guard. Qed. - Lemma interp_heap_wr {X} : forall a h (aux : Sigma) v w + Lemma interp_heap_wr {X} : forall a h allocs (aux : Sigma) v w (k : unit -> ictree (heapE + G) X), h a = Some w -> - interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,aux) ~ - interp_state (h_sum heap_handler other) (k tt) (upd h a v,aux). + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) ((h,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k tt) ((upd h a v,allocs),aux). Proof. - intros a h aux v w k H. + intros a h allocs aux v w k H. unfold heap_write, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_wr_some (F:=F) a h aux v w H), bind_ret_l. + rewrite (heap_handler_wr_some (F:=F) a h allocs aux v w H), bind_ret_l. apply sb_guard. Qed. - Lemma interp_heap_wr_present {X} : forall a h (aux : Sigma) v + Lemma interp_heap_wr_present {X} : forall a h allocs (aux : Sigma) v (k : unit -> ictree (heapE + G) X), h a <> None -> - interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) (h,aux) ~ - interp_state (h_sum heap_handler other) (k tt) (upd h a v,aux). + interp_state (h_sum heap_handler other) (x <- heap_write a v;; k x) ((h,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k tt) ((upd h a v,allocs),aux). Proof. - intros a h aux v k H; destruct (h a) as [w |] eqn:Ha; [| contradiction]. + intros a h allocs aux v k H; destruct (h a) as [w |] eqn:Ha; [| contradiction]. eapply interp_heap_wr; eauto. Qed. - Lemma interp_heap_rd_stuck a h (aux : Sigma) : + Lemma interp_heap_rd_stuck a h allocs (aux : Sigma) : h a = None -> - interp_state (h_sum heap_handler other) (heap_read (E:=heapE + G) a) (h,aux) - ≅ (stuck : ictree F (nat * (Heap * Sigma))). + interp_state (h_sum heap_handler other) (heap_read (E:=heapE + G) a) ((h,allocs),aux) + ≅ (stuck : ictree F (nat * (ManagedHeap * Sigma))). Proof. intro H; unfold heap_read, ICtree.trigger. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_rd_none (F:=F) a h aux H). + rewrite (heap_handler_rd_none (F:=F) a h allocs aux H). apply bind_stuck_equ. Qed. - Lemma interp_heap_wr_stuck a v h (aux : Sigma) : + Lemma interp_heap_wr_stuck a v h allocs (aux : Sigma) : h a = None -> - interp_state (h_sum heap_handler other) (heap_write (E:=heapE + G) a v) (h,aux) - ≅ (stuck : ictree F (unit * (Heap * Sigma))). + interp_state (h_sum heap_handler other) (heap_write (E:=heapE + G) a v) ((h,allocs),aux) + ≅ (stuck : ictree F (unit * (ManagedHeap * Sigma))). Proof. intro H; unfold heap_write, ICtree.trigger. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_wr_none (F:=F) a h aux v H). + rewrite (heap_handler_wr_none (F:=F) a h allocs aux v H). apply bind_stuck_equ. Qed. - Lemma interp_heap_cas_success {X} a expected desired h (aux : Sigma) + Lemma interp_heap_cas_success {X} a expected desired h allocs (aux : Sigma) (k : bool -> ictree (heapE + G) X) : h a = Some expected -> interp_state (h_sum heap_handler other) - (b <- heap_cas a expected desired;; k b) (h,aux) ~ - interp_state (h_sum heap_handler other) (k true) (upd h a desired,aux). + (b <- heap_cas a expected desired;; k b) ((h,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k true) ((upd h a desired,allocs),aux). Proof. intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_cas_success (F:=F) a expected desired h aux H), + rewrite (heap_handler_cas_success (F:=F) a expected desired h allocs aux H), bind_ret_l. apply sb_guard. Qed. - Lemma interp_heap_cas_failure {X} a expected desired current h (aux : Sigma) + Lemma interp_heap_cas_failure {X} a expected desired current h allocs (aux : Sigma) (k : bool -> ictree (heapE + G) X) : h a = Some current -> current <> expected -> interp_state (h_sum heap_handler other) - (b <- heap_cas a expected desired;; k b) (h,aux) ~ - interp_state (h_sum heap_handler other) (k false) (h,aux). + (b <- heap_cas a expected desired;; k b) ((h,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k false) ((h,allocs),aux). Proof. intros H N; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_cas_failure (F:=F) a expected desired current h aux H N), + rewrite (heap_handler_cas_failure (F:=F) a expected desired current h allocs aux H N), bind_ret_l. apply sb_guard. Qed. - Lemma interp_heap_cas_missing {X} a expected desired h (aux : Sigma) + Lemma interp_heap_cas_missing {X} a expected desired h allocs (aux : Sigma) (k : bool -> ictree (heapE + G) X) : h a = None -> interp_state (h_sum heap_handler other) - (b <- heap_cas a expected desired;; k b) (h,aux) ~ - (stuck : ictree F (X * (Heap * Sigma))). + (b <- heap_cas a expected desired;; k b) ((h,allocs),aux) ~ + (stuck : ictree F (X * (ManagedHeap * Sigma))). Proof. intro H; unfold heap_cas, ICtree.trigger; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_cas_missing (F:=F) a expected desired h aux H). + rewrite (heap_handler_cas_missing (F:=F) a expected desired h allocs aux H). rewrite bind_stuck_equ; reflexivity. Qed. - Lemma interp_heap_alloc_zero h (aux : Sigma) : - interp_state (h_sum heap_handler other) (heap_alloc (E:=heapE + G) 0) (h,aux) - ≅ (stuck : ictree F (nat * (Heap * Sigma))). + Lemma interp_heap_alloc_zero h allocs (aux : Sigma) : + interp_state (h_sum heap_handler other) (heap_alloc (E:=heapE + G) 0) ((h,allocs),aux) + ≅ (stuck : ictree F (nat * (ManagedHeap * Sigma))). Proof. unfold heap_alloc, ICtree.trigger, resum, resum_ret, ReSum_inl, ReSumRet_inl. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_alloc_zero (F:=F) h aux). + rewrite (heap_handler_alloc_zero (F:=F) h allocs aux). apply bind_stuck_equ. Qed. - Lemma interp_heap_alloc_first {X} h size base (aux : Sigma) + Lemma interp_heap_alloc_first {X} h allocs size base (aux : Sigma) (k : nat -> ictree (heapE + G) X) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_state (h_sum heap_handler other) (a <- heap_alloc size;; k a) (h,aux) ~ + interp_state (h_sum heap_handler other) (a <- heap_alloc size;; k a) ((h,allocs),aux) ~ interp_state (h_sum heap_handler other) (k base) - (hunion (hblock base size) h,aux). + (managed_alloc (h,allocs) base size,aux). Proof. intros Pos B Free First. unfold heap_alloc, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl; rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_alloc_first (F:=F) h size base aux Pos B Free First), + rewrite (heap_handler_alloc_first (F:=F) h allocs size base aux Pos B Free First), bind_ret_l. apply sb_guard. Qed. + + (** A valid free continues with the released memory. *) + Lemma interp_heap_free {X} base (memory memory' : ManagedHeap) (aux : Sigma) + (k : unit -> ictree (heapE + G) X) : + managed_free memory base = Some memory' -> + interp_state (h_sum heap_handler other) (x <- heap_free base;; k x) (memory,aux) ~ + interp_state (h_sum heap_handler other) (k tt) (memory',aux). + Proof. + intro H; unfold heap_free, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_free (F:=F) base memory memory' aux H), bind_ret_l. + apply sb_guard. + Qed. + + (** An invalid free never runs its continuation. *) + Lemma interp_heap_free_invalid {X} base (memory : ManagedHeap) (aux : Sigma) + (k : unit -> ictree (heapE + G) X) : + managed_free memory base = None -> + interp_state (h_sum heap_handler other) (x <- heap_free base;; k x) (memory,aux) ~ + (stuck : ictree F (X * (ManagedHeap * Sigma))). + Proof. + intro H; unfold heap_free, ICtree.trigger; rewrite bind_vis; + setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [h_sum]. + rewrite (heap_handler_free_invalid (F:=F) base memory aux H). + rewrite bind_stuck_equ; reflexivity. + Qed. End HeapInterp. diff --git a/theories/ICTree/Logic/Heap.v b/theories/ICTree/Logic/Heap.v index 320c5fd..3b5973a 100644 --- a/theories/ICTree/Logic/Heap.v +++ b/theories/ICTree/Logic/Heap.v @@ -28,20 +28,20 @@ Local Typeclasses Transparent equ. Section HeapNoStep. Context {F G : Type} {HF : Encode F} {HG : Encode G} {Sigma : Type} - (other : G ~> stateT (Heap * Sigma) (ictree F)). + (other : G ~> stateT (ManagedHeap * Sigma) (ictree F)). (** An out-of-footprint read cannot step, regardless of its continuation. *) - Lemma interp_heap_rd_nostep {X} : forall a h (aux : Sigma) + Lemma interp_heap_rd_nostep {X} : forall a h allocs (aux : Sigma) (k : nat -> ictree (heapE + G) X) w, h a = None -> ~ can_step - (interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) (h,aux)) w. + (interp_state (h_sum heap_handler other) (x <- heap_read a;; k x) ((h,allocs),aux)) w. Proof. - intros a h aux k w H. + intros a h allocs aux k w H. unfold heap_read, ICtree.trigger, resum, ReSum_inl, resum_ret, ReSumRet_inl. rewrite bind_vis; setoid_rewrite bind_ret_l. rewrite interp_state_vis; cbn [h_sum]. - rewrite (heap_handler_rd_none (F:=F) a h aux H). + rewrite (heap_handler_rd_none (F:=F) a h allocs aux H). intro Hs; apply can_step_bind in Hs as [(t' & w' & TR & _) | (y & w' & TR & _)]; revert TR; apply ktrans_stuck. Qed. diff --git a/theories/Lang/CSL.v b/theories/Lang/CSL.v deleted file mode 100644 index a2f9f33..0000000 --- a/theories/Lang/CSL.v +++ /dev/null @@ -1,3 +0,0 @@ -From TICL Require Export - Lang.CSL.Heap Lang.CSL.Syntax Lang.CSL.Denote - ICTree.Interp.Refine Lang.CSL.Interp Lang.CSL.Segments Lang.CSL.Ticl. diff --git a/theories/Lang/CSL/Denote.v b/theories/Lang/CSL/Denote.v deleted file mode 100644 index 8497222..0000000 --- a/theories/Lang/CSL/Denote.v +++ /dev/null @@ -1,106 +0,0 @@ -From TICL Require Import - ICTree.Core ICTree.Equ ICTree.Events.Yield ICTree.Events.Writer ICTree.Interp.Refine - Lang.CSL.Heap Lang.CSL.Syntax. - -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. - -Definition CEff := (yieldE + (forkE + sE))%type. -#[global] Instance ReSum_heap_CEff : ReSum heapE CEff := - fun e => inr (inr (inl e)). -#[global] Instance ReSumRet_heap_CEff : ReSumRet heapE CEff := - fun e response => response. -#[global] Instance ReSum_tagged_CEff : ReSum (writerE (nat * nat)) CEff := - fun e => inr (inr (inr e)). -#[global] Instance ReSumRet_tagged_CEff : ReSumRet (writerE (nat * nat)) CEff := - fun e response => response. -Definition source_yield : ictree CEff unit := - Vis (inl Yield) (fun _ => Ret tt). -Definition source_fork : ictree CEff bool := - Vis (inr (inl Fork)) (fun b => Ret b). - -Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := - match p in CProg A return ictree CEff (option A) with - | CRead a => x <- heap_read (E:=CEff) a;; Ret (Some x) - | CWrite a v => heap_write (E:=CEff) a v;; Ret (Some tt) - | CEmit q v => ICtree.trigger (E2:=CEff) (Log (q,v));; Ret (Some tt) - | CYield => source_yield;; Ret (Some tt) - | CFork body => - child <- source_fork;; - if child then denote_flow body;; Ret None else Ret (Some tt) - | CRet x => Ret (Some x) - | CBind body next => - flow <- denote_flow body;; - match flow with None => Ret None | Some x => denote_flow (next x) end - | CUntilNone body => - ICtree.iter - (fun _ : unit => - flow <- denote_flow body;; - match flow with - | None => Ret (inr None) - | Some None => Ret (inr (Some tt)) - | Some (Some _) => Ret (inl tt) - end) tt - | CAlloc size => a <- heap_alloc (E:=CEff) size;; Ret (Some a) - | CCAS a expected desired => - b <- heap_cas (E:=CEff) a expected desired;; Ret (Some b) - end. - -Definition denote (p : CProg unit) : thread sE := - denote_flow p;; Ret tt. - -Lemma denote_flow_branchfree {A} (p : CProg A) : BranchFree (denote_flow p). -Proof. - induction p as [a|a v|q v| |body IH|A x|A B body IH next IHnext|A body IH|size|a expected desired]; - cbn [denote_flow]. - - apply branchfree_bind. - + unfold heap_read, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. - + intro x; apply bf_ret. - - apply branchfree_bind. - + unfold heap_write, ICtree.trigger; apply bf_vis; intros []; apply bf_ret. - + intros []; apply bf_ret. - - apply branchfree_bind. - + unfold ICtree.trigger; apply bf_vis; intros []; apply bf_ret. - + intros []; apply bf_ret. - - apply branchfree_bind. - + unfold source_yield; apply bf_vis; intros []; apply bf_ret. - + intros []; apply bf_ret. - - apply branchfree_bind. - + unfold source_fork; apply bf_vis; intro b; apply bf_ret. - + intros []; cbn. - * apply branchfree_bind; [exact IH|intro flow; apply bf_ret]. - * apply bf_ret. - - apply bf_ret. - - apply branchfree_bind; [exact IH|]. - intros [x|]; [apply IHnext|apply bf_ret]. - - apply branchfree_iter; intros []. - apply branchfree_bind; [exact IH|]. - intros [[x|]|]; apply bf_ret. - - apply branchfree_bind. - + unfold heap_alloc, ICtree.trigger; apply bf_vis; intro a; apply bf_ret. - + intro a; apply bf_ret. - - apply branchfree_bind. - + unfold heap_cas, ICtree.trigger; apply bf_vis; intro b; apply bf_ret. - + intro b; apply bf_ret. -Qed. - -Lemma denote_branchfree (p : CProg unit) : BranchFree (denote p). -Proof. - unfold denote; apply branchfree_bind; - [apply denote_flow_branchfree|intro flow; apply bf_ret]. -Qed. - -Lemma denote_fork_bind (p : CProg unit) (next : unit -> CProg unit) : - denote (CBind (CFork p) next) ≅ - Vis (inr (inl Fork)) - (fun child : bool => if child then denote p else denote (next tt)). -Proof. - unfold denote; cbn [denote_flow]; unfold source_fork. - rewrite !bind_bind, bind_vis. - step; constructor; intro child. - rewrite bind_ret_l; destruct child; cbn. - - rewrite !bind_bind. - apply equ_clo_bind_eq; intro flow. - rewrite !bind_ret_l; reflexivity. - - rewrite !bind_ret_l; reflexivity. -Qed. diff --git a/theories/Lang/CSL/Heap.v b/theories/Lang/CSL/Heap.v deleted file mode 100644 index 8bbe7c5..0000000 --- a/theories/Lang/CSL/Heap.v +++ /dev/null @@ -1,65 +0,0 @@ -(** * The CSL effect sum and its handler. - - Everything generic about checked heap access, allocation search and - indexed observation lives one layer down, in [ICTree.Interp.Heap] and - [ICTree.Events.Writer]. This module only fixes the CSL effect sum, its - interpretation state, and the handler instance that pairs them. *) - -From Stdlib Require Import - List - Lia - Arith.PeanoNat. - -From ExtLib Require Import - Structures.MonadState - Data.Monads.StateMonad. - -From TICL Require Import - ICTree.Core - ICTree.Equ - ICTree.SBisim - ICTree.Interp.State.Mod - ICTree.Events.State - ICTree.Logic.Trans - ICTree.Logic.CanStep - ICTree.Logic.AX - ICTree.Logic.AF - ICTree.Logic.AG - ICTree.Logic.Bind - ICTree.Logic.Iter - ICTree.Logic.State - Logic.Core. - -From TICL Require Export - Events.HeapModel - ICTree.Events.Heap - ICTree.Events.Writer - ICTree.Interp.Heap - ICTree.Logic.Heap. - -Import ICtree ICTreeNotations TiclNotations ListNotations. -Local Open Scope ictree_scope. -Local Open Scope ticl_scope. -Local Open Scope list_scope. - -Local Typeclasses Transparent equ. -Local Typeclasses Transparent sbisim. - -(** ** Events *) - -Definition sE : Type := (heapE + writerE (nat * nat))%type. - -Definition semit (q v : nat) : ictree sE unit := - ICtree.trigger (Log (q,v)). - -(** Interpretation state: the SHARED heap (which holds both queues and the - outer frame) and one GLOBAL occurrence counter. *) -Notation SSig := (Heap * nat)%type. - -(** The CSL handler is exactly the shared checked-heap handler summed with - the shared indexing handler. The tag travels in the payload; the - -From Coinduction Require Import coinduction. - occurrence index is supplied by [h_indexed], which owns the counter. *) -Definition sh : sE ~> stateT SSig (ictreeW (indexed (nat * nat))) := - h_sum heap_handler h_indexed. diff --git a/theories/Lang/CSL/Interp.v b/theories/Lang/CSL/Interp.v deleted file mode 100644 index a387444..0000000 --- a/theories/Lang/CSL/Interp.v +++ /dev/null @@ -1,807 +0,0 @@ -From TICL Require Export ICTree.Trace ICTree.Interp.Yield.Nondeterministic. -From Stdlib Require Import Fin Vector List Arith.PeanoNat Lia. -From TICL Require Import - Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote - ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Logic.State Logic.World - ICTree.Events.Writer ICTree.Events.Yield - ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim - ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic - ICTree.Interp.Refine - ICTree.Interp.State.Mod Utils.Vectors. - -Import ICtree ICTreeNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. - -(** ** Head normalisation of [denote_flow]. - - What a single source instruction looks like at the head of a thread, - before any scheduling is applied. The [interp_*] families below are - built on top of these raw equations. *) - -Lemma source_raw_read_head a (K : option nat -> thread sE) : - (denote_flow (CRead a) >>= K) ≅ Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v)). -Proof. - cbn [denote_flow]; unfold heap_read, ICtree.trigger; rewrite !bind_bind, bind_vis. - step; constructor; intro x; rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_write_head a v (K : option unit -> thread sE) : - (denote_flow (CWrite a v) >>= K) ≅ Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt)). -Proof. - cbn [denote_flow]; unfold heap_write, ICtree.trigger; rewrite !bind_bind, bind_vis. - step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_cas_head a old desired (K : option bool -> thread sE) : - (denote_flow (CCAS a old desired) >>= K) ≅ - Vis (inr (inr (inl (HCAS a old desired)))) (fun b => K (Some b)). -Proof. - cbn [denote_flow]; unfold heap_cas, ICtree.trigger; rewrite !bind_bind, bind_vis. - step; constructor; intro x; rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_emit_head tag value (K : option unit -> thread sE) : - (denote_flow (CEmit tag value) >>= K) ≅ - Vis (inr (inr (inr (Log (tag,value))))) (fun _ => K (Some tt)). -Proof. - cbn [denote_flow]; unfold ICtree.trigger, resum, resum_ret, - ReSum_tagged_CEff, ReSumRet_tagged_CEff. - rewrite bind_bind, bind_vis; step; constructor; intros []. - rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_yield_head (K : option unit -> thread sE) : - (denote_flow CYield >>= K) ≅ Vis (inl Yield) (fun _ => K (Some tt)). -Proof. - cbn [denote_flow]; unfold source_yield. - rewrite bind_bind, bind_vis; step; constructor; intros []. - change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ - K (Some tt)). - rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_alloc_head size (K : option nat -> thread sE) : - (denote_flow (CAlloc size) >>= K) ≅ - Vis (inr (inr (inl (HAlloc size)))) (fun base => K (Some base)). -Proof. - cbn [denote_flow]; unfold heap_alloc, ICtree.trigger, resum, resum_ret, - ReSum_heap_CEff, ReSumRet_heap_CEff. - rewrite bind_bind, bind_vis; step; constructor; intro base. - rewrite !bind_ret_l; reflexivity. -Qed. - -Lemma source_raw_fork_head (child : CProg unit) (K : option unit -> thread sE) : - (denote_flow (CFork child) >>= K) ≅ - Vis (inr (inl Fork)) - (fun spawned : bool => if spawned - then denote_flow child >>= fun _ => K None else K (Some tt)). -Proof. - cbn [denote_flow]; unfold source_fork. - rewrite bind_bind, bind_vis; step; constructor; intro spawned. - rewrite bind_ret_l; destruct spawned; cbn. - - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. - rewrite bind_ret_l; reflexivity. - - apply bind_ret_l. -Qed. - -(** These are the actual [CUntilNone] continuations, including halt flow. *) -Definition until_tail {A} (body : CProg (option A)) - (K : option unit -> thread sE) (flow : option (option A)) : thread sE := - match flow with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) - end. - -(** Raw source equations retain the outer option; in particular a successful - remote publication must return through its caller before reaching Yield. *) -Lemma source_raw_bind {A B} (p : CProg A) (next : A -> CProg B) - (K : option B -> thread sE) : - (denote_flow (CBind p next) >>= K) ≅ - (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end). -Proof. - cbn [denote_flow]; rewrite bind_bind. - apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. -Qed. - -Lemma source_raw_ret {A} (x : A) (K : option A -> thread sE) : - (denote_flow (CRet x) >>= K) ≅ K (Some x). -Proof. cbn [denote_flow]; apply bind_ret_l. Qed. - -Lemma source_raw_until {A} (body : CProg (option A)) - (K : option unit -> thread sE) : - (denote_flow (CUntilNone body) >>= K) ≅ - (denote_flow body >>= until_tail body K). -Proof. - set (loop_body := fun _ : unit => - flow <- denote_flow body;; - match flow with - | None => Ret (inr (None : option unit)) - | Some None => Ret (inr (Some tt)) - | Some (Some _) => Ret (inl tt) - end). - change ((ICtree.iter loop_body tt >>= K) ≅ - (denote_flow body >>= fun flow => - match flow with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) - end)). - transitivity ((loop_body tt >>= fun lr => - match lr with - | inl j => Guard (ICtree.iter loop_body j) - | inr result => Ret result - end) >>= K). - - apply equ_clo_bind with (S := eq). - + apply unfold_iter. - + intros r r' <-; reflexivity. - - etransitivity; [apply bind_bind|]. - unfold loop_body at 1. - etransitivity; [apply bind_bind|]. - apply equ_clo_bind_eq; intros [[x|]|]; cbn. - + etransitivity; [apply bind_ret_l|]. apply bind_guard. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. - + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. -Qed. - -Definition run_rr (p : CProg unit) (h : Heap) (c : nat) - : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (h,c). - -Definition run_nd (p : CProg unit) (h : Heap) (c : nat) - : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) (h,c). - -Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m σ ≅ - interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ. -Proof. - apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_ret. -Qed. - -Lemma interp_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m σ ~ - (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => - interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). -Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HRead a)) - (fun x => K (Some x)) m σ). - apply source_raw_read_head. -Qed. - -Lemma interp_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m sigma : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m sigma ~ - (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => - interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). -Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HAlloc size)) - (fun base => K (Some base)) m sigma). - apply source_raw_alloc_head. -Qed. - -Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) m sigma : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) - (Some i) m sigma ~ - (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => - interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). -Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HCAS a expected desired)) - (fun b => K (Some b)) m sigma). - apply source_raw_cas_head. -Qed. - -Lemma interp_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m σ ~ - (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). -Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HWrite a v)) - (fun _ => K (Some tt)) m σ). - apply source_raw_write_head. -Qed. - -Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - q v (K : option unit -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) m σ ~ - (interp_state sh (semit q v) σ >>= fun '(_,σ') => - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). -Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inr (Log (q,v))) - (fun _ => K (Some tt)) m σ). - apply source_raw_emit_head. -Qed. - -Lemma interp_rr_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m σ : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m σ ≅ - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun r => - match r with None => K None | Some x => denote_flow (next x) >>= K end)) - (Some i) m σ. -Proof. - apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_bind. -Qed. - -Lemma interp_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) m σ ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) None m σ. -Proof. - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow CYield >>= K)) - (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) - (Some i) m σ - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma interp_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg unit) (K : option unit -> thread sE) m σ : - interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) m σ ~ - interp_schedule_rr sh (S (S n)) - ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) - (Some (Fin.FS i)) m σ. -Proof. - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (denote_flow (CFork p) >>= K)) - (ts @ i := Vis (inr (inl Fork)) - (fun child : bool => if child - then denote_flow p >>= fun _ => K None else K (Some tt))) - (Some i) m σ - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_fork by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma interp_rr_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m σ : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m σ ≅ - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= fun r => - match r with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) - end)) (Some i) m σ. -Proof. - apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_until. -Qed. - -Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) h c : - run_rr (CBind (CFork p) next) h c ~ - interp_schedule_rr sh 2 [denote p; denote (next tt)]%vector - (Some (Fin.FS Fin.F1)) 0 (h,c). -Proof. - unfold run_rr. - assert (Hpool : pool_equ [denote (CBind (CFork p) next)]%vector - [Vis (inr (inl Fork)) - (fun child : bool => if child then denote p else denote (next tt))]%vector). - { apply cons_pool_equ; [apply denote_fork_bind|apply pool_equ_refl]. } - rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 (h,c) Hpool). - erewrite interp_schedule_rr_fork by reflexivity. - reflexivity. -Qed. - -Lemma interp_nd_source_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ - interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ. -Proof. - apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_ret. -Qed. - -Lemma interp_nd_source_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ - (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => - interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ'). -Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HRead a)) - (fun x => K (Some x)) σ). - apply source_raw_read_head. -Qed. - -Lemma interp_nd_source_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) sigma : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) sigma ~ - (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => - interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) sigma'). -Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HAlloc size)) - (fun base => K (Some base)) sigma). - apply source_raw_alloc_head. -Qed. - -Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) sigma : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) - (Some i) sigma ~ - (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => - interp_schedule_nd sh (S n) (ts @ i := K (Some b)) (Some i) sigma'). -Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HCAS a expected desired)) - (fun b => K (Some b)) sigma). - apply source_raw_cas_head. -Qed. - -Lemma interp_nd_source_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ - (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => - interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). -Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HWrite a v)) - (fun _ => K (Some tt)) σ). - apply source_raw_write_head. -Qed. - -Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - q v (K : option unit -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) σ ~ - (interp_state sh (semit q v) σ >>= fun '(_,σ') => - interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). -Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inr (Log (q,v))) - (fun _ => K (Some tt)) σ). - apply source_raw_emit_head. -Qed. - -Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) σ : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) σ ≅ - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun r => - match r with None => K None | Some x => denote_flow (next x) >>= K end)) - (Some i) σ. -Proof. - apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_bind. -Qed. - -Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ - interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) None σ. -Proof. - pose proof ((interp_schedule_nd_equ sh) (S n) - (ts @ i := (denote_flow CYield >>= K)) - (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) - (Some i) σ - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. - rewrite Hpool. - erewrite (interp_schedule_nd_yield sh) by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma interp_nd_source_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg unit) (K : option unit -> thread sE) σ : - interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) σ ~ - interp_schedule_nd sh (S (S n)) - ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) - (Some (Fin.FS i)) σ. -Proof. - pose proof ((interp_schedule_nd_equ sh) (S n) - (ts @ i := (denote_flow (CFork p) >>= K)) - (ts @ i := Vis (inr (inl Fork)) - (fun child : bool => if child - then denote_flow p >>= fun _ => K None else K (Some tt))) - (Some i) σ - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. - rewrite Hpool. - erewrite (interp_schedule_nd_fork sh) by (rewrite Vector.nth_replace_eq; reflexivity). - rewrite Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) σ : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) σ ≅ - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= fun r => - match r with - | None => K None - | Some None => K (Some tt) - | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) - end)) (Some i) σ. -Proof. - apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. - apply source_raw_until. -Qed. - -(** Silent checked writes, with the continuation held fixed while the state - handler is simplified. No congruence on a pool of bisimilar threads is - used here. *) -Lemma interp_rr_write_present n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c : - h a <> None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m (upd h a v,c). -Proof. - intro Present. - pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c v - (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_rr_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_nd_source_write_present n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c : - h a <> None -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c) ~ - interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) (upd h a v,c). -Proof. - intro Present. - pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c v - (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_nd_source_write. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. -Lemma interp_rr_read_value n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c : - h a = Some value -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m (h,c). -Proof. - intro Lookup. - pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c value - (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_rr_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_nd_source_read_value n - (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c : - h a = Some value -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ - interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) (h,c). -Proof. - intro Lookup. - pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c value - (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_nd_source_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -(** Checked operations with their scheduler continuation held fixed. *) - -Lemma interp_rr_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c : - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c) ~ - (log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)). -Proof. - pose proof (interp_indexed_emit heap_handler (tag,value) h c - (fun x : unit => (Ret x : ictree sE unit))) as Hemit. - rewrite bind_ret_r in Hemit. - assert (Hstate : interp_state sh (semit tag value) (h,c) ~ - (log (stamp (tag,value) c);; Ret (tt,(h,S c)))). - { etransitivity; [exact Hemit |]. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - eapply equ_clos_sbisim_goal; - [apply interp_state_ret | reflexivity | reflexivity]. } - rewrite interp_rr_emit. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_rr_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c : - h a = Some current -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c) ~ - (if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)). -Proof. - intro Lookup; rewrite interp_rr_cas. - destruct (Nat.eqb current expected) eqn:Cmp. - - apply Nat.eqb_eq in Cmp; subst current. - pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c - (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. - - apply Nat.eqb_neq in Cmp. - pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired current h c - (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_rr_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c). -Proof. - intros Pos Base Free First. - pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h size base c - (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_rr_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_rr_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) m h c : - h a = None -> - interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) - a h c Missing) as Hstate. - rewrite interp_rr_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c : - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c) ~ - (log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)). -Proof. - pose proof (interp_indexed_emit heap_handler (tag,value) h c - (fun x : unit => (Ret x : ictree sE unit))) as Hemit. - rewrite bind_ret_r in Hemit. - assert (Hstate : interp_state sh (semit tag value) (h,c) ~ - (log (stamp (tag,value) c);; Ret (tt,(h,S c)))). - { etransitivity; [exact Hemit |]. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - eapply equ_clos_sbisim_goal; - [apply interp_state_ret | reflexivity | reflexivity]. } - rewrite interp_nd_source_emit. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_bind. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_nd_source_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c : - h a = Some current -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c) ~ - (if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)). -Proof. - intro Lookup; rewrite interp_nd_source_cas. - destruct (Nat.eqb current expected) eqn:Cmp. - - apply Nat.eqb_eq in Cmp; subst current. - pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired h c - (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. - - apply Nat.eqb_neq in Cmp. - pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a expected desired current h c - (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_nd_source_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c) ~ - interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c). -Proof. - intros Pos Base Free First. - pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) h size base c - (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. - rewrite bind_ret_r, interp_state_ret in Hstate. - rewrite interp_nd_source_alloc. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [exact Hstate | intro result; reflexivity] |] - end. - rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_nd_source_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) h c : - h a = None -> - interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). -Proof. - intro Missing. - pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=Heap))) a h c Missing) as Hstate. - rewrite interp_nd_source_read. - lazymatch goal with - | |- (interp_state sh _ _ >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2 := next); - [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] - end. - rewrite bind_stuck_equ; reflexivity. -Qed. - -(** Physical free is a raw shared command, not a source constructor. *) - -Lemma raw_heap_free_head a (K : unit -> thread sE) : - (heap_free (E:=CEff) a >>= K) ≅ - Vis (inr (inr (inl (HFree a)))) K. -Proof. - unfold heap_free, ICtree.trigger, resum, resum_ret, - ReSum_heap_CEff, ReSumRet_heap_CEff. - rewrite bind_vis; setoid_rewrite bind_ret_l; reflexivity. -Qed. - -Lemma interp_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c : - interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c) ~ - interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c). -Proof. - pose proof (interp_schedule_rr_equ sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) - (ts @ i := Vis (inr (inr (inl (HFree a)))) K) - (Some i) m (h,c) - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head a K))) as Hpool. - rewrite Hpool. - erewrite interp_schedule_rr_user with (e:=inl (HFree a)) (k:=K) - by (rewrite Vector.nth_replace_eq; reflexivity). - lazymatch goal with |- (?t >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2:=next); - [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free a h c) | reflexivity | reflexivity] - | intro result; reflexivity] |] - end. - rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. -Qed. - -Lemma interp_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c : - interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c) ~ - interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c). -Proof. - pose proof ((interp_schedule_nd_equ sh) (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) - (ts @ i := Vis (inr (inr (inl (HFree a)))) K) - (Some i) (h,c) - (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head a K))) as Hpool. - rewrite Hpool. - erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree a)) (k:=K) - by (rewrite Vector.nth_replace_eq; reflexivity). - lazymatch goal with |- (?t >>= ?next) ~ _ => - etransitivity; - [apply sbisim_clo_bind_eq with (k2:=next); - [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free a h c) | reflexivity | reflexivity] - | intro result; reflexivity] |] - end. - rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. -Qed. diff --git a/theories/Lang/CSL/Mod.v b/theories/Lang/CSL/Mod.v new file mode 100644 index 0000000..1c64ec4 --- /dev/null +++ b/theories/Lang/CSL/Mod.v @@ -0,0 +1,3027 @@ +(** * The canonical CSL source language. + + Syntax ([CProg]), its denotation into threads over the CSL effects, the + source-instruction execution equations under both schedulers, the + exact first-yield segment rules, and the structural Ticl rules stated over + source programs. Every law here specializes an effect-level law of + [ICTree.Interp.CSL.Mod]. *) + +From TICL Require Export ICTree.Interp.CSL.Mod. + +From Stdlib Require Import List Arith.PeanoNat Lia Fin Vector + Classes.Morphisms Classes.RelationClasses Program.Equality. +From ExtLib Require Import Data.Monads.StateMonad. +From Coinduction Require Import coinduction lattice tactics. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace + ICTree.Events.Writer ICTree.Events.Yield ICTree.Events.Heap + ICTree.Interp.State.Mod ICTree.Interp.Refine + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic + ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG + ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep + Logic.World Logic.Core Utils.Vectors. + +Import ICtree ICTreeNotations TiclNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +(** ** Syntax *) + +Module CSLSyntax. + Inductive CProg : Type -> Type := + | CRead (a : nat) : CProg nat + | CWrite (a v : nat) : CProg unit + | CEmit (tag value : nat) : CProg unit + | CYield : CProg unit + | CFork (body : CProg unit) : CProg unit + | CRet {A : Type} (value : A) : CProg A + | CBind {A B : Type} (body : CProg A) (next : A -> CProg B) : CProg B + | CUntilNone {A : Type} (body : CProg (option A)) : CProg unit + | CAlloc (size : nat) : CProg nat + | CFree (base : nat) : CProg unit + | CCAS (a expected desired : nat) : CProg bool. +End CSLSyntax. +Export CSLSyntax. + +(** ** Denotation *) + +Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := + match p in CProg A return ictree CEff (option A) with + | CRead a => x <- heap_read (E:=CEff) a;; Ret (Some x) + | CWrite a v => heap_write (E:=CEff) a v;; Ret (Some tt) + | CEmit q v => ICtree.trigger (E2:=CEff) (Log (q,v));; Ret (Some tt) + | CYield => source_yield;; Ret (Some tt) + | CFork body => + child <- source_fork;; + if child then denote_flow body;; Ret None else Ret (Some tt) + | CRet x => Ret (Some x) + | CBind body next => + flow <- denote_flow body;; + match flow with None => Ret None | Some x => denote_flow (next x) end + | CUntilNone body => + ICtree.iter + (fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr None) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end) tt + | CAlloc size => a <- heap_alloc (E:=CEff) size;; Ret (Some a) + | CFree base => heap_free (E:=CEff) base;; Ret (Some tt) + | CCAS a expected desired => + b <- heap_cas (E:=CEff) a expected desired;; Ret (Some b) + end. + +Definition denote (p : CProg unit) : thread sE := + denote_flow p;; Ret tt. + +Lemma denote_flow_branchfree {A} (p : CProg A) : BranchFree (denote_flow p). +Proof. + induction p as [a|a v|q v| |body IH|A x|A B body IH next IHnext|A body IH|size|base + |a expected desired]; + cbn [denote_flow]. + - apply branchfree_bind. + + unfold heap_read, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. + + intro x; apply bf_ret. + - apply branchfree_bind. + + unfold heap_write, ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold source_yield; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold source_fork; apply bf_vis; intro b; apply bf_ret. + + intros []; cbn. + * apply branchfree_bind; [exact IH|intro flow; apply bf_ret]. + * apply bf_ret. + - apply bf_ret. + - apply branchfree_bind; [exact IH|]. + intros [x|]; [apply IHnext|apply bf_ret]. + - apply branchfree_iter; intros []. + apply branchfree_bind; [exact IH|]. + intros [[x|]|]; apply bf_ret. + - apply branchfree_bind. + + unfold heap_alloc, ICtree.trigger; apply bf_vis; intro a; apply bf_ret. + + intro a; apply bf_ret. + - apply branchfree_bind. + + unfold heap_free, ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + + intros []; apply bf_ret. + - apply branchfree_bind. + + unfold heap_cas, ICtree.trigger; apply bf_vis; intro b; apply bf_ret. + + intro b; apply bf_ret. +Qed. + +Lemma denote_branchfree (p : CProg unit) : BranchFree (denote p). +Proof. + unfold denote; apply branchfree_bind; + [apply denote_flow_branchfree|intro flow; apply bf_ret]. +Qed. + +Lemma denote_fork_bind (p : CProg unit) (next : unit -> CProg unit) : + denote (CBind (CFork p) next) ≅ + Vis (inr (inl Fork)) + (fun child : bool => if child then denote p else denote (next tt)). +Proof. + unfold denote; cbn [denote_flow]; unfold source_fork. + rewrite !bind_bind, bind_vis. + step; constructor; intro child. + rewrite bind_ret_l; destruct child; cbn. + - rewrite !bind_bind. + apply equ_clo_bind_eq; intro flow. + rewrite !bind_ret_l; reflexivity. + - rewrite !bind_ret_l; reflexivity. +Qed. + +(** ** Head normalisation of [denote_flow]. + + What a single source instruction looks like at the head of a thread, + before any scheduling is applied. The [interp_*] families below are + built on top of these raw equations. *) + +Lemma source_raw_read_head a (K : option nat -> thread sE) : + (denote_flow (CRead a) >>= K) ≅ Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v)). +Proof. + cbn [denote_flow]; unfold heap_read, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_write_head a v (K : option unit -> thread sE) : + (denote_flow (CWrite a v) >>= K) ≅ Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold heap_write, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_cas_head a old desired (K : option bool -> thread sE) : + (denote_flow (CCAS a old desired) >>= K) ≅ + Vis (inr (inr (inl (HCAS a old desired)))) (fun b => K (Some b)). +Proof. + cbn [denote_flow]; unfold heap_cas, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intro x; rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_emit_head tag value (K : option unit -> thread sE) : + (denote_flow (CEmit tag value) >>= K) ≅ + Vis (inr (inr (inr (Log (tag,value))))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold ICtree.trigger, resum, resum_ret, + ReSum_tagged_CEff, ReSumRet_tagged_CEff. + rewrite bind_bind, bind_vis; step; constructor; intros []. + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_yield_head (K : option unit -> thread sE) : + (denote_flow CYield >>= K) ≅ Vis (inl Yield) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold source_yield. + rewrite bind_bind, bind_vis; step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_alloc_head size (K : option nat -> thread sE) : + (denote_flow (CAlloc size) >>= K) ≅ + Vis (inr (inr (inl (HAlloc size)))) (fun base => K (Some base)). +Proof. + cbn [denote_flow]; unfold heap_alloc, ICtree.trigger, resum, resum_ret, + ReSum_heap_CEff, ReSumRet_heap_CEff. + rewrite bind_bind, bind_vis; step; constructor; intro base. + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_free_head base (K : option unit -> thread sE) : + (denote_flow (CFree base) >>= K) ≅ + Vis (inr (inr (inl (HFree base)))) (fun _ => K (Some tt)). +Proof. + cbn [denote_flow]; unfold heap_free, ICtree.trigger; rewrite !bind_bind, bind_vis. + step; constructor; intros []. + change (((Ret tt : thread sE) >>= fun _ : unit => Ret (Some tt) >>= K) ≅ + K (Some tt)). + rewrite !bind_ret_l; reflexivity. +Qed. + +Lemma source_raw_fork_head (child : CProg unit) (K : option unit -> thread sE) : + (denote_flow (CFork child) >>= K) ≅ + Vis (inr (inl Fork)) + (fun spawned : bool => if spawned + then denote_flow child >>= fun _ => K None else K (Some tt)). +Proof. + cbn [denote_flow]; unfold source_fork. + rewrite bind_bind, bind_vis; step; constructor; intro spawned. + rewrite bind_ret_l; destruct spawned; cbn. + - rewrite bind_bind; apply equ_clo_bind_eq; intro flow. + rewrite bind_ret_l; reflexivity. + - apply bind_ret_l. +Qed. + +(** These are the actual [CUntilNone] continuations, including halt flow. *) +Definition until_tail {A} (body : CProg (option A)) + (K : option unit -> thread sE) (flow : option (option A)) : thread sE := + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end. + +(** Raw source equations retain the outer option halt flow: [None] skips + [next] and reaches the continuation unchanged, and [Some x] runs [next x] + before the continuation, so a completed callee returns through its caller + before any following instruction (such as a yield). *) +Lemma source_raw_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) : + (denote_flow (CBind p next) >>= K) ≅ + (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intros [x|]; [reflexivity|apply bind_ret_l]. +Qed. + +Lemma source_raw_ret {A} (x : A) (K : option A -> thread sE) : + (denote_flow (CRet x) >>= K) ≅ K (Some x). +Proof. cbn [denote_flow]; apply bind_ret_l. Qed. + +Lemma source_raw_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) : + (denote_flow (CUntilNone body) >>= K) ≅ + (denote_flow body >>= until_tail body K). +Proof. + set (loop_body := fun _ : unit => + flow <- denote_flow body;; + match flow with + | None => Ret (inr (None : option unit)) + | Some None => Ret (inr (Some tt)) + | Some (Some _) => Ret (inl tt) + end). + change ((ICtree.iter loop_body tt >>= K) ≅ + (denote_flow body >>= fun flow => + match flow with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (ICtree.iter loop_body tt >>= K) + end)). + transitivity ((loop_body tt >>= fun lr => + match lr with + | inl j => Guard (ICtree.iter loop_body j) + | inr result => Ret result + end) >>= K). + - apply equ_clo_bind with (S := eq). + + apply unfold_iter. + + intros r r' <-; reflexivity. + - etransitivity; [apply bind_bind|]. + unfold loop_body at 1. + etransitivity; [apply bind_bind|]. + apply equ_clo_bind_eq; intros [[x|]|]; cbn. + + etransitivity; [apply bind_ret_l|]. apply bind_guard. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. + + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. +Qed. + +(** Runners start from explicit managed memory: [managed_empty] for a fresh + program, or an explicit [(h,allocs)] for preallocated data. *) +Definition run_rr (p : CProg unit) (memory : ManagedHeap) (c : nat) + : ictreeW (indexed (nat * nat)) (unit * SSig) := + interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (memory,c). + +Definition run_nd (p : CProg unit) (memory : ManagedHeap) (c : nat) + : ictreeW (indexed (nat * nat)) (unit * SSig) := + interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) (memory,c). + +Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_ret. +Qed. + +Lemma interp_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m σ ~ + (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some x)) (Some i) m σ'). +Proof. + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HRead a)) + (fun x => K (Some x)) m σ). + apply source_raw_read_head. +Qed. + +Lemma interp_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m sigma ~ + (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => + interp_schedule_rr sh (S n) (ts @ i := K (Some base)) (Some i) m sigma'). +Proof. + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HAlloc size)) + (fun base => K (Some base)) m sigma). + apply source_raw_alloc_head. +Qed. + +Lemma interp_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) m sigma : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (Some i) m sigma ~ + (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => + interp_schedule_rr sh (S n) (ts @ i := K (Some b)) (Some i) m sigma'). +Proof. + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HCAS a expected desired)) + (fun b => K (Some b)) m sigma). + apply source_raw_cas_head. +Qed. + +Lemma interp_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m σ ~ + (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). +Proof. + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inl (HWrite a v)) + (fun _ => K (Some tt)) m σ). + apply source_raw_write_head. +Qed. + +Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + q v (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) m σ ~ + (interp_state sh (semit q v) σ >>= fun '(_,σ') => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). +Proof. + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inr (Log (q,v))) + (fun _ => K (Some tt)) m σ). + apply source_raw_emit_head. +Qed. + +Lemma interp_rr_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m σ : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun r => + match r with None => K None | Some x => denote_flow (next x) >>= K end)) + (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_bind. +Qed. + +Lemma interp_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) m σ ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) None m σ. +Proof. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow CYield >>= K)) + (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) + (Some i) m σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg unit) (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) m σ ~ + interp_schedule_rr sh (S (S n)) + ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) + (Some (Fin.FS i)) m σ. +Proof. + pose proof (interp_schedule_rr_equ sh (S n) + (ts @ i := (denote_flow (CFork p) >>= K)) + (ts @ i := Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))) + (Some i) m σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. + rewrite Hpool. + erewrite interp_schedule_rr_fork by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m σ : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m σ ≅ + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end)) (Some i) m σ. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_until. +Qed. + +Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) memory c : + run_rr (CBind (CFork p) next) memory c ~ + interp_schedule_rr sh 2 [denote p; denote (next tt)]%vector + (Some (Fin.FS Fin.F1)) 0 (memory,c). +Proof. + unfold run_rr. + assert (Hpool : pool_equ [denote (CBind (CFork p) next)]%vector + [Vis (inr (inl Fork)) + (fun child : bool => if child then denote p else denote (next tt))]%vector). + { apply cons_pool_equ; [apply denote_fork_bind|apply pool_equ_refl]. } + rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 (memory,c) Hpool). + erewrite interp_schedule_rr_fork by reflexivity. + reflexivity. +Qed. + +Lemma interp_nd_source_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) σ ≅ + interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ. +Proof. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_ret. +Qed. + +Lemma interp_nd_source_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) σ ~ + (interp_state sh (heap_read (E:=sE) a) σ >>= fun '(x,σ') => + interp_schedule_nd sh (S n) (ts @ i := K (Some x)) (Some i) σ'). +Proof. + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HRead a)) + (fun x => K (Some x)) σ). + apply source_raw_read_head. +Qed. + +Lemma interp_nd_source_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) sigma : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) sigma ~ + (interp_state sh (heap_alloc (E:=sE) size) sigma >>= fun '(base,sigma') => + interp_schedule_nd sh (S n) (ts @ i := K (Some base)) (Some i) sigma'). +Proof. + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HAlloc size)) + (fun base => K (Some base)) sigma). + apply source_raw_alloc_head. +Qed. + +Lemma interp_nd_source_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) sigma : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) + (Some i) sigma ~ + (interp_state sh (heap_cas (E:=sE) a expected desired) sigma >>= fun '(b,sigma') => + interp_schedule_nd sh (S n) (ts @ i := K (Some b)) (Some i) sigma'). +Proof. + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HCAS a expected desired)) + (fun b => K (Some b)) sigma). + apply source_raw_cas_head. +Qed. + +Lemma interp_nd_source_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) σ ~ + (interp_state sh (heap_write (E:=sE) a v) σ >>= fun '(_,σ') => + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). +Proof. + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inl (HWrite a v)) + (fun _ => K (Some tt)) σ). + apply source_raw_write_head. +Qed. + +Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + q v (K : option unit -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CEmit q v) >>= K)) (Some i) σ ~ + (interp_state sh (semit q v) σ >>= fun '(_,σ') => + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). +Proof. + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inr (Log (q,v))) + (fun _ => K (Some tt)) σ). + apply source_raw_emit_head. +Qed. + +Lemma interp_nd_source_bind {A B} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) σ : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) σ ≅ + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun r => + match r with None => K None | Some x => denote_flow (next x) >>= K end)) + (Some i) σ. +Proof. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_bind. +Qed. + +Lemma interp_nd_source_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow CYield >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) None σ. +Proof. + pose proof ((interp_schedule_nd_equ sh) (S n) + (ts @ i := (denote_flow CYield >>= K)) + (ts @ i := Vis (inl Yield) (fun _ => K (Some tt))) + (Some i) σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_yield_head K))) as Hpool. + rewrite Hpool. + erewrite (interp_schedule_nd_yield sh) by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg unit) (K : option unit -> thread sE) σ : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFork p) >>= K)) (Some i) σ ~ + interp_schedule_nd sh (S (S n)) + ((denote_flow p >>= fun _ => K None) :: (ts @ i := K (Some tt))) + (Some (Fin.FS i)) σ. +Proof. + pose proof ((interp_schedule_nd_equ sh) (S n) + (ts @ i := (denote_flow (CFork p) >>= K)) + (ts @ i := Vis (inr (inl Fork)) + (fun child : bool => if child + then denote_flow p >>= fun _ => K None else K (Some tt))) + (Some i) σ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_fork_head p K))) as Hpool. + rewrite Hpool. + erewrite (interp_schedule_nd_fork sh) by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_source_until_none {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) σ : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) σ ≅ + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= fun r => + match r with + | None => K None + | Some None => K (Some tt) + | Some (Some _) => Guard (denote_flow (CUntilNone body) >>= K) + end)) (Some i) σ. +Proof. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_until. +Qed. + +(** Silent checked writes, with the continuation held fixed while the state + handler is simplified. No congruence on a pool of bisimilar threads is + used here. *) +Lemma interp_rr_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c : + h a <> None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m ((upd h a v,allocs),c). +Proof. + intro Present. + pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_write_present n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c : + h a <> None -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) ((upd h a v,allocs),c). +Proof. + intro Present. + pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c v + (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. +Lemma interp_rr_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c : + h a = Some value -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m ((h,allocs),c). +Proof. + intro Lookup. + pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_read_value n + (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c : + h a = Some value -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) ((h,allocs),c). +Proof. + intro Lookup. + pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c value + (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +(** Checked operations with their scheduler continuation held fixed. *) + +Lemma interp_rr_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c : + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c) ~ + (log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)). +Proof. + pose proof (interp_indexed_emit heap_handler (tag,value) memory c + (fun x : unit => (Ret x : ictree sE unit))) as Hemit. + rewrite bind_ret_r in Hemit. + assert (Hstate : interp_state sh (semit tag value) (memory,c) ~ + (log (stamp (tag,value) c);; Ret (tt,(memory,S c)))). + { etransitivity; [exact Hemit |]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. } + rewrite interp_rr_emit. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c : + h a = Some current -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c) ~ + (if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)). +Proof. + intro Lookup; rewrite interp_rr_cas. + destruct (Nat.eqb current expected) eqn:Cmp. + - apply Nat.eqb_eq in Cmp; subst current. + pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired h allocs c + (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. + - apply Nat.eqb_neq in Cmp. + pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired current h allocs c + (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c) ~ + interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c). +Proof. + intros Pos Base Free First. + pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) h allocs size base c + (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_rr_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_rr_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) m h allocs c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a h allocs c Missing) as Hstate. + rewrite interp_rr_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a v h allocs c Missing) as Hstate. + rewrite interp_rr_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_rr_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) m h allocs c : + h a = None -> + interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a expected desired h allocs c (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. + rewrite bind_ret_r in Hstate. + rewrite interp_rr_cas. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + + +Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c) ~ + (log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)). +Proof. + pose proof (interp_indexed_emit heap_handler (tag,value) memory c + (fun x : unit => (Ret x : ictree sE unit))) as Hemit. + rewrite bind_ret_r in Hemit. + assert (Hstate : interp_state sh (semit tag value) (memory,c) ~ + (log (stamp (tag,value) c);; Ret (tt,(memory,S c)))). + { etransitivity; [exact Hemit |]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + eapply equ_clos_sbisim_goal; + [apply interp_state_ret | reflexivity | reflexivity]. } + rewrite interp_nd_source_emit. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c : + h a = Some current -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c) ~ + (if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)). +Proof. + intro Lookup; rewrite interp_nd_source_cas. + destruct (Nat.eqb current expected) eqn:Cmp. + - apply Nat.eqb_eq in Cmp; subst current. + pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired h allocs c + (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. + - apply Nat.eqb_neq in Cmp. + pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired current h allocs c + (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c) ~ + interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c). +Proof. + intros Pos Base Free First. + pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) h allocs size base c + (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. + rewrite bind_ret_r, interp_state_ret in Hstate. + rewrite interp_nd_source_alloc. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_source_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a (K : option nat -> thread sE) h allocs c : + h a = None -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c Missing) as Hstate. + rewrite interp_nd_source_read. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c : + h a = None -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a v h allocs c Missing) as Hstate. + rewrite interp_nd_source_write. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); + [eapply equ_clos_sbisim_goal; [exact Hstate | reflexivity | reflexivity] | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + +Lemma interp_nd_source_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired (K : option bool -> thread sE) h allocs c : + h a = None -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + a expected desired h allocs c (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. + rewrite bind_ret_r in Hstate. + rewrite interp_nd_source_cas. + lazymatch goal with + | |- (interp_state sh _ _ >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2 := next); [exact Hstate | intro result; reflexivity] |] + end. + rewrite bind_stuck_equ; reflexivity. +Qed. + + +(** Whole-block free: a valid free replaces the focused instruction by its + continuation at the released memory, preserving focus (and the RR + cursor); an invalid free is a fault for every continuation. *) + +Lemma source_free_raw_heap_free base (K : option unit -> thread sE) : + (denote_flow (CFree base) >>= K) ≅ + (heap_free (E:=CEff) base >>= fun _ => K (Some tt)). +Proof. + etransitivity; [apply source_raw_free_head|]. + symmetry; apply raw_heap_free_head. +Qed. + +Lemma interp_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) base + (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c : + managed_free memory base = Some memory' -> + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (Some i) cursor (memory,c) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) cursor (memory',c). +Proof. + intro Free. + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). + exact (interp_rr_heap_free n ts i base (fun _ => K (Some tt)) cursor memory memory' c Free). +Qed. + +Lemma interp_rr_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) base + (K : option unit -> thread sE) cursor (memory : ManagedHeap) c : + managed_free memory base = None -> + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (Some i) cursor (memory,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Invalid. + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). + exact (interp_rr_heap_free_invalid n ts i base (fun _ => K (Some tt)) cursor memory c Invalid). +Qed. + +Lemma interp_nd_source_free n (ts : pool sE (S n)) (i : Fin.t (S n)) base + (K : option unit -> thread sE) (memory memory' : ManagedHeap) c : + managed_free memory base = Some memory' -> + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (Some i) (memory,c) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) (memory',c). +Proof. + intro Free. + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). + exact (interp_nd_heap_free n ts i base (fun _ => K (Some tt)) memory memory' c Free). +Qed. + +Lemma interp_nd_source_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) base + (K : option unit -> thread sE) (memory : ManagedHeap) c : + managed_free memory base = None -> + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (Some i) (memory,c) ~ + (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Proof. + intro Invalid. + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,c) + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). + exact (interp_nd_heap_free_invalid n ts i base (fun _ => K (Some tt)) memory c Invalid). +Qed. + + + +(** ** Source-instruction first-yield rules, in exact mode. *) + +Local Open Scope list_scope. + +Lemma exact_source_bind {A B} (p : CProg A) (next : A -> CProg B) + (K : option B -> thread sE) sigma logs target sigma' : + segment_to sh csl_equ (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end) + sigma logs target sigma' -> + segment_to sh csl_equ (denote_flow (CBind p next) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply segment_to_equ; [apply source_raw_bind|exact H]. +Qed. + +Lemma exact_source_ret {A} (x : A) (K : option A -> thread sE) + sigma logs target sigma' : + segment_to sh csl_equ (K (Some x)) sigma logs target sigma' -> + segment_to sh csl_equ (denote_flow (CRet x) >>= K) sigma logs target sigma'. +Proof. + intro H; eapply segment_to_equ; [apply source_raw_ret|exact H]. +Qed. + +Lemma exact_source_until {A} (body : CProg (option A)) + (K : option unit -> thread sE) sigma logs target sigma' : + segment_to sh csl_equ (denote_flow body >>= until_tail body K) + sigma logs target sigma' -> + segment_to sh csl_equ (denote_flow (CUntilNone body) >>= K) + sigma logs target sigma'. +Proof. + intro H; eapply segment_to_equ; [apply source_raw_until|exact H]. +Qed. + +Lemma exact_source_read a v (K : option nat -> thread sE) + h allocs c logs target sigma' : + h a = Some v -> + segment_to sh csl_equ (K (Some v)) ((h,allocs),c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CRead a) >>= K) ((h,allocs),c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))). + - apply source_raw_read_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) + ((h,allocs),c) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_rd_some a h allocs c v Hr); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_write a v (K : option unit -> thread sE) + h allocs c logs target sigma' : + h a <> None -> + segment_to sh csl_equ (K (Some tt)) ((upd h a v,allocs),c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CWrite a v) >>= K) ((h,allocs),c) logs target sigma'. +Proof. + intros Hp (residual & Hseg & Htail). + destruct (h a) as [w|] eqn:Hw; [|contradiction]. + exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))). + - apply source_raw_write_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) + ((h,allocs),c) ([] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_wr_some a h allocs c v w Hw); reflexivity. + - reflexivity. +Qed. + +(** The raw handler equation [h_indexed_log] is the response certificate here; + [interp_indexed_emit] is an interpretation equation and cannot discharge + this premise. *) +Lemma exact_source_emit tag block (K : option unit -> thread sE) + (memory : ManagedHeap) c logs target sigma' : + segment_to sh csl_equ (K (Some tt)) (memory,S c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CEmit tag block) >>= K) (memory,c) + (stamp (tag,block) c :: logs) target sigma'. +Proof. + intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))). + - apply source_raw_emit_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))) + (memory,c) ([stamp (tag,block) c] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (h_indexed_log (Sigma:=ManagedHeap) (tag,block) memory c); + reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_cas_success a expected desired + (K : option bool -> thread sE) h allocs c logs target sigma' : + h a = Some expected -> + segment_to sh csl_equ (K (Some true)) ((upd h a desired,allocs),c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) + ((h,allocs),c) logs target sigma'. +Proof. + intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). + - apply source_raw_cas_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) + ((h,allocs),c) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + rewrite (heap_handler_cas_success a expected desired h allocs c Hr); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_cas_failure a expected desired current + (K : option bool -> thread sE) h allocs c logs target sigma' : + h a = Some current -> current <> expected -> + segment_to sh csl_equ (K (Some false)) ((h,allocs),c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) + ((h,allocs),c) logs target sigma'. +Proof. + intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). + - apply source_raw_cas_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) + ((h,allocs),c) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + rewrite (heap_handler_cas_failure a expected desired current h allocs c Hr Hne); + reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_free base (K : option unit -> thread sE) + (memory memory' : ManagedHeap) c logs target sigma' : + managed_free memory base = Some memory' -> + segment_to sh csl_equ (K (Some tt)) (memory',c) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CFree base) >>= K) (memory,c) logs target sigma'. +Proof. + intros Free (residual & Hseg & Htail). + exists residual; split; [|exact Htail]. + eapply segment_equ with (u' := residual) + (u := Vis (inr (inr (inl (HFree base)))) (fun _ => K (Some tt))). + - apply source_raw_free_head. + - change (ThreadSegment sh csl_equ + (Vis (inr (inr (inl (HFree base)))) (fun _ => K (Some tt))) + (memory,c) ([] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_free base memory memory' c Free); reflexivity. + - reflexivity. +Qed. + +Lemma exact_source_yield (K : option unit -> thread sE) sigma target : + guard_equ (K (Some tt)) target -> + segment_to sh csl_equ (denote_flow CYield >>= K) sigma [] target sigma. +Proof. + intro Htail; exists (K (Some tt)); split; [|exact Htail]. + eapply segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). + - apply source_raw_yield_head. + - apply segment_yield. + - reflexivity. +Qed. + +(** Finite syntax normalization is used only for raw equ and leading guards. + It never changes a scheduler focus or invokes pool sbisim congruence. *) +Ltac csl_raw_equ := + cbn beta iota zeta; + first [reflexivity | + lazymatch goal with + | |- (denote_flow (CBind _ _) >>= _) ≅ _ => + etransitivity; [apply source_raw_bind|]; csl_raw_equ + | |- (denote_flow (CRet _) >>= _) ≅ _ => + etransitivity; [apply source_raw_ret|]; csl_raw_equ + | |- ((?t >>= ?k) >>= ?j) ≅ _ => + etransitivity; [apply bind_bind|]; csl_raw_equ + | |- (Ret _ >>= _) ≅ _ => + etransitivity; [apply bind_ret_l|]; csl_raw_equ + | |- _ ≅ (denote_flow (CBind _ _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ (denote_flow (CRet _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ ((_ >>= _) >>= _) => symmetry; csl_raw_equ + | |- _ ≅ (Ret _ >>= _) => symmetry; csl_raw_equ + | |- Guard _ ≅ Guard _ => apply guard_equ_node; csl_raw_equ + end]. + +Local Close Scope list_scope. + +(** ** Structural Ticl rules over source programs *) + +Local Open Scope ticl_scope. +Local Typeclasses Transparent equ sbisim. + +(** ** Checked silent effects *) + +Lemma anl_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. +Qed. + +Lemma anr_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. +Qed. + +Lemma aul_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. +Qed. + +Lemma aur_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. +Qed. + +Lemma ag_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. +Qed. + +Lemma anl_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. +Qed. + +Lemma anr_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. +Qed. + +Lemma aul_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. +Qed. + +Lemma aur_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some value -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. +Qed. + +Lemma ag_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) + a value (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a = Some value -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. +Qed. + +Lemma anl_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. +Qed. + +Lemma anr_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. +Qed. + +Lemma aul_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. +Qed. + +Lemma aur_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. +Qed. + +Lemma ag_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Present. + rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. +Qed. + +Lemma anl_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. +Qed. + +Lemma anr_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. +Qed. + +Lemma aul_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. +Qed. + +Lemma aur_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a <> None -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. +Qed. + +Lemma ag_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) + a v (K : option unit -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a <> None -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Present. + rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. +Qed. + +(** ** Valid whole-block free; [managed_free] covers the null no-op. *) + +Lemma anl_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AN ψ )>)). +Proof. + intros Free. + rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma anr_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Free. + rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma aul_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AU ψ )>)). +Proof. + intros Free. + rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma aur_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Free. + rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma ag_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= AG φ )>)). +Proof. + intros Free. + rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. +Qed. + +Lemma anl_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AN ψ )>)). +Proof. + intros Free. + rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. +Qed. + +Lemma anr_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Free. + rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. +Qed. + +Lemma aul_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w + (φ ψ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AU ψ )>)). +Proof. + intros Free. + rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. +Qed. + +Lemma aur_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + managed_free memory base = Some memory' -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Free. + rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. +Qed. + +Lemma ag_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w + (φ : ticllW (indexed (nat * nat))) : + managed_free memory base = Some memory' -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= AG φ )>)). +Proof. + intros Free. + rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. +Qed. + +Lemma anl_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma anr_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma aul_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma aur_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma ag_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma anl_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma anr_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma aul_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma aur_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma ag_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) + size base (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) : + Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>)). +Proof. + intros Pos Base Free First. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. +Qed. + +Lemma anl_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. +Qed. + +Lemma anr_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. +Qed. + +Lemma aul_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. +Qed. + +Lemma aur_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. +Qed. + +Lemma ag_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_nd sh (S n) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + else + interp_schedule_nd sh (S n) + (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. +Qed. + +Lemma anl_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. +Qed. + +Lemma anr_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. +Qed. + +Lemma aul_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. +Qed. + +Lemma aur_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + h a = Some current -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (<[ {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. +Qed. + +Lemma ag_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) + a expected desired current (K : option bool -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) : + h a = Some current -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (<( {if Nat.eqb current expected then + interp_schedule_rr sh (S n) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + else + interp_schedule_rr sh (S n) + (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )>)). +Proof. + intros Lookup. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. +Qed. + +(** ** Source flow and pool structure *) + +Lemma anl_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (x : A) (K : option A -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow p >>= fun flow => + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) + (body : CProg (option A)) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. +Qed. + +Lemma anl_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. +Qed. + +Lemma anr_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. +Qed. + +Lemma aul_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. +Qed. + +Lemma aur_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. +Qed. + +Lemma ag_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) + (child : CProg unit) (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S (S n)) + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. +Qed. + +(** ** Observable emission and cooperative selection *) + +Lemma anl_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). +Proof. + rewrite interp_nd_source_emit_log. + apply anl_log_iff. +Qed. + +Lemma anr_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). +Proof. + rewrite interp_nd_source_emit_log. + apply anr_log_iff. +Qed. + +Lemma aul_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= ψ )> \/ + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). +Proof. + rewrite interp_nd_source_emit_log. + apply aul_log_iff. +Qed. + +Lemma aur_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= ψ ]> \/ + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). +Proof. + rewrite interp_nd_source_emit_log. + apply aur_log_iff. +Qed. + +Lemma ag_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). +Proof. + rewrite interp_nd_source_emit_log. + apply ag_log_iff. +Qed. + +Lemma anl_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). +Proof. + rewrite interp_rr_emit_log. + apply anl_log_iff. +Qed. + +Lemma anr_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). +Proof. + rewrite interp_rr_emit_log. + apply anr_log_iff. +Qed. + +Lemma aul_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= ψ )> \/ + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). +Proof. + rewrite interp_rr_emit_log. + apply aul_log_iff. +Qed. + +Lemma aur_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= ψ ]> \/ + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). +Proof. + rewrite interp_rr_emit_log. + apply aur_log_iff. +Qed. + +Lemma ag_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) + tag value (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {log (stamp (tag,value) c);; + interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). +Proof. + rewrite interp_rr_emit_log. + apply ag_log_iff. +Qed. + +Lemma anl_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= ψ )>)). +Proof. + rewrite interp_nd_source_yield. + apply anl_csl_nd_select. +Qed. + +Lemma anr_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= ψ ]>)). +Proof. + rewrite interp_nd_source_yield. + apply anr_csl_nd_select. +Qed. + +Lemma aul_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= ψ )> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= φ AU ψ )>))). +Proof. + rewrite interp_nd_source_yield. + apply aul_csl_nd_select. +Qed. + +Lemma aur_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= ψ ]> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= φ AU ψ ]>))). +Proof. + rewrite interp_nd_source_yield. + apply aur_csl_nd_select. +Qed. + +Lemma ag_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_nd_source_yield. + apply ag_csl_nd_select. +Qed. + +Lemma anl_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ )>)). +Proof. + rewrite interp_rr_yield. + apply anl_csl_rr_select. +Qed. + +Lemma anr_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ ]>)). +Proof. + rewrite interp_rr_yield. + apply anr_csl_rr_select. +Qed. + +Lemma aul_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m memory c w + (φ ψ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ )>)). +Proof. + rewrite interp_rr_yield. + apply aul_csl_rr_select. +Qed. + +Lemma aur_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ ]>)). +Proof. + rewrite interp_rr_yield. + apply aur_csl_rr_select. +Qed. + +Lemma ag_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : option unit -> thread sE) m memory c w + (φ : ticllW (indexed (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= AG φ )>)). +Proof. + rewrite interp_rr_yield. + apply ag_csl_rr_select. +Qed. + +(** ** Finite heaps supply their constructive first-fit witness *) + +Lemma anl_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anl_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anl_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anr_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anr_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anr_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aul_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aul_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aul_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aur_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aur_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aur_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma ag_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) h allocs c w + (φ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_nd sh (S n) + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (ag_csl_nd_alloc n ts i size base K h allocs c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (ag_csl_nd_alloc n ts i size base K h allocs c w φ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anl_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anl_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anl_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma anr_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (anr_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (anr_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aul_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h allocs c w + (φ ψ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aul_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aul_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma aur_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + heap_finite h -> Nat.lt 0 size -> + (<[ {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <[ {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (aur_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (aur_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply Hall; assumption. +Qed. + +Lemma ag_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) + size (K : option nat -> thread sE) m h allocs c w + (φ : ticllW (indexed (nat * nat))) : + heap_finite h -> Nat.lt 0 size -> + (<( {interp_schedule_rr sh (S n) + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + forall base, + Nat.lt 0 base -> block_free h base size -> + (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> + <( {interp_schedule_rr sh (S n) + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>). +Proof. + intros Finite Pos; split. + - intros Hsource base Base Free First. + apply (proj1 (ag_csl_rr_alloc n ts i size base K m h allocs c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + as (base & Base & Free & First & _). + apply (proj2 (ag_csl_rr_alloc n ts i size base K m h allocs c w φ Pos Base Free First)). + apply Hall; assumption. +Qed. + +(** ** Source loops: actual observations sustain AG; guard-only divergence does not *) + +Lemma run_nd_emit_loop_ag tag value memory c w : + not_done w -> + <( {run_nd (CUntilNone (CBind (CEmit tag value) + (fun _ => CRet (Some tt : option unit)))) memory c}, {w} |= AG ⊤ )>. +Proof. + revert c w; coinduction R CIH; intros c w Hw. + unfold run_nd, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_schedule_nd sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) (memory,c)) w). + rewrite interp_nd_source_until_none, interp_nd_source_bind, + interp_nd_source_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_nd_source_ret. + erewrite (interp_schedule_nd_guard sh) by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. +Qed. + +Lemma run_rr_emit_loop_ag tag value memory c w : + not_done w -> + <( {run_rr (CUntilNone (CBind (CEmit tag value) + (fun _ => CRet (Some tt : option unit)))) memory c}, {w} |= AG ⊤ )>. +Proof. + revert c w; coinduction R CIH; intros c w Hw. + unfold run_rr, denote. + change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R + (interp_schedule_rr sh 1 + (([Ret tt] : pool sE 1) @ Fin.F1 := + (denote_flow + (CUntilNone + (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) + >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (memory,c)) w). + rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. + unfold log, ICtree.trigger. + rewrite bind_vis. + setoid_rewrite bind_ret_l. + split; [split; [exact I | exact Hw] |]. + split. + - apply can_step_vis; [exact tt | exact Hw]. + - intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & Hnd). + rewrite interp_rr_ret. + erewrite interp_schedule_rr_guard by reflexivity. + cbn [Vector.replace]. + apply CIH. + constructor. +Qed. + +(** The silent loop starts focused, so the whole run is raw-equivalent to its + own guard and hence to [stuck]; no scheduler tau is erased. *) +Lemma run_nd_silent_loop_no_ag memory c w : + ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) memory c}, {w} |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + assert (Hguard : run_nd p memory c ≅ Guard (run_nd p memory c)). + { unfold run_nd. + etransitivity. + - apply ((interp_schedule_nd_equ sh) 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_schedule_nd. + rewrite (SBisim.trans_schedule_focused_guard + 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, ICTree.Interp.State.Mod.interp_state_tau. + reflexivity. } + rewrite (equ_guard_stuck _ Hguard). + apply ag_stuck. +Qed. + +Lemma run_rr_silent_loop_no_ag memory c w : + ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) memory c}, {w} |= AG ⊤ )>. +Proof. + set (p := CUntilNone (CRet (Some tt : option unit))). + assert (Hraw : denote p ≅ Guard (denote p)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + assert (Hguard : run_rr p memory c ≅ Guard (run_rr p memory c)). + { unfold run_rr. + etransitivity. + - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). + apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. + - unfold interp_schedule_rr. + rewrite unfold_run_round_robin, + (schedule_focused_guard 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). + rewrite interp_erase_guard, ICTree.Interp.State.Mod.interp_state_tau. + reflexivity. } + rewrite (equ_guard_stuck _ Hguard). + apply ag_stuck. +Qed. diff --git a/theories/Lang/CSL/Queue.v b/theories/Lang/CSL/Queue.v deleted file mode 100644 index 271c43a..0000000 --- a/theories/Lang/CSL/Queue.v +++ /dev/null @@ -1,6 +0,0 @@ -From TICL Require Export - Lang.CSL - Lang.CSL.Queue.Representation Lang.CSL.Queue.Layout Lang.CSL.Queue.Operations - Lang.CSL.Queue.Sequential Lang.CSL.Queue.Recurrence Lang.CSL.Queue.Trace - Lang.CSL.Queue.Frame Lang.CSL.Queue.Separation Lang.CSL.Queue.Alternating - Lang.CSL.Queue.Composition Lang.CSL.Queue.Program Lang.CSL.Queue.Ticl. diff --git a/theories/Lang/CSL/Segments.v b/theories/Lang/CSL/Segments.v deleted file mode 100644 index afa3331..0000000 --- a/theories/Lang/CSL/Segments.v +++ /dev/null @@ -1,198 +0,0 @@ -(** * Source-instruction first-yield rules. - - Everything structural about first-yield segments — the inductive, its - inversion laws, guard transport, determinism, branch-freedom and the - scheduling equations — is owned by [ICTree.Interp.Yield.Segments] and is - polymorphic in the handler and the response relation. What remains here - is exactly the [CProg]-dependent layer: one rule per source instruction, - stated at the CSL handler [sh] in EXACT mode, plus the raw normalization - tactic those rules are applied through. *) - -From Stdlib Require Import List Arith.PeanoNat Fin Vector - Classes.Morphisms Classes.RelationClasses Program.Equality. -From ExtLib Require Import Data.Monads.StateMonad. -From TICL Require Import - Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp - ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace - ICTree.Events.Writer ICTree.Events.Yield ICTree.Interp.State.Mod - ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim - ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic - Utils.Vectors. - -From TICL Require Export ICTree.Interp.Yield.Segments. - -Import ICtree ICTreeNotations ListNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. -Local Open Scope list_scope. - -(** ** The two response-relation instances. - - Naming them is not a compatibility layer: they are the two arguments the - generic segment theory is instantiated at. *) -Notation csl_sb := - (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ~ u). -Notation csl_equ := - (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ≅ u). -(** ** Source-instruction rules, in exact mode. *) - -Lemma exact_source_bind {A B} (p : CProg A) (next : A -> CProg B) - (K : option B -> thread sE) sigma logs target sigma' : - segment_to sh csl_equ (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end) - sigma logs target sigma' -> - segment_to sh csl_equ (denote_flow (CBind p next) >>= K) sigma logs target sigma'. -Proof. - intro H; eapply segment_to_equ; [apply source_raw_bind|exact H]. -Qed. - -Lemma exact_source_ret {A} (x : A) (K : option A -> thread sE) - sigma logs target sigma' : - segment_to sh csl_equ (K (Some x)) sigma logs target sigma' -> - segment_to sh csl_equ (denote_flow (CRet x) >>= K) sigma logs target sigma'. -Proof. - intro H; eapply segment_to_equ; [apply source_raw_ret|exact H]. -Qed. - -Lemma exact_source_until {A} (body : CProg (option A)) - (K : option unit -> thread sE) sigma logs target sigma' : - segment_to sh csl_equ (denote_flow body >>= until_tail body K) - sigma logs target sigma' -> - segment_to sh csl_equ (denote_flow (CUntilNone body) >>= K) - sigma logs target sigma'. -Proof. - intro H; eapply segment_to_equ; [apply source_raw_until|exact H]. -Qed. - -Lemma exact_source_read a v (K : option nat -> thread sE) - h c logs target sigma' : - h a = Some v -> - segment_to sh csl_equ (K (Some v)) (h,c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CRead a) >>= K) (h,c) logs target sigma'. -Proof. - intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))). - - apply source_raw_read_head. - - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) - (h,c) ([] ++ logs) residual sigma'). - eapply segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (heap_handler_rd_some a h c v Hr); reflexivity. - - reflexivity. -Qed. - -Lemma exact_source_write a v (K : option unit -> thread sE) - h c logs target sigma' : - h a <> None -> - segment_to sh csl_equ (K (Some tt)) (upd h a v,c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CWrite a v) >>= K) (h,c) logs target sigma'. -Proof. - intros Hp (residual & Hseg & Htail). - destruct (h a) as [w|] eqn:Hw; [|contradiction]. - exists residual; split; [|exact Htail]. - eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))). - - apply source_raw_write_head. - - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) - (h,c) ([] ++ logs) residual sigma'). - eapply segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (heap_handler_wr_some a h c v w Hw); reflexivity. - - reflexivity. -Qed. - -(** The raw handler equation [h_indexed_log] is the response certificate here; - [interp_indexed_emit] is an interpretation equation and cannot discharge - this premise. *) -Lemma exact_source_emit tag block (K : option unit -> thread sE) - h c logs target sigma' : - segment_to sh csl_equ (K (Some tt)) (h,S c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CEmit tag block) >>= K) (h,c) - (stamp (tag,block) c :: logs) target sigma'. -Proof. - intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))). - - apply source_raw_emit_head. - - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))) - (h,c) ([stamp (tag,block) c] ++ logs) residual sigma'). - eapply segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (h_indexed_log (Sigma:=Heap) (tag,block) h c); - reflexivity. - - reflexivity. -Qed. - -Lemma exact_source_cas_success a expected desired - (K : option bool -> thread sE) h c logs target sigma' : - h a = Some expected -> - segment_to sh csl_equ (K (Some true)) (upd h a desired,c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) - (h,c) logs target sigma'. -Proof. - intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). - - apply source_raw_cas_head. - - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) - (h,c) ([] ++ logs) residual sigma'). - eapply segment_user; [|exact Hseg]. - cbn [emit_list]; - rewrite (heap_handler_cas_success a expected desired h c Hr); reflexivity. - - reflexivity. -Qed. - -Lemma exact_source_cas_failure a expected desired current - (K : option bool -> thread sE) h c logs target sigma' : - h a = Some current -> current <> expected -> - segment_to sh csl_equ (K (Some false)) (h,c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) - (h,c) logs target sigma'. -Proof. - intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. - eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))). - - apply source_raw_cas_head. - - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) - (h,c) ([] ++ logs) residual sigma'). - eapply segment_user; [|exact Hseg]. - cbn [emit_list]; - rewrite (heap_handler_cas_failure a expected desired current h c Hr Hne); - reflexivity. - - reflexivity. -Qed. - -Lemma exact_source_yield (K : option unit -> thread sE) sigma target : - guard_equ (K (Some tt)) target -> - segment_to sh csl_equ (denote_flow CYield >>= K) sigma [] target sigma. -Proof. - intro Htail; exists (K (Some tt)); split; [|exact Htail]. - eapply segment_equ with (u := Vis (inl Yield) (fun _ => K (Some tt))). - - apply source_raw_yield_head. - - apply segment_yield. - - reflexivity. -Qed. - -(** Finite syntax normalization is used only for raw equ and leading guards. - It never changes a scheduler focus or invokes pool sbisim congruence. *) -Ltac csl_raw_equ := - cbn beta iota zeta; - first [reflexivity | - lazymatch goal with - | |- (denote_flow (CBind _ _) >>= _) ≅ _ => - etransitivity; [apply source_raw_bind|]; csl_raw_equ - | |- (denote_flow (CRet _) >>= _) ≅ _ => - etransitivity; [apply source_raw_ret|]; csl_raw_equ - | |- ((?t >>= ?k) >>= ?j) ≅ _ => - etransitivity; [apply bind_bind|]; csl_raw_equ - | |- (Ret _ >>= _) ≅ _ => - etransitivity; [apply bind_ret_l|]; csl_raw_equ - | |- _ ≅ (denote_flow (CBind _ _) >>= _) => symmetry; csl_raw_equ - | |- _ ≅ (denote_flow (CRet _) >>= _) => symmetry; csl_raw_equ - | |- _ ≅ ((_ >>= _) >>= _) => symmetry; csl_raw_equ - | |- _ ≅ (Ret _ >>= _) => symmetry; csl_raw_equ - | |- Guard _ ≅ Guard _ => apply guard_equ_node; csl_raw_equ - end]. diff --git a/theories/Lang/CSL/Syntax.v b/theories/Lang/CSL/Syntax.v deleted file mode 100644 index 8d22ba0..0000000 --- a/theories/Lang/CSL/Syntax.v +++ /dev/null @@ -1,14 +0,0 @@ -Module CSLSyntax. - Inductive CProg : Type -> Type := - | CRead (a : nat) : CProg nat - | CWrite (a v : nat) : CProg unit - | CEmit (tag value : nat) : CProg unit - | CYield : CProg unit - | CFork (body : CProg unit) : CProg unit - | CRet {A : Type} (value : A) : CProg A - | CBind {A B : Type} (body : CProg A) (next : A -> CProg B) : CProg B - | CUntilNone {A : Type} (body : CProg (option A)) : CProg unit - | CAlloc (size : nat) : CProg nat - | CCAS (a expected desired : nat) : CProg bool. -End CSLSyntax. -Export CSLSyntax. diff --git a/theories/Lang/CSL/Ticl.v b/theories/Lang/CSL/Ticl.v deleted file mode 100644 index 2962ce6..0000000 --- a/theories/Lang/CSL/Ticl.v +++ /dev/null @@ -1,1931 +0,0 @@ -From Stdlib Require Import Arith.PeanoNat Fin Vector. -From Coinduction Require Import coinduction lattice tactics. -From TICL Require Import - Lang.CSL.Syntax Lang.CSL.Heap Lang.CSL.Denote Lang.CSL.Interp - ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer - ICTree.Events.Yield ICTree.Events.Heap ICTree.Interp.Refine ICTree.Interp.Yield.Mod - ICTree.Interp.Yield.RoundRobin ICTree.Logic.Trans - ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep Logic.Core Utils.Vectors. - -Import ICtree ICTreeNotations TiclNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. -Local Open Scope ticl_scope. -Local Typeclasses Transparent equ sbisim. - -(** ** Selection from an unfocused nonempty pool *) - -Lemma anl_csl_nd_select n (ts : pool sE (S n)) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - ts (None) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - ts (Some j) (h,c)}, {w} |= ψ )>)). -Proof. - rewrite (interp_schedule_nd_select sh). - apply anl_br. -Qed. - -Lemma anr_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - ts (None) (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <[ {interp_schedule_nd sh (S n) - ts (Some j) (h,c)}, {w} |= ψ ]>)). -Proof. - rewrite (interp_schedule_nd_select sh). - apply anr_br. -Qed. - -Lemma aul_csl_nd_select n (ts : pool sE (S n)) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - ts (None) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= ψ )> \/ - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - ts (Some j) (h,c)}, {w} |= φ AU ψ )>))). - -From Coinduction Require Import coinduction. -Proof. - rewrite (interp_schedule_nd_select sh). - symmetry; apply aul_br. -Qed. - -Lemma aur_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - ts (None) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= ψ ]> \/ - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <[ {interp_schedule_nd sh (S n) - ts (Some j) (h,c)}, {w} |= φ AU ψ ]>))). -Proof. - rewrite (interp_schedule_nd_select sh). - symmetry; apply aur_br. -Qed. - -Lemma ag_csl_nd_select n (ts : pool sE (S n)) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - ts (None) (h,c)}, {w} |= AG φ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - ts (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - ts (Some j) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_schedule_nd_select sh). - symmetry; apply ag_br. -Qed. - -Lemma anl_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - ts (None) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite interp_schedule_rr_select; reflexivity. -Qed. - -Lemma anr_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - ts (None) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite interp_schedule_rr_select; reflexivity. -Qed. - -Lemma aul_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - ts (None) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite interp_schedule_rr_select; reflexivity. -Qed. - -Lemma aur_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - ts (None) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite interp_schedule_rr_select; reflexivity. -Qed. - -Lemma ag_csl_rr_select n (ts : pool sE (S n)) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - ts (None) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite interp_schedule_rr_select; reflexivity. -Qed. - -(** ** Checked silent effects *) - -Lemma anl_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. -Qed. - -Lemma anr_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some value -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. -Qed. - -Lemma aul_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. -Qed. - -Lemma aur_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some value -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. -Qed. - -Lemma ag_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) (h,c)}, {w} |= AG φ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h c Lookup); reflexivity. -Qed. - -Lemma anl_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. -Qed. - -Lemma anr_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some value -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. -Qed. - -Lemma aul_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. -Qed. - -Lemma aur_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some value -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. -Qed. - -Lemma ag_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - h a = Some value -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m (h,c)}, {w} |= AG φ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h c Lookup); reflexivity. -Qed. - -Lemma anl_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. -Qed. - -Lemma anr_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a <> None -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. -Qed. - -Lemma aul_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. -Qed. - -Lemma aur_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a <> None -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. -Qed. - -Lemma ag_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (upd h a v,c)}, {w} |= AG φ )>)). -Proof. - intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h c Present); reflexivity. -Qed. - -Lemma anl_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Present. - rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. -Qed. - -Lemma anr_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a <> None -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Present. - rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. -Qed. - -Lemma aul_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Present. - rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. -Qed. - -Lemma aur_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a <> None -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Present. - rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. -Qed. - -Lemma ag_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - h a <> None -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (upd h a v,c)}, {w} |= AG φ )>)). -Proof. - intros Present. - rewrite (interp_rr_write_present n ts i a v K m h c Present); reflexivity. -Qed. - -Lemma anl_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. -Qed. - -Lemma anr_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. -Qed. - -Lemma aul_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. -Qed. - -Lemma aur_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. -Qed. - -Lemma ag_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h c Pos Base Free First); reflexivity. -Qed. - -Lemma anl_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. -Qed. - -Lemma anr_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. -Qed. - -Lemma aul_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. -Qed. - -Lemma aur_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. -Qed. - -Lemma ag_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= AG φ )>)). -Proof. - intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h c Pos Base Free First); reflexivity. -Qed. - -Lemma anl_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. -Qed. - -Lemma anr_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some current -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. -Qed. - -Lemma aul_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. -Qed. - -Lemma aur_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some current -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. -Qed. - -Lemma ag_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) (upd h a desired,c) - else - interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) (h,c)}, {w} |= AG φ )>)). -Proof. - intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h c Lookup); reflexivity. -Qed. - -Lemma anl_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. -Qed. - -Lemma anr_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some current -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. -Qed. - -Lemma aul_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. -Qed. - -Lemma aur_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - h a = Some current -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. -Qed. - -Lemma ag_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - h a = Some current -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {if Nat.eqb current expected then - interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m (upd h a desired,c) - else - interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m (h,c)}, {w} |= AG φ )>)). -Proof. - intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h c Lookup); reflexivity. -Qed. - -(** ** Source flow and pool structure *) - -Lemma anl_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. -Qed. - -Lemma anr_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. -Qed. - -Lemma aul_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. -Qed. - -Lemma aur_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. -Qed. - -Lemma ag_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_nd_source_ret n ts i x K (h,c)); reflexivity. -Qed. - -Lemma anl_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. -Qed. - -Lemma anr_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. -Qed. - -Lemma aul_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. -Qed. - -Lemma aur_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. -Qed. - -Lemma ag_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_rr_ret n ts i x K m (h,c)); reflexivity. -Qed. - -Lemma anl_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. -Qed. - -Lemma anr_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. -Qed. - -Lemma aul_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. -Qed. - -Lemma aur_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. -Qed. - -Lemma ag_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_nd_source_bind n ts i p next K (h,c)); reflexivity. -Qed. - -Lemma anl_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. -Qed. - -Lemma anr_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. -Qed. - -Lemma aul_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. -Qed. - -Lemma aur_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. -Qed. - -Lemma ag_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_rr_bind n ts i p next K m (h,c)); reflexivity. -Qed. - -Lemma anl_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. -Qed. - -Lemma anr_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. -Qed. - -Lemma aul_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. -Qed. - -Lemma aur_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. -Qed. - -Lemma ag_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_nd_source_until_none n ts i body K (h,c)); reflexivity. -Qed. - -Lemma anl_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. -Qed. - -Lemma anr_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. -Qed. - -Lemma aul_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. -Qed. - -Lemma aur_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. -Qed. - -Lemma ag_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_rr_until_none n ts i body K m (h,c)); reflexivity. -Qed. - -Lemma anl_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. -Qed. - -Lemma anr_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. -Qed. - -Lemma aul_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. -Qed. - -Lemma aur_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. -Qed. - -Lemma ag_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_nd_source_fork n ts i child K (h,c)); reflexivity. -Qed. - -Lemma anl_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. -Qed. - -Lemma anr_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. -Qed. - -Lemma aul_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. -Qed. - -Lemma aur_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. -Qed. - -Lemma ag_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite (interp_rr_fork n ts i child K m (h,c)); reflexivity. -Qed. - -(** ** Observable emission and cooperative selection *) - -Lemma anl_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). -Proof. - rewrite interp_nd_source_emit_log. - apply anl_log_iff. -Qed. - -Lemma anr_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). -Proof. - rewrite interp_nd_source_emit_log. - apply anr_log_iff. -Qed. - -Lemma aul_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ )> \/ - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). -Proof. - rewrite interp_nd_source_emit_log. - apply aul_log_iff. -Qed. - -Lemma aur_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= ψ ]> \/ - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). -Proof. - rewrite interp_nd_source_emit_log. - apply aur_log_iff. -Qed. - -Lemma ag_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). -Proof. - rewrite interp_nd_source_emit_log. - apply ag_log_iff. -Qed. - -Lemma anl_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). -Proof. - rewrite interp_rr_emit_log. - apply anl_log_iff. -Qed. - -Lemma anr_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ - <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). -Proof. - rewrite interp_rr_emit_log. - apply anr_log_iff. -Qed. - -Lemma aul_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ )> \/ - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). -Proof. - rewrite interp_rr_emit_log. - apply aul_log_iff. -Qed. - -Lemma aur_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= ψ ]> \/ - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ - <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). -Proof. - rewrite interp_rr_emit_log. - apply aur_log_iff. -Qed. - -Lemma ag_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {log (stamp (tag,value) c);; - interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {w} |= φ )> /\ - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (h,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). -Proof. - rewrite interp_rr_emit_log. - apply ag_log_iff. -Qed. - -Lemma anl_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ )>)). -Proof. - rewrite interp_nd_source_yield. - apply anl_csl_nd_select. -Qed. - -Lemma anr_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= ψ ]>)). -Proof. - rewrite interp_nd_source_yield. - apply anr_csl_nd_select. -Qed. - -Lemma aul_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ )> \/ - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ )>))). -Proof. - rewrite interp_nd_source_yield. - apply aul_csl_nd_select. -Qed. - -Lemma aur_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= ψ ]> \/ - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= φ AU ψ ]>))). -Proof. - rewrite interp_nd_source_yield. - apply aur_csl_nd_select. -Qed. - -Lemma ag_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - (<( {Br n (fun j : Fin.t (S n) => - interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c))}, {w} |= φ )> /\ - forall j : Fin.t (S n), - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite interp_nd_source_yield. - apply ag_csl_nd_select. -Qed. - -Lemma anl_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ )>)). -Proof. - rewrite interp_rr_yield. - apply anl_csl_rr_select. -Qed. - -Lemma anr_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AN ψ ]>)). -Proof. - rewrite interp_rr_yield. - apply anr_csl_rr_select. -Qed. - -Lemma aul_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ )>)). -Proof. - rewrite interp_rr_yield. - apply aul_csl_rr_select. -Qed. - -Lemma aur_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= φ AU ψ ]>)). -Proof. - rewrite interp_rr_yield. - apply aur_csl_rr_select. -Qed. - -Lemma ag_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (h,c)}, {w} |= AG φ )>)). -Proof. - rewrite interp_rr_yield. - apply ag_csl_rr_select. -Qed. - -(** ** Finite heaps supply their constructive first-fit witness *) - -Lemma anl_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (anl_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma anr_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - heap_finite h -> Nat.lt 0 size -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (anr_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma aul_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (aul_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma aur_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - heap_finite h -> Nat.lt 0 size -> - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (aur_csl_nd_alloc n ts i size base K h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma ag_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (hunion (hblock base size) h,c)}, {w} |= AG φ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (ag_csl_nd_alloc n ts i size base K h c w φ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma anl_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (anl_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma anr_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - heap_finite h -> Nat.lt 0 size -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AN ψ ]>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (anr_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma aul_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (aul_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma aur_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - heap_finite h -> Nat.lt 0 size -> - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= φ AU ψ ]>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (aur_csl_rr_alloc n ts i size base K m h c w φ ψ Pos Base Free First)). - apply Hall; assumption. -Qed. - -Lemma ag_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - heap_finite h -> Nat.lt 0 size -> - (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - forall base, - Nat.lt 0 base -> block_free h base size -> - (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> - <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (hunion (hblock base size) h,c)}, {w} |= AG φ )>). -Proof. - intros Finite Pos; split. - - intros Hsource base Base Free First. - apply (proj1 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)); exact Hsource. - - intro Hall. - destruct (heap_handler_alloc_finite h size c Finite Pos) - as (base & Base & Free & First & _). - apply (proj2 (ag_csl_rr_alloc n ts i size base K m h c w φ Pos Base Free First)). - apply Hall; assumption. -Qed. - -(** ** Total single-cell free through the shared raw heap event *) - -Lemma anl_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ )> <-> - <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AN ψ )>). -Proof. - rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. -Qed. - -Lemma anr_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AN ψ ]> <-> - <[ {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AN ψ ]>). -Proof. - rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. -Qed. - -Lemma aul_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ )> <-> - <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AU ψ )>). -Proof. - rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. -Qed. - -Lemma aur_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= φ AU ψ ]> <-> - <[ {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= φ AU ψ ]>). -Proof. - rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. -Qed. - -Lemma ag_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) (h,c)}, {w} |= AG φ )> <-> - <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (hfree a h,c)}, {w} |= AG φ )>). -Proof. - rewrite (interp_nd_heap_free n ts i a K h c); reflexivity. -Qed. - -Lemma anl_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ )> <-> - <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AN ψ )>). -Proof. - rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. -Qed. - -Lemma anr_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AN ψ ]> <-> - <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AN ψ ]>). -Proof. - rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. -Qed. - -Lemma aul_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c w - (φ ψ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ )> <-> - <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AU ψ )>). -Proof. - rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. -Qed. - -Lemma aur_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : - (<[ {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= φ AU ψ ]> <-> - <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= φ AU ψ ]>). -Proof. - rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. -Qed. - -Lemma ag_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : unit -> thread sE) m h c w - (φ : ticllW (indexed (nat * nat))) : - (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) a >>= K)) (Some i) m (h,c)}, {w} |= AG φ )> <-> - <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (hfree a h,c)}, {w} |= AG φ )>). -Proof. - rewrite (interp_rr_heap_free n ts i a K m h c); reflexivity. -Qed. - -(** ** Source loops: actual observations sustain AG; guard-only divergence does not *) - -Lemma run_nd_emit_loop_ag tag value h c w : - not_done w -> - <( {run_nd (CUntilNone (CBind (CEmit tag value) - (fun _ => CRet (Some tt : option unit)))) h c}, {w} |= AG ⊤ )>. -Proof. - revert c w; coinduction R CIH; intros c w Hw. - unfold run_nd, denote. - change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R - (interp_schedule_nd sh 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) (h,c)) w). - rewrite interp_nd_source_until_none, interp_nd_source_bind, - interp_nd_source_emit_log. - unfold log, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - split; [split; [exact I | exact Hw] |]. - split. - - apply can_step_vis; [exact tt | exact Hw]. - - intros t' w' Htr. - apply ktrans_vis in Htr as ([] & -> & <- & Hnd). - rewrite interp_nd_source_ret. - erewrite (interp_schedule_nd_guard sh) by reflexivity. - cbn [Vector.replace]. - apply CIH. - constructor. -Qed. - -Lemma run_rr_emit_loop_ag tag value h c w : - not_done w -> - <( {run_rr (CUntilNone (CBind (CEmit tag value) - (fun _ => CRet (Some tt : option unit)))) h c}, {w} |= AG ⊤ )>. -Proof. - revert c w; coinduction R CIH; intros c w Hw. - unfold run_rr, denote. - change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R - (interp_schedule_rr sh 1 - (([Ret tt] : pool sE 1) @ Fin.F1 := - (denote_flow - (CUntilNone - (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) - >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (h,c)) w). - rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. - unfold log, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - split; [split; [exact I | exact Hw] |]. - split. - - apply can_step_vis; [exact tt | exact Hw]. - - intros t' w' Htr. - apply ktrans_vis in Htr as ([] & -> & <- & Hnd). - rewrite interp_rr_ret. - erewrite interp_schedule_rr_guard by reflexivity. - cbn [Vector.replace]. - apply CIH. - constructor. -Qed. - -(** The silent loop starts focused, so the whole run is raw-equivalent to its - own guard and hence to [stuck]; no scheduler tau is erased. *) -Lemma run_nd_silent_loop_no_ag h c w : - ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) h c}, {w} |= AG ⊤ )>. -Proof. - set (p := CUntilNone (CRet (Some tt : option unit))). - assert (Hraw : denote p ≅ Guard (denote p)). - { unfold p, denote. - etransitivity; [apply source_raw_until |]. - etransitivity; [apply source_raw_ret |]. - reflexivity. } - assert (Hguard : run_nd p h c ≅ Guard (run_nd p h c)). - { unfold run_nd. - etransitivity. - - apply ((interp_schedule_nd_equ sh) 1 _ [Guard (denote p)]). - apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. - - unfold interp_schedule_nd. - rewrite (SBisim.trans_schedule_focused_guard - 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). - rewrite interp_erase_guard, Mod.interp_state_tau. - reflexivity. } - rewrite (equ_guard_stuck _ Hguard). - apply ag_stuck. -Qed. - -Lemma run_rr_silent_loop_no_ag h c w : - ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) h c}, {w} |= AG ⊤ )>. -Proof. - set (p := CUntilNone (CRet (Some tt : option unit))). - assert (Hraw : denote p ≅ Guard (denote p)). - { unfold p, denote. - etransitivity; [apply source_raw_until |]. - etransitivity; [apply source_raw_ret |]. - reflexivity. } - assert (Hguard : run_rr p h c ≅ Guard (run_rr p h c)). - { unfold run_rr. - etransitivity. - - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). - apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. - - unfold interp_schedule_rr. - rewrite unfold_run_round_robin, - (schedule_focused_guard 0 [Guard (denote p)] Fin.F1 (denote p) eq_refl). - rewrite interp_erase_guard, Mod.interp_state_tau. - reflexivity. } - rewrite (equ_guard_stuck _ Hguard). - apply ag_stuck. -Qed. diff --git a/theories/Utils/Pcm.v b/theories/Utils/Pcm.v index b2346f8..b5a261f 100644 --- a/theories/Utils/Pcm.v +++ b/theories/Utils/Pcm.v @@ -208,6 +208,32 @@ Arguments atrue {A _}. Notation "P ⋆ Q" := (asep P Q) (at level 55, right associativity): pcm_scope. Notation "P -⋆ Q" := (awand P Q) (at level 60, right associativity): pcm_scope. +(** ** Componentwise products. + + Equivalence, definedness, and composition are all componentwise, and the + unit is the pair of units. Every law is inherited from the components; + nothing here needs cancellativity. *) +#[global] Instance ProductPCM {A B : Type} {PA : PCM A} {PB : PCM B} : PCM (A * B). +Proof. + refine {| peq := fun x y => @peq A PA (fst x) (fst y) /\ @peq B PB (snd x) (snd y); + pdef := fun x y => @pdef A PA (fst x) (fst y) /\ @pdef B PB (snd x) (snd y); + pop := fun x y => (@pop A PA (fst x) (fst y), @pop B PB (snd x) (snd y)); + pemp := (@pemp A PA, @pemp B PB) |}; cbn. + - intros a; split; apply peq_refl. + - intros a b [H1 H2]; split; apply peq_sym; assumption. + - intros a b c [H1 H2] [H3 H4]; split; eapply peq_trans; eassumption. + - intros a a' b b' [H1 H2] [H3 H4] [H5 H6]; split; eapply pdef_resp; eassumption. + - intros a a' b b' [H1 H2] [H3 H4]; split; apply pop_resp; assumption. + - intros a b [H1 H2]; split; apply pdef_comm; assumption. + - intros a b [H1 H2]; split; apply pop_comm; assumption. + - intros a; split; apply pdef_emp. + - intros a; split; apply pop_emp. + - intros a b c [H1 H2] [H3 H4]; split; eapply pdef_assocL; eassumption. + - intros a b c [H1 H2] [H3 H4]; split; eapply pdef_assocR; eassumption. + - intros a b c [H1 H2] [H3 H4] [H5 H6]; split; apply pdef_assocI; assumption. + - intros a b c [H1 H2] [H3 H4]; split; apply pop_assoc; assumption. +Defined. + (** ** A PCM in which cancellativity fails. Carrier [bool], composition [orb], always defined, unit [false]. Every PCM From 6536ca2deef9b2f7298646e2d188c35b4633cb5d Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 2 Oct 2026 11:20:25 +0000 Subject: [PATCH 12/14] feat(csl): merge Yield into CSL; verify shared queue with two spawned workers - Move Lang/Maps.v to Utils/Maps.v so the interpreter can use the context. - CSL state is now ManagedHeap * (Ctx.Ctx * nat) with observations Ctx.Ctx + indexed A; sh combines heap, context and indexed-emission handlers. - One CProg AST gains CExp, CEval, CAssign, CIf and CWhile; variable reads yield once, missing variables are stuck. Full-state and pool runners. - Port the Yield structural rules onto CSL and delete Lang/Yield*. - Generic guard alignment (galigned) gives unconditional guard-equivalent pool congruence for ND and RR; closed-turn segment loops; ClosedTurns/RankedTurns pool invariance and eventuality rules with source specializations. - Migrate all CSL examples; add Control.v and Queue/Shared.v (AG AF recurrence for the allocated shared queue under ND and RR, prefix and empty-queue fault). --- examples/CSL/Allocator/Counterexamples.v | 84 +- examples/CSL/Allocator/Execution.v | 198 +- examples/CSL/Allocator/Liveness.v | 154 +- examples/CSL/Allocator/Model.v | 20 +- examples/CSL/Control.v | 151 + examples/CSL/Memory.v | 42 +- examples/CSL/Queue.v | 2 +- examples/CSL/Queue/Alternating.v | 47 +- examples/CSL/Queue/Composition.v | 86 +- examples/CSL/Queue/Frame.v | 28 +- examples/CSL/Queue/Operations.v | 30 +- examples/CSL/Queue/Program.v | 298 +- examples/CSL/Queue/Recurrence.v | 100 +- examples/CSL/Queue/Sequential.v | 27 +- examples/CSL/Queue/Shared.v | 377 +++ examples/CSL/Queue/Ticl.v | 110 +- examples/CSL/Queue/Trace.v | 26 +- examples/CSL/README.md | 97 +- examples/Toy.v | 2 +- theories/ICTree/Eq/Core.v | 2 +- theories/ICTree/Interp/CSL/Mod.v | 564 +++- theories/ICTree/Interp/Refine.v | 10 + theories/ICTree/Interp/Yield/Mod.v | 71 +- .../ICTree/Interp/Yield/Nondeterministic.v | 36 + theories/ICTree/Interp/Yield/RoundRobin.v | 95 + theories/ICTree/Interp/Yield/SBisim.v | 598 +++- theories/ICTree/Interp/Yield/Segments.v | 53 + theories/ICTree/Logic/Yield.v | 319 +- theories/Lang/CSL/Mod.v | 2706 ++++++++++++----- theories/Lang/HeapImp.v | 2 +- theories/Lang/MeS.v | 2 +- theories/Lang/StImp.v | 2 +- theories/Lang/Yield.v | 18 - theories/Lang/Yield/Denote.v | 177 -- theories/Lang/Yield/Interp.v | 52 - theories/Lang/Yield/SBisim.v | 35 - theories/Lang/Yield/SchedulerFairness.v | 49 - theories/Lang/Yield/Syntax.v | 29 - theories/Lang/Yield/Ticl.v | 647 ---- theories/{Lang => Utils}/Maps.v | 0 40 files changed, 4724 insertions(+), 2622 deletions(-) create mode 100644 examples/CSL/Control.v create mode 100644 examples/CSL/Queue/Shared.v delete mode 100644 theories/Lang/Yield.v delete mode 100644 theories/Lang/Yield/Denote.v delete mode 100644 theories/Lang/Yield/Interp.v delete mode 100644 theories/Lang/Yield/SBisim.v delete mode 100644 theories/Lang/Yield/SchedulerFairness.v delete mode 100644 theories/Lang/Yield/Syntax.v delete mode 100644 theories/Lang/Yield/Ticl.v rename theories/{Lang => Utils}/Maps.v (100%) diff --git a/examples/CSL/Allocator/Counterexamples.v b/examples/CSL/Allocator/Counterexamples.v index 0e7a816..3b7f82d 100644 --- a/examples/CSL/Allocator/Counterexamples.v +++ b/examples/CSL/Allocator/Counterexamples.v @@ -34,13 +34,13 @@ Let starvation_cycle : list Actor := Let starvation_prefix : list Actor := [Owner; Owner; Owner; Owner; Owner; Remote1] ++ starvation_cycle. -Let starve_prefix_logs (c : nat) : list (indexed (nat * nat)) := - [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); - stamp (tag_retire,6) (2+c); stamp (tag_retry,8) (3+c); - stamp (tag_reclaim,6) (4+c); stamp (tag_alloc,6) (5+c)]. -Let starve_cycle_logs (c : nat) : list (indexed (nat * nat)) := - [stamp (tag_retire,6) c; stamp (tag_retry,8) (1+c); - stamp (tag_reclaim,6) (2+c); stamp (tag_alloc,6) (3+c)]. +Let starve_prefix_logs (c : nat) : list (CSLObs (nat * nat)) := + [inr (stamp (tag_alloc,6) c); inr (stamp (tag_alloc,8) (1+c)); + inr (stamp (tag_retire,6) (2+c)); inr (stamp (tag_retry,8) (3+c)); + inr (stamp (tag_reclaim,6) (4+c)); inr (stamp (tag_alloc,6) (5+c))]. +Let starve_cycle_logs (c : nat) : list (CSLObs (nat * nat)) := + [inr (stamp (tag_retire,6) c); inr (stamp (tag_retry,8) (1+c)); + inr (stamp (tag_reclaim,6) (2+c)); inr (stamp (tag_alloc,6) (3+c))]. (** A pointwise representative only: the infinite witness always retains the actual heap returned by its preceding turn. *) @@ -56,22 +56,22 @@ Let starve_boundary (c : nat) : AState := remote1_state := RRead 8 |}. (** The observation of each individual turn, including every silent turn. *) -Let starve_prefix_event (c i : nat) : option (indexed (nat * nat)) := +Let starve_prefix_event (c i : nat) : option (CSLObs (nat * nat)) := match i with - | 3 => Some (stamp (tag_alloc,6) c) - | 4 => Some (stamp (tag_alloc,8) (1+c)) - | 11 => Some (stamp (tag_retire,6) (2+c)) - | 12 => Some (stamp (tag_retry,8) (3+c)) - | 15 => Some (stamp (tag_reclaim,6) (4+c)) - | 17 => Some (stamp (tag_alloc,6) (5+c)) + | 3 => Some (inr (stamp (tag_alloc,6) c)) + | 4 => Some (inr (stamp (tag_alloc,8) (1+c))) + | 11 => Some (inr (stamp (tag_retire,6) (2+c))) + | 12 => Some (inr (stamp (tag_retry,8) (3+c))) + | 15 => Some (inr (stamp (tag_reclaim,6) (4+c))) + | 17 => Some (inr (stamp (tag_alloc,6) (5+c))) | _ => None end. -Let starve_cycle_event (c i : nat) : option (indexed (nat * nat)) := +Let starve_cycle_event (c i : nat) : option (CSLObs (nat * nat)) := match i with - | 5 => Some (stamp (tag_retire,6) c) - | 6 => Some (stamp (tag_retry,8) (1+c)) - | 9 => Some (stamp (tag_reclaim,6) (2+c)) - | 11 => Some (stamp (tag_alloc,6) (3+c)) + | 5 => Some (inr (stamp (tag_retire,6) c)) + | 6 => Some (inr (stamp (tag_retry,8) (1+c))) + | 9 => Some (inr (stamp (tag_reclaim,6) (2+c))) + | 11 => Some (inr (stamp (tag_alloc,6) (3+c))) | _ => None end. @@ -149,7 +149,7 @@ Qed. whose existential witnesses must not range over its closure. *) Let starvation_choices : nat -> Actor := periodic_choices starvation_prefix Remote1 (List.tl starvation_cycle). -Let starvation_execution : Execution AState Actor (option (indexed (nat * nat))) := +Let starvation_execution : Execution AState Actor (option (CSLObs (nat * nat))) := allocator_execution 2 0 starvation_choices. Local Lemma starvation_execution_valid : allocator_valid 2 0 starvation_execution. @@ -280,14 +280,14 @@ Proof. Qed. Local Lemma starve_prefix_never_retire8 c i idx : i < 19 -> - starve_prefix_event c i <> Some (stamp (tag_retire,8) idx). + starve_prefix_event c i <> Some (inr (stamp (tag_retire,8) idx)). Proof. intro Hi. do 19 (destruct i as [|i]; [vm_compute; discriminate|]). lia. Qed. Local Lemma starve_cycle_never_retire8 c i idx : i < 13 -> - starve_cycle_event c i <> Some (stamp (tag_retire,8) idx). + starve_cycle_event c i <> Some (inr (stamp (tag_retire,8) idx)). Proof. intro Hi. do 13 (destruct i as [|i]; [vm_compute; discriminate|]). @@ -339,7 +339,7 @@ Theorem fair_starvation_exists : exists e, infinitely (fun k => block_event tag_reclaim 6 (emitted e k)) /\ infinitely (fun k => block_event tag_alloc 6 (emitted e k)) /\ realizes (fun j => turn_labels (emitted e j)) 0 - (run_nd (allocator_program 2) managed_empty 0). + (run_nd (allocator_program 2) (managed_empty,((List.nil : Ctx.Ctx),0))). Proof. exists starvation_execution. split; [exact starvation_execution_valid|]. @@ -360,9 +360,9 @@ Theorem starvation_chained_cycle_actual_source : exists last labels residual, Some (last,starve_prefix_logs 0 ++ starve_cycle_logs 6) /\ label_logs labels = starve_prefix_logs 0 ++ starve_cycle_logs 6 /\ label_taus labels = 32 /\ - finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. destruct (starve_prefix_run 0) as (first & Hprefix & Hfirst). destruct (starve_cycle_run_actual 6 first Hfirst) as (last & Hcycle & Hlast). @@ -370,7 +370,7 @@ Proof. starvation_prefix starvation_cycle (initial_state 2 0) first last (starve_prefix_logs 0) (starve_cycle_logs 6) Hprefix Hcycle) as Hrun. - destruct (run_turns_realizes_source 2 0 (starvation_prefix ++ starvation_cycle) + destruct (run_turns_realizes_source 2 (List.nil : Ctx.Ctx) 0 (starvation_prefix ++ starvation_cycle) last (starve_prefix_logs 0 ++ starve_cycle_logs 6) Hrun) as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). exists last, labels, residual; repeat first [assumption | split]. @@ -386,15 +386,15 @@ Let owner_stall_cycle : list Actor := [Remote0; Remote1]. Let owner_stall_choices : nat -> Actor := periodic_choices owner_stall_prefix Remote0 [Remote1]. -Let stalled_prefix_logs (c : nat) : list (indexed (nat * nat)) := - [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); - stamp (tag_retire,6) (2+c); stamp (tag_retire,8) (3+c)]. +Let stalled_prefix_logs (c : nat) : list (CSLObs (nat * nat)) := + [inr (stamp (tag_alloc,6) c); inr (stamp (tag_alloc,8) (1+c)); + inr (stamp (tag_retire,6) (2+c)); inr (stamp (tag_retire,8) (3+c))]. -Let stalled_prefix_observations : list (option (indexed (nat * nat))) := - [None; None; None; Some (stamp (tag_alloc,6) 0); - Some (stamp (tag_alloc,8) 1); None; None; None; - Some (stamp (tag_retire,6) 2); None; None; None; - Some (stamp (tag_retire,8) 3)]. +Let stalled_prefix_observations : list (option (CSLObs (nat * nat))) := + [None; None; None; Some (inr (stamp (tag_alloc,6) 0)); + Some (inr (stamp (tag_alloc,8) 1)); None; None; None; + Some (inr (stamp (tag_retire,6) 2)); None; None; None; + Some (inr (stamp (tag_retire,8) 3))]. (** This is only a pointwise representative of the returned heap. The execution always runs the actual preceding turn. *) @@ -445,7 +445,7 @@ Qed. (** The infinite execution follows the periodic script from the actual initial state; bound after the finite calculations above. *) -Let owner_stall_execution : Execution AState Actor (option (indexed (nat * nat))) := +Let owner_stall_execution : Execution AState Actor (option (CSLObs (nat * nat))) := allocator_execution 2 0 owner_stall_choices. Local Lemma owner_stall_execution_valid : allocator_valid 2 0 owner_stall_execution. @@ -495,7 +495,7 @@ Proof. Qed. Local Lemma stalled_retire6 : - emitted owner_stall_execution 8 = Some (stamp (tag_retire,6) 2). + emitted owner_stall_execution 8 = Some (inr (stamp (tag_retire,6) 2)). Proof. exact (stalled_prefix_observation 8 ltac:(lia)). Qed. Local Lemma stalled_tail_choices n : @@ -596,12 +596,12 @@ Theorem stalled_prefix_source : exists last labels residual, state_equiv last (stalled_boundary 4) /\ label_logs labels = stalled_prefix_logs 0 /\ label_taus labels = 13 /\ - finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. destruct (stalled_prefix_run 0) as (last & Hrun & Hstate). - destruct (run_turns_realizes_source 2 0 owner_stall_prefix last + destruct (run_turns_realizes_source 2 (List.nil : Ctx.Ctx) 0 owner_stall_prefix last (stalled_prefix_logs 0) Hrun) as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Hresidual). exists last, labels, residual; split; [exact Hrun|]. @@ -613,7 +613,7 @@ Qed. (** Every silent polling choice still consumes one real scheduler tau. *) Theorem stalled_tail_source_tau n - (t : ictreeW (indexed (nat * nat)) (unit * SSig)) : + (t : ictreeW (CSLObs (nat * nat)) (unit * SSig)) : realizes (fun j => turn_labels (emitted owner_stall_execution j)) (13+n) t -> exists next, finite_steps t [tau] next /\ realizes (fun j => turn_labels (emitted owner_stall_execution j)) (S (13+n)) next. @@ -628,10 +628,10 @@ Theorem owner_stall_prevents_reclamation : exists e, (forall k, 5 <= k -> selected e k <> Owner) /\ infinitely (fun k => selected e k = Remote0) /\ infinitely (fun k => selected e k = Remote1) /\ - emitted e 8 = Some (stamp (tag_retire,6) 2) /\ + emitted e 8 = Some (inr (stamp (tag_retire,6) 2)) /\ (forall k, ~ block_event tag_reclaim 6 (emitted e k)) /\ realizes (fun j => turn_labels (emitted e j)) 0 - (run_nd (allocator_program 2) managed_empty 0). + (run_nd (allocator_program 2) (managed_empty,((List.nil : Ctx.Ctx),0))). Proof. exists owner_stall_execution; split; [exact owner_stall_execution_valid|]. split; [exact stalled_no_owner|]. diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v index c87a028..8b21351 100644 --- a/examples/CSL/Allocator/Execution.v +++ b/examples/CSL/Allocator/Execution.v @@ -87,11 +87,11 @@ Definition source_pool0 base : pool sE 3 := [denote (remote_client base true); denote (remote_client base false); denote (CUntilNone (owner_round base))]%vector. Definition state_agrees (sigma : SSig) (s : AState) : Prop := - heq (fst (fst sigma)) (aheap s) /\ snd sigma = acount s. + heq (fst (fst sigma)) (aheap s) /\ csl_counter sigma = acount s. Definition source_reheap (sigma : SSig) (s : AState) : AState := - {| aheap := fst (fst sigma); acount := snd sigma; + {| aheap := fst (fst sigma); acount := csl_counter sigma; owner_state := owner_state s; remote0_state := remote0_state s; remote1_state := remote1_state s |}. @@ -109,13 +109,13 @@ Proof. apply pool_equ_refl. Qed. Lemma interp_rr_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) - first count (K : option unit -> thread sE) m h allocs c : + first count (K : option unit -> thread sE) m h allocs ctx c : (forall offset, Nat.lt offset (2 * count) -> h (first + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m ((init_links_heap first count h,allocs),c). + (Some i) m ((init_links_heap first count h,allocs),(ctx,c)). Proof. revert first h; induction count as [|count IH]; intros first h Allocated. - cbn [init_links init_links_heap]; rewrite interp_rr_ret; reflexivity. @@ -130,13 +130,13 @@ Proof. Qed. Lemma interp_nd_init_links n (ts : pool sE (S n)) (i : Fin.t (S n)) - first count (K : option unit -> thread sE) h allocs c : + first count (K : option unit -> thread sE) h allocs ctx c : (forall offset, Nat.lt offset (2 * count) -> h (first + offset)%nat <> None) -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (init_links first count) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) ((init_links_heap first count h,allocs),c). + (Some i) ((init_links_heap first count h,allocs),(ctx,c)). Proof. revert first h; induction count as [|count IH]; intros first h Allocated. - cbn [init_links init_links_heap]; rewrite interp_nd_source_ret; reflexivity. @@ -154,12 +154,12 @@ Qed. five metadata writes and every link write are checked against allocated cells, and the untouched payloads retain the allocation's zeroes. *) Lemma interp_rr_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - base capacity (K : option unit -> thread sE) m h allocs c : + base capacity (K : option unit -> thread sE) m h allocs ctx c : interp_schedule_rr sh (S n) (ts @ i := (denote_flow (init_page base capacity) >>= K)) - (Some i) m ((hunion (hblock base (page_size capacity)) h,allocs),c) ~ + (Some i) m ((hunion (hblock base (page_size capacity)) h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m ((page_heap base capacity h,allocs),c). + (Some i) m ((page_heap base capacity h,allocs),(ctx,c)). Proof. unfold init_page, page_heap. do 5 (rewrite interp_rr_bind; etransitivity; @@ -174,12 +174,12 @@ Proof. Qed. Lemma interp_nd_init_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - base capacity (K : option unit -> thread sE) h allocs c : + base capacity (K : option unit -> thread sE) h allocs ctx c : interp_schedule_nd sh (S n) (ts @ i := (denote_flow (init_page base capacity) >>= K)) - (Some i) ((hunion (hblock base (page_size capacity)) h,allocs),c) ~ + (Some i) ((hunion (hblock base (page_size capacity)) h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) ((page_heap base capacity h,allocs),c). + (Some i) ((page_heap base capacity h,allocs),(ctx,c)). Proof. unfold init_page, page_heap. do 5 (rewrite interp_nd_source_bind; etransitivity; @@ -197,14 +197,14 @@ Qed. so concrete initialized source programs can use a known fresh base. The allocation records the page's whole extent in the allocation table. *) Lemma interp_rr_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity base (K : option nat -> thread sE) m h allocs c : + capacity base (K : option nat -> thread sE) m h allocs ctx c : Nat.lt 0 base -> block_free h base (page_size capacity) -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j (page_size capacity)) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some base)) - (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),c). + (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),(ctx,c)). Proof. intros Positive Free First. unfold new_page; rewrite interp_rr_bind. @@ -216,14 +216,14 @@ Proof. Qed. Lemma interp_nd_new_page_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity base (K : option nat -> thread sE) h allocs c : + capacity base (K : option nat -> thread sE) h allocs ctx c : Nat.lt 0 base -> block_free h base (page_size capacity) -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j (page_size capacity)) -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some base)) - (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),c). + (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),(ctx,c)). Proof. intros Positive Free First. unfold new_page; rewrite interp_nd_source_bind. @@ -235,7 +235,7 @@ Proof. Qed. Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) m h allocs c : + capacity (K : option nat -> thread sE) m h allocs ctx c : heap_finite h -> exists base, Nat.lt 0 base /\ block_free h base (page_size capacity) /\ @@ -244,12 +244,12 @@ Lemma interp_rr_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) heap_finite (page_heap base capacity h) /\ (forall x, h x <> None -> page_heap base capacity h x = h x) /\ interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some base)) - (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),c). + (Some i) m ((page_heap base capacity h,upd allocs base (page_size capacity)),(ctx,c)). Proof. intro Finite. - destruct (heap_handler_alloc_finite h allocs (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h allocs (page_size capacity) (ctx,c) Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -258,7 +258,7 @@ Proof. Qed. Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) h allocs c : + capacity (K : option nat -> thread sE) h allocs ctx c : heap_finite h -> exists base, Nat.lt 0 base /\ block_free h base (page_size capacity) /\ @@ -267,12 +267,12 @@ Lemma interp_nd_new_page n (ts : pool sE (S n)) (i : Fin.t (S n)) heap_finite (page_heap base capacity h) /\ (forall x, h x <> None -> page_heap base capacity h x = h x) /\ interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some base)) - (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),c). + (Some i) ((page_heap base capacity h,upd allocs base (page_size capacity)),(ctx,c)). Proof. intro Finite. - destruct (heap_handler_alloc_finite h allocs (page_size capacity) c Finite + destruct (heap_handler_alloc_finite h allocs (page_size capacity) (ctx,c) Finite (page_size_positive capacity)) as (base & Positive & Free & First & Alloc). exists base; split; [exact Positive |]; split; [exact Free |]. split; [exact First |]; split; [now apply page_heap_finite |]. @@ -284,11 +284,11 @@ Qed. the allocation request is always for at least the five metadata cells. *) Lemma interp_rr_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) m c : + capacity (K : option nat -> thread sE) m ctx c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (managed_empty,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) m (managed_empty,(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) - (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. apply interp_rr_new_page_first. - lia. @@ -297,11 +297,11 @@ Proof. Qed. Lemma interp_nd_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (K : option nat -> thread sE) c : + capacity (K : option nat -> thread sE) ctx c : interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (managed_empty,c) ~ + (ts @ i := (denote_flow (new_page capacity) >>= K)) (Some i) (managed_empty,(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some 1)) - (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. apply interp_nd_new_page_first. - lia. @@ -314,26 +314,26 @@ Qed. the corresponding [page_heap_*] lookup laws, without assuming a fixture. *) Lemma interp_rr_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (address : nat -> nat) value (K : option nat -> thread sE) m c : + capacity (address : nat -> nat) value (K : option nat -> thread sE) m ctx c : page_heap 1 capacity hemp (address 1) = Some value -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some value)) - (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + (Some i) m ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. intro Lookup; rewrite interp_rr_bind, interp_rr_new_page_hemp. apply interp_rr_read_value; exact Lookup. Qed. Lemma interp_nd_new_page_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (address : nat -> nat) value (K : option nat -> thread sE) c : + capacity (address : nat -> nat) value (K : option nat -> thread sE) ctx c : page_heap 1 capacity hemp (address 1) = Some value -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,c) ~ + (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some value)) - (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + (Some i) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. apply interp_nd_source_read_value; exact Lookup. @@ -341,12 +341,12 @@ Qed. Lemma interp_rr_new_page_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (address : nat -> nat) (K : option nat -> thread sE) m c : + capacity (address : nat -> nat) (K : option nat -> thread sE) m ctx c : page_heap 1 capacity hemp (address 1) = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (fun base => CRead (address base))) >>= K)) (Some i) m (managed_empty,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_rr_bind, interp_rr_new_page_hemp. apply interp_rr_read_missing; exact Missing. @@ -354,12 +354,12 @@ Qed. Lemma interp_nd_new_page_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - capacity (address : nat -> nat) (K : option nat -> thread sE) c : + capacity (address : nat -> nat) (K : option nat -> thread sE) ctx c : page_heap 1 capacity hemp (address 1) = None -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CBind (new_page capacity) - (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (fun base => CRead (address base))) >>= K)) (Some i) (managed_empty,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. apply interp_nd_source_read_missing; exact Missing. @@ -368,18 +368,18 @@ Qed. (** The children are the actual scoped-fork children: their [None] branch terminates rather than running the parent's remaining initialization. Parent focus advances twice, but its cursor is unchanged until selection. *) -Theorem run_rr_allocator_initialized capacity c : - run_rr (allocator_program capacity) managed_empty c ~ +Theorem run_rr_allocator_initialized capacity ctx c : + run_rr (allocator_program capacity) (managed_empty,(ctx,c)) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. unfold run_rr. change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (managed_empty,c) ~ + (Some Fin.F1) 0 (managed_empty,(ctx,c)) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). unfold allocator_program; rewrite interp_rr_bind, interp_rr_new_page_hemp. rewrite interp_rr_bind, interp_rr_fork. change (interp_schedule_rr sh 2 @@ -387,33 +387,33 @@ Proof. (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). rewrite interp_rr_bind, interp_rr_fork. change (interp_schedule_rr sh 3 ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector @ Fin.FS (Fin.FS Fin.F1) := (denote_flow (owner 1) >>= fun _ => Ret tt)) (Some (Fin.FS (Fin.FS Fin.F1))) 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) ~ interp_schedule_rr sh 3 (source_pool0 1) None 0 - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). unfold owner; rewrite interp_rr_bind, interp_rr_yield; reflexivity. Qed. -Theorem run_nd_allocator_initialized capacity c : - run_nd (allocator_program capacity) managed_empty c ~ +Theorem run_nd_allocator_initialized capacity ctx c : + run_nd (allocator_program capacity) (managed_empty,(ctx,c)) ~ interp_schedule_nd sh 3 (source_pool0 1) None - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)). Proof. unfold run_nd. change (interp_schedule_nd sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (allocator_program capacity) >>= fun _ => Ret tt)) - (Some Fin.F1) (managed_empty,c) ~ + (Some Fin.F1) (managed_empty,(ctx,c)) ~ interp_schedule_nd sh 3 (source_pool0 1) None - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). unfold allocator_program; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. rewrite interp_nd_source_bind, interp_nd_source_fork. change (interp_schedule_nd sh 2 @@ -421,18 +421,18 @@ Proof. (denote_flow (CBind (CFork (remote_client 1 true)) (fun _ => owner 1)) >>= fun _ => Ret tt)) (Some (Fin.FS Fin.F1)) - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) ~ interp_schedule_nd sh 3 (source_pool0 1) None - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). rewrite interp_nd_source_bind, interp_nd_source_fork. change (interp_schedule_nd sh 3 ([denote (remote_client 1 true); denote (remote_client 1 false); Ret tt]%vector @ Fin.FS (Fin.FS Fin.F1) := (denote_flow (owner 1) >>= fun _ => Ret tt)) (Some (Fin.FS (Fin.FS Fin.F1))) - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) ~ + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) ~ interp_schedule_nd sh 3 (source_pool0 1) None - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)). + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))). unfold owner; rewrite interp_nd_source_bind, interp_nd_source_yield; reflexivity. Qed. @@ -544,11 +544,11 @@ Local Opaque denote_flow ICtree.iter ICtree.bind. (** Every allocator round accesses linked-list cells only (read/write/CAS, emit, yield), so an arbitrary allocation table [allocs] is carried through the segment unchanged. *) -Lemma turn_source_exact_segment base who s t event allocs : +Lemma turn_source_exact_segment base who s t event allocs ctx : turn base who s = Some (t,event) -> exists residual, (ThreadSegment sh csl_equ) ((allocator_pool base s) $ slot_of_actor who) - ((aheap s,allocs),acount s) (event_obs event) residual ((aheap t,allocs),acount t) /\ + ((aheap s,allocs),(ctx,acount s)) (event_obs event) residual ((aheap t,allocs),(ctx,acount t)) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. destruct s as [h c op r0 r1]; destruct who; @@ -627,13 +627,13 @@ Proof. pose proof (state_agrees_reheap sigma s Hagree) as Hreheap. destruct (step_some_compatible (turn base) state_equiv (turn_proper base) who s (source_reheap sigma s) s' event Hreheap Hturn) as (actual & Hactual & Hnext). - destruct sigma as [[h allocs] c]. + destruct sigma as [[h allocs] [ctx c]]. destruct (turn_source_exact_segment base who - (source_reheap ((h,allocs),c) s) actual event allocs Hactual) + (source_reheap ((h,allocs),(ctx,c)) s) actual event allocs ctx Hactual) as (residual & Hseg & Htail). cbn [source_reheap aheap acount owner_state remote0_state remote1_state allocator_pool fst snd] in Hseg, Htail |- *. - exists residual, ((aheap actual,allocs),acount actual). + exists residual, ((aheap actual,allocs),(ctx,acount actual)). split; [exact Hseg |]. split. + destruct Hnext as [Hheap [Hcount _]]. @@ -645,7 +645,7 @@ Proof. (slot_of_actor who)). * intros j Hj. etransitivity; - [exact (turn_other_slots base who (source_reheap ((h,allocs),c) s) actual event + [exact (turn_other_slots base who (source_reheap ((h,allocs),(ctx,c)) s) actual event Hactual j Hj) |]. symmetry; exact (allocator_pool_state_equiv base s' actual Hnext j). Qed. @@ -668,47 +668,47 @@ Qed. promoted to an unfocused-pool congruence. At the canonical state the handler state after the turn is EXACTLY the model's heap and counter, with the allocation table unchanged. *) -Theorem turn_interp_nd base capacity who s t event allocs : +Theorem turn_interp_nd base capacity who s t event allocs ctx : allocator_inv base capacity s -> turn base who s = Some (t,event) -> exists residual, guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_nd sh 3 (allocator_pool base s) (Some (slot_of_actor who)) - ((aheap s,allocs),acount s) ~ + ((aheap s,allocs),(ctx,acount s)) ~ emit_list (event_obs event) (interp_schedule_nd sh 3 (allocator_pool base t @ slot_of_actor who := residual) - None ((aheap t,allocs),acount t)). + None ((aheap t,allocs),(ctx,acount t))). Proof. intros Hinv Hturn. - destruct (turn_source_exact_segment base who s t event allocs Hturn) + destruct (turn_source_exact_segment base who s t event allocs ctx Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - exact (segment_interp_nd sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) ((aheap s,allocs),acount s) - (event_obs event) residual ((aheap t,allocs),acount t) Hseg). + 2 (allocator_pool base s) (slot_of_actor who) ((aheap s,allocs),(ctx,acount s)) + (event_obs event) residual ((aheap t,allocs),(ctx,acount t)) Hseg). - apply emit_list_sbisim, equ_sbisim, (interp_schedule_nd_equ sh). exact (source_replace_turn base who s t event residual Hturn). Qed. -Theorem turn_interp_rr base capacity who s t event allocs cursor : +Theorem turn_interp_rr base capacity who s t event allocs ctx cursor : allocator_inv base capacity s -> turn base who s = Some (t,event) -> exists residual, guard_equ residual ((allocator_pool base t) $ slot_of_actor who) /\ interp_schedule_rr sh 3 (allocator_pool base s) (Some (slot_of_actor who)) - cursor ((aheap s,allocs),acount s) ~ + cursor ((aheap s,allocs),(ctx,acount s)) ~ emit_list (event_obs event) (interp_schedule_rr sh 3 (allocator_pool base t @ slot_of_actor who := residual) - None cursor ((aheap t,allocs),acount t)). + None cursor ((aheap t,allocs),(ctx,acount t))). Proof. intros Hinv Hturn. - destruct (turn_source_exact_segment base who s t event allocs Hturn) + destruct (turn_source_exact_segment base who s t event allocs ctx Hturn) as (residual & Hseg & Htail). exists residual; split; [exact Htail|]. etransitivity. - exact (segment_interp_rr sh csl_equ (fun X t u => equ_sbisim t u) - 2 (allocator_pool base s) (slot_of_actor who) cursor ((aheap s,allocs),acount s) - (event_obs event) residual ((aheap t,allocs),acount t) Hseg). + 2 (allocator_pool base s) (slot_of_actor who) cursor ((aheap s,allocs),(ctx,acount s)) + (event_obs event) residual ((aheap t,allocs),(ctx,acount t)) Hseg). - apply emit_list_sbisim, equ_sbisim, interp_schedule_rr_equ. exact (source_replace_turn base who s t event residual Hturn). Qed. @@ -764,47 +764,47 @@ Qed. From Coinduction Require Import coinduction rel tactics. Local Open Scope nat_scope. -Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event allocs : +Lemma selected_turn_exact_segment base (ts : pool sE 3) s who t event allocs ctx : pool_guard_equ ts (allocator_pool base s) -> turn base who s = Some (t,event) -> exists residual, - (ThreadSegment sh csl_equ) (ts $ slot_of_actor who) ((aheap s,allocs),acount s) - (event_obs event) residual ((aheap t,allocs),acount t) /\ + (ThreadSegment sh csl_equ) (ts $ slot_of_actor who) ((aheap s,allocs),(ctx,acount s)) + (event_obs event) residual ((aheap t,allocs),(ctx,acount t)) /\ guard_equ residual ((allocator_pool base t) $ slot_of_actor who). Proof. intros Hpool Hturn. - destruct (turn_source_exact_segment base who s t event allocs Hturn) + destruct (turn_source_exact_segment base who s t event allocs ctx Hturn) as (residual & Hseg & Htail). exists residual; split; [|exact Htail]. apply (proj2 ((guard_equ_segment_iff sh csl_equ) (ts $ slot_of_actor who) ((allocator_pool base s) $ slot_of_actor who) - (Hpool (slot_of_actor who)) ((aheap s,allocs),acount s) (event_obs event) - residual ((aheap t,allocs),acount t))); exact Hseg. + (Hpool (slot_of_actor who)) ((aheap s,allocs),(ctx,acount s)) (event_obs event) + residual ((aheap t,allocs),(ctx,acount t)))); exact Hseg. Qed. -Theorem run_rr_allocator_bisim capacity c : - run_rr (allocator_program capacity) managed_empty c ~ +Theorem run_rr_allocator_bisim capacity ctx c : + run_rr (allocator_program capacity) (managed_empty,(ctx,c)) ~ (model_rr 2 actor_of_slot (turn 1) (initial_state capacity c) 0 - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_allocator_initialized. exact (pool_simulation_rr_bisim actor_of_slot slot_of_actor_of_slot (allocator_simulation 1 capacity) (initial_state capacity c) (source_pool0 1) - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) 0 + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) 0 (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). Qed. -Theorem run_nd_allocator_bisim capacity c : - run_nd (allocator_program capacity) managed_empty c ~ +Theorem run_nd_allocator_bisim capacity ctx c : + run_nd (allocator_program capacity) (managed_empty,(ctx,c)) ~ (model_nd 2 actor_of_slot (turn 1) (initial_state capacity c) - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_nd_allocator_initialized. exact (pool_simulation_nd_bisim actor_of_slot slot_of_actor_of_slot (allocator_simulation 1 capacity) (initial_state capacity c) (source_pool0 1) - ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c))). Qed. @@ -812,7 +812,7 @@ Qed. (** The one program-specific validity entry point for raw source executions: the library's pool validity at the allocator handler, slot map, initial source pool, and initialized page with its recorded extent. *) -Definition allocator_source_valid (capacity c : nat) - (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) : Prop := +Definition allocator_source_valid (capacity : nat) (ctx : Ctx.Ctx) (c : nat) + (se : Execution (pool sE 3 * SSig) Actor (list (CSLObs (nat * nat)))) : Prop := pool_execution_valid 2 sh slot_of_actor - (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) se. + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) se. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v index 401c3ac..372d31f 100644 --- a/examples/CSL/Allocator/Liveness.v +++ b/examples/CSL/Allocator/Liveness.v @@ -18,9 +18,9 @@ Local Open Scope nat_scope. (** One observation's tag, one actor's pending remote phase, and owner selection: each predicate is stated on the actual turn data, so an idle turn, an owner turn, and a polling remote are all explicit cases. *) -Definition event_is (tag : nat) (event : option (indexed (nat * nat))) : bool := - match event with None => false - | Some o => Nat.eqb (fst (indexed_value o)) tag end. +Definition event_is (tag : nat) (event : option (CSLObs (nat * nat))) : bool := + match event with None | Some (inl _) => false + | Some (inr o) => Nat.eqb (fst (indexed_value o)) tag end. Definition remote_pending (who : Actor) (s : AState) : bool := match who with | Owner => false @@ -34,9 +34,10 @@ Lemma owner_selected_spec who : owner_selected who = true <-> who = Owner. Proof. destruct who; cbn [owner_selected]; split; intro H; congruence. Qed. Lemma event_is_spec tag event : event_is tag event = true <-> - exists block idx, event = Some (stamp (tag,block) idx). + exists block idx, event = Some (inr (stamp (tag,block) idx)). Proof. - unfold event_is; destruct event as [[[kind block] idx]|]; cbn. + unfold event_is; destruct event as [[ctx|[[kind block] idx]]|]; cbn. + - split; [discriminate|intros (b & i & H); discriminate]. - rewrite Nat.eqb_eq; split. + intro H; subst kind; now exists block, idx. + intros (b & i & H); inversion H; reflexivity. @@ -364,10 +365,10 @@ Qed. (** Finite raw-source reachability has no model premise. It is useful before an infinite schedule is supplied: every physical slot remains selectable. *) -Theorem every_reachable_source_slot_yields capacity c ts sigma (i : Fin.t 3) : +Theorem every_reachable_source_slot_yields capacity ctx c ts sigma (i : Fin.t 3) : reachable (pool_step 2 sh slot_of_actor) (fun p => pool_equ (fst p) (source_pool0 1) /\ - snd p = ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c)) + snd p = ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c))) (ts,sigma) -> BranchFree (ts $ i) /\ (exists logs residual sigma', (ThreadSegment sh csl_sb) (ts $ i) sigma logs residual sigma') /\ @@ -388,7 +389,7 @@ Proof. Hstep H). } split; [apply Hbf|]. destruct (pool_simulation_reachable (allocator_simulation 1 capacity) - (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) (initial_state capacity c) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) ts sigma Hreach) @@ -412,10 +413,10 @@ Qed. allocator's per-turn chunking; the model application is the library's [valid_execution_realizes_model] at [step := turn 1]. No allocator-local cofixpoint remains. *) -Theorem valid_execution_realizes_source capacity c e : +Theorem valid_execution_realizes_source capacity ctx c e : allocator_valid capacity c e -> realizes (fun j => turn_labels (emitted e j)) 0 - (run_nd (allocator_program capacity) managed_empty c). + (run_nd (allocator_program capacity) (managed_empty,(ctx,c))). Proof. intro Hvalid. apply (valid_execution_realizes_model 2 actor_of_slot (turn 1) slot_of_actor @@ -425,22 +426,22 @@ Qed. (** Labels retain their interleaving: exactly one scheduling tau per actual turn, followed by its zero or one source observation. *) -Theorem run_turns_realizes_source capacity c script last logs : +Theorem run_turns_realizes_source capacity ctx c script last logs : run_turns (turn 1) event_obs script (initial_state capacity c) = Some (last,logs) -> exists labels residual, option_map snd (run_turns (turn 1) turn_labels script (initial_state capacity c)) = Some labels /\ label_logs labels = logs /\ label_taus labels = List.length script /\ - finite_steps (run_nd (allocator_program capacity) managed_empty c) labels residual /\ + finite_steps (run_nd (allocator_program capacity) (managed_empty,(ctx,c))) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Hrun. destruct (model_run_turns_labels (X := (unit * SSig)%type) 2 actor_of_slot (turn 1) slot_of_actor actor_of_slot_of_actor script (initial_state capacity c) last logs Hrun) as (labels & model & Hlabels & Hlogs & Htaus & Hsteps & Emodel). - pose proof (run_nd_allocator_bisim capacity c) as Esource; symmetry in Esource. + pose proof (run_nd_allocator_bisim capacity ctx c) as Esource; symmetry in Esource. destruct (finite_steps_sbisim _ _ _ Hsteps _ Esource) as (residual & Hsource & Eresidual). exists labels, residual; split; [rewrite Hlabels; reflexivity|]. @@ -454,7 +455,7 @@ Qed. Definition raw_remote_pending base client (t : thread sE) : Prop := exists pc, pc <> RPoll /\ guard_equ t (remote_residual base client pc). Definition selected_source_pending - (se : Execution (pool sE 3 * SSig) Actor (list (indexed (nat * nat)))) k : Prop := + (se : Execution (pool sE 3 * SSig) Actor (list (CSLObs (nat * nat)))) k : Prop := match selected se k with | Owner => False | Remote0 => raw_remote_pending 1 false (fst (states se k) $ slot_of_actor Remote0) @@ -521,8 +522,8 @@ Qed. (** On a valid raw execution the raw pending predicate is exactly the model's pending-remote predicate at the model execution of the same selections. *) -Lemma selected_source_pending_alignment capacity c se k : - allocator_source_valid capacity c se -> +Lemma selected_source_pending_alignment capacity ctx c se k : + allocator_source_valid capacity ctx c se -> (selected_source_pending se k <-> remote_pending (selected se k) (states (allocator_execution capacity c (selected se)) k) = true). @@ -531,7 +532,7 @@ Proof. assert (Hmodel : allocator_valid capacity c (allocator_execution capacity c (selected se))) by apply execution_of_choices_valid. destruct (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) (initial_state capacity c) se (allocator_execution capacity c (selected se)) (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel @@ -543,24 +544,24 @@ Proof. - apply raw_remote_pending_alignment; exact (Hpool (slot_of_actor Remote1)). Qed. -Theorem source_remote_free_lockfree capacity c se : - allocator_source_valid capacity c se -> +Theorem source_remote_free_lockfree capacity ctx c se : + allocator_source_valid capacity ctx c se -> infinitely (selected_source_pending se) -> infinitely (fun k => - exists block idx, List.In (stamp (tag_retire,block) idx) (emitted se k)). + exists block idx, List.In (inr (stamp (tag_retire,block) idx)) (emitted se k)). Proof. intros Hvalid Hpending. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. pose proof (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. assert (Hpend : infinitely (fun k => remote_pending (selected e k) (states e k) = true)). { intro n; destruct (Hpending n) as (k & Hnk & Hk); exists k; split; [exact Hnk|]. - exact (proj1 (selected_source_pending_alignment capacity c se k Hvalid) Hk). } + exact (proj1 (selected_source_pending_alignment capacity ctx c se k Hvalid) Hk). } pose proof (remote_free_lockfree capacity c e Hmodel Hpend) as Hlive. intro n; destruct (Hlive n) as (k & Hnk & Hevent). apply event_is_spec in Hevent as (block & idx & Hevent). @@ -620,8 +621,8 @@ Definition owner_rank (capacity : nat) (pc : owner_pc) (R D : list nat) : nat := | OOffer true => 1 end. Definition owner_round_bound capacity := 3 * capacity + 5. -Definition block_event (tag block : nat) (event : option (indexed (nat * nat))) : Prop := - exists idx, event = Some (stamp (tag,block) idx). +Definition block_event (tag block : nat) (event : option (CSLObs (nat * nat))) : Prop := + exists idx, event = Some (inr (stamp (tag,block) idx)). Lemma ownership_rank_step capacity who pc pc' event L R D L' R' D' : ownership_transition who pc pc' event L R D L' R' D' -> @@ -695,7 +696,7 @@ Proof. - exact Hv. Qed. -Definition round_completion (e : (Execution AState Actor (option (indexed (nat * nat))))) k := +Definition round_completion (e : (Execution AState Actor (option (CSLObs (nat * nat))))) k := owner_boundary (selected e k) (owner_state (states e k)) = true. (** The owner round budget is [credit_interval] at the existentially-bounded @@ -871,7 +872,7 @@ Proof. Qed. Lemma execution_retired_credit capacity c e k block idx : - allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> + allocator_valid capacity c e -> emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> exists L R D credit, allocator_view 1 capacity (states e (S k)) L R D /\ reclaim_credit capacity block (owner_state (states e (S k))) R D credit /\ @@ -930,7 +931,8 @@ Qed. Definition block_event_dec tag block event : sumbool (block_event tag block event) (not (block_event tag block event)). Proof. - destruct event as [[[kind b] idx]|]. + destruct event as [[ctx|[[kind b] idx]]|]. + - right; intros [i H]; discriminate. - destruct (Nat.eq_dec kind tag) as [->|Hkind]; destruct (Nat.eq_dec b block) as [->|Hb]. + left; exists idx; reflexivity. @@ -941,7 +943,7 @@ Proof. Defined. Theorem no_reclaim_owner_bound capacity c e k block idx len : - allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> + allocator_valid capacity c e -> emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> (forall j, S k <= j < S k + len -> ~ block_event tag_reclaim block (emitted e j)) -> count_if (fun k => owner_selected (selected e k)) (S k) len < 6 * capacity + 10. Proof. @@ -955,10 +957,10 @@ Proof. Qed. Theorem retired_reclaimed_owner_selection_bound capacity c e k block idx len : - allocator_valid capacity c e -> emitted e k = Some (stamp (tag_retire,block) idx) -> + allocator_valid capacity c e -> emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> 6 * capacity + 10 <= count_if (fun k => owner_selected (selected e k)) (S k) len -> exists j idx', k < j /\ j < S k + len /\ idx < idx' /\ - emitted e j = Some (stamp (tag_reclaim,block) idx') /\ + emitted e j = Some (inr (stamp (tag_reclaim,block) idx')) /\ count_if (fun k => owner_selected (selected e k)) (S k) (j-k) <= 6 * capacity + 10. Proof. intros Hv Hret Hcount. @@ -970,7 +972,7 @@ Proof. Hcount) as (j & Hj & [idx' Hreclaim] & Hbound). exists j, idx'; split; [lia|]; split; [lia|]; split. - exact (execution_event_order (turn 1) - (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) + (fun s => s = initial_state capacity c) acount csl_index (turn_counter 1) e k j _ _ Hv ltac:(lia) Hret Hreclaim). - split; [exact Hreclaim|exact Hbound]. Qed. @@ -979,9 +981,9 @@ Theorem retired_eventually_reclaimed capacity c e : allocator_valid capacity c e -> infinitely (fun k => selected e k = Owner) -> forall k block idx, - emitted e k = Some (stamp (tag_retire,block) idx) -> + emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> exists j idx', k < j /\ idx < idx' /\ - emitted e j = Some (stamp (tag_reclaim,block) idx'). + emitted e j = Some (inr (stamp (tag_reclaim,block) idx')). Proof. intros Hv Howner k block idx Hret. assert (Hcharged : infinitely (fun j => owner_selected (selected e j) = true)). @@ -996,9 +998,9 @@ Qed. Theorem retired_not_reallocated_before_reclaim capacity c e k block idx j : allocator_valid capacity c e -> - emitted e k = Some (stamp (tag_retire,block) idx) -> k < j -> - (forall q idx', k < q < j -> emitted e q <> Some (stamp (tag_reclaim,block) idx')) -> - forall idx', emitted e j <> Some (stamp (tag_alloc,block) idx'). + emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> k < j -> + (forall q idx', k < q < j -> emitted e q <> Some (inr (stamp (tag_reclaim,block) idx'))) -> + forall idx', emitted e j <> Some (inr (stamp (tag_alloc,block) idx')). Proof. intros Hv Hret Hkj Hnone idx' Halloc. destruct (execution_retired_credit capacity c e k block idx Hv Hret) @@ -1018,10 +1020,10 @@ Qed. Theorem retired_reallocation_requires_reclaim capacity c e k j block idx alloc_idx : allocator_valid capacity c e -> k < j -> - emitted e k = Some (stamp (tag_retire,block) idx) -> - emitted e j = Some (stamp (tag_alloc,block) alloc_idx) -> + emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> + emitted e j = Some (inr (stamp (tag_alloc,block) alloc_idx)) -> exists q reclaim_idx, k < q /\ q < j /\ idx < reclaim_idx /\ - reclaim_idx < alloc_idx /\ emitted e q = Some (stamp (tag_reclaim,block) reclaim_idx). + reclaim_idx < alloc_idx /\ emitted e q = Some (inr (stamp (tag_reclaim,block) reclaim_idx)). Proof. intros Hv Hkj Hret Halloc. destruct (finite_first (fun q => block_event tag_reclaim block (emitted e q)) @@ -1032,31 +1034,31 @@ Proof. intros q qi Hq Hreclaim; apply (Hnone q ltac:(lia)); now exists qi. - exists q, qi; split; [lia|]; split; [lia|]; split. + exact (execution_event_order (turn 1) - (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e k q _ _ Hv ltac:(lia) Hret Hreclaim). + (fun s => s = initial_state capacity c) acount csl_index (turn_counter 1) e k q _ _ Hv ltac:(lia) Hret Hreclaim). + split; [|exact Hreclaim]. exact (execution_event_order (turn 1) - (fun s => s = initial_state capacity c) acount indexed_index (turn_counter 1) e q j _ _ Hv ltac:(lia) Hreclaim Halloc). + (fun s => s = initial_state capacity c) acount csl_index (turn_counter 1) e q j _ _ Hv ltac:(lia) Hreclaim Halloc). Qed. -Theorem source_retired_eventually_reclaimed capacity c se : - allocator_source_valid capacity c se -> +Theorem source_retired_eventually_reclaimed capacity ctx c se : + allocator_source_valid capacity ctx c se -> infinitely (fun k => selected se k = Owner) -> forall k block idx, - List.In (stamp (tag_retire,block) idx) (emitted se k) -> + List.In (inr (stamp (tag_retire,block) idx)) (emitted se k) -> exists j idx', k < j /\ idx < idx' /\ - List.In (stamp (tag_reclaim,block) idx') (emitted se j). + List.In (inr (stamp (tag_reclaim,block) idx')) (emitted se j). Proof. intros Hvalid Howner k block idx Hretire. set (e := allocator_execution capacity c (selected se)). assert (Hmodel : allocator_valid capacity c e) by apply execution_of_choices_valid. pose proof (source_execution_complete (allocator_simulation 1 capacity) - (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),c) + (source_pool0 1) ((page_heap 1 capacity hemp,upd hemp 1 (page_size capacity)),(ctx,c)) (initial_state capacity c) se e (initial_state_inv capacity c) (conj (heq_refl _) eq_refl) (pool_equ_guard _ _ (source_pool0_initial capacity c)) Hvalid Hmodel (execution_of_choices_selected _ _ _ _ _ _ (selected se))) as Halign. assert (Howner' : infinitely (fun j => selected e j = Owner)) by exact Howner. - assert (Eretire : emitted e k = Some (stamp (tag_retire,block) idx)). + assert (Eretire : emitted e k = Some (inr (stamp (tag_retire,block) idx))). { destruct (Halign k) as (_ & _ & _ & Hlogs); rewrite Hlogs in Hretire. destruct (emitted e k) as [o|] eqn:E; cbn [event_obs] in Hretire; @@ -1094,18 +1096,18 @@ Section AllocatorRecurrence. (** These lists use left numerals so that symbolic counters compute without inspecting the counter. [n+c] is, of course, the prescribed [c+n]. *) -Let demo_prefix (c : nat) : list (indexed (nat * nat)) := - [stamp (tag_alloc,6) c; stamp (tag_alloc,8) (1+c); - stamp (tag_retire,6) (2+c); stamp (tag_retry,8) (3+c); - stamp (tag_retire,8) (4+c); stamp (tag_reclaim,8) (5+c); - stamp (tag_reclaim,6) (6+c); stamp (tag_alloc,6) (7+c); - stamp (tag_alloc,8) (8+c)]. - -Let demo_cycle_logs (c : nat) : list (indexed (nat * nat)) := - [stamp (tag_retire,6) c; stamp (tag_retry,8) (1+c); - stamp (tag_retire,8) (2+c); stamp (tag_reclaim,8) (3+c); - stamp (tag_reclaim,6) (4+c); stamp (tag_alloc,6) (5+c); - stamp (tag_alloc,8) (6+c)]. +Let demo_prefix (c : nat) : list (CSLObs (nat * nat)) := + [inr (stamp (tag_alloc,6) c); inr (stamp (tag_alloc,8) (1+c)); + inr (stamp (tag_retire,6) (2+c)); inr (stamp (tag_retry,8) (3+c)); + inr (stamp (tag_retire,8) (4+c)); inr (stamp (tag_reclaim,8) (5+c)); + inr (stamp (tag_reclaim,6) (6+c)); inr (stamp (tag_alloc,6) (7+c)); + inr (stamp (tag_alloc,8) (8+c))]. + +Let demo_cycle_logs (c : nat) : list (CSLObs (nat * nat)) := + [inr (stamp (tag_retire,6) c); inr (stamp (tag_retry,8) (1+c)); + inr (stamp (tag_retire,8) (2+c)); inr (stamp (tag_reclaim,8) (3+c)); + inr (stamp (tag_reclaim,6) (4+c)); inr (stamp (tag_alloc,6) (5+c)); + inr (stamp (tag_alloc,8) (6+c))]. (** Only a pointwise representative; no execution ever resets its heap to it. *) Let demo_boundary_heap : Heap := fun x => @@ -1149,7 +1151,7 @@ Qed. Local Lemma demo_cycle_fresh_member c kind : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> - exists o, List.In o (demo_cycle_logs c) /\ (fst (indexed_value o)) = kind /\ c <= indexed_index o. + exists o, List.In (inr o) (demo_cycle_logs c) /\ (fst (indexed_value o)) = kind /\ c <= indexed_index o. Proof. intros [<-|[<-|[<-|[]]]]. - exists (stamp (tag_alloc,6) (5+c)); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; @@ -1165,11 +1167,11 @@ Proof. intros n _; unfold demo_cycle_logs; discriminate. Qed. (** The actual source is the 57-turn prefix followed by the repeating cycle, each cycle a genuine 42-turn round-robin run from the actual state. *) -Theorem run_rr_allocator_demo_bisim c : - run_rr (allocator_program 2) managed_empty c ~ +Theorem run_rr_allocator_demo_bisim ctx c : + run_rr (allocator_program 2) (managed_empty,(ctx,c)) ~ emit_list (demo_prefix c) (emit_batches demo_cycle_logs (fun n => n+7) (c+9) - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_allocator_bisim. destruct (demo_prefix_run c) as (last & Hrun & Hlast). @@ -1187,19 +1189,19 @@ Qed. [P o := fst (indexed_value o) = kind /\ kb <= indexed_index o]. The concrete tag premise is retained: the generic rule accepts arbitrary predicates, but this proof must not claim recurrence of arbitrary tags. *) -Theorem allocator_demo_agaf_fresh c kind kb : +Theorem allocator_demo_agaf_fresh ctx c kind kb : List.In kind [tag_alloc;tag_retire;tag_reclaim] -> - <( {run_rr (allocator_program 2) managed_empty c}, Pure - |= AG (AF visW {fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o}) )>. + <( {run_rr (allocator_program 2) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o)}) )>. Proof. intro Hkind. assert (Hprogress : forall n : nat, True -> (exists o, List.In o (demo_cycle_logs n) /\ - ((fst (indexed_value o)) = kind /\ kb <= indexed_index o)) + csl_indexed (fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o) o) \/ kb - (n+7) < kb - n). { intros n _; destruct (Nat.le_gt_cases kb n) as [Hle|Hlt]. - left; destruct (demo_cycle_fresh_member n kind Hkind) as (o & Hin & Htag & Hidx). - exists o; split; [exact Hin |]; split; [exact Htag | lia]. + exists (inr o); split; [exact Hin |]; cbn; split; [exact Htag | lia]. - right; lia. } rewrite run_rr_allocator_bisim. destruct (demo_prefix_run c) as (last & Hrun & Hlast). @@ -1210,7 +1212,7 @@ Proof. apply (model_rr_agaf 2 actor_of_slot (turn 1) state_equiv (turn_proper 1) demo_boundary demo_cycle_logs (fun n => n+7) (fun _ => True) 0 42 eq_refl (fun _ _ => I) demo_cycle_logs_nonempty (fun n _ => demo_cycle_run n) - (fun n => kb - n) (fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o) + (fun n => kb - n) (csl_indexed (fun o => (fst (indexed_value o)) = kind /\ kb <= indexed_index o)) Hprogress (c+9)); [exact I|]. apply after_logs_not_done; constructor. Qed. @@ -1230,9 +1232,9 @@ Let aba_before_reuse := Let aba_before_commit := aba_before_reuse ++ List.repeat Owner 6 ++ List.repeat Remote0 4. Let aba_script := aba_before_commit ++ [Remote1]. -Let aba_logs : list (indexed (nat * nat)) := - [stamp (0,6) 0; stamp (0,8) 1; stamp (1,6) 2; stamp (2,6) 3; - stamp (0,6) 4; stamp (1,6) 5; stamp (1,8) 6]. +Let aba_logs : list (CSLObs (nat * nat)) := + [inr (stamp (0,6) 0); inr (stamp (0,8) 1); inr (stamp (1,6) 2); inr (stamp (2,6) 3); + inr (stamp (0,6) 4); inr (stamp (1,6) 5); inr (stamp (1,8) 6)]. Theorem aba_snapshot_survives_reuse : option_map (fun result => (owner_state (fst result), remote0_state (fst result), @@ -1273,12 +1275,12 @@ Theorem aba_actual_source_no_loss : exists last labels residual, allocator_inv 1 2 last /\ aheap last (remote_head 1) = Some 8 /\ linked (fun a next => aheap last a = Some next) [8;6] 0 /\ label_logs labels = aba_logs /\ label_taus labels = 23 /\ - finite_steps (run_nd (allocator_program 2) managed_empty 0) labels residual /\ + finite_steps (run_nd (allocator_program 2) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ residual ~ (model_nd 2 actor_of_slot (turn 1) last - : ictreeW (indexed (nat * nat)) (unit * SSig)). + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. destruct aba_run_no_loss as (last & Hrun & Hinv & Hhead & Hchain & Hnd & Hp). - destruct (run_turns_realizes_source 2 0 aba_script last aba_logs Hrun) + destruct (run_turns_realizes_source 2 (List.nil : Ctx.Ctx) 0 aba_script last aba_logs Hrun) as (labels & residual & Hlabels & Hlogs & Htaus & Hsteps & Htail). exists last, labels, residual; repeat first [assumption | split]. Qed. diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v index d562e97..68155f4 100644 --- a/examples/CSL/Allocator/Model.v +++ b/examples/CSL/Allocator/Model.v @@ -25,14 +25,14 @@ Record AState := { (** One selected source segment, ending at its first yield. The helpers below only assemble this example's result; missing checked cells fault. *) Definition turn (base : nat) (who : Actor) (s : AState) - : option (AState * option (indexed (nat * nat))) := + : option (AState * option (CSLObs (nat * nat))) := let finish (h : Heap) (op : owner_pc) (r0 r1 : remote_pc) (event : option (nat * nat)) := Some ({| aheap := h; acount := match event with None => acount s | Some _ => S (acount s) end; owner_state := op; remote0_state := r0; remote1_state := r1 |}, match event with None => None - | Some (tag,block) => Some (stamp (tag,block) (acount s)) end) in + | Some (tag,block) => Some (inr (stamp (tag,block) (acount s))) end) in let own pc h event := finish h pc (remote0_state s) (remote1_state s) event in let remote (client : bool) := let pc := if client then remote1_state s else remote0_state s in @@ -216,7 +216,7 @@ Lemma turn_counter base who s t event : turn base who s = Some (t,event) -> match event with | None => acount t = acount s - | Some o => acount t = S (acount s) /\ indexed_index o = acount s + | Some o => acount t = S (acount s) /\ csl_index o = acount s end. Proof. destruct s as [h c op r0 r1]; destruct who; @@ -520,7 +520,7 @@ Local Ltac ai_reduce_turn := Definition owner_after_offer (client : bool) := if client then ORead else OOffer true. Inductive ownership_transition : - Actor -> owner_pc -> owner_pc -> option (indexed (nat * nat)) -> + Actor -> owner_pc -> owner_pc -> option (CSLObs (nat * nat)) -> list nat -> list nat -> list nat -> list nat -> list nat -> list nat -> Prop := | ownership_read L R : ownership_transition Owner ORead (OCAS (List.hd 0 R)) None L R [] L R [] @@ -532,21 +532,21 @@ Inductive ownership_transition : | ownership_drain_empty L R : ownership_transition Owner ODrain (OOffer false) None L R [] L R [] | ownership_drain L R b D idx : - ownership_transition Owner ODrain ODrain (Some (stamp (tag_reclaim,b) idx)) + ownership_transition Owner ODrain ODrain (Some (inr (stamp (tag_reclaim,b) idx))) L R (b :: D) (b :: L) R D | ownership_offer_empty client L R : ownership_transition Owner (OOffer client) (owner_after_offer client) None L R [] L R [] | ownership_offer client L R b idx : ownership_transition Owner (OOffer client) (owner_after_offer client) - (Some (stamp (tag_alloc,b) idx)) (b :: L) R [] L R [] + (Some (inr (stamp (tag_alloc,b) idx))) (b :: L) R [] L R [] | ownership_remote who pc event L R D : who <> Owner -> - (event = None \/ exists b idx, event = Some (stamp (tag_retry,b) idx)) -> + (event = None \/ exists b idx, event = Some (inr (stamp (tag_retry,b) idx))) -> ownership_transition who pc pc event L R D L R D | ownership_publish who pc L R D b idx : who <> Owner -> - ownership_transition who pc pc (Some (stamp (tag_retire,b) idx)) + ownership_transition who pc pc (Some (inr (stamp (tag_retire,b) idx))) L R D L (b :: R) D. (** Finish one branch: the computed result, its ownership view at the new @@ -730,12 +730,12 @@ Proof. intros ->; apply initial_state_inv. Qed. Exactly two instantiations of [Utils.Execution]; no example-local execution record, constructor or replay proof remains. *) Definition allocator_valid (capacity c : nat) - (e : Execution AState Actor (option (indexed (nat * nat)))) : Prop := + (e : Execution AState Actor (option (CSLObs (nat * nat)))) : Prop := execution_valid (fun who s o s' => turn 1 who s = Some (s',o)) (fun s => s = initial_state capacity c) e. Definition allocator_execution (capacity c : nat) (picks : nat -> Actor) - : Execution AState Actor (option (indexed (nat * nat))) := + : Execution AState Actor (option (CSLObs (nat * nat))) := execution_of_choices (turn 1) (allocator_inv 1 capacity) (fun who s Hs => match turn_total 1 capacity who s Hs with diff --git a/examples/CSL/Control.v b/examples/CSL/Control.v new file mode 100644 index 0000000..e3df3e6 --- /dev/null +++ b/examples/CSL/Control.v @@ -0,0 +1,151 @@ +(** * Control behavior of the combined Yield+CSL source language. + + Concrete programs run through the real round-robin interpreter. They pin + the scoped semantics of [CFork] (a child runs only its body), the single + yield of a successful variable read together with the late context read of + an assignment, the separation of context observations from the indexed + counter, and the fault on a missing variable. *) + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Strings.String. +From ExtLib Require Import Structures.Maps Data.Map.FMapAList Data.String. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Writer ICTree.Events.Yield + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin ICTree.Interp.Refine + Lang.CSL.Mod Utils.Vectors. + +Import ICtree ICTreeNotations ListNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. + +(** ** Driving the round-robin run *) + +(** Expose the focused slot as an explicit replacement, so that the source + execution laws of [Lang.CSL.Mod] apply to it. *) +Ltac rr_focus := + lazymatch goal with + | |- interp_schedule_rr ?h ?N ?P (Some ?i) ?m ?s ~ _ => + rewrite <- (interp_schedule_rr_equ h N (P @ i := (P $ i)) P (Some i) m s + (pool_replace_current P i)); + let x := eval cbn [Vector.nth Vector.replace Vector.caseS Vector.caseS'] in (P $ i) in + change (P $ i) with x; unfold denote + end. + +Ltac rr_finish := + cbn beta iota zeta; + rewrite interp_schedule_rr_ret by reflexivity; + lazymatch goal with + | |- interp_schedule_rr _ _ (?v -- _) _ _ _ ~ _ => + let v' := eval cbn in v in change v with v' + end; + rewrite vector_remove_head; + apply interp_schedule_rr_empty. + +(** A focused finished slot is removed; the remaining pool is computed + without unfolding any source denotation. *) +Ltac rr_finish_step := + rewrite interp_schedule_rr_ret by reflexivity; + cbn [Vector.replace Vector.caseS Vector.caseS']; + rewrite ?vector_remove_tail, ?vector_remove_head. + +(** Round-robin selection, with the picked slot computed. *) +Ltac rr_select := + rewrite interp_schedule_rr_select; + lazymatch goal with + | |- context [rr_pick ?n ?m] => + let p := eval vm_compute in (rr_pick n m) in change (rr_pick n m) with p + end. + +Definition ctx0 : Ctx.Ctx := List.nil. +Definition state0 : SSig := (managed_empty, (ctx0, 0)). + +(** ** Scoped fork + + The child runs only its own body; it never executes the parent's + continuation. Parent first (the focus stays on the parent after a + fork), then the child, each emitting exactly once. *) +Theorem scoped_fork_no_parent_replay : + run_rr (CBind (CFork (CEmit 1 7)) (fun _ => CEmit 0 9)) state0 ~ + emit_list [inr (stamp (0,9) 0); inr (stamp (1,7) 1)]%list + (Ret (tt, (managed_empty, (ctx0, 2)))). +Proof. + rewrite run_rr_fork_bind; unfold state0. + rr_focus. + rewrite interp_rr_emit_log. + unfold emit_list; cbn [List.fold_right]. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rr_finish_step. + rr_select; rr_focus. + rewrite interp_rr_emit_log. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rr_finish_step. + apply interp_schedule_rr_empty. +Qed. + +(** ** Late context reads + + [x := 1; fork (z := 9); y := x]. The parent's read of [x] yields once, + so the child updates the shared context first; the parent's assignment + then reads the context again, so the child's update is preserved. Only + context observations are emitted, and the indexed counter stays [0]. *) +Definition context_program : CProg unit := + CBind (CAssign "x" (CLit 1)) (fun _ => + CBind (CFork (CAssign "z" (CLit 9))) (fun _ => + CAssign "y" (CVar "x"))). + +Theorem context_resume_preserves_updates : + let ctx1 := add "x"%string 1 ctx0 in + let ctx2 := add "z"%string 9 ctx1 in + let ctx3 := add "y"%string 1 ctx2 in + run_rr context_program state0 ~ + emit_list [inl ctx1; inl ctx2; inl ctx3]%list + (Ret (tt, (managed_empty, (ctx3, 0)))). +Proof. + intros ctx1 ctx2 ctx3. + rewrite run_rr_unfold; unfold state0, context_program. + unfold emit_list; cbn [List.fold_right]. + (* parent: x := 1 *) + rr_focus. + rewrite interp_rr_bind, interp_rr_assign, interp_rr_lit; cbv beta. + rewrite interp_rr_get_ctx; cbv beta. + rewrite interp_rr_put_ctx. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + (* parent: fork the child, keep the focus *) + cbv beta iota. + rewrite interp_rr_bind, interp_rr_fork. + (* parent: y := x reads x and yields *) + rr_focus. + rewrite interp_rr_assign. + rewrite (interp_rr_var _ _ _ "x"%string 1) by reflexivity. + (* the child runs next: z := 9, then halts *) + rr_select; rr_focus. + rewrite interp_rr_assign, interp_rr_lit; cbv beta. + rewrite interp_rr_get_ctx; cbv beta. + rewrite interp_rr_put_ctx. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + cbv beta iota. + rr_finish_step. + (* the parent resumes with the captured value and a fresh context read *) + rr_select; rr_focus. + rewrite interp_rr_get_ctx; cbv beta. + rewrite interp_rr_put_ctx. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + cbv beta iota. + rr_finish_step. + apply interp_schedule_rr_empty. +Qed. + +(** ** Missing variables fault + + There is no default value: reading an unbound variable is stuck, so the + whole run is [stuck] rather than an empty observation sequence. *) +Theorem missing_variable_stuck : + run_rr (CBind (CEval (CVar "missing")) (fun _ => CRet tt)) state0 ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + rewrite run_rr_unfold; unfold state0. + rr_focus. + rewrite interp_rr_bind. + rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 _ + (replace_pool_equ _ _ Fin.F1 _ _ (pool_equ_refl _) (source_raw_eval _ _))). + apply interp_rr_var_missing; reflexivity. +Qed. diff --git a/examples/CSL/Memory.v b/examples/CSL/Memory.v index 2e5e19b..855793b 100644 --- a/examples/CSL/Memory.v +++ b/examples/CSL/Memory.v @@ -63,11 +63,11 @@ Definition use_after_free_cas : CProg unit := Each step applies one source execution rule of [Lang.CSL.Mod] at the focused thread; concrete heap facts are discharged by computation. *) -Lemma run_rr_focus p memory c : - run_rr p memory c ≅ +Lemma run_rr_focus p (s : SSig) : + run_rr p s ≅ interp_schedule_rr sh 1 (([Ret tt] : pool sE 1) @ Fin.F1 := (denote_flow p >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (memory,c). + (Some Fin.F1) 0 s. Proof. reflexivity. Qed. Ltac first_fit := @@ -123,9 +123,9 @@ Ltac rr_finish := extent, and the observation stamps. *) Theorem lifecycle_scope : exists memory : ManagedHeap, - run_rr lifecycle managed_empty 0 ~ - emit_list [stamp (80,1) 0; stamp (81,0) 1; stamp (82,11) 2]%list - (Ret (tt,(memory,3))) /\ + run_rr lifecycle (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + emit_list [inr (stamp (80,1) 0); inr (stamp (81,0) 1); inr (stamp (82,11) 2)]%list + (Ret (tt,(memory,((List.nil : Ctx.Ctx),3)))) /\ fst memory 1 = None /\ fst memory 2 = None /\ fst memory 3 = None /\ fst memory 4 = Some 11 /\ fst memory 5 = Some 0 /\ snd memory 1 = None /\ snd memory 4 = Some 2. @@ -154,8 +154,8 @@ Qed. extent recorded and zero-initialized again. *) Theorem reuse_first_fit : exists memory : ManagedHeap, - run_rr reallocate managed_empty 0 ~ - emit_list [stamp (83,1) 0]%list (Ret (tt,(memory,1))) /\ + run_rr reallocate (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + emit_list [inr (stamp (83,1) 0)]%list (Ret (tt,(memory,((List.nil : Ctx.Ctx),1)))) /\ snd memory 1 = Some 3 /\ fst memory 1 = Some 0 /\ fst memory 2 = Some 0 /\ fst memory 3 = Some 0. Proof. @@ -173,19 +173,19 @@ Proof. Qed. (** Freeing null leaves every component of the state unchanged. *) -Theorem free_null_unchanged (memory : ManagedHeap) c : - run_rr (CFree 0) memory c ~ Ret (tt,(memory,c)). +Theorem free_null_unchanged (memory : ManagedHeap) ctx c : + run_rr (CFree 0) (memory,(ctx,c)) ~ Ret (tt,(memory,(ctx,c))). Proof. rewrite run_rr_focus. - rewrite (interp_rr_free _ _ _ 0 _ _ memory memory c eq_refl). + rewrite (interp_rr_free _ _ _ 0 _ _ memory memory ctx c eq_refl). rr_finish. Qed. (** ** Faults *) Theorem invalid_interior_stuck : - run_rr invalid_interior managed_empty 0 ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + run_rr invalid_interior (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_focus; unfold invalid_interior. rr_step; rr_alloc 1. @@ -194,8 +194,8 @@ Proof. Qed. Theorem invalid_double_stuck : - run_rr invalid_double managed_empty 0 ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + run_rr invalid_double (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_focus; unfold invalid_double. rr_step; rr_alloc 1. @@ -205,8 +205,8 @@ Proof. Qed. Theorem use_after_free_read_stuck : - run_rr use_after_free_read managed_empty 0 ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + run_rr use_after_free_read (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_focus; unfold use_after_free_read. rr_step; rr_alloc 1. @@ -216,8 +216,8 @@ Proof. Qed. Theorem use_after_free_write_stuck : - run_rr use_after_free_write managed_empty 0 ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + run_rr use_after_free_write (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_focus; unfold use_after_free_write. rr_step; rr_alloc 1. @@ -227,8 +227,8 @@ Proof. Qed. Theorem use_after_free_cas_stuck : - run_rr use_after_free_cas managed_empty 0 ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + run_rr use_after_free_cas (managed_empty,((List.nil : Ctx.Ctx),0)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. rewrite run_rr_focus; unfold use_after_free_cas. rr_step; rr_alloc 1. diff --git a/examples/CSL/Queue.v b/examples/CSL/Queue.v index c8f6f0b..06289d4 100644 --- a/examples/CSL/Queue.v +++ b/examples/CSL/Queue.v @@ -3,4 +3,4 @@ From examples Require Export CSL.Queue.Representation CSL.Queue.Layout CSL.Queue.Operations CSL.Queue.Sequential CSL.Queue.Recurrence CSL.Queue.Trace CSL.Queue.Frame CSL.Queue.Separation CSL.Queue.Alternating - CSL.Queue.Composition CSL.Queue.Program CSL.Queue.Ticl. + CSL.Queue.Composition CSL.Queue.Program CSL.Queue.Ticl CSL.Queue.Shared. diff --git a/examples/CSL/Queue/Alternating.v b/examples/CSL/Queue/Alternating.v index e20a4b1..fe2f747 100644 --- a/examples/CSL/Queue/Alternating.v +++ b/examples/CSL/Queue/Alternating.v @@ -49,15 +49,16 @@ Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). Instantiate [Operations.queue_turn_spec] with tagged observations. The arbitrary tail reuses the same heap operation proof as sequential rotation. *) -Theorem turnk_spec {X}: forall q hdr a ns pv vs h allocs c (kt: ictree sE X), +Theorem turnk_spec {X}: forall q hdr a ns pv vs h allocs ctx c (kt: ictree sE X), qrep hdr (a :: ns) (pv :: vs) h -> - interp_state sh (turnk q hdr kt) ((h, allocs), c) - ~ (log (stamp (q,pv) c) ;; - interp_state sh kt ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c)). + interp_state sh (turnk q hdr kt) ((h, allocs), (ctx, c)) + ~ (log (inr (stamp (q,pv) c) : CSLObs (nat * nat)) ;; + interp_state sh kt ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), (ctx, S c))). Proof. - intros q hdr a ns pv vs h allocs c kt Hq; unfold turnk. - eapply (queue_turn_spec h_indexed (semit q) (fun value index => stamp (q,value) index)). - - intros; unfold semit; apply (interp_indexed_emit heap_handler). + intros q hdr a ns pv vs h allocs ctx c kt Hq; unfold turnk. + eapply (queue_turn_spec (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat))) + (semit q) (fun value index => inr (stamp (q,value) index))). + - intros; unfold semit; apply interp_csl_emit. From Coinduction Require Import coinduction. - exact Hq. @@ -78,29 +79,29 @@ Definition sbody (u v: nat) (n: nat) : ictree sE (nat + unit) := Definition sched (u v n: nat) : ictree sE unit := ICtree.iter (sbody u v) n. -Definition srun (u v n: nat) (memory: ManagedHeap) (c: nat) - : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_state sh (sched u v n) (memory, c). +Definition srun (u v n: nat) (s: SSig) + : ictreeW (CSLObs (nat * nat)) (unit * SSig) := + interp_state sh (sched u v n) s. (** One scheduler turn, for EITHER phase, in one statement. [hdrof]/[tagof] are what let the phase case analysis happen once, in the temporal proof, rather than twice in the language layer. *) -Theorem sbody_spec: forall u v n a ns pv vs h allocs c, +Theorem sbody_spec: forall u v n a ns pv vs h allocs ctx c, qrep (hdrof u v n) (a :: ns) (pv :: vs) h -> - interp_state sh (sbody u v n) ((h, allocs), c) - ~ (log (stamp ((tagof n),pv) c) ;; + interp_state sh (sbody u v n) ((h, allocs), (ctx, c)) + ~ (log (inr (stamp ((tagof n),pv) c) : CSLObs (nat * nat)) ;; Ret (@inl nat unit (S n), ((rot_heap (hdrof u v n) a (List.hd 0 ns) (zof (hdrof u v n) ns) h, allocs), - S c))). + (ctx, S c)))). Proof. - intros u v n a ns pv vs h allocs c Hq. + intros u v n a ns pv vs h allocs ctx c Hq. unfold sbody, hdrof, tagof in *. destruct (Nat.even n). - - rewrite (turnk_spec 1 u a ns pv vs h allocs c + - rewrite (turnk_spec 1 u a ns pv vs h allocs ctx c (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_state_ret; reflexivity. - - rewrite (turnk_spec 2 v a ns pv vs h allocs c + - rewrite (turnk_spec 2 v a ns pv vs h allocs ctx c (Ret (@inl nat unit (S n)): ictree sE (nat + unit)) Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite interp_state_ret; reflexivity. @@ -128,7 +129,7 @@ Proof. intros n H; unfold tagof; now rewrite H. Qed. (** ** Observation predicates - Tagged observations are [indexed (nat * nat)]: the payload pairs the + Tagged observations are [inr] of [indexed (nat * nat)]: the payload pairs the queue tag with the (fun o => indexed_value o = value), and the occurrence index is the record's own field. A plain predicate is therefore [fun o => indexed_value o = (q,nl)] and its freshness companion is @@ -146,10 +147,10 @@ Proof. apply queue_turn_equ; symmetry; apply bind_ret_l. Qed. -Lemma srun_turn u v n memory c : - srun u v n memory c ~ - (interp_state sh (turn (tagof n) (hdrof u v n)) (memory,c) >>= - fun '(_, (memory',c')) => srun u v (S n) memory' c'). +Lemma srun_turn u v n (s : SSig) : + srun u v n s ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) s >>= + fun '(_, s') => srun u v (S n) s'). Proof. unfold srun, sched. rewrite interp_state_unfold_iter. @@ -157,7 +158,7 @@ Proof. unfold sbody, tagof, hdrof. destruct (Nat.even n). all: rewrite turnk_bind, interp_state_bind, bind_bind. - all: apply sbisim_clo_bind_eq; [reflexivity | intros [x [h' c']]]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [x s']]. all: rewrite interp_state_ret, bind_ret_l. all: apply sb_guard. Qed. diff --git a/examples/CSL/Queue/Composition.v b/examples/CSL/Queue/Composition.v index dc192b8..457855a 100644 --- a/examples/CSL/Queue/Composition.v +++ b/examples/CSL/Queue/Composition.v @@ -158,7 +158,7 @@ Section Composition. exists nsf vsf nsg vsg df dg, qrep fh nsf vsf (fst (fst s)) /\ qrep gh nsg vsg (fst (fst s)) /\ Disj fh nsf gh nsg /\ find_index Nat.eqb nlf vsf = Some df /\ find_index Nat.eqb nlg vsg = Some dg - /\ m = (kb - snd s, (df, if fturn n then 0 else 1)). + /\ m = (kb - csl_counter s, (df, if fturn n then 0 else 1)). (** ** The inner eventuality: the focused queue pops its element again *) @@ -166,28 +166,28 @@ Section Composition. Context (nlf nlg kb: nat) (P: (indexed (nat * nat)) -> Prop) (HP: forall j, Nat.le kb j -> P (stamp (fq,nlf) j)). - Lemma inner_af: forall n h allocs c w, + Lemma inner_af: forall n h allocs ctx c w, not_done w -> Iq nlf nlg h -> - <( {interp_state sh (sched u v n) ((h, allocs), c)}, w |= AF visW {P} )>. + <( {interp_state sh (sched u v n) ((h, allocs), (ctx, c))}, w |= AF visW {csl_indexed P} )>. Proof. - intros n h allocs c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). + intros n h allocs ctx c w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). unfold sched. apply (aul_state_iter_ghost sh rank3 (Ig nlf nlg kb) (sbody u v) _ _ - rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n ((h, allocs), c) w Hd). + rank3_wf (kb - c, (df, if fturn n then 0 else 1)) n ((h, allocs), (ctx, c)) w Hd). - exists nsf, vsf, nsg, vsg, df, dg; cbn. split; [exact Hqf |]; split; [exact Hqg |]; split; [exact Hdj |]; split; [exact Hff |]; split; [exact Hfg | reflexivity]. - - clear n h allocs c w Hd nsf vsf nsg vsg df dg Hqf Hqg Hdj Hff Hfg. + - clear n h allocs ctx c w Hd nsf vsf nsg vsg df dg Hqf Hqg Hdj Hff Hfg. intros m n s w Hd (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg & Hm). - destruct s as ((h, allocs), c); cbn in Hqf, Hqg, Hm. + destruct s as ((h, allocs), (ctx, c)); cbn in Hqf, Hqg, Hm. destruct (fturn n) eqn:Eph. + (* --- the FOCUSED queue's turn --- *) destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. destruct nsf as [| a nsf']; [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. - pose proof (sbody_spec u v n a nsf' pv vsf' h allocs c) as Hspec. + pose proof (sbody_spec u v n a nsf' pv vsf' h allocs ctx c) as Hspec. rewrite (Hfh n Eph), (Hft n Eph) in Hspec. specialize (Hspec Hqf). destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) @@ -197,14 +197,14 @@ Section Composition. rank3 (kb - S c, (df', 1)) m -> (exists g' i' s' w', not_done w' - /\ <[ {interp_state sh ((sbody u v) n) ((h, allocs), c)}, w + /\ <[ {interp_state sh ((sbody u v) n) ((h, allocs), (ctx, c))}, w |= ⊤ AU AX done= {(@inl nat unit i', s')} w' ]> /\ Ig nlf nlg kb g' i' s' /\ rank3 g' m)). { intros df' Hdf' Hlex. exists (kb - S c, (df', 1)), (S n), - ((rot_heap fh a (List.hd 0 nsf') (zof fh nsf') h, allocs), S c), - (Obs (Log (stamp (fq,pv) c)) tt). + ((rot_heap fh a (List.hd 0 nsf') (zof fh nsf') h, allocs), (ctx, S c)), + (Obs (Log (inr (stamp (fq,pv) c) : CSLObs (nat * nat))) tt). split; [constructor |]. split. { rewrite Hspec; apply aur_log; @@ -241,7 +241,7 @@ Section Composition. destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. destruct nsg as [| b nsg']; [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. - pose proof (sbody_spec u v n b nsg' pw vsg' h allocs c) as Hspec. + pose proof (sbody_spec u v n b nsg' pw vsg' h allocs ctx c) as Hspec. rewrite (Hgh n Eph) in Hspec. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) @@ -250,8 +250,8 @@ Section Composition. rewrite rotl_cons in Hdg'. right. exists (kb - S c, (df, 0)), (S n), - ((rot_heap gh b (List.hd 0 nsg') (zof gh nsg') h, allocs), S c), - (Obs (Log (stamp ((tagof n),pw) c)) tt). + ((rot_heap gh b (List.hd 0 nsg') (zof gh nsg') h, allocs), (ctx, S c)), + (Obs (Log (inr (stamp ((tagof n),pw) c) : CSLObs (nat * nat))) tt). split; [constructor |]. split. { rewrite Hspec; apply aur_log; @@ -269,20 +269,20 @@ Section Composition. Qed. (** ** The recurrence theorem for the focused queue *) - Theorem sched_agaf: forall n h allocs c w, + Theorem sched_agaf: forall n h allocs ctx c w, not_done w -> Iq nlf nlg h -> - <( {interp_state sh (sched u v n) ((h, allocs), c)}, w |= AG (AF visW {P}) )>. + <( {interp_state sh (sched u v n) ((h, allocs), (ctx, c))}, w |= AG (AF visW {csl_indexed P}) )>. Proof. - intros n h allocs c w Hd HI. + intros n h allocs ctx c w Hd HI. unfold sched. - apply (ag_state_iter sh ((h, allocs), c) - (fun (_: nat) (s: SSig) (_: WorldW (indexed (nat * nat))) => + apply (ag_state_iter sh ((h, allocs), (ctx, c)) + (fun (_: nat) (s: SSig) (_: WorldW (CSLObs (nat * nat))) => Iq nlf nlg (fst (fst s))) n w); [assumption | exact HI |]. - clear n h allocs c w Hd HI. + clear n h allocs ctx c w Hd HI. intros n s w Hd HI. - destruct s as ((h, allocs), c); cbn in HI. + destruct s as ((h, allocs), (ctx, c)); cbn in HI. split; [now apply inner_af |]. destruct HI as (nsf & vsf & nsg & vsg & df & dg & Hqf & Hqg & Hdj & Hff & Hfg). @@ -291,7 +291,7 @@ Section Composition. destruct vsf as [| pv vsf']; [cbn in Hff; discriminate |]. destruct nsf as [| a nsf']; [apply qrep_len in Hqf; cbn in Hqf; discriminate |]. - pose proof (sbody_spec u v n a nsf' pv vsf' h allocs c) as Hspec. + pose proof (sbody_spec u v n a nsf' pv vsf' h allocs ctx c) as Hspec. rewrite (Hfh n Eph), (Hft n Eph) in Hspec. specialize (Hspec Hqf). destruct (step_focus nsf' vsf' nsg vsg a pv h Hqf Hqg Hdj) @@ -310,7 +310,7 @@ Section Composition. destruct vsg as [| pw vsg']; [cbn in Hfg; discriminate |]. destruct nsg as [| b nsg']; [apply qrep_len in Hqg; cbn in Hqg; discriminate |]. - pose proof (sbody_spec u v n b nsg' pw vsg' h allocs c) as Hspec. + pose proof (sbody_spec u v n b nsg' pw vsg' h allocs ctx c) as Hspec. rewrite (Hgh n Eph) in Hspec. specialize (Hspec Hqg). destruct (step_foreign nsf vsf nsg' vsg' b pw h Hqf Hnef Hqg Hdj) @@ -340,40 +340,40 @@ End Composition. Theorem sched_agaf_q1_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), (forall j, Nat.le kb j -> P (stamp (1,nl1) j)) -> - forall n h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure |= AG (AF visW {P}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure |= AG (AF visW {csl_indexed P}) )>. Proof. - intros u v nl1 nl2 kb P HP n h allocs c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + intros u v nl1 nl2 kb P HP n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. unfold srun. apply (sched_agaf u v 1 u v Nat.even (fun n H => hdrof_even u v n H) (fun n H => hdrof_odd u v n H) (fun n H => tagof_even n H) - even_flip nl1 nl2 kb P HP n h allocs c Pure); + even_flip nl1 nl2 kb P HP n h allocs ctx c Pure); [constructor |]. exists ns1, vs1, ns2, vs2, d1, d2. split; [exact Hq1 |]; split; [exact Hq2 |]; split; [exact Hdj |]; split; [exact Hf1 | exact Hf2]. Qed. -Theorem sched_agaf_q1: forall u v nl1 nl2 n h allocs c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q1: forall u v nl1 nl2 n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. Proof. intros. eapply (sched_agaf_q1_gen u v nl1 nl2 0 ((fun o => indexed_value o = (1,nl1)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. -Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h allocs c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q1_fresh: forall u v nl1 nl2 k n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. intros. eapply (sched_agaf_q1_gen u v nl1 nl2 k ((indexed_after (fun x => x = (1,nl1)) k))); @@ -385,40 +385,40 @@ Qed. Theorem sched_agaf_q2_gen: forall u v nl1 nl2 kb (P: (indexed (nat * nat)) -> Prop), (forall j, Nat.le kb j -> P (stamp (2,nl2) j)) -> - forall n h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure |= AG (AF visW {P}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure |= AG (AF visW {csl_indexed P}) )>. Proof. - intros u v nl1 nl2 kb P HP n h allocs c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. + intros u v nl1 nl2 kb P HP n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 Hq1 Hq2 Hdj Hf1 Hf2. unfold srun. apply (sched_agaf u v 2 v u (fun n => negb (Nat.even n)) (fun n H => hdrof_odd u v n (proj1 (negb_true_iff _) H)) (fun n H => hdrof_even u v n (proj1 (negb_false_iff _) H)) (fun n H => tagof_odd n (proj1 (negb_true_iff _) H)) - (fun n => f_equal negb (even_flip n)) nl2 nl1 kb P HP n h allocs c Pure); + (fun n => f_equal negb (even_flip n)) nl2 nl1 kb P HP n h allocs ctx c Pure); [constructor |]. exists ns2, vs2, ns1, vs1, d2, d1. split; [exact Hq2 |]; split; [exact Hq1 |]; split; [now apply Disj_sym | split; [exact Hf2 | exact Hf1]]. Qed. -Theorem sched_agaf_q2: forall u v nl1 nl2 n h allocs c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q2: forall u v nl1 nl2 n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (2,nl2))}) )>. Proof. intros. eapply (sched_agaf_q2_gen u v nl1 nl2 0 ((fun o => indexed_value o = (2,nl2)))); [intros j _; split; reflexivity | eassumption .. ]. Qed. -Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h allocs c ns1 vs1 ns2 vs2 d1 d2, +Theorem sched_agaf_q2_fresh: forall u v nl1 nl2 k n h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {srun u v n (h, allocs) c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. + <( {srun u v n ((h, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. intros. eapply (sched_agaf_q2_gen u v nl1 nl2 k ((indexed_after (fun x => x = (2,nl2)) k))); diff --git a/examples/CSL/Queue/Frame.v b/examples/CSL/Queue/Frame.v index 27fc284..7fa0d8f 100644 --- a/examples/CSL/Queue/Frame.v +++ b/examples/CSL/Queue/Frame.v @@ -215,55 +215,55 @@ Qed. Apply [Recurrence.v] with framed representation premises. The shared [aul_state_iter_ghost] rule and queue invariants are reused unchanged. *) -Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f allocs c, +Theorem rotate_agaf_pop_framed: forall hdr nlv ns vs d h f allocs ctx c, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> find_index Nat.eqb nlv vs = Some d -> - <( {run hdr (hunion h f, allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = nlv)}) )>. + <( {run hdr ((hunion h f, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = nlv)}) )>. Proof. - intros hdr nlv ns vs d h f allocs c Hx Hd Hf Hfind. + intros hdr nlv ns vs d h f allocs ctx c Hx Hd Hf Hfind. eapply rotate_agaf_pop_heap; [eapply qrepX_frame; eassumption | exact Hfind]. Qed. -Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f allocs c k, +Theorem rotate_agaf_pop_fresh_framed: forall hdr nlv ns vs d h f allocs ctx c k, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> find_index Nat.eqb nlv vs = Some d -> - <( {run hdr (hunion h f, allocs) c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = nlv) k)}) )>. + <( {run hdr ((hunion h f, allocs), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = nlv) k)}) )>. Proof. - intros hdr nlv ns vs d h f allocs c k Hx Hd Hf Hfind. + intros hdr nlv ns vs d h f allocs ctx c k Hx Hd Hf Hfind. eapply rotate_agaf_pop_fresh; [eapply qrepX_frame; eassumption | exact Hfind]. Qed. (** The control that separates "the payload is somewhere in the global heap" from "the payload is popped": an element absent from the OWNED queue is never observed, no matter what the frame stores. *) -Theorem absent_never_observed_framed: forall hdr ns vs nlv h f allocs c, +Theorem absent_never_observed_framed: forall hdr ns vs nlv h f allocs ctx c, qrepX hdr ns vs h -> hdisj h f -> f 0 = None -> ns <> [] -> ~ In nlv vs -> - <( {run hdr (hunion h f, allocs) c}, Pure |= AG (now {obs_sat (fun x => x <> nlv)}) )>. + <( {run hdr ((hunion h f, allocs), (ctx, c))}, Pure |= AG (now {obs_sat (fun x => x <> nlv)}) )>. Proof. - intros hdr ns vs nlv h f allocs c Hx Hd Hf Hne Hnin. + intros hdr ns vs nlv h f allocs ctx c Hx Hd Hf Hne Hnin. eapply absent_never_observed; [eapply qrepX_frame; eassumption | exact Hne | exact Hnin]. Qed. (** The stuck control transports too: an empty owned queue is stuck even when the frame is a large populated heap. *) -Theorem empty_queue_no_ag_framed: forall hdr vs h f allocs c w phi, +Theorem empty_queue_no_ag_framed: forall hdr vs h f allocs ctx c w phi, qrepX hdr [] vs h -> hdisj h f -> f 0 = None -> - ~ <( {run hdr (hunion h f, allocs) c}, w |= AG phi )>. + ~ <( {run hdr ((hunion h f, allocs), (ctx, c))}, w |= AG phi )>. Proof. - intros hdr vs h f allocs c w phi Hx Hd Hf. + intros hdr vs h f allocs ctx c w phi Hx Hd Hf. eapply empty_queue_no_ag; eapply qrepX_frame; eassumption. Qed. diff --git a/examples/CSL/Queue/Operations.v b/examples/CSL/Queue/Operations.v index 7fd310c..3447ebb 100644 --- a/examples/CSL/Queue/Operations.v +++ b/examples/CSL/Queue/Operations.v @@ -46,18 +46,18 @@ Qed. Lemma queue_turn_spec {E W : Type} {HE : Encode E} {X} (other : E ~> stateT SSig (ictreeW W)) (emit_value : nat -> ictree (heapE + E) unit) (observe_value : nat -> nat -> W) : - (forall value h allocs c (tail : ictree (heapE + E) X), - interp_state (h_sum heap_handler other) (emit_value value;; tail) ((h,allocs),c) ~ + (forall value h allocs ctx c (tail : ictree (heapE + E) X), + interp_state (h_sum heap_handler other) (emit_value value;; tail) ((h,allocs),(ctx,c)) ~ (log (observe_value value c);; - interp_state (h_sum heap_handler other) tail ((h,allocs),S c))) -> - forall hdr a ns value values h allocs c (tail : ictree (heapE + E) X), + interp_state (h_sum heap_handler other) tail ((h,allocs),(ctx,S c)))) -> + forall hdr a ns value values h allocs ctx c (tail : ictree (heapE + E) X), qrep hdr (a :: ns) (value :: values) h -> - interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) ((h,allocs),c) ~ + interp_state (h_sum heap_handler other) (queue_turn emit_value hdr tail) ((h,allocs),(ctx,c)) ~ (log (observe_value value c);; interp_state (h_sum heap_handler other) tail - ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,allocs),S c)). + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,allocs),(ctx,S c))). Proof. - intros Emit hdr a ns value values h allocs c tail Hq. + intros Emit hdr a ns value values h allocs ctx c tail Hq. pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). cbn in Hhd, Htl. apply chain_cons in Hch as (Ha & Hsa & Hch). @@ -69,22 +69,22 @@ Proof. assert (Hread_hdr : upd h (S hdr) (List.hd 0 ns) hdr = Some (last (a :: ns) 0)) by (rewrite upd_neq by congruence; exact Htl). unfold queue_turn. - etransitivity; [apply (interp_heap_rd other (S hdr) h allocs c a _ Hhd)|]. - etransitivity; [apply (interp_heap_rd other a h allocs c value _ Ha)|]. + etransitivity; [apply (interp_heap_rd other (S hdr) h allocs (ctx,c) a _ Hhd)|]. + etransitivity; [apply (interp_heap_rd other a h allocs (ctx,c) value _ Ha)|]. etransitivity; [apply Emit|]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. - etransitivity; [apply (interp_heap_rd other (S a) h allocs (S c) (List.hd 0 ns) _ Hsa)|]. + etransitivity; [apply (interp_heap_rd other (S a) h allocs (ctx,S c) (List.hd 0 ns) _ Hsa)|]. etransitivity; - [apply (interp_heap_wr_present other (S hdr) h allocs (S c) (List.hd 0 ns) _ Hshdrdom)|]. - etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (List.hd 0 ns)) allocs (S c) + [apply (interp_heap_wr_present other (S hdr) h allocs (ctx,S c) (List.hd 0 ns) _ Hshdrdom)|]. + etransitivity; [apply (interp_heap_rd other hdr (upd h (S hdr) (List.hd 0 ns)) allocs (ctx,S c) (last (a :: ns) 0) _ Hread_hdr)|]. cbn beta iota. rewrite (zof_compute hdr a ns Hwf). - etransitivity; [apply (interp_heap_wr_present other (S (zof hdr ns)) _ allocs (S c) a _ + etransitivity; [apply (interp_heap_wr_present other (S (zof hdr ns)) _ allocs (ctx,S c) a _ (upd_mono _ _ _ _ Hzdom))|]. - etransitivity; [apply (interp_heap_wr_present other (S a) _ allocs (S c) 0 _ + etransitivity; [apply (interp_heap_wr_present other (S a) _ allocs (ctx,S c) 0 _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hsadom)))|]. - etransitivity; [apply (interp_heap_wr_present other hdr _ allocs (S c) a _ + etransitivity; [apply (interp_heap_wr_present other hdr _ allocs (ctx,S c) a _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ (upd_mono _ _ _ _ Hhdrdom))))|]. reflexivity. Qed. diff --git a/examples/CSL/Queue/Program.v b/examples/CSL/Queue/Program.v index 8087a00..402e2ba 100644 --- a/examples/CSL/Queue/Program.v +++ b/examples/CSL/Queue/Program.v @@ -54,6 +54,13 @@ Definition allocated_parallel_queues (values1 values2 : list nat) : CProg unit : CBind (new_queue values1) (fun u => CBind (new_queue values2) (fun v => parallel_queues u v)). +Definition shared_queue (hdr : nat) : CProg unit := + CBind (CFork (worker 1 hdr)) (fun _ => + CBind (CFork (worker 2 hdr)) (fun _ => CRet tt)). + +Definition allocated_shared_queue (values : list nat) : CProg unit := + CBind (new_queue values) shared_queue. + Lemma denote_rotate_once q hdr : denote_flow (rotate_once q hdr) ≅ (a <- heap_read (E:=CEff) (S hdr);; @@ -137,15 +144,15 @@ Local Ltac rotate_effect law := try rewrite interp_rr_bind; etransitivity; [apply law|]; rotate_state_bind; - apply sbisim_clo_bind_eq; [reflexivity | intros [? [? ?]]]. + apply sbisim_clo_bind_eq; [reflexivity | intros [? ?]]. Lemma interp_rr_rotate_once n (ts : pool sE (S n)) - (i : Fin.t (S n)) q hdr (K : option unit -> thread sE) m memory c : + (i : Fin.t (S n)) q hdr (K : option unit -> thread sE) m (s : SSig) : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (rotate_once q hdr) >>= K)) (Some i) m (memory,c) ~ - (interp_state sh (turn q hdr) (memory,c) >>= - fun '(_, (memory',c')) => - interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m (memory',c')). + (ts @ i := (denote_flow (rotate_once q hdr) >>= K)) (Some i) m s ~ + (interp_state sh (turn q hdr) s >>= + fun '(_, s') => + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m s'). Proof. unfold rotate_once, turn, turnk, queue_turn. rotate_effect interp_rr_read. @@ -185,10 +192,10 @@ Proof. Qed. Local Lemma interp_rr_worker n (ts : pool sE (S n)) - (i : Fin.t (S n)) q hdr m memory c : - interp_schedule_rr sh (S n) (ts @ i := denote (worker q hdr)) (Some i) m (memory,c) ~ - (interp_state sh (turn q hdr) (memory,c) >>= fun '(_, (memory',c')) => - interp_schedule_rr sh (S n) (ts @ i := Guard (denote (worker q hdr))) None m (memory',c')). + (i : Fin.t (S n)) q hdr m (s : SSig) : + interp_schedule_rr sh (S n) (ts @ i := denote (worker q hdr)) (Some i) m s ~ + (interp_state sh (turn q hdr) s >>= fun '(_, s') => + interp_schedule_rr sh (S n) (ts @ i := Guard (denote (worker q hdr))) None m s'). Proof. set (again := fun r : option (option unit) => match r with @@ -204,11 +211,11 @@ Proof. (ts @ i := (denote_flow (CBind (rotate_once q hdr) (fun _ => CBind CYield (fun _ => CRet (Some tt)))) >>= again)) - (Some i) m (memory,c) ~ rhs) + (Some i) m s ~ rhs) end. rewrite interp_rr_bind. etransitivity; [apply interp_rr_rotate_once|]. - apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. + apply sbisim_clo_bind_eq; [reflexivity | intros [ignored s']]. rewrite interp_rr_bind, interp_rr_yield. assert (Hpark : pool_equ (ts @ i := (denote_flow (CRet (Some tt)) >>= again)) @@ -219,19 +226,19 @@ Proof. etransitivity; [exact (bind_ret_l (Some (Some tt)) again)|]. reflexivity. } - pose proof (interp_schedule_rr_equ sh (S n) _ _ None m (memory',c') Hpark) as Hdone. + pose proof (interp_schedule_rr_equ sh (S n) _ _ None m s' Hpark) as Hdone. eapply equ_clos_sbisim_goal; [exact Hdone | reflexivity | reflexivity]. Qed. -Lemma queue_pool_turn u v n g2 g1 memory c : +Lemma queue_pool_turn u v n g2 g1 (s : SSig) : interp_schedule_rr sh 2 (queue_workers u v g2 g1) - (Some (queue_slot n)) n (memory,c) ~ - (interp_state sh (turn (tagof n) (hdrof u v n)) (memory,c) >>= - fun '(_, (memory',c')) => + (Some (queue_slot n)) n s ~ + (interp_state sh (turn (tagof n) (hdrof u v n)) s >>= + fun '(_, s') => interp_schedule_rr sh 2 (queue_workers u v (if Nat.even n then g2 else true) (if Nat.even n then true else g1)) - (Some (queue_slot (S n))) (S n) (memory',c')). + (Some (queue_slot (S n))) (S n) s'). Proof. unfold queue_slot at 1; unfold tagof, hdrof. destruct (Nat.even n) eqn:Hphase. @@ -241,10 +248,10 @@ Proof. | |- _ ~ ?rhs => change (interp_schedule_rr sh 2 (queue_workers u v g2 false @ Fin.FS Fin.F1 := denote (worker 1 u)) - (Some (Fin.FS Fin.F1)) n (memory,c) ~ rhs) + (Some (Fin.FS Fin.F1)) n s ~ rhs) end. all: etransitivity; [apply interp_rr_worker|]. - all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored s']]. all: etransitivity; [apply interp_schedule_rr_select|]. all: rewrite queue_pick_next; reflexivity. - destruct g2; @@ -253,10 +260,10 @@ Proof. | |- _ ~ ?rhs => change (interp_schedule_rr sh 2 (queue_workers u v false g1 @ Fin.F1 := denote (worker 2 v)) - (Some Fin.F1) n (memory,c) ~ rhs) + (Some Fin.F1) n s ~ rhs) end. all: etransitivity; [apply interp_rr_worker|]. - all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored [memory' c']]]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored s']]. all: etransitivity; [apply interp_schedule_rr_select|]. all: rewrite queue_pick_next; reflexivity. Qed. @@ -287,38 +294,38 @@ Local Ltac queue_fault Hnone := etransitivity; [ apply equ_clo_bind with (S := eq) (k2 := fun '(x,s') => interp_state H (next x) s'); - [exact ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) + [exact ((interp_heap_rd_stuck (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs c Hnone) | intros x y <-; reflexivity] | apply bind_stuck_equ ]); eapply equ_clos_sbisim_goal; [exact Hfault | reflexivity | reflexivity] end. -Lemma queue_pool_bisim : forall u v n g2 g1 h allocs c, +Lemma queue_pool_bisim : forall u v n g2 g1 (s : SSig), interp_schedule_rr sh 2 (queue_workers u v g2 g1) - (Some (queue_slot n)) n ((h,allocs),c) ~ srun u v n (h,allocs) c. + (Some (queue_slot n)) n s ~ srun u v n s. Proof. - coinduction R CIH; intros u v n g2 g1 h allocs c. + coinduction R CIH; intros u v n g2 g1 [[h allocs] [ctx c]]. etransitivity; [apply (coinduction.gfp_bt (sb eq) R), queue_pool_turn|]. etransitivity; [|apply (coinduction.gfp_bt (sb eq) R); symmetry; apply srun_turn]. unfold turn, turnk, queue_turn. destruct (h (S (hdrof u v n))) as [a|] eqn:Hhead. - - queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))); exact Hhead). + - queue_prefix R ltac:(eapply (interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))); exact Hhead). destruct (h a) as [payload|] eqn:Hpayload. - + queue_prefix R ltac:(eapply (interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))); exact Hpayload). - queue_prefix R ltac:(unfold semit; apply (interp_indexed_emit heap_handler)). + + queue_prefix R ltac:(eapply (interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))); exact Hpayload). + queue_prefix R ltac:(unfold semit; apply interp_csl_emit). eapply equ_sbt_closed_goal; [apply bind_bind | apply bind_bind |]. unfold log, ICtree.trigger. eapply equ_sbt_closed_goal; [apply bind_vis | apply bind_vis |]. apply step_sb_vis. * intros []; exists tt; split; [|reflexivity]. eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. - apply st_clo_bind_eq; [reflexivity | intros [ignored [[h' allocs'] c']]; apply CIH]. + apply st_clo_bind_eq; [reflexivity | intros [ignored s']; apply CIH]. * intros []; exists tt; split; [|reflexivity]. eapply equ_clos_st_goal; [apply bind_ret_l | apply bind_ret_l |]. - apply st_clo_bind_eq; [reflexivity | intros [ignored [[h' allocs'] c']]; apply CIH]. + apply st_clo_bind_eq; [reflexivity | intros [ignored s']; apply CIH]. + queue_prefix R ltac:(queue_fault Hpayload). eapply equ_sbt_closed_goal; [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. @@ -327,13 +334,12 @@ Proof. [apply bind_stuck_equ | apply bind_stuck_equ | reflexivity]. Qed. -Theorem run_rr_parallel_bisim u v memory c : - run_rr (parallel_queues u v) memory c ~ srun u v 0 memory c. +Theorem run_rr_parallel_bisim u v (s : SSig) : + run_rr (parallel_queues u v) s ~ srun u v 0 s. Proof. - destruct memory as [h allocs]. unfold parallel_queues; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 (queue_workers u v false false) - (Some (queue_slot 0)) 0 ((h,allocs),c) ~ srun u v 0 (h,allocs) c). + (Some (queue_slot 0)) 0 s ~ srun u v 0 s). apply queue_pool_bisim. Qed. @@ -342,8 +348,8 @@ Local Ltac srun_pop_turn Hq := lazymatch type of Hq with | qrep ?hdr (?a :: ?ns) (?pv :: ?vs) ?h => lazymatch goal with - | |- srun ?u ?v ?n (h, ?allocs) ?c ~ ?rhs => - let Hbody := constr:(sbody_spec u v n a ns pv vs h allocs c Hq) in + | |- srun ?u ?v ?n ((h, ?allocs), (?ctx, ?c)) ~ ?rhs => + let Hbody := constr:(sbody_spec u v n a ns pv vs h allocs ctx c Hq) in unfold srun, sched at 1; rewrite interp_state_unfold_iter; cbv beta; @@ -359,7 +365,7 @@ Local Ltac srun_pop_turn Hq := rewrite bind_ret_l, sb_guard; lazymatch goal with | |- _ ~ ?tail => - change (srun u v (S n) (qstep hdr (a :: ns) h, allocs) (S c) ~ tail) + change (srun u v (S n) ((qstep hdr (a :: ns) h, allocs), (ctx, S c)) ~ tail) end end end. @@ -367,16 +373,18 @@ Local Ltac srun_pop_turn Hq := (** The first four pops of two disjoint queues under the shared source round-robin scheduler: queue 1 rotates [a;b], queue 2 its singleton [d], alternating, with the observation counter advancing once per pop. *) -Lemma parallel_queues_four_pop_bisim u a b v d h allocs x y z c : +Lemma parallel_queues_four_pop_bisim u a b v d h allocs x y z ctx c : qrep u [a;b] [x;y] h -> qrep v [d] [z] h -> Disj u [a;b] v [d] -> let h1 := qstep u [a;b] h in let h2 := qstep v [d] h1 in let h3 := qstep u [b;a] h2 in let h4 := qstep v [d] h3 in - run_rr (parallel_queues u v) (h,allocs) c ~ - (log (stamp (1,x) c);; log (stamp (2,z) (S c));; - log (stamp (1,y) (S (S c)));; log (stamp (2,z) (S (S (S c))));; - srun u v 4 (h4,allocs) (S (S (S (S c))))). + run_rr (parallel_queues u v) ((h,allocs),(ctx,c)) ~ + (log (inr (stamp (1,x) c) : CSLObs (nat * nat));; + log (inr (stamp (2,z) (S c)) : CSLObs (nat * nat));; + log (inr (stamp (1,y) (S (S c))) : CSLObs (nat * nat));; + log (inr (stamp (2,z) (S (S (S c)))) : CSLObs (nat * nat));; + srun u v 4 ((h4,allocs),(ctx,S (S (S (S c)))))). Proof. intros H1 H2 Hd; cbv zeta. pose proof (qstep_qrep u [a;b] [x;y] h H1 ltac:(discriminate)) as H1a. @@ -393,7 +401,7 @@ Proof. change (qrep v [d] [z] (qstep v [d] (qstep u [a;b] h))) in H2b. pose proof (foreign_pres u [b;a] [y;x] v [d] [z] (qstep v [d] (qstep u [a;b] h)) H1b ltac:(discriminate) H2b Hda) as H2c. - etransitivity; [exact (run_rr_parallel_bisim u v (h,allocs) c) |]. + etransitivity; [exact (run_rr_parallel_bisim u v ((h,allocs),(ctx,c))) |]. srun_pop_turn H1. srun_pop_turn H2a. srun_pop_turn H1b. @@ -402,17 +410,17 @@ Proof. Qed. (** Queue 1 takes the first source turn; a fault there faults the whole run. *) -Local Lemma parallel_queues_first_turn_stuck u v memory c : - interp_state sh (turn 1 u) (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)) -> - run_rr (parallel_queues u v) memory c ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Local Lemma parallel_queues_first_turn_stuck u v (s : SSig) : + interp_state sh (turn 1 u) s ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)) -> + run_rr (parallel_queues u v) s ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Hfault. unfold parallel_queues; rewrite run_rr_fork_bind. change (interp_schedule_rr sh 2 (queue_workers u v false false) - (Some (queue_slot 0)) 0 (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig))). + (Some (queue_slot 0)) 0 s ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig))). etransitivity; [apply queue_pool_turn |]. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -423,9 +431,9 @@ Proof. eapply equ_clos_sbisim_goal; [apply bind_stuck_equ | reflexivity | reflexivity]. Qed. -Lemma parallel_queues_hemp_stuck u v c : - run_rr (parallel_queues u v) managed_empty c ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Lemma parallel_queues_hemp_stuck u v ctx c : + run_rr (parallel_queues u v) (managed_empty,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. apply parallel_queues_first_turn_stuck. assert (Hhead : hemp (S u) = None) by reflexivity. @@ -436,13 +444,13 @@ Qed. Lemma interp_rr_fill_nodes n (ts : pool sE (S n)) (i : Fin.t (S n)) - first values (K : option unit -> thread sE) m h allocs c : + first values (K : option unit -> thread sE) m h allocs ctx c : (forall offset, Nat.lt offset (2 * length values) -> h (first + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m ((fill_nodes_heap first values h,allocs),c). + (Some i) m ((fill_nodes_heap first values h,allocs),(ctx,c)). Proof. revert first h; induction values as [|value values IH]; intros first h Allocated. - cbn [fill_nodes fill_nodes_heap]; rewrite interp_rr_ret; reflexivity. @@ -460,13 +468,13 @@ Proof. Qed. Lemma interp_rr_init_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) - hdr values (K : option unit -> thread sE) m h allocs c : + hdr values (K : option unit -> thread sE) m h allocs ctx c : (forall offset, Nat.lt offset (2 * S (length values)) -> h (hdr + offset)%nat <> None) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m ((init_queue_heap hdr values h,allocs),c). + (Some i) m ((init_queue_heap hdr values h,allocs),(ctx,c)). Proof. intro Allocated; unfold init_queue, init_queue_heap; rewrite interp_rr_bind. etransitivity. @@ -482,15 +490,15 @@ Proof. Qed. Lemma interp_rr_new_queue_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - values hdr (K : option nat -> thread sE) m h allocs c : + values hdr (K : option nat -> thread sE) m h allocs ctx c : Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> (forall j, Nat.lt 0 j -> Nat.lt j hdr -> ~ block_free h j (2 * S (length values))) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) (Some i) m ((new_queue_heap hdr values h, - upd allocs hdr (2 * S (length values))),c). + upd allocs hdr (2 * S (length values))),(ctx,c)). Proof. intros Positive Free First. unfold new_queue; rewrite interp_rr_bind. @@ -504,19 +512,139 @@ Proof. Qed. Lemma interp_rr_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) - values (K : option nat -> thread sE) m c : + values (K : option nat -> thread sE) m ctx c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (managed_empty,c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m (managed_empty,(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some 1)) (Some i) m ((new_queue_heap 1 values hemp, - upd hemp 1 (2 * S (length values))),c). + upd hemp 1 (2 * S (length values))),(ctx,c)). Proof. apply interp_rr_new_queue_first; [lia | intros offset Hlt; reflexivity | intros j Hj Hfirst; lia]. Qed. +Lemma interp_nd_fill_nodes n (ts : pool sE (S n)) (i : Fin.t (S n)) + first values (K : option unit -> thread sE) h allocs ctx c : + (forall offset, Nat.lt offset (2 * length values) -> + h (first + offset)%nat <> None) -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (fill_nodes first values) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) ((fill_nodes_heap first values h,allocs),(ctx,c)). +Proof. + revert first h; induction values as [|value values IH]; intros first h Allocated. + - cbn [fill_nodes fill_nodes_heap]; rewrite interp_nd_source_ret; reflexivity. + - cbn [fill_nodes fill_nodes_heap]; rewrite interp_nd_source_bind. + etransitivity. + + apply interp_nd_source_write_present. + specialize (Allocated 0 ltac:(cbn; lia)); now rewrite Nat.add_0_r in Allocated. + + rewrite interp_nd_source_bind; etransitivity. + * apply interp_nd_source_write_present, upd_mono. + specialize (Allocated 1 ltac:(cbn; lia)). + replace (first + 1)%nat with (S first) in Allocated by lia; exact Allocated. + * apply IH; intros offset O; apply upd_mono, upd_mono. + replace (first + 2 + offset)%nat with (first + (2 + offset))%nat by lia. + apply Allocated; cbn; lia. +Qed. + +Lemma interp_nd_init_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) + hdr values (K : option unit -> thread sE) h allocs ctx c : + (forall offset, Nat.lt offset (2 * S (length values)) -> + h (hdr + offset)%nat <> None) -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (init_queue hdr values) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) ((init_queue_heap hdr values h,allocs),(ctx,c)). +Proof. + intro Allocated; unfold init_queue, init_queue_heap; rewrite interp_nd_source_bind. + etransitivity. + - apply interp_nd_source_write_present. + specialize (Allocated 0 ltac:(lia)); now rewrite Nat.add_0_r in Allocated. + - rewrite interp_nd_source_bind; etransitivity. + + apply interp_nd_source_write_present, upd_mono. + specialize (Allocated 1 ltac:(lia)). + replace (hdr + 1)%nat with (S hdr) in Allocated by lia; exact Allocated. + + apply interp_nd_fill_nodes; intros offset O; apply upd_mono, upd_mono. + replace (hdr + 2 + offset)%nat with (hdr + (2 + offset))%nat by lia. + apply Allocated; lia. +Qed. + +Lemma interp_nd_new_queue_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + values hdr (K : option nat -> thread sE) h allocs ctx c : + Nat.lt 0 hdr -> block_free h hdr (2 * S (length values)) -> + (forall j, Nat.lt 0 j -> Nat.lt j hdr -> + ~ block_free h j (2 * S (length values))) -> + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some hdr)) + (Some i) ((new_queue_heap hdr values h, + upd allocs hdr (2 * S (length values))),(ctx,c)). +Proof. + intros Positive Free First. + unfold new_queue; rewrite interp_nd_source_bind. + rewrite interp_nd_source_alloc_first with (base:=hdr) by (try lia; assumption). + unfold managed_alloc; cbn [fst snd]. + rewrite interp_nd_source_bind; etransitivity. + - apply interp_nd_init_queue; intros offset O. + unfold hunion; rewrite (hblock_in hdr (2 * S (length values)) offset O). + discriminate. + - rewrite interp_nd_source_ret; reflexivity. +Qed. + +Lemma interp_nd_new_queue_empty n (ts : pool sE (S n)) (i : Fin.t (S n)) + values (K : option nat -> thread sE) ctx c : + interp_schedule_nd sh (S n) + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) (managed_empty,(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some 1)) + (Some i) ((new_queue_heap 1 values hemp, + upd hemp 1 (2 * S (length values))),(ctx,c)). +Proof. + apply interp_nd_new_queue_first; + [lia | intros offset Hlt; reflexivity | intros j Hj Hfirst; lia]. +Qed. + +Lemma run_nd_allocated_shared_queue values ctx c : + run_nd (allocated_shared_queue values) (managed_empty,(ctx,c)) ~ + run_nd (shared_queue 1) + ((new_queue_heap 1 values hemp, upd hemp 1 (2 * S (length values))),(ctx,c)). +Proof. + rewrite !run_nd_unfold; unfold allocated_shared_queue, denote. + change (interp_schedule_nd sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (new_queue values) shared_queue) >>= fun _ => Ret tt)) + (Some Fin.F1) (managed_empty,(ctx,c)) ~ + interp_schedule_nd sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (shared_queue 1) >>= fun _ => Ret tt)) + (Some Fin.F1) + ((new_queue_heap 1 values hemp, upd hemp 1 (2 * S (length values))),(ctx,c))). + rewrite interp_nd_source_bind. + etransitivity; [apply interp_nd_new_queue_empty |]. + reflexivity. +Qed. + +Lemma run_rr_allocated_shared_queue values ctx c : + run_rr (allocated_shared_queue values) (managed_empty,(ctx,c)) ~ + run_rr (shared_queue 1) + ((new_queue_heap 1 values hemp, upd hemp 1 (2 * S (length values))),(ctx,c)). +Proof. + rewrite !run_rr_unfold; unfold allocated_shared_queue, denote. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (new_queue values) shared_queue) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 (managed_empty,(ctx,c)) ~ + interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (shared_queue 1) >>= fun _ => Ret tt)) + (Some Fin.F1) 0 + ((new_queue_heap 1 values hemp, upd hemp 1 (2 * S (length values))),(ctx,c))). + rewrite interp_rr_bind. + etransitivity; [apply interp_rr_new_queue_empty |]. + reflexivity. +Qed. + Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) - values (K : option nat -> thread sE) m h allocs c : + values (K : option nat -> thread sE) m h allocs ctx c : heap_finite h -> exists hdr, Nat.lt 0 hdr /\ block_free h hdr (2 * S (length values)) /\ @@ -524,14 +652,14 @@ Lemma interp_rr_new_queue n (ts : pool sE (S n)) (i : Fin.t (S n)) asep (qrepX hdr (queue_nodes hdr (length values)) values) (fun frame => heq frame h) (new_queue_heap hdr values h) /\ interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (new_queue values) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some hdr)) (Some i) m ((new_queue_heap hdr values h, - upd allocs hdr (2 * S (length values))),c). + upd allocs hdr (2 * S (length values))),(ctx,c)). Proof. intro Finite. - destruct (heap_handler_alloc_finite (F:=writerE (indexed (nat * nat))) - h allocs (2 * S (length values)) c Finite ltac:(lia)) + destruct (heap_handler_alloc_finite (F:=writerE (CSLObs (nat * nat))) + h allocs (2 * S (length values)) (ctx,c) Finite ltac:(lia)) as (hdr & Positive & Free & First & _). exists hdr; split; [exact Positive |]; split; [exact Free |]; split. - now apply new_queue_heap_finite. @@ -539,15 +667,15 @@ Proof. apply interp_rr_new_queue_first; assumption. Qed. -Theorem run_rr_allocated_parallel : forall values1 values2 c, +Theorem run_rr_allocated_parallel : forall values1 values2 ctx c, exists u v h allocs, heap_finite h /\ asep (qrepX u (queue_nodes u (length values1)) values1) (qrepX v (queue_nodes v (length values2)) values2) h /\ - run_rr (allocated_parallel_queues values1 values2) managed_empty c ~ - run_rr (parallel_queues u v) (h,allocs) c. + run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c)) ~ + run_rr (parallel_queues u v) ((h,allocs),(ctx,c)). Proof. - intros values1 values2 c. + intros values1 values2 ctx c. set (done := fun _ : option unit => (Ret tt : thread sE)). set (after1 := fun r : option nat => match r with @@ -555,7 +683,7 @@ Proof. | Some u => denote_flow (CBind (new_queue values2) (fun v => parallel_queues u v)) >>= done end). - destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values1 after1 0 hemp hemp c + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values1 after1 0 hemp hemp ctx c heap_finite_hemp) as (u & Upos & Ufree & Finite1 & Own1 & Run1). set (h1 := new_queue_heap u values1 hemp). set (allocs1 := upd hemp u (2 * S (length values1))). @@ -564,7 +692,7 @@ Proof. | None => done None | Some v => denote_flow (parallel_queues u v) >>= done end). - destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values2 after2 0 h1 allocs1 c + destruct (interp_rr_new_queue 0 [Ret tt]%vector Fin.F1 values2 after2 0 h1 allocs1 ctx c Finite1) as (v & Vpos & Vfree & Finite2 & Own2 & Run2). exists u, v, (new_queue_heap v values2 h1), (upd allocs1 v (2 * S (length values2))). split; [exact Finite2 |]; split. @@ -584,14 +712,14 @@ Proof. * apply hunion_resp; [apply heq_refl | exact E1]. * apply hunion_comm; exact D21. + split; split; try apply qheap_qex; apply qheap_queue_nodes_rep; assumption. - - unfold allocated_parallel_queues, run_rr at 1; unfold denote at 1. + - unfold allocated_parallel_queues. change (interp_schedule_rr sh 1 ([Ret tt]%vector @ Fin.F1 := (denote_flow (CBind (new_queue values1) (fun u => CBind (new_queue values2) (fun v => parallel_queues u v))) >>= done)) - (Some Fin.F1) 0 ((hemp,hemp),c) ~ + (Some Fin.F1) 0 ((hemp,hemp),(ctx,c)) ~ run_rr (parallel_queues u v) - (new_queue_heap v values2 h1, upd allocs1 v (2 * S (length values2))) c). + ((new_queue_heap v values2 h1, upd allocs1 v (2 * S (length values2))),(ctx,c))). rewrite interp_rr_bind. etransitivity; [exact Run1 |]. cbn [after1]; rewrite interp_rr_bind. @@ -601,17 +729,17 @@ Qed. (** An allocated empty first queue has head pointer [0], and the null cell is unallocated: the first source turn faults, whatever the second queue is. *) -Lemma allocated_parallel_queues_empty_stuck values c : - run_rr (allocated_parallel_queues [] values) managed_empty c ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). +Lemma allocated_parallel_queues_empty_stuck values ctx c : + run_rr (allocated_parallel_queues [] values) (managed_empty,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. - destruct (run_rr_allocated_parallel [] values c) + destruct (run_rr_allocated_parallel [] values ctx c) as (u & v & h & allocs & _ & Owned & Run). destruct (owned_queues_sound _ _ _ _ _ _ _ Owned) as ((_ & Hhead & _ & _ & Hnull & _) & _ & _). change (h (S u) = Some 0) in Hhead. rewrite Run; apply parallel_queues_first_turn_stuck. unfold turn, turnk, queue_turn. - etransitivity; [eapply (interp_heap_rd h_indexed); exact Hhead |]. + etransitivity; [eapply (interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))); exact Hhead |]. queue_fault Hnull. Qed. diff --git a/examples/CSL/Queue/Recurrence.v b/examples/CSL/Queue/Recurrence.v index ccf7582..bdea153 100644 --- a/examples/CSL/Queue/Recurrence.v +++ b/examples/CSL/Queue/Recurrence.v @@ -86,23 +86,23 @@ Section Recurrence. (** The [AG] invariant: the state is a valid representation of SOME queue that still contains [nl]. The abstract queue is existentially quantified -- no extraction function from heaps to lists is needed. *) - Definition Rq (_: unit) (s: SSig) (_: WorldW (indexed nat)) : Prop := + Definition Rq (_: unit) (s: SSig) (_: WorldW (CSLObs nat)) : Prop := exists ns vs d, qrep hdr ns vs (fst (fst s)) /\ find_index Nat.eqb nl vs = Some d. (** *** One iteration, as a deterministic suffix formula. This is the only place the body is opened, and it is opened through [rot_body_spec] -- a bisimulation -- not by unfolding [auc]. *) - Lemma body_det: forall ns vs a v h allocs c w, + Lemma body_det: forall ns vs a v h allocs ctx c w, qrep hdr (a :: ns) (v :: vs) h -> not_done w -> - <[ {interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), c)}, w + <[ {interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), (ctx, c))}, w |= ⊤ AU AX done= {(@inl unit unit tt, - ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c))} - {Obs (Log (stamp v c)) tt} ]>. + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), (ctx, S c)))} + {Obs (Log (inr (stamp v c) : CSLObs nat)) tt} ]>. Proof. - intros ns vs a v h allocs c w Hq Hd. - rewrite (rot_body_spec hdr a ns v vs h allocs c Hq). + intros ns vs a v h allocs ctx c w Hq Hd. + rewrite (rot_body_spec hdr a ns v vs h allocs ctx c Hq). apply aur_log. - cleft; apply axr_ret; [constructor | split; reflexivity]. - apply ticll_top; assumption. @@ -117,22 +117,22 @@ Section Recurrence. Definition InvQ (m: nat * nat) (_: unit) (s: SSig) : Prop := exists ns vs d, qrep hdr ns vs (fst (fst s)) /\ find_index Nat.eqb nl vs = Some d - /\ m = (kb - snd s, d). + /\ m = (kb - csl_counter s, d). - Lemma inner_af: forall h allocs c ns vs d w, + Lemma inner_af: forall h allocs ctx c ns vs d w, not_done w -> qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AF visW {P} )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), (ctx, c))}, w |= AF visW {csl_indexed P} )>. Proof. - intros h allocs c ns vs d w Hd Hq Hf. + intros h allocs ctx c ns vs d w Hd Hq Hf. unfold rotate. apply (aul_state_iter_ghost (sh (A:=nat)) lexnat InvQ (fun _: unit => rot_body hdr) - _ _ lexnat_wf (kb - c, d) tt ((h, allocs), c) w Hd). + _ _ lexnat_wf (kb - c, d) tt ((h, allocs), (ctx, c)) w Hd). - exists ns, vs, d; split; [exact Hq | split; [exact Hf | reflexivity]]. - - clear h allocs c ns vs d w Hd Hq Hf. + - clear h allocs ctx c ns vs d w Hd Hq Hf. intros m [] s w Hd (ns & vs & d & Hq & Hf & Hm). - destruct s as ((h, allocs), c); cbn in Hq, Hm. + destruct s as ((h, allocs), (ctx, c)); cbn in Hq, Hm. destruct vs as [| v vs']; [cbn in Hf; discriminate |]. destruct ns as [| a ns']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. (* the shared "rotate once" step *) @@ -141,14 +141,14 @@ Section Recurrence. (exists g' i' s' w', not_done w' /\ <[ {interp_state (sh (A:=nat)) - ((fun _: unit => rot_body hdr) tt) ((h, allocs), c)}, w + ((fun _: unit => rot_body hdr) tt) ((h, allocs), (ctx, c))}, w |= ⊤ AU AX done= {(@inl unit unit i', s')} w' ]> /\ InvQ g' i' s' /\ lexnat g' m)). { intros d' Hd' Hlex. exists (kb - S c, d'), tt, - ((rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, allocs), S c), - (Obs (Log (stamp v c)) tt). + ((rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, allocs), (ctx, S c)), + (Obs (Log (inr (stamp v c) : CSLObs nat)) tt). split; [constructor |]. split; [eapply body_det; eassumption |]. split; [| exact Hlex]. @@ -161,7 +161,7 @@ Section Recurrence. destruct (Nat.le_gt_cases kb c) as [Hle | Hgt]. * (* and the occurrence bound is already met: observe it now *) left. - rewrite (rot_body_spec hdr a ns' nl vs' h allocs c Hq). + rewrite (rot_body_spec hdr a ns' nl vs' h allocs ctx c Hq). apply afl_log; [assumption |]. cleft; apply ticll_vis; constructor; now apply HP. * (* the bound is not met yet: rotate, the bound gets closer *) @@ -177,24 +177,24 @@ Section Recurrence. Qed. (** *** The recurrence theorem. *) - Theorem rotate_agaf_core: forall h allocs c ns vs d w, + Theorem rotate_agaf_core: forall h allocs ctx c ns vs d w, not_done w -> qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AG (AF visW {P}) )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), (ctx, c))}, w |= AG (AF visW {csl_indexed P}) )>. Proof. - intros h allocs c ns vs d w Hd Hq Hf. + intros h allocs ctx c ns vs d w Hd Hq Hf. unfold rotate. - apply (ag_state_iter (sh (A:=nat)) ((h, allocs), c) Rq tt w); [assumption | |]. + apply (ag_state_iter (sh (A:=nat)) ((h, allocs), (ctx, c)) Rq tt w); [assumption | |]. - exists ns, vs, d; split; assumption. - intros [] s w' Hd' (ns1 & vs1 & d1 & Hq1 & Hf1). - destruct s as ((h1, allocs1), c1); cbn in Hq1. + destruct s as ((h1, allocs1), (ctx1, c1)); cbn in Hq1. destruct vs1 as [| v1 vs1']; [cbn in Hf1; discriminate |]. destruct ns1 as [| a1 ns1']; [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. split. + eapply inner_af; [exact Hd' | exact Hq1 | exact Hf1]. - + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 c1 Hq1). + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 ctx1 c1 Hq1). apply anr_log; [| apply ticll_top; assumption]. cleft; apply axr_ret; [constructor |]. exists tt; split; [reflexivity | split; [constructor |]]. @@ -217,23 +217,23 @@ End Recurrence. strictly increasing and each observation carries its own, this cannot be discharged by a retained world ([indexed_excludes_retained]). *) -Theorem rotate_agaf_pop_heap: forall hdr nl h allocs c ns vs d, +Theorem rotate_agaf_pop_heap: forall hdr nl h allocs ctx c ns vs d, qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {run hdr (h, allocs) c}, Pure |= AG (AF visW {(fun o => indexed_value o = nl)}) )>. + <( {run hdr ((h, allocs), (ctx, c))}, Pure |= AG (AF visW {csl_indexed (fun o => indexed_value o = nl)}) )>. Proof. - intros hdr nl h allocs c ns vs d Hq Hf. + intros hdr nl h allocs ctx c ns vs d Hq Hf. unfold run. eapply (rotate_agaf_core hdr nl 0 ((fun o => indexed_value o = nl))); [ intros j _; reflexivity | constructor | exact Hq | exact Hf ]. Qed. -Theorem rotate_agaf_pop_fresh: forall hdr nl h allocs c ns vs d k, +Theorem rotate_agaf_pop_fresh: forall hdr nl h allocs ctx c ns vs d k, qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> - <( {run hdr (h, allocs) c}, Pure |= AG (AF visW {(indexed_after (fun x => x = nl) k)}) )>. + <( {run hdr ((h, allocs), (ctx, c))}, Pure |= AG (AF visW {csl_indexed (indexed_after (fun x => x = nl) k)}) )>. Proof. - intros hdr nl h allocs c ns vs d k Hq Hf. + intros hdr nl h allocs ctx c ns vs d k Hq Hf. unfold run. eapply (rotate_agaf_core hdr nl k ((indexed_after (fun x => x = nl) k))); [ intros j Hj; split; [reflexivity | exact Hj] | constructor | exact Hq | exact Hf ]. @@ -252,19 +252,19 @@ Qed. hence NO [AG] formula holds of it -- in particular not the recurrence formula. This is what the hypothesis [find_index Nat.eqb nl vs = Some d] (which forces a non-empty queue) buys. *) -Theorem empty_queue_no_ag: forall hdr h allocs c vs w phi, - qrep hdr [] vs h -> ~ <( {run hdr (h, allocs) c}, w |= AG phi )>. +Theorem empty_queue_no_ag: forall hdr h allocs ctx c vs w phi, + qrep hdr [] vs h -> ~ <( {run hdr ((h, allocs), (ctx, c))}, w |= AG phi )>. Proof. - intros hdr h allocs c vs w phi Hq H. + intros hdr h allocs ctx c vs w phi Hq H. pose proof Hq as (Hwf & Hhd & _ & _ & _); cbn in Hhd. pose proof (qrep_null _ _ _ _ Hq) as H0. - assert (Hns: ~ can_step (run hdr (h, allocs) c) w). + assert (Hns: ~ can_step (run hdr ((h, allocs), (ctx, c))) w). { unfold run, rotate, sh; rewrite interp_state_unfold_iter. apply nostep_bind. unfold rot_body, queue_turn. - rewrite (interp_heap_rd (h_indexed (A:=nat) (Sigma:=ManagedHeap)) - (S hdr) h allocs c 0 _ Hhd). - now apply (interp_heap_rd_nostep (h_indexed (A:=nat) (Sigma:=ManagedHeap))). } + rewrite (interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat))) + (S hdr) h allocs (ctx, c) 0 _ Hhd). + now apply (interp_heap_rd_nostep (h_sum csl_context_handler (csl_emit_handler (A:=nat)))). } cdestruct H; now apply Hns. Qed. @@ -276,21 +276,21 @@ Qed. statement below is the [AG] invariance; deriving [~ AF] from [AG ~] is the standard duality and is NOT mechanised here. *) -Definition obs_sat (Q: nat -> Prop) : WorldW (indexed nat) -> Prop := - fun w => forall o, w = Obs (Log o) tt -> Q (indexed_value o). +Definition obs_sat (Q: nat -> Prop) : WorldW (CSLObs nat) -> Prop := + fun w => forall o, w = Obs (Log (inr o)) tt -> Q (indexed_value o). -Theorem rotate_ag_obs: forall hdr h allocs c ns vs w (Q: nat -> Prop), +Theorem rotate_ag_obs: forall hdr h allocs ctx c ns vs w (Q: nat -> Prop), (forall x, In x vs -> Q x) -> not_done w -> qrep hdr ns vs h -> ns <> [] -> obs_sat Q w -> - <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), c)}, w |= AG (now {obs_sat Q}) )>. + <( {interp_state (sh (A:=nat)) (rotate hdr) ((h, allocs), (ctx, c))}, w |= AG (now {obs_sat Q}) )>. Proof. - intros hdr h allocs c ns vs w Q HQ Hd Hq Hne Hw. + intros hdr h allocs ctx c ns vs w Q HQ Hd Hq Hne Hw. unfold rotate. - apply (ag_state_iter (sh (A:=nat)) ((h, allocs), c) - (fun (_: unit) (s: SSig) (w: WorldW (indexed nat)) => + apply (ag_state_iter (sh (A:=nat)) ((h, allocs), (ctx, c)) + (fun (_: unit) (s: SSig) (w: WorldW (CSLObs nat)) => (exists ns' vs', qrep hdr ns' vs' (fst (fst s)) /\ ns' <> [] /\ (forall x, In x vs' -> Q x)) /\ obs_sat Q w) @@ -298,13 +298,13 @@ Proof. - split; [exists ns, vs; split; [exact Hq | split; [exact Hne | exact HQ]] | exact Hw]. - intros [] s w' Hd' ((ns1 & vs1 & Hq1 & Hne1 & Hin1) & Hw'). - destruct s as ((h1, allocs1), c1); cbn in Hq1. + destruct s as ((h1, allocs1), (ctx1, c1)); cbn in Hq1. destruct ns1 as [| a1 ns1']; [contradiction |]. destruct vs1 as [| v1 vs1']; [apply qrep_len in Hq1; cbn in Hq1; discriminate |]. assert (Hv1: Q v1) by (apply Hin1, in_eq). split. + apply ticll_now; split; assumption. - + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 c1 Hq1). + + rewrite (rot_body_spec hdr a1 ns1' v1 vs1' h1 allocs1 ctx1 c1 Hq1). apply anr_log; [| apply ticll_top; assumption]. cleft; apply axr_ret; [constructor |]. exists tt; split; [reflexivity | split; [constructor |]]. @@ -319,15 +319,15 @@ Qed. (** The control itself: an element outside the initial queue is never the payload of any observation. *) -Corollary absent_never_observed: forall hdr h allocs c ns vs nl, +Corollary absent_never_observed: forall hdr h allocs ctx c ns vs nl, qrep hdr ns vs h -> ns <> [] -> ~ In nl vs -> - <( {run hdr (h, allocs) c}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. + <( {run hdr ((h, allocs), (ctx, c))}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. Proof. - intros hdr h allocs c ns vs nl Hq Hne Hnin. + intros hdr h allocs ctx c ns vs nl Hq Hne Hnin. unfold run. - apply (rotate_ag_obs hdr h allocs c ns vs Pure (fun x => x <> nl)); + apply (rotate_ag_obs hdr h allocs ctx c ns vs Pure (fun x => x <> nl)); [ intros x Hx C; subst; contradiction | constructor | exact Hq | exact Hne | intros o Ho; discriminate ]. diff --git a/examples/CSL/Queue/Sequential.v b/examples/CSL/Queue/Sequential.v index b4f005d..43d904b 100644 --- a/examples/CSL/Queue/Sequential.v +++ b/examples/CSL/Queue/Sequential.v @@ -76,12 +76,12 @@ Local Typeclasses Transparent sbisim. (** ** Events *) -Definition qE : Type := (heapE + writerE nat)%type. +Definition qE : Type := (heapE + (stateE Ctx.Ctx + writerE nat))%type. (** Memory commands use the shared heap triggers; payload emission is the example-specific instruction in the right summand. *) Definition emit (v: nat) : ictree qE unit := - @ICtree.trigger (writerE nat) qE _ _ ReSum_inr ReSumRet_inr (Log v). + @ICtree.trigger qE qE _ _ ReSum_refl ReSumRet_refl (inr (inr (Log v))). (** ** The rotating queue program. @@ -97,11 +97,12 @@ Definition rotate (hdr: nat) : ictree qE unit := (** [run] interprets the rotation with the one CSL handler [sh] at the unary payload [nat]. Its state is the shared CSL state [SSig]: the managed - memory [(h,allocs)] and the PRIVATE occurrence counter. The rotation never + memory [(h,allocs)], the (unused) variable context, and the PRIVATE + occurrence counter. The rotation never allocates or frees, so [allocs] is carried through unchanged; no heap operation reads the counter, which only indexes the observations. *) -Definition run (hdr: nat) (memory: ManagedHeap) (c: nat) : ictreeW (indexed nat) (unit * SSig) := - interp_state (sh (A:=nat)) (rotate hdr) (memory, c). +Definition run (hdr: nat) (s: SSig) : ictreeW (CSLObs nat) (unit * SSig) := + interp_state (sh (A:=nat)) (rotate hdr) s. (** ** The body correspondence. @@ -121,16 +122,18 @@ Definition run (hdr: nat) (memory: ManagedHeap) (c: nat) : ictreeW (indexed nat) - **the observation.** The single event is [stamp v c] where [v] is the payload READ OUT OF the head node's cell and [c] is the occurrence counter before the pop. *) -Theorem rot_body_spec: forall hdr a ns v vs h allocs c, +Theorem rot_body_spec: forall hdr a ns v vs h allocs ctx c, qrep hdr (a :: ns) (v :: vs) h -> - interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), c) - ~ (log (stamp v c) ;; - Ret (@inl unit unit tt, ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), S c))). + interp_state (sh (A:=nat)) (rot_body hdr) ((h, allocs), (ctx, c)) + ~ (log (inr (stamp v c) : CSLObs nat) ;; + Ret (@inl unit unit tt, + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), (ctx, S c)))). Proof. - intros hdr a ns v vs h allocs c Hq; unfold rot_body. + intros hdr a ns v vs h allocs ctx c Hq; unfold rot_body. etransitivity. - - eapply (queue_turn_spec h_indexed emit stamp). - + intros; apply (interp_indexed_emit heap_handler). + - eapply (queue_turn_spec (h_sum csl_context_handler (csl_emit_handler (A:=nat))) + emit (fun v c => inr (stamp v c))). + + intros; apply interp_csl_emit. + exact Hq. - apply sbisim_clo_bind_eq; [reflexivity | intros []]. apply equ_sbisim, interp_state_ret. diff --git a/examples/CSL/Queue/Shared.v b/examples/CSL/Queue/Shared.v new file mode 100644 index 0000000..f329552 --- /dev/null +++ b/examples/CSL/Queue/Shared.v @@ -0,0 +1,377 @@ +(** * Shared: one finite heap queue rotated forever by two spawned workers. + + Both workers of [shared_queue] rotate the SAME queue. Each scheduled turn + of either worker is an exact first-yield source segment that logs one pop + and rotates the queue once ([exact_worker_turn]). The invariant/variant + certificate [shared_worker_turn] is the queue's standard rank argument, + stated per worker slot so that it is independent of which worker the + scheduler selects. *) + +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import + ICTree.Core ICTree.Equ ICTree.Events.Writer Events.WriterE + ICTree.Interp.Yield.Segments Lang.CSL.Mod Utils.Lists Utils.Relations + ICTree.Logic.Yield ICTree.Logic.AG ICTree.SBisim ICTree.Interp.Refine + ICTree.Interp.Yield.Mod ICTree.Interp.Yield.RoundRobin ICTree.Logic.State Logic.Core. +From examples Require Import CSL.Queue.Representation CSL.Queue.Program + CSL.Queue.Trace CSL.Queue.Layout CSL.Queue.Frame. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. + +(** ** One worker turn as an exact source segment. *) + +Lemma exact_worker_turn : forall tag hdr a ns v vs h allocs ctx c, + qrep hdr (a :: ns) (v :: vs) h -> + segment_to sh csl_equ (denote (worker tag hdr)) + ((h,allocs),(ctx,c)) [inr (stamp (tag,v) c)] + (denote (worker tag hdr)) + ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h,allocs),(ctx,S c)). +Proof. + intros tag hdr a ns v vs h allocs ctx c Hq. + pose proof Hq as (Hwf & Hhd & Htl & Hch & Hdom). + cbn in Hhd, Htl. + apply chain_cons in Hch as (Ha & Hsa & Hch). + pose proof (qwf_neqs _ _ _ Hwf) as (Hha & Hsha & Hhsa & Hshsa & Hhshdr). + pose proof (qrep_zof_dom _ _ _ _ _ _ Hq) as Hzdom. + assert (Hhdrdom : h hdr <> None) by (rewrite Htl; discriminate). + assert (Hsadom : h (S a) <> None) by (rewrite Hsa; discriminate). + assert (Hshdrdom : h (S hdr) <> None) by (rewrite Hhd; discriminate). + assert (Hread_hdr : upd h (S hdr) (List.hd 0 ns) hdr = Some (last (a :: ns) 0)) + by (rewrite upd_neq by congruence; exact Htl). + unfold denote, worker. + apply exact_source_until. + apply exact_source_bind. + unfold rotate_once. + apply exact_source_bind; eapply exact_source_read; [exact Hhd|]; cbn beta iota. + apply exact_source_bind; eapply exact_source_read; [exact Ha|]; cbn beta iota. + apply exact_source_bind; apply exact_source_emit; cbn beta iota. + apply exact_source_bind; eapply exact_source_read; [exact Hsa|]; cbn beta iota. + apply exact_source_bind; apply exact_source_write; [exact Hshdrdom|]; cbn beta iota. + apply exact_source_bind; eapply exact_source_read; [exact Hread_hdr|]; cbn beta iota. + rewrite (zof_compute hdr a ns Hwf). + apply exact_source_bind; apply exact_source_write; [now apply upd_mono|]; + cbn beta iota. + apply exact_source_bind; apply exact_source_write; [now apply upd_mono, upd_mono|]; + cbn beta iota. + apply exact_source_write; [now apply upd_mono, upd_mono, upd_mono|]; cbn beta iota. + apply exact_source_bind; apply exact_source_yield. + eapply guard_equ_trans; [apply guard_equ_equ, source_raw_ret|]. + cbn [until_tail]; apply guard_equ_left, guard_equ_equ; reflexivity. +Qed. + +(** ** Observation targets and the shared-queue invariant. *) + +Definition shared_pop (nl : nat) : CSLObs (nat * nat) -> Prop := + csl_indexed (fun o => snd (indexed_value o) = nl). + +Definition shared_pop_after (nl k : nat) : CSLObs (nat * nat) -> Prop := + csl_indexed (indexed_after (fun p => snd p = nl) k). + +Definition SharedInv (hdr nl k : nat) (g : nat * nat) (s : SSig) : Prop := + exists ns vs d, + qrep hdr ns vs (fst (csl_memory s)) /\ + find_index Nat.eqb nl vs = Some d /\ + g = (k - csl_counter s, d). + +(** Either worker's turn preserves the invariant and either meets the target + or strictly decreases the rank [(k - counter, position of nl)]. *) +Lemma shared_worker_turn : forall tag hdr nl k g s, + SharedInv hdr nl k g s -> + exists g' s' o, + segment_to sh csl_equ (denote (worker tag hdr)) s [o] + (denote (worker tag hdr)) s' /\ + SharedInv hdr nl k g' s' /\ + (shared_pop_after nl k o \/ lexnat g' g). +Proof. + intros tag hdr nl k g s (ns & vs & d & Hq & Hf & Hg). + destruct s as ((h, allocs), (ctx, c)); cbn in Hq, Hg; subst g. + destruct vs as [| v vs']; [cbn in Hf; discriminate |]. + destruct ns as [| a ns']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. + set (s' := ((rot_heap hdr a (List.hd 0 ns') (zof hdr ns') h, allocs), (ctx, S c))). + assert (Hstep : forall d', find_index Nat.eqb nl (vs' ++ [v]) = Some d' -> + SharedInv hdr nl k (k - S c, d') s'). + { intros d' Hd'; exists (ns' ++ [a]), (vs' ++ [v]), d'; cbn; split; + [apply (rot_heap_spec hdr a ns' v vs' h Hq) | split; [exact Hd' | reflexivity]]. } + pose proof (exact_worker_turn tag hdr a ns' v vs' h allocs ctx c Hq) as Hturn. + destruct d as [| d0]. + - pose proof (find_index_head Nat.eqb Nat.eqb_eq _ _ _ Hf) as Hv; subst v. + destruct (find_index_last_ex Nat.eqb Nat.eqb_eq nl vs') as (d' & Hd'). + exists (k - S c, d'), s', (inr (stamp (tag, nl) c)). + split; [exact Hturn |]; split; [now apply Hstep |]. + destruct (Nat.le_gt_cases k c) as [Hle | Hgt]. + + left; cbn; split; [reflexivity | exact Hle]. + + right; left; cbn; lia. + - pose proof (find_index_rotl Nat.eqb nl v vs' d0 Hf) as Hd0. + rewrite rotl_cons in Hd0. + exists (k - S c, d0), s', (inr (stamp (tag, v) c)). + split; [exact Hturn |]; split; [now apply Hstep |]. + right; destruct (Nat.le_gt_cases k c); + [right; cbn; split; lia | left; cbn; lia]. +Qed. + +(** Invariant closure alone, without the rank. *) +Corollary shared_worker_closed : forall tag hdr nl k g s, + SharedInv hdr nl k g s -> + exists g' s' o, + segment_to sh csl_equ (denote (worker tag hdr)) s [o] + (denote (worker tag hdr)) s' /\ + SharedInv hdr nl k g' s'. +Proof. + intros tag hdr nl k g s Hinv. + destruct (shared_worker_turn tag hdr nl k g s Hinv) as (g' & s' & o & Hseg & Hinv' & _). + exists g', s', o; split; assumption. +Qed. + +(** ** The two-worker pool and its turn certificates. + + After both forks the parent has terminated and the pool is + [worker 2 hdr; worker 1 hdr]. Either slot closes a turn from every + invariant state, so neither the nondeterministic nor the round-robin + proof needs a fairness or phase argument. *) + +Import Vector.VectorNotations TiclNotations. +Local Open Scope ticl_scope. +Local Open Scope list_scope. + +Lemma shared_ranked hdr nl k : + RankedTurns sh (csl_pool [worker 2 hdr; worker 1 hdr]%vector) + (SharedInv hdr nl k) (fun g => g) lexnat (shared_pop_after nl k). +Proof. + intros g s i Hinv; pattern i; apply Fin.caseS'. + - exact (shared_worker_turn 2 hdr nl k g s Hinv). + - intro j; pattern j; apply Fin.caseS'. + + exact (shared_worker_turn 1 hdr nl k g s Hinv). + + intro z; inversion z. +Qed. + +(** Plain recurrence uses the same certificate at occurrence bound [0]. *) +Lemma shared_ranked_pop hdr nl : + RankedTurns sh (csl_pool [worker 2 hdr; worker 1 hdr]%vector) + (SharedInv hdr nl 0) (fun g => g) lexnat (shared_pop nl). +Proof. + intros g s i Hinv. + destruct (shared_ranked hdr nl 0 g s i Hinv) + as (g' & s' & o & Hseg & Hinv' & [HP|Hlt]); + exists g', s', o; split; [exact Hseg| |exact Hseg|]; + split; try exact Hinv'. + - left; destruct o as [ctx|o]; [destruct HP|exact (proj1 HP)]. + - right; exact Hlt. +Qed. + +Lemma shared_pool_agaf_nd hdr nl k g s (P : CSLObs (nat * nat) -> Prop) : + RankedTurns sh (csl_pool [worker 2 hdr; worker 1 hdr]%vector) + (SharedInv hdr nl k) (fun g => g) lexnat P -> + SharedInv hdr nl k g s -> + <( {run_nd_pool [worker 2 hdr; worker 1 hdr]%vector None s}, Pure + |= AG (AF visW {P}) )>. +Proof. + intros Hranked Hinv. + apply (ag_csl_nd_invariance _ (SharedInv hdr nl k) _ + (ranked_turns_closed sh _ _ _ _ _ Hranked)) with (g := g); + [|exact Hinv|constructor]. + intros g0 s0 focus w Hinv0 Hw. + exact (aul_csl_nd_eventually _ _ (fun g => g) lexnat P lexnat_wf Hranked + g0 s0 focus w Hinv0 Hw). +Qed. + +Lemma shared_pool_agaf_rr hdr nl k g s cursor (P : CSLObs (nat * nat) -> Prop) : + RankedTurns sh (csl_pool [worker 2 hdr; worker 1 hdr]%vector) + (SharedInv hdr nl k) (fun g => g) lexnat P -> + SharedInv hdr nl k g s -> + <( {run_rr_pool [worker 2 hdr; worker 1 hdr]%vector None cursor s}, Pure + |= AG (AF visW {P}) )>. +Proof. + intros Hranked Hinv. + apply (ag_csl_rr_invariance _ (SharedInv hdr nl k) _ + (ranked_turns_closed sh _ _ _ _ _ Hranked)) with (g := g); + [|exact Hinv|constructor]. + intros g0 s0 focus c0 w Hinv0 Hw. + exact (aul_csl_rr_eventually _ _ (fun g => g) lexnat P lexnat_wf Hranked + g0 s0 focus c0 w Hinv0 Hw). +Qed. + +(** ** Recurrence of the actual shared program from a represented queue. *) + +Theorem shared_rotate_agaf_pop_nd_fresh : forall hdr nl h allocs ctx c ns vs d k, + qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> + <( {run_nd (shared_queue hdr) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {shared_pop_after nl k}) )>. +Proof. + intros hdr nl h allocs ctx c ns vs d k Hq Hf. + unfold shared_queue; rewrite run_nd_two_forks. + apply (shared_pool_agaf_nd hdr nl k (k - c, d)); [apply shared_ranked|]. + exists ns, vs, d; split; [exact Hq|split; [exact Hf|reflexivity]]. +Qed. + +Theorem shared_rotate_agaf_pop_rr_fresh : forall hdr nl h allocs ctx c ns vs d k, + qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> + <( {run_rr (shared_queue hdr) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {shared_pop_after nl k}) )>. +Proof. + intros hdr nl h allocs ctx c ns vs d k Hq Hf. + unfold shared_queue; rewrite run_rr_two_forks. + apply (shared_pool_agaf_rr hdr nl k (k - c, d)); [apply shared_ranked|]. + exists ns, vs, d; split; [exact Hq|split; [exact Hf|reflexivity]]. +Qed. + +Theorem shared_rotate_agaf_pop_nd : forall hdr nl h allocs ctx c ns vs d, + qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> + <( {run_nd (shared_queue hdr) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {shared_pop nl}) )>. +Proof. + intros hdr nl h allocs ctx c ns vs d Hq Hf. + unfold shared_queue; rewrite run_nd_two_forks. + apply (shared_pool_agaf_nd hdr nl 0 (0 - c, d)); [apply shared_ranked_pop|]. + exists ns, vs, d; split; [exact Hq|split; [exact Hf|reflexivity]]. +Qed. + +Theorem shared_rotate_agaf_pop_rr : forall hdr nl h allocs ctx c ns vs d, + qrep hdr ns vs h -> find_index Nat.eqb nl vs = Some d -> + <( {run_rr (shared_queue hdr) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {shared_pop nl}) )>. +Proof. + intros hdr nl h allocs ctx c ns vs d Hq Hf. + unfold shared_queue; rewrite run_rr_two_forks. + apply (shared_pool_agaf_rr hdr nl 0 (0 - c, d)); [apply shared_ranked_pop|]. + exists ns, vs, d; split; [exact Hq|split; [exact Hf|reflexivity]]. +Qed. + +(** ** The allocated program. *) + +Lemma allocated_shared_queue_rep values : + qrep 1 (queue_nodes 1 (length values)) values (new_queue_heap 1 values hemp). +Proof. + pose proof (qheap_queue_nodes_rep 1 values ltac:(lia)) as Hq. + pose proof (new_queue_heap_agrees 1 values hemp ltac:(lia) + ltac:(intros offset _; reflexivity)) as Hagree. + apply (qrep_agree_fp 1 _ _ _ _ Hq). + - intros x _; rewrite (Hagree x); unfold hunion, hemp. + destruct (qheap 1 (queue_nodes 1 (length values)) values x); reflexivity. + - rewrite (Hagree 0); unfold hunion; rewrite (qrep_null _ _ _ _ Hq); reflexivity. +Qed. + +Theorem shared_rotate_agaf_pop_alloc_nd : forall values nl ctx c d, + find_index Nat.eqb nl values = Some d -> + <( {run_nd (allocated_shared_queue values) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {shared_pop nl}) )>. +Proof. + intros values nl ctx c d Hf; rewrite run_nd_allocated_shared_queue. + eapply shared_rotate_agaf_pop_nd; [apply allocated_shared_queue_rep|exact Hf]. +Qed. + +Theorem shared_rotate_agaf_pop_alloc_rr : forall values nl ctx c d, + find_index Nat.eqb nl values = Some d -> + <( {run_rr (allocated_shared_queue values) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {shared_pop nl}) )>. +Proof. + intros values nl ctx c d Hf; rewrite run_rr_allocated_shared_queue. + eapply shared_rotate_agaf_pop_rr; [apply allocated_shared_queue_rep|exact Hf]. +Qed. + +Theorem shared_rotate_agaf_pop_alloc_nd_fresh : forall values nl ctx c d k, + find_index Nat.eqb nl values = Some d -> + <( {run_nd (allocated_shared_queue values) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {shared_pop_after nl k}) )>. +Proof. + intros values nl ctx c d k Hf; rewrite run_nd_allocated_shared_queue. + eapply shared_rotate_agaf_pop_nd_fresh; [apply allocated_shared_queue_rep|exact Hf]. +Qed. + +Theorem shared_rotate_agaf_pop_alloc_rr_fresh : forall values nl ctx c d k, + find_index Nat.eqb nl values = Some d -> + <( {run_rr (allocated_shared_queue values) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {shared_pop_after nl k}) )>. +Proof. + intros values nl ctx c d k Hf; rewrite run_rr_allocated_shared_queue. + eapply shared_rotate_agaf_pop_rr_fresh; [apply allocated_shared_queue_rep|exact Hf]. +Qed. + +Local Open Scope ictree_scope. +Local Open Scope list_scope. + +(** ** Concrete execution. + + The first three complete rotations of the allocated program under round + robin: worker 2 runs first (the parent is gone and the cursor is still + [0]), then worker 1, then worker 2 again, each rotating the same queue + once and logging one pop. *) +Theorem shared_queue_rr_prefix3 : + let h0 := new_queue_heap 1 [10;20;30] hemp in + let h3 := qstepN 1 3 [3;5;7] h0 in + run_rr (allocated_shared_queue [10;20;30]) (managed_empty,(List.nil,0)) ~ + emit_list [inr (stamp (2,10) 0); inr (stamp (1,20) 1); + inr (stamp (2,30) 2)] + (run_rr_pool [worker 2 1; worker 1 1]%vector None 3 + ((h3,upd hemp 1 8),(List.nil,3))). +Proof. + intros h0 h3. + rewrite run_rr_allocated_shared_queue; unfold shared_queue; rewrite run_rr_two_forks. + set (allocs := upd hemp 1 (2 * S (length [10;20;30]))). + pose proof (allocated_shared_queue_rep [10;20;30]) as Hq0. + change (qrep 1 [3;5;7] [10;20;30] h0) in Hq0. + pose proof (qstep_qrep 1 [3;5;7] [10;20;30] h0 Hq0 ltac:(discriminate)) as Hq1. + change (qrep 1 [5;7;3] [20;30;10] (qstep 1 [3;5;7] h0)) in Hq1. + pose proof (qstep_qrep 1 [5;7;3] [20;30;10] _ Hq1 ltac:(discriminate)) as Hq2. + change (qrep 1 [7;3;5] [30;10;20] (qstep 1 [5;7;3] (qstep 1 [3;5;7] h0))) in Hq2. + cbn [emit_list List.fold_right]. + (* worker 2 *) + rewrite (run_rr_pool_select [worker 2 1; worker 1 1]%vector 0), (rr_pick_even 0 eq_refl). + etransitivity; + [exact (run_rr_pool_turn [worker 2 1; worker 1 1]%vector Fin.F1 1 _ _ _ + (exact_worker_turn 2 1 3 [5;7] 10 [20;30] h0 allocs List.nil 0 Hq0))|]. + cbn [emit_list List.fold_right]. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + (* worker 1 *) + rewrite (run_rr_pool_select [worker 2 1; worker 1 1]%vector 1), (rr_pick_odd 1 eq_refl). + etransitivity; + [exact (run_rr_pool_turn [worker 2 1; worker 1 1]%vector (Fin.FS Fin.F1) 2 _ _ _ + (exact_worker_turn 1 1 5 [7;3] 20 [30;10] (qstep 1 [3;5;7] h0) allocs List.nil 1 Hq1))|]. + cbn [emit_list List.fold_right]. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + (* worker 2 again *) + rewrite (run_rr_pool_select [worker 2 1; worker 1 1]%vector 2), (rr_pick_even 2 eq_refl). + etransitivity; + [exact (run_rr_pool_turn [worker 2 1; worker 1 1]%vector Fin.F1 3 _ _ _ + (exact_worker_turn 2 1 7 [3;5] 30 [10;20] (qstep 1 [5;7;3] (qstep 1 [3;5;7] h0)) + allocs List.nil 2 Hq2))|]. + cbn [emit_list List.fold_right]. + apply sbisim_clo_bind_eq; [reflexivity|intros []]. + reflexivity. +Qed. + +Local Open Scope fin_vector_scope. + +(** ** The empty queue faults. + + An allocated empty queue has a null head pointer and the null cell is + unallocated: the first worker turn reads it and the whole run is stuck, + so no [AG] formula holds. *) +Lemma allocated_shared_queue_empty_stuck : forall ctx c, + run_rr (allocated_shared_queue []) (managed_empty,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + intros ctx c. + rewrite run_rr_allocated_shared_queue; unfold shared_queue; rewrite run_rr_two_forks. + rewrite run_rr_pool_select, (rr_pick_even 0 eq_refl). + unfold run_rr_pool, csl_pool; cbn [Vector.map]. + change (interp_schedule_rr sh 2 + ([Ret tt; denote (worker 1 1)]%vector @ Fin.F1 := + (denote_flow (worker 2 1) >>= fun _ => Ret tt)) (Some Fin.F1) 1 + ((new_queue_heap 1 [] hemp, upd hemp 1 (2 * S (length (@List.nil nat)))),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig))). + unfold worker at 2; rewrite interp_rr_until_none, interp_rr_bind. + unfold rotate_once at 1; rewrite interp_rr_bind. + rewrite (interp_rr_read_value _ _ _ 2 0) by reflexivity; cbv beta iota. + rewrite interp_rr_bind. + apply interp_rr_read_missing; reflexivity. +Qed. + +Lemma allocated_shared_queue_empty_no_ag : forall ctx c w + (phi : ticllW (CSLObs (nat * nat))), + ~ <( {run_rr (allocated_shared_queue []) (managed_empty,(ctx,c))}, {w} + |= AG phi )>. +Proof. + intros ctx c w phi; rewrite allocated_shared_queue_empty_stuck; apply ag_stuck. +Qed. diff --git a/examples/CSL/Queue/Ticl.v b/examples/CSL/Queue/Ticl.v index e152eab..3d059b2 100644 --- a/examples/CSL/Queue/Ticl.v +++ b/examples/CSL/Queue/Ticl.v @@ -12,79 +12,79 @@ Local Open Scope ticl_scope. Local Typeclasses Transparent equ sbisim. Theorem rotate_agaf_pop_rr : - forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. + <( {run_rr (parallel_queues u v) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. Proof. - intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v (h,allocs) c). - exact (Composition.sched_agaf_q1 u v nl1 nl2 0 h allocs c + intros u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v ((h,allocs),(ctx,c))). + exact (Composition.sched_agaf_q1 u v nl1 nl2 0 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_q2 : - forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. + <( {run_rr (parallel_queues u v) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (2,nl2))}) )>. Proof. - intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v (h,allocs) c). - exact (Composition.sched_agaf_q2 u v nl1 nl2 0 h allocs c + intros u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v ((h,allocs),(ctx,c))). + exact (Composition.sched_agaf_q2 u v nl1 nl2 0 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_fresh : - forall u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 k h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. + <( {run_rr (parallel_queues u v) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. - intros u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v (h,allocs) c). - exact (Composition.sched_agaf_q1_fresh u v nl1 nl2 k 0 h allocs c + intros u v nl1 nl2 k h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v ((h,allocs),(ctx,c))). + exact (Composition.sched_agaf_q1_fresh u v nl1 nl2 k 0 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_q2_fresh : - forall u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 k h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, qrep u ns1 vs1 h -> qrep v ns2 vs2 h -> Disj u ns1 v ns2 -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. + <( {run_rr (parallel_queues u v) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. - intros u v nl1 nl2 k h allocs c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. - rewrite (run_rr_parallel_bisim u v (h,allocs) c). + intros u v nl1 nl2 k h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2. + rewrite (run_rr_parallel_bisim u v ((h,allocs),(ctx,c))). From Coinduction Require Import coinduction. - exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h allocs c + exact (Composition.sched_agaf_q2_fresh u v nl1 nl2 k 0 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 H1 H2 Hd F1 F2). Qed. Theorem rotate_agaf_pop_rr_owned : - forall u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2, + forall u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2, owned_queues u ns1 vs1 v ns2 vs2 h -> find_index Nat.eqb nl1 vs1 = Some d1 -> find_index Nat.eqb nl2 vs2 = Some d2 -> - <( {run_rr (parallel_queues u v) (h,allocs) c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. + <( {run_rr (parallel_queues u v) ((h,allocs),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. Proof. - intros u v nl1 nl2 h allocs c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. + intros u v nl1 nl2 h allocs ctx c ns1 vs1 ns2 vs2 d1 d2 Hown F1 F2. destruct (owned_queues_sound u ns1 vs1 v ns2 vs2 h Hown) as (H1 & H2 & Hd). eapply rotate_agaf_pop_rr; eassumption. Qed. Theorem rotate_agaf_pop_alloc : - forall values1 values2 nl1 nl2 c d1 d2, + forall values1 values2 nl1 nl2 ctx c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (1,nl1))}) )>. + <( {run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. Proof. - intros values1 values2 nl1 nl2 c d1 d2 F1 F2. - destruct (run_rr_allocated_parallel values1 values2 c) + intros values1 values2 nl1 nl2 ctx c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 ctx c) as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. @@ -93,13 +93,13 @@ Proof. Qed. Theorem rotate_agaf_pop_alloc_q2 : - forall values1 values2 nl1 nl2 c d1 d2, + forall values1 values2 nl1 nl2 ctx c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure - |= AG (AF visW {(fun o => indexed_value o = (2,nl2))}) )>. + <( {run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (2,nl2))}) )>. Proof. - intros values1 values2 nl1 nl2 c d1 d2 F1 F2. - destruct (run_rr_allocated_parallel values1 values2 c) + intros values1 values2 nl1 nl2 ctx c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 ctx c) as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. @@ -108,13 +108,13 @@ Proof. Qed. Theorem rotate_agaf_pop_alloc_fresh : - forall values1 values2 nl1 nl2 k c d1 d2, + forall values1 values2 nl1 nl2 k ctx c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (1,nl1)) k)}) )>. + <( {run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (1,nl1)) k)}) )>. Proof. - intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. - destruct (run_rr_allocated_parallel values1 values2 c) + intros values1 values2 nl1 nl2 k ctx c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 ctx c) as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. @@ -123,13 +123,13 @@ Proof. Qed. Theorem rotate_agaf_pop_alloc_q2_fresh : - forall values1 values2 nl1 nl2 k c d1 d2, + forall values1 values2 nl1 nl2 k ctx c d1 d2, find_index Nat.eqb nl1 values1 = Some d1 -> find_index Nat.eqb nl2 values2 = Some d2 -> - <( {run_rr (allocated_parallel_queues values1 values2) managed_empty c}, Pure - |= AG (AF visW {(indexed_after (fun x => x = (2,nl2)) k)}) )>. + <( {run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (2,nl2)) k)}) )>. Proof. - intros values1 values2 nl1 nl2 k c d1 d2 F1 F2. - destruct (run_rr_allocated_parallel values1 values2 c) + intros values1 values2 nl1 nl2 k ctx c d1 d2 F1 F2. + destruct (run_rr_allocated_parallel values1 values2 ctx c) as (u & v & h & allocs & Finite & Owned & Run). change (owned_queues u (queue_nodes u (List.length values1)) values1 v (queue_nodes v (List.length values2)) values2 h) in Owned. @@ -137,11 +137,11 @@ Proof. rewrite Run; eapply rotate_agaf_pop_rr_q2_fresh; eassumption. Qed. -Lemma parallel_queues_hemp_no_ag u v c (phi : ticllW (indexed (nat * nat))) w : - ~ <( {run_rr (parallel_queues u v) managed_empty c}, {w} |= AG phi )>. -Proof. rewrite (parallel_queues_hemp_stuck u v c); apply ag_stuck. Qed. +Lemma parallel_queues_hemp_no_ag u v ctx c (phi : ticllW (CSLObs (nat * nat))) w : + ~ <( {run_rr (parallel_queues u v) (managed_empty,(ctx,c))}, {w} |= AG phi )>. +Proof. rewrite (parallel_queues_hemp_stuck u v ctx c); apply ag_stuck. Qed. -Lemma allocated_parallel_queues_empty_no_ag values c - (phi : ticllW (indexed (nat * nat))) w : - ~ <( {run_rr (allocated_parallel_queues [] values) managed_empty c}, {w} |= AG phi )>. -Proof. rewrite (allocated_parallel_queues_empty_stuck values c); apply ag_stuck. Qed. +Lemma allocated_parallel_queues_empty_no_ag values ctx c + (phi : ticllW (CSLObs (nat * nat))) w : + ~ <( {run_rr (allocated_parallel_queues [] values) (managed_empty,(ctx,c))}, {w} |= AG phi )>. +Proof. rewrite (allocated_parallel_queues_empty_stuck values ctx c); apply ag_stuck. Qed. diff --git a/examples/CSL/Queue/Trace.v b/examples/CSL/Queue/Trace.v index 3b55013..6ed4a0b 100644 --- a/examples/CSL/Queue/Trace.v +++ b/examples/CSL/Queue/Trace.v @@ -41,17 +41,17 @@ Local Typeclasses Transparent sbisim. the rotated heap. This is [Sequential.rot_body_spec] lifted through the iteration; the [Guard] is discharged by [sb_guard], so no stuttering theory is needed. *) -Lemma run_step: forall hdr a ns v vs h allocs c, +Lemma run_step: forall hdr a ns v vs h allocs ctx c, qrep hdr (a :: ns) (v :: vs) h -> - run hdr (h, allocs) c - ~ (log (stamp v c) ;; - run hdr (rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs) (S c)). + run hdr ((h, allocs), (ctx, c)) + ~ (log (inr (stamp v c) : CSLObs nat) ;; + run hdr ((rot_heap hdr a (List.hd 0 ns) (zof hdr ns) h, allocs), (ctx, S c))). Proof. - intros hdr a ns v vs h allocs c Hq. + intros hdr a ns v vs h allocs ctx c Hq. unfold run, rotate. rewrite interp_state_unfold_iter. cbv beta. - rewrite (rot_body_spec hdr a ns v vs h allocs c Hq). + rewrite (rot_body_spec hdr a ns v vs h allocs ctx c Hq). rewrite bind_bind. apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite bind_ret_l. @@ -77,10 +77,10 @@ Fixpoint qstepN (hdr: nat) (n: nat) (ns: list nat) (h: Heap) : Heap := (** The observation prefix of [n] rotations, with the continuation threaded so that no [bind]-associativity reasoning is needed. *) Fixpoint runN (hdr: nat) (n: nat) (ns vs: list nat) (h: Heap) (c: nat) - (k: ictreeW (indexed nat) (unit * SSig)) : ictreeW (indexed nat) (unit * SSig) := + (k: ictreeW (CSLObs nat) (unit * SSig)) : ictreeW (CSLObs nat) (unit * SSig) := match n with | 0 => k - | S m => log (stamp (hd 0 vs) c) ;; + | S m => log (inr (stamp (hd 0 vs) c) : CSLObs nat) ;; runN hdr m (rotl ns) (rotl vs) (qstep hdr ns h) (S c) k end. @@ -108,17 +108,17 @@ Qed. (** [n] rotations of the run are [n] logged pops followed by the run from the [n]-times-rotated heap. *) -Theorem run_stepN: forall n hdr ns vs h allocs c, +Theorem run_stepN: forall n hdr ns vs h allocs ctx c, qrep hdr ns vs h -> ns <> [] -> - run hdr (h, allocs) c - ~ runN hdr n ns vs h c (run hdr (qstepN hdr n ns h, allocs) (c + n)). + run hdr ((h, allocs), (ctx, c)) + ~ runN hdr n ns vs h c (run hdr ((qstepN hdr n ns h, allocs), (ctx, (c + n)%nat))). Proof. - induction n as [| n IH]; intros hdr ns vs h allocs c Hq Hne. + induction n as [| n IH]; intros hdr ns vs h allocs ctx c Hq Hne. - cbn [runN qstepN]; rewrite Nat.add_0_r; reflexivity. - destruct ns as [| a ns']; [contradiction |]. destruct vs as [| v vs']; [apply qrep_len in Hq; cbn in Hq; discriminate |]. cbn [runN qstepN qstep hd]. - rewrite (run_step hdr a ns' v vs' h allocs c Hq). + rewrite (run_step hdr a ns' v vs' h allocs ctx c Hq). apply sbisim_clo_bind_eq; [reflexivity | intros []]. rewrite <- Nat.add_succ_comm. apply (IH hdr (rotl (a :: ns')) (rotl (v :: vs'))). diff --git a/examples/CSL/README.md b/examples/CSL/README.md index b7d6246..71924fd 100644 --- a/examples/CSL/README.md +++ b/examples/CSL/README.md @@ -1,7 +1,10 @@ # Cooperative heap queues `TICL.Lang.CSL.Mod` is a typed cooperative fork/yield language over a disjoint heap -PCM. `examples.CSL.Queue.Program.allocated_parallel_queues values1 values2` constructs two linked +PCM and a shared variable context: heap commands and Yield-style expressions, +assignment, conditionals and loops live in one `CProg` AST. `examples.CSL.Queue.Shared` +verifies one heap queue rotated forever by two spawned workers (see below). +`examples.CSL.Queue.Program.allocated_parallel_queues values1 values2` constructs two linked queues by source execution on `managed_empty`, then starts their workers. The lower-level `examples.CSL.Queue.Program.parallel_queues u v` remains available for preallocated heaps. Both workers own **different queues in one shared heap**; they do not concurrently @@ -10,11 +13,14 @@ modify one queue, and the facade does not assert a general CSL parallel rule. ## Library ownership `ICTree.Interp.CSL.Mod` is the one CSL interpreter: the effect sum `sE`, the -state `SSig`, the payload-polymorphic handler `sh`, thread effects, the raw -physical-free laws, and the effect-level select/heap-free Ticl rules. It -imports no language or example. `Lang.CSL.Mod` is the one CSL language: `CProg`, -its denotation, source execution equations, exact first-yield segment rules, -and the structural Ticl matrix; it re-exports the interpreter. Import +state `SSig`, the observation sum `CSLObs`, the payload-polymorphic handler +`sh` (heap, context and indexed-emission handlers), thread effects, the +context get/put laws, the raw physical-free laws, and the effect-level +select/heap-free Ticl rules. It imports no language or example. +`Lang.CSL.Mod` is the one CSL language: `CExp`, `CProg`, their denotation, +source execution equations, exact first-yield segment rules, the structural +Ticl matrix, the Yield-fragment rules, and the source-pool rules; it +re-exports the interpreter and the generic Yield scheduler/logic layers. Import `examples.CSL.Queue` for the queue development and `examples.CSL.Allocator.*` for the allocator. The previous split implementation modules were removed, not retained as compatibility re-export files. @@ -31,7 +37,10 @@ retained as compatibility re-export files. | `Utils.Vectors` | Pointwise update/removal/cons laws shared by pool equivalence and bisimulation | | `ICTree.Interp.CSL.Mod` | CSL effects, managed state, the shared handler instance, raw free and select rules | | `ICTree.Interp.Yield.Segments` | Exact and bisimilar first-yield segments, guard transport, arbitrary-pool ND/RR equations | -| `Lang.CSL.Mod` | CSL syntax, denotation, source execution equations, source segment rules, structural matrix | +| `ICTree.Interp.Yield.SBisim` | Guard alignment (`galigned`), its preservation by erasure/state/round-robin interpretation, guard-equivalent pool congruence | +| `ICTree.Logic.Yield` | Thread rules over arbitrary handlers; `ClosedTurns`/`RankedTurns` pool invariance and eventuality rules (ND and RR) | +| `Utils.Maps` | The variable context `Ctx.Ctx` shared by languages and the CSL interpreter | +| `Lang.CSL.Mod` | CSL syntax, denotation, source execution equations, source segment rules, structural matrix, Yield-fragment and source-pool rules | Concrete address layouts, overlap counterexamples, allocator-specific state machines and their fairness/rank arguments, and regression consumers remain in @@ -113,7 +122,7 @@ original worker execution, at the same observation counter. It also covers empty input lists. No initialized heap is assumed. `examples.CSL.Queue.Ticl` exposes recurrence directly for -`run_rr (allocated_parallel_queues values1 values2) managed_empty c`: +`run_rr (allocated_parallel_queues values1 values2) (managed_empty,(ctx,c))`: - `rotate_agaf_pop_alloc`: queue 1 ordinary recurrence. - `rotate_agaf_pop_alloc_q2`: queue 2 ordinary recurrence. @@ -132,13 +141,35 @@ bisimulation. The lower-level statements remain: - `rotate_agaf_pop_rr_owned`: queue 1 recurrence from actual PCM separation. Each lower-level conclusion is `AG (AF visW {...})` over -`run_rr (parallel_queues u v) (h,allocs) c` for an arbitrary extent table `allocs`. +`run_rr (parallel_queues u v) ((h,allocs),(ctx,c))` for an arbitrary extent table +`allocs` and context `ctx`; the queue predicates are `csl_indexed P`. Both membership premises remain: both workers must be nonempty and productive for recurrence. The internal execution bisimulation also covers faulty heaps. Freshness is `indexed_after P k`: the payload satisfies `P` and its occurrence index is at least `k`. `ICTree.Logic.Trace.indexed_excludes_retained` prevents counting an old observation at index `j` toward the bound `S j`. +## One shared queue, two spawned workers + +`shared_queue hdr` forks `worker 1 hdr`, then `worker 2 hdr`, and terminates; +the remaining pool is `[worker 2 hdr; worker 1 hdr]` (`run_{nd,rr}_two_forks`; +`scheduled_visible_two_forks` exhibits both `Spawn` events). Both workers rotate +the SAME queue. `exact_worker_turn` is an exact first-yield source segment of +one worker: one pop logged as `inr (stamp (tag,v) c)`, one rotation, and a +return to the same worker. `shared_worker_turn` packages it with the standard +invariant/position variant, for either worker, so the generic +`ag_csl_{nd,rr}_invariance` and `aul_csl_{nd,rr}_eventually` rules apply with +no fairness or phase argument. The public results are +`shared_rotate_agaf_pop_{nd,rr}` and `_fresh` (from any represented queue +containing the payload) and `shared_rotate_agaf_pop_alloc_{nd,rr}` and `_fresh` +(from `managed_empty`, one `find_index` premise). The plain theorems reuse the +fresh certificate at bound `0`. Under round robin worker 2 runs first, because +the parent is gone and the cursor is still `0`. + +The pool rules rely on `interp_schedule_{nd,rr}_guard_equ`: pools equal up to +finitely many leading guards per slot are bisimilar for every focus, cursor and +state, proved through the guard-alignment relation `galigned`. + ## Heap and ownership contract The canonical data heap is `nat -> option nat`, with pointwise `heq`, pointwise @@ -147,17 +178,22 @@ support. `heap_finite` is an existential proof bound, not a new carrier or runti field. The managed memory `ManagedHeap := Heap * AllocationTable` pairs the data heap with the live malloc extents (base to positive length, same partial-map representation); `ProductPCM` gives it componentwise separation, so an extent -record is an owned resource. `SSig` is `(ManagedHeap * nat)%type`, a state is -`((h,allocs),c)`, and results remain `(result, SSig)`. Runners start at -`managed_empty` or an explicit `(h,allocs)`; preallocated data uses `(h,hemp)`. +record is an owned resource. `SSig` is `ManagedHeap * (Ctx.Ctx * nat)`, a state is +`((h,allocs),(ctx,c))`, and results remain `(result, SSig)`. The context is +shared by all threads and is not part of heap ownership. Runners take a full +state: `run_rr p ((h,allocs),(ctx,c))`, `run_nd p ...`, and the pool runners +`run_{nd,rr}_pool`. Runners start at `managed_empty` or an explicit `(h,allocs)`; +preallocated data uses `(h,hemp)`. `Events.HeapE` supplies the single shared command algebra: `HRead`, `HWrite`, `HAlloc`, `HFree`, and `HCAS`. `ICTree.Events.Heap` supplies the polymorphic `heap_read`, `heap_write`, `heap_alloc`, `heap_free`, and `heap_cas` triggers. Neither module imports a language, concrete heap, allocator, or observation type. -CSL uses `sE := heapE + writerE (nat * nat)`; the sequential queue model uses -`qE := heapE + writerE nat`. Both are interpreted by the one payload-polymorphic -`sh := h_sum heap_handler h_indexed`, at payloads `nat * nat` and `nat`. +CSL uses `sE := heapE + (stateE Ctx.Ctx + writerE (nat * nat))`; the sequential +queue model uses `qE := heapE + (stateE Ctx.Ctx + writerE nat)`. Both are +interpreted by the one payload-polymorphic +`sh := h_sum heap_handler (h_sum csl_context_handler csl_emit_handler)`, at +payloads `nat * nat` and `nat`. Observations are `CSLObs A := Ctx.Ctx + indexed A`. `CAlloc size` uses `heap_alloc`/`HAlloc` and a guarded, constructive search inside the shared handler. It returns the least positive base whose entire interval is free and @@ -171,11 +207,14 @@ infinite heap with no suitable interval silently diverges, as proved by `alloc_search_no_space`. This is not a finite-memory exhaustion policy. Reads and writes remain checked; writes never allocate implicitly. Emit records -`stamp (tag,value) c`, preserves the managed memory, and increments the global -observation counter. CAS faults on an absent cell, updates and returns `true` on -a matching value, and otherwise returns `false` without changing the heap. It -does not log. The scheduler cursor is separate. There is no variable store, -lock, or implicit read/write yield. +`inr (stamp (tag,value) c)`, preserves the managed memory and context, and +increments the global observation counter. CAS faults on an absent cell, updates +and returns `true` on a matching value, and otherwise returns `false` without +changing the heap. It does not log. The scheduler cursor is separate. A +variable read `CVar x` looks up the shared context, yields once on success and +returns the captured value; an unbound variable is `stuck`. `CAssign x e` +evaluates `e`, then reads the current context again and logs exactly +`inl (add x v ctx)`; it does not change the counter. There is no lock. `CFree base` (`HFree base`) is whole-block free through `managed_free`: at a live recorded base it removes every cell of exactly that extent and its extent @@ -217,7 +256,7 @@ independently named equivalences. Silent rules transport the interpreted residual in the same world. Emit rules keep the current-prefix obligation in the old world and place only the successor -in `Obs (Log (stamp (tag,value) c)) tt`. ND yield checks every branch, including the +in `Obs (Log (inr (stamp (tag,value) c))) tt`. ND yield checks every branch, including the single branch of a singleton pool; RR yield selects `rr_pick n m` and advances only the cursor. Fork prepends its child but keeps the parent focused. Bind and until preserve the pool and the outer `None` halt flow. These rules assert no @@ -232,6 +271,15 @@ memory'` and preserve focus, pool size, cursor, counter, and observation world. Fault rules compose with the generic stuck rules: strong AN and AG are false, while AU may match its target immediately. +The Yield fragment is reasoned about through `scheduled_visible` (Spawn and +Yield visible), the standalone erased views `instr_exp_erased` and +`instr_flow_erased` (outer option flow exposed), and `run_nd`: expression rules +`axr_csl_exp_*`, singleton rules `axr_csl_nd_skip`, `axax_csl_nd_yield` (the +`AX AX` count is ND-specific), assignment rules `a{u,l}r_csl_{flow,nd}_assign*`, +bind and conditional rules `*_csl_flow_bind*`/`*_csl_flow_if`, and raw-event +while rules `*_csl_raw_while*` over `World CEff`, which make no scheduled +liveness claim. + ## Runtime queue construction `new_queue values` allocates one block of `2 * S (length values)` cells, then @@ -323,6 +371,13 @@ lifecycle consumer of the source language: first-fit blocks, whole-extent release, and the exact stamp sequence), `reuse_first_fit`, `free_null_unchanged`, and the `*_stuck` faults for interior-pointer free, double free, and read/write/CAS after free. +- `examples/CSL/Control.v`: `scoped_fork_no_parent_replay` (a child runs only + its body), `context_resume_preserves_updates` (one yield per variable read, + late context read in assignment, separate counter), and + `missing_variable_stuck`. +- `examples/CSL/Queue/Shared.v`: `shared_queue_rr_prefix3` (the first three + complete rotations of the allocated shared queue under round robin) and + `allocated_shared_queue_empty_stuck`/`_no_ag`. - `examples.CSL.Queue.Program`: `parallel_queues_four_pop_bisim` (the exact first four pops of any two represented, disjoint queues, then the reference loop; payloads may repeat), `parallel_queues_hemp_stuck`, and diff --git a/examples/Toy.v b/examples/Toy.v index 198f1d6..93535d2 100644 --- a/examples/Toy.v +++ b/examples/Toy.v @@ -15,7 +15,7 @@ From TICL Require Import ICTree.Interp.State.Mod ICTree.Events.State ICTree.Events.Writer - Lang.Maps + Utils.Maps Lang.StImp. From ExtLib Require Import diff --git a/theories/ICTree/Eq/Core.v b/theories/ICTree/Eq/Core.v index d372595..2218780 100644 --- a/theories/ICTree/Eq/Core.v +++ b/theories/ICTree/Eq/Core.v @@ -351,7 +351,7 @@ Proof. step; now cbn. Qed. Lemma resumICtree_ret {E1 E2 : Type} `{ReSumRet E1 E2} {R} (r : R) : - resumICtree (Ret r) ≅ Ret r. + @resumICtree E1 E2 _ _ _ _ R (Ret r) ≅ Ret r. Proof. step. cbn. constructor. reflexivity. Qed. Lemma resumICtree_br {E1 E2 : Type} `{ReSumRet E1 E2} diff --git a/theories/ICTree/Interp/CSL/Mod.v b/theories/ICTree/Interp/CSL/Mod.v index f03fe38..1ad78ed 100644 --- a/theories/ICTree/Interp/CSL/Mod.v +++ b/theories/ICTree/Interp/CSL/Mod.v @@ -1,8 +1,9 @@ (** * The canonical CSL effect interpreter. This module owns the CSL effect sum, its interpretation state and the one - payload-polymorphic handler [sh] that pairs the shared checked heap with - the shared indexing writer. Everything here is stated over effects and + payload-polymorphic handler [sh] that combines the shared checked heap, + the shared variable context (with context-update observations) and the + shared indexing writer. Everything here is stated over effects and trees: it does not mention CSL syntax. The source language ([Lang.CSL.Mod]) specializes these laws to its denotation. @@ -22,19 +23,20 @@ From TICL Require Export Events.HeapModel ICTree.Events.Heap ICTree.Events.Writer + ICTree.Events.State ICTree.Interp.Heap ICTree.Logic.Heap ICTree.Trace ICTree.Interp.Refine ICTree.Interp.Yield.Nondeterministic - ICTree.Interp.Yield.Segments. + ICTree.Interp.Yield.Segments + Utils.Maps. From TICL Require Import ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans - ICTree.Events.State ICTree.Events.Yield ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod @@ -60,49 +62,152 @@ Local Open Scope ticl_scope. (** ** Effects and interpretation state *) (** [sE] is a notation, not a definition: the payload-polymorphic handler - [sh] below is typed over [heapE + writerE A], so instantiating it at the - tagged payload yields this sum syntactically, and rewrites stated over - [sE] keep matching terms elaborated through [sh]. *) -Notation sE := (heapE + writerE (nat * nat))%type. - -Definition semit (q v : nat) : ictree sE unit := - ICtree.trigger (Log (q,v)). + [sh] below is typed over [heapE + (stateE Ctx.Ctx + writerE A)], so + instantiating it at the tagged payload yields this sum syntactically, and + rewrites stated over [sE] keep matching terms elaborated through [sh]. *) +Notation sE := (heapE + (stateE Ctx.Ctx + writerE (nat * nat)))%type. (** Interpretation state: the SHARED managed memory (data heap and live - allocation extents) and one GLOBAL occurrence counter. A state is - [((h,allocs),c)]. *) -Notation SSig := (ManagedHeap * nat)%type. + allocation extents), the SHARED variable context, and one GLOBAL + occurrence counter for indexed emissions. A state is + [((h,allocs),(ctx,c))]. The context is not part of heap ownership. *) +Definition SSig : Type := (ManagedHeap * (Ctx.Ctx * nat))%type. + +(** Observations: a context update logs the new context ([inl]); an indexed + emission logs its stamped payload ([inr]). *) +Definition CSLObs (A : Type) : Type := (Ctx.Ctx + indexed A)%type. + +Definition CEff : Type := (yieldE + (forkE + sE))%type. + +Definition csl_memory (s : SSig) : ManagedHeap := fst s. +Definition csl_context (s : SSig) : Ctx.Ctx := fst (snd s). +Definition csl_counter (s : SSig) : nat := snd (snd s). +Definition csl_set_context (s : SSig) (ctx : Ctx.Ctx) : SSig := + (csl_memory s, (ctx, csl_counter s)). +Definition csl_indexed {A} (P : indexed A -> Prop) (o : CSLObs A) : Prop := + match o with inl _ => False | inr x => P x end. +(** The occurrence index of an indexed emission; context updates carry no + occurrence index and project to [0]. *) +Definition csl_index {A} (o : CSLObs A) : nat := + match o with inl _ => 0 | inr x => indexed_index x end. + +Definition semit (q v : nat) : ictree sE unit := + @ICtree.trigger sE sE _ _ ReSum_refl ReSumRet_refl (inr (inr (Log (q,v)))). + +(** The context handler projects the shared context, runs the existing + [h_stateW], injects its context logs on the left, and rebuilds the state. + Memory and the indexed counter are untouched. *) +Definition csl_context_handler {A : Type} : + stateE Ctx.Ctx ~> stateT SSig (ictreeW (CSLObs A)) := + fun e => mkStateT (fun s => + '(x, ctx') <- @resumICtree (writerE Ctx.Ctx) (writerE (CSLObs A)) _ _ _ _ _ + (runStateT (h_stateW e) (csl_context s));; + Ret (x, csl_set_context s ctx')). + +(** The emission handler reassociates [(memory,(ctx,c))] to + [((memory,ctx),c)], runs the existing [h_indexed], injects its stamped + logs on the right, and reassociates back. *) +Definition csl_emit_handler {A : Type} : + writerE A ~> stateT SSig (ictreeW (CSLObs A)) := + fun e => mkStateT (fun s => + '(x, ((memory, ctx), c)) <- + @resumICtree (writerE (indexed A)) (writerE (CSLObs A)) _ _ _ _ _ + (runStateT (h_indexed (Sigma:=ManagedHeap * Ctx.Ctx) e) + ((csl_memory s, csl_context s), csl_counter s));; + Ret (x, (memory, (ctx, c)))). (** The one CSL handler: the shared checked-heap handler summed with the - shared indexing handler. It is polymorphic in the observation payload; - the tagged source language uses [nat * nat], a unary reference model uses - [nat]. The occurrence index is supplied by [h_indexed], which owns the - counter and passes the managed memory through unchanged. *) + context and indexing handlers. It is polymorphic in the observation + payload; the tagged source language uses [nat * nat], a unary reference + model uses [nat]. *) Definition sh {A : Type} : - (heapE + writerE A) ~> stateT SSig (ictreeW (indexed A)) := - h_sum heap_handler h_indexed. + (heapE + (stateE Ctx.Ctx + writerE A)) ~> stateT SSig (ictreeW (CSLObs A)) := + h_sum heap_handler (h_sum csl_context_handler csl_emit_handler). + +Local Typeclasses Transparent equ. + +(** Raw handler equations: [Get] is silent, [Put] logs exactly the new + context, [Log] logs exactly one stamp and advances only the counter. *) +Lemma csl_context_handler_get {A} memory ctx c : + runStateT (csl_context_handler (A:=A) Get) (memory,(ctx,c)) ≅ + Ret (ctx,(memory,(ctx,c))). +Proof. + unfold csl_context_handler; cbn [runStateT h_stateW]. + step; cbn; constructor; reflexivity. +Qed. + +Lemma csl_context_handler_put {A} ctx' memory ctx c : + runStateT (csl_context_handler (A:=A) (Put ctx')) (memory,(ctx,c)) ≅ + (log (inl ctx' : CSLObs A);; Ret (tt,(memory,(ctx',c)))). +Proof. + unfold csl_context_handler; cbn [runStateT h_stateW]. + step; cbn; constructor; intros []. + step; cbn; constructor; reflexivity. +Qed. + +Lemma csl_emit_handler_log {A} (a : A) memory ctx c : + runStateT (csl_emit_handler (Log a)) (memory,(ctx,c)) ≅ + (log (inr (stamp a c) : CSLObs A);; Ret (tt,(memory,(ctx,S c)))). +Proof. + unfold csl_emit_handler; cbn [runStateT h_indexed]. + step; cbn; constructor; intros []. + step; cbn; constructor; reflexivity. +Qed. + +(** Interpretation-level emission: exactly one right-injected stamp. *) +Lemma interp_csl_emit {A X} (a : A) memory ctx c + (k : unit -> ictree (heapE + (stateE Ctx.Ctx + writerE A)) X) : + interp_state sh + ((@ICtree.trigger _ _ _ _ ReSum_refl ReSumRet_refl + (inr (inr (Log a)) : heapE + (stateE Ctx.Ctx + writerE A))) >>= k) + (memory,(ctx,c)) ~ + (log (inr (stamp a c) : CSLObs A);; + interp_state sh (k tt) (memory,(ctx,S c))). +Proof. + unfold ICtree.trigger, resum, resum_ret, ReSum_refl, ReSumRet_refl; + rewrite bind_vis; setoid_rewrite bind_ret_l. + rewrite interp_state_vis; cbn [sh h_sum]. + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_emit_handler_log a memory ctx c) | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; apply sb_guard. +Qed. +Local Typeclasses Opaque equ. (** ** Thread effects *) -Definition CEff := (yieldE + (forkE + sE))%type. #[global] Instance ReSum_heap_CEff : ReSum heapE CEff := fun e => inr (inr (inl e)). #[global] Instance ReSumRet_heap_CEff : ReSumRet heapE CEff := fun e response => response. +#[global] Instance ReSum_ctx_CEff : ReSum (stateE Ctx.Ctx) CEff := + fun e => inr (inr (inr (inl e))). +#[global] Instance ReSumRet_ctx_CEff : ReSumRet (stateE Ctx.Ctx) CEff := + fun e response => response. #[global] Instance ReSum_tagged_CEff : ReSum (writerE (nat * nat)) CEff := - fun e => inr (inr (inr e)). + fun e => inr (inr (inr (inr e))). #[global] Instance ReSumRet_tagged_CEff : ReSumRet (writerE (nat * nat)) CEff := fun e response => response. Definition source_yield : ictree CEff unit := Vis (inl Yield) (fun _ => Ret tt). Definition source_fork : ictree CEff bool := Vis (inr (inl Fork)) (fun b => Ret b). +Definition source_get : ictree CEff Ctx.Ctx := + ICtree.trigger (E1:=stateE Ctx.Ctx) (E2:=CEff) Get. +Definition source_put (ctx : Ctx.Ctx) : ictree CEff unit := + ICtree.trigger (E1:=stateE Ctx.Ctx) (E2:=CEff) (Put ctx). (** ** The two response-relation instances of the generic segment theory. *) Notation csl_sb := - (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ~ u). + (fun X (t u : ictreeW (CSLObs (nat * nat)) X) => t ~ u). Notation csl_equ := - (fun X (t u : ictreeW (indexed (nat * nat)) X) => t ≅ u). + (fun X (t u : ictreeW (CSLObs (nat * nat)) X) => t ≅ u). (** ** Raw physical free through the shared heap event *) @@ -116,18 +221,18 @@ Proof. Qed. Lemma interp_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c : managed_free memory base = Some memory' -> interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c) ~ + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c)) ~ interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c). + (ts @ i := K tt) (Some i) m (memory',(ctx,c)). Proof. intro Free. pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := (heap_free (E:=CEff) base >>= K)) (ts @ i := Vis (inr (inr (inl (HFree base)))) K) - (Some i) m (memory,c) + (Some i) m (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. rewrite Hpool. erewrite interp_schedule_rr_user with (e:=inl (HFree base)) (k:=K) @@ -136,24 +241,24 @@ Proof. etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free base memory memory' c Free) | reflexivity | reflexivity] + [exact (heap_handler_free base memory memory' (ctx,c) Free) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. Qed. Lemma interp_rr_heap_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory : ManagedHeap) c : + base (K : unit -> thread sE) m (memory : ManagedHeap) ctx c : managed_free memory base = None -> interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Invalid. pose proof (interp_schedule_rr_equ sh (S n) (ts @ i := (heap_free (E:=CEff) base >>= K)) (ts @ i := Vis (inr (inr (inl (HFree base)))) K) - (Some i) m (memory,c) + (Some i) m (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. rewrite Hpool. erewrite interp_schedule_rr_user with (e:=inl (HFree base)) (k:=K) @@ -162,25 +267,25 @@ Proof. etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free_invalid base memory c Invalid) | reflexivity | reflexivity] + [exact (heap_handler_free_invalid base memory (ctx,c) Invalid) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_stuck_equ; reflexivity. Qed. Lemma interp_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c : managed_free memory base = Some memory' -> interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c) ~ + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c)) ~ interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c). + (ts @ i := K tt) (Some i) (memory',(ctx,c)). Proof. intro Free. pose proof ((interp_schedule_nd_equ sh) (S n) (ts @ i := (heap_free (E:=CEff) base >>= K)) (ts @ i := Vis (inr (inr (inl (HFree base)))) K) - (Some i) (memory,c) + (Some i) (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. rewrite Hpool. erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree base)) (k:=K) @@ -189,24 +294,24 @@ Proof. etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free base memory memory' c Free) | reflexivity | reflexivity] + [exact (heap_handler_free base memory memory' (ctx,c) Free) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. Qed. Lemma interp_nd_heap_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory : ManagedHeap) c : + base (K : unit -> thread sE) (memory : ManagedHeap) ctx c : managed_free memory base = None -> interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Invalid. pose proof ((interp_schedule_nd_equ sh) (S n) (ts @ i := (heap_free (E:=CEff) base >>= K)) (ts @ i := Vis (inr (inr (inl (HFree base)))) K) - (Some i) (memory,c) + (Some i) (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_heap_free_head base K))) as Hpool. rewrite Hpool. erewrite (interp_schedule_nd_user sh) with (e:=inl (HFree base)) (k:=K) @@ -215,144 +320,321 @@ Proof. etransitivity; [apply sbisim_clo_bind_eq with (k2:=next); [eapply equ_clos_sbisim_goal; - [exact (heap_handler_free_invalid base memory c Invalid) | reflexivity | reflexivity] + [exact (heap_handler_free_invalid base memory (ctx,c) Invalid) | reflexivity | reflexivity] | intro result; reflexivity] |] end. rewrite bind_stuck_equ; reflexivity. Qed. +(** ** Shared-context access through the scheduler + + [Get] substitutes the current context and is silent; [Put] emits exactly + the left-injected new context. Neither changes focus or the RR cursor, + and neither touches memory or the indexed counter. *) + +Lemma raw_source_get_head {X} (K : Ctx.Ctx -> ictree CEff X) : + (source_get >>= K) ≅ Vis (inr (inr (inr (inl Get))) : CEff) K. +Proof. + unfold source_get, ICtree.trigger, resum, resum_ret, + ReSum_ctx_CEff, ReSumRet_ctx_CEff. + rewrite bind_vis; setoid_rewrite bind_ret_l; reflexivity. +Qed. + +Lemma raw_source_put_head {X} ctx' (K : unit -> ictree CEff X) : + (source_put ctx' >>= K) ≅ Vis (inr (inr (inr (inl (Put ctx')))) : CEff) K. +Proof. + unfold source_put, ICtree.trigger, resum, resum_ret, + ReSum_ctx_CEff, ReSumRet_ctx_CEff. + rewrite bind_vis; setoid_rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_nd_get_ctx n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : Ctx.Ctx -> thread sE) (s : SSig) : + interp_schedule_nd sh (S n) (ts @ i := (source_get >>= K)) (Some i) s ~ + interp_schedule_nd sh (S n) (ts @ i := K (csl_context s)) (Some i) s. +Proof. + destruct s as [memory [ctx c]]. + rewrite ((interp_schedule_nd_equ sh) (S n) _ + (ts @ i := Vis (inr (inr (inr (inl Get))) : CEff) K) (Some i) _ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_source_get_head K))). + erewrite (interp_schedule_nd_user sh) with (e:=inr (inl Get)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_get (A:=nat * nat) memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_get_ctx n (ts : pool sE (S n)) (i : Fin.t (S n)) + (K : Ctx.Ctx -> thread sE) (cursor : nat) (s : SSig) : + interp_schedule_rr sh (S n) (ts @ i := (source_get >>= K)) (Some i) cursor s ~ + interp_schedule_rr sh (S n) (ts @ i := K (csl_context s)) (Some i) cursor s. +Proof. + destruct s as [memory [ctx c]]. + rewrite (interp_schedule_rr_equ sh (S n) _ + (ts @ i := Vis (inr (inr (inr (inl Get))) : CEff) K) (Some i) cursor _ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_source_get_head K))). + erewrite interp_schedule_rr_user with (e:=inr (inl Get)) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_get (A:=nat * nat) memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_put_ctx n (ts : pool sE (S n)) (i : Fin.t (S n)) + (ctx' : Ctx.Ctx) (K : unit -> thread sE) (s : SSig) : + interp_schedule_nd sh (S n) (ts @ i := (source_put ctx' >>= K)) (Some i) s ~ + (log (inl ctx' : CSLObs (nat * nat));; + interp_schedule_nd sh (S n) (ts @ i := K tt) (Some i) + (csl_set_context s ctx')). +Proof. + destruct s as [memory [ctx c]]. + rewrite ((interp_schedule_nd_equ sh) (S n) _ + (ts @ i := Vis (inr (inr (inr (inl (Put ctx')))) : CEff) K) (Some i) _ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_source_put_head ctx' K))). + erewrite (interp_schedule_nd_user sh) with (e:=inr (inl (Put ctx'))) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_put (A:=nat * nat) ctx' memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_put_ctx n (ts : pool sE (S n)) (i : Fin.t (S n)) + (ctx' : Ctx.Ctx) (K : unit -> thread sE) (cursor : nat) (s : SSig) : + interp_schedule_rr sh (S n) (ts @ i := (source_put ctx' >>= K)) (Some i) cursor s ~ + (log (inl ctx' : CSLObs (nat * nat));; + interp_schedule_rr sh (S n) (ts @ i := K tt) (Some i) cursor + (csl_set_context s ctx')). +Proof. + destruct s as [memory [ctx c]]. + rewrite (interp_schedule_rr_equ sh (S n) _ + (ts @ i := Vis (inr (inr (inr (inl (Put ctx')))) : CEff) K) (Some i) cursor _ + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (raw_source_put_head ctx' K))). + erewrite interp_schedule_rr_user with (e:=inr (inl (Put ctx'))) (k:=K) + by (rewrite Vector.nth_replace_eq; reflexivity). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_put (A:=nat * nat) ctx' memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l, Vector.replace_replace_eq; reflexivity. +Qed. + Local Typeclasses Transparent equ sbisim. +(** ** Standalone erased threads over the CSL handler + + The erased standalone view resolves [Fork] to the parent branch, erases + [Yield], and interprets the residual effects with [sh]. Context access + behaves exactly as under the schedulers. *) + +Lemma interp_thread_get_ctx {X} (K : Ctx.Ctx -> ictree CEff X) (s : SSig) : + interp_state sh (interp_thread (source_get >>= K)) s ~ + interp_state sh (interp_thread (K (csl_context s))) s. +Proof. + destruct s as [memory [ctx c]]. + rewrite (raw_source_get_head K). + rewrite (interp_state_thread_user sh (inr (inl Get))). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_get (A:=nat * nat) memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_ret_l; reflexivity. +Qed. + +Lemma interp_thread_put_ctx {X} ctx' (K : unit -> ictree CEff X) (s : SSig) : + interp_state sh (interp_thread (source_put ctx' >>= K)) s ~ + (log (inl ctx' : CSLObs (nat * nat));; + interp_state sh (interp_thread (K tt)) (csl_set_context s ctx')). +Proof. + destruct s as [memory [ctx c]]. + rewrite (raw_source_put_head ctx' K). + rewrite (interp_state_thread_user sh (inr (inl (Put ctx')))). + lazymatch goal with |- (?t >>= ?next) ~ _ => + etransitivity; + [apply sbisim_clo_bind_eq with (k2:=next); + [eapply equ_clos_sbisim_goal; + [exact (csl_context_handler_put (A:=nat * nat) ctx' memory ctx c) + | reflexivity | reflexivity] + | intro result; reflexivity] |] + end. + rewrite bind_bind. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite bind_ret_l; reflexivity. +Qed. + +(** A read-modify-write of the shared context leaves exactly one context + observation. *) +Lemma interp_thread_ctx_update {X} (f : Ctx.Ctx -> Ctx.Ctx) (r : X) (s : SSig) : + interp_state sh (interp_thread + (ctx <- source_get;; source_put (f ctx);; Ret r)) s ~ + (log (inl (f (csl_context s)) : CSLObs (nat * nat));; + Ret (r, csl_set_context s (f (csl_context s)))). +Proof. + rewrite interp_thread_get_ctx; cbv beta. + rewrite interp_thread_put_ctx. + apply sbisim_clo_bind_eq; [reflexivity | intros []]. + rewrite interp_state_thread_ret; reflexivity. +Qed. + (** ** Selection from an unfocused nonempty pool *) -Lemma anl_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : +Lemma anl_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - ts (None) (memory,c)}, {w} |= φ AN ψ )> <-> + ts (None) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= φ )> /\ + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - ts (Some j) (memory,c)}, {w} |= ψ )>)). + ts (Some j) (memory,(ctx,c))}, {w} |= ψ )>)). Proof. rewrite (interp_schedule_nd_select sh). apply anl_br. Qed. -Lemma anr_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : +Lemma anr_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - ts (None) (memory,c)}, {w} |= φ AN ψ ]> <-> + ts (None) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= φ )> /\ + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <[ {interp_schedule_nd sh (S n) - ts (Some j) (memory,c)}, {w} |= ψ ]>)). + ts (Some j) (memory,(ctx,c))}, {w} |= ψ ]>)). Proof. rewrite (interp_schedule_nd_select sh). apply anr_br. Qed. -Lemma aul_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : +Lemma aul_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - ts (None) (memory,c)}, {w} |= φ AU ψ )> <-> + ts (None) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= ψ )> \/ + ts (Some j) (memory,(ctx,c)))}, {w} |= ψ )> \/ (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= φ )> /\ + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - ts (Some j) (memory,c)}, {w} |= φ AU ψ )>))). + ts (Some j) (memory,(ctx,c))}, {w} |= φ AU ψ )>))). Proof. rewrite (interp_schedule_nd_select sh). symmetry; apply aul_br. Qed. -Lemma aur_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : +Lemma aur_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - ts (None) (memory,c)}, {w} |= φ AU ψ ]> <-> + ts (None) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= ψ ]> \/ + ts (Some j) (memory,(ctx,c)))}, {w} |= ψ ]> \/ (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= φ )> /\ + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <[ {interp_schedule_nd sh (S n) - ts (Some j) (memory,c)}, {w} |= φ AU ψ ]>))). + ts (Some j) (memory,(ctx,c))}, {w} |= φ AU ψ ]>))). Proof. rewrite (interp_schedule_nd_select sh). symmetry; apply aur_br. Qed. -Lemma ag_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : +Lemma ag_csl_nd_select n (ts : pool sE (S n)) (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - ts (None) (memory,c)}, {w} |= AG φ )> <-> + ts (None) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - ts (Some j) (memory,c))}, {w} |= φ )> /\ + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - ts (Some j) (memory,c)}, {w} |= AG φ )>)). + ts (Some j) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. rewrite (interp_schedule_nd_select sh). symmetry; apply ag_br. Qed. -Lemma anl_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : +Lemma anl_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - ts (None) m (memory,c)}, {w} |= φ AN ψ )> <-> + ts (None) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ )>)). + ts (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. rewrite interp_schedule_rr_select; reflexivity. Qed. -Lemma anr_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : +Lemma anr_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - ts (None) m (memory,c)}, {w} |= φ AN ψ ]> <-> + ts (None) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ ]>)). + ts (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. rewrite interp_schedule_rr_select; reflexivity. Qed. -Lemma aul_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : +Lemma aul_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - ts (None) m (memory,c)}, {w} |= φ AU ψ )> <-> + ts (None) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ )>)). + ts (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. rewrite interp_schedule_rr_select; reflexivity. Qed. -Lemma aur_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : +Lemma aur_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - ts (None) m (memory,c)}, {w} |= φ AU ψ ]> <-> + ts (None) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ ]>)). + ts (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. rewrite interp_schedule_rr_select; reflexivity. Qed. -Lemma ag_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : +Lemma ag_csl_rr_select n (ts : pool sE (S n)) m (memory : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - ts (None) m (memory,c)}, {w} |= AG φ )> <-> + ts (None) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - ts (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= AG φ )>)). + ts (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. rewrite interp_schedule_rr_select; reflexivity. Qed. @@ -360,121 +642,121 @@ Qed. (** ** Valid whole-block free through the shared raw heap event *) Lemma anl_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AN ψ )>). + (ts @ i := K tt) (Some i) (memory',(ctx,c))}, {w} |= φ AN ψ )>). Proof. - intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma anr_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> <[ {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AN ψ ]>). + (ts @ i := K tt) (Some i) (memory',(ctx,c))}, {w} |= φ AN ψ ]>). Proof. - intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma aul_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AU ψ )>). + (ts @ i := K tt) (Some i) (memory',(ctx,c))}, {w} |= φ AU ψ )>). Proof. - intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma aur_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> <[ {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c)}, {w} |= φ AU ψ ]>). + (ts @ i := K tt) (Some i) (memory',(ctx,c))}, {w} |= φ AU ψ ]>). Proof. - intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma ag_csl_nd_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> <( {interp_schedule_nd sh (S n) - (ts @ i := K tt) (Some i) (memory',c)}, {w} |= AG φ )>). + (ts @ i := K tt) (Some i) (memory',(ctx,c))}, {w} |= AG φ )>). Proof. - intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' c Free); reflexivity. + intro Free; rewrite (interp_nd_heap_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma anl_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AN ψ )>). + (ts @ i := K tt) (Some i) m (memory',(ctx,c))}, {w} |= φ AN ψ )>). Proof. - intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' ctx c Free); reflexivity. Qed. Lemma anr_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AN ψ ]>). + (ts @ i := K tt) (Some i) m (memory',(ctx,c))}, {w} |= φ AN ψ ]>). Proof. - intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' ctx c Free); reflexivity. Qed. Lemma aul_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AU ψ )>). + (ts @ i := K tt) (Some i) m (memory',(ctx,c))}, {w} |= φ AU ψ )>). Proof. - intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' ctx c Free); reflexivity. Qed. Lemma aur_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> <[ {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= φ AU ψ ]>). + (ts @ i := K tt) (Some i) m (memory',(ctx,c))}, {w} |= φ AU ψ ]>). Proof. - intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' ctx c Free); reflexivity. Qed. Lemma ag_csl_rr_heap_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : unit -> thread sE) m (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : + base (K : unit -> thread sE) m (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (heap_free (E:=CEff) base >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> <( {interp_schedule_rr sh (S n) - (ts @ i := K tt) (Some i) m (memory',c)}, {w} |= AG φ )>). + (ts @ i := K tt) (Some i) m (memory',(ctx,c))}, {w} |= AG φ )>). Proof. - intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' c Free); reflexivity. + intro Free; rewrite (interp_rr_heap_free n ts i base K m memory memory' ctx c Free); reflexivity. Qed. diff --git a/theories/ICTree/Interp/Refine.v b/theories/ICTree/Interp/Refine.v index 2593c6a..9b2d358 100644 --- a/theories/ICTree/Interp/Refine.v +++ b/theories/ICTree/Interp/Refine.v @@ -117,6 +117,16 @@ Section BranchFreeLaws. (forall x, BranchFree (k x)) -> BranchFree (Vis e k). Proof. intro Hk; apply branchfree_unfold; now constructor. Qed. + (** [stuck] is an infinite chain of guards: divergent, but branch-free. *) + Lemma bf_stuck {A} : BranchFree (stuck : ictree E A). + Proof. + enough (H : forall u : unit, BranchFree (stuck : ictree E A)) by exact (H tt). + change (forall u : unit, gfp fbranchfree (stuck : ictree E A)). + apply_coinduction; intros R IH u. + change (branchfreeF (coinduction.t fbranchfree R) (observe (stuck : ictree E A))). + cbn; constructor; apply (IH tt). + Qed. + Lemma branchfree_equ_impl {A} : forall (t u : ictree E A), t ≅ u -> BranchFree t -> BranchFree u. Proof. diff --git a/theories/ICTree/Interp/Yield/Mod.v b/theories/ICTree/Interp/Yield/Mod.v index 55073e1..3ff2bd4 100644 --- a/theories/ICTree/Interp/Yield/Mod.v +++ b/theories/ICTree/Interp/Yield/Mod.v @@ -303,6 +303,58 @@ Proof. reflexivity. Qed. +(** ** Thread erasure under an arbitrary state handler. + + The same algebra as [instr_thread], for any handler [h]: a standalone + raw thread erases [Fork] to the parent branch and erases cooperative + [Yield], then interprets its residual user events with [h]. *) +Section ThreadStateInterp. + Context {E F S : Type} {HE : Encode E} {HF : Encode F} + (h : E ~> stateT S (ictree F)). + + Lemma interp_state_thread_ret {X} (x : X) (s : S) : + interp_state h (interp_thread (Ret x : ictree (yieldE + (forkE + E)) X)) s ≅ Ret (x, s). + Proof. + unfold interp_thread, interp_yield. + rewrite interp_ret_node, interp_ret_node. + apply interp_state_ret. + Qed. + + Lemma interp_state_thread_bind {A B} + (t : ictree (yieldE + (forkE + E)) A) + (k : A -> ictree (yieldE + (forkE + E)) B) (s : S) : + interp_state h (interp_thread (t >>= k)) s + ≅ (interp_state h (interp_thread t) s >>= fun '(x, s') => + interp_state h (interp_thread (k x)) s'). + Proof. + unfold interp_thread, interp_yield. + rewrite !interp_bind_hetero. + apply interp_state_bind. + Qed. + + Lemma interp_state_thread_yield {X} + (k : unit -> ictree (yieldE + (forkE + E)) X) (s : S) : + interp_state h (interp_thread (Vis (inl Yield) k)) s + ~ interp_state h (interp_thread (k tt)) s. + Proof. + rewrite interp_thread_yield_node. + rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. + reflexivity. + Qed. + + Lemma interp_state_thread_user {X} (e : E) + (k : encode e -> ictree (yieldE + (forkE + E)) X) (s : S) : + interp_state h (interp_thread (Vis (inr (inr e)) k)) s + ~ (runStateT (h e) s >>= fun '(x, s') => + interp_state h (interp_thread (k x)) s'). + Proof. + rewrite interp_thread_user_node, interp_state_vis. + apply sbisim_clo_bind_eq; [reflexivity | intros [x s']]. + rewrite sb_guard, interp_state_tau, sb_guard, interp_state_tau, sb_guard. + reflexivity. + Qed. +End ThreadStateInterp. + (** ** Instrumentation algebra for raw threads. *) #[global] Instance instr_thread_equ {Σ X} : @@ -315,32 +367,19 @@ Qed. Lemma instr_thread_ret {Σ X} (x : X) (σ : Σ) : instr_thread (Ret x) σ ≅ Ret (x, σ). -Proof. - unfold instr_thread, interp_thread, interp_yield, instr_stateE. - rewrite interp_ret_node, interp_ret_node. - apply interp_state_ret. -Qed. +Proof. exact (interp_state_thread_ret h_stateW x σ). Qed. Lemma instr_thread_bind {Σ A B} (t : ictree (yieldE + (forkE + stateE Σ)) A) (k : A -> ictree (yieldE + (forkE + stateE Σ)) B) (σ : Σ) : instr_thread (t >>= k) σ ≅ (instr_thread t σ >>= fun '(x, σ') => instr_thread (k x) σ'). -Proof. - unfold instr_thread, interp_thread, interp_yield, instr_stateE. - rewrite !interp_bind_hetero. - apply interp_state_bind. -Qed. +Proof. exact (interp_state_thread_bind h_stateW t k σ). Qed. Lemma instr_thread_yield {Σ X} (k : unit -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : instr_thread (Vis (inl Yield) k) σ ~ instr_thread (k tt) σ. -Proof. - unfold instr_thread, instr_stateE. - rewrite interp_thread_yield_node. - rewrite interp_state_tau, sb_guard, interp_state_tau, sb_guard. - reflexivity. -Qed. +Proof. exact (interp_state_thread_yield h_stateW k σ). Qed. Lemma instr_thread_get {Σ X} (k : Σ -> ictree (yieldE + (forkE + stateE Σ)) X) (σ : Σ) : diff --git a/theories/ICTree/Interp/Yield/Nondeterministic.v b/theories/ICTree/Interp/Yield/Nondeterministic.v index f5d41e5..21b9ec4 100644 --- a/theories/ICTree/Interp/Yield/Nondeterministic.v +++ b/theories/ICTree/Interp/Yield/Nondeterministic.v @@ -150,6 +150,30 @@ Section NondeterministicInterpretation. interp_state_tau, sb_guard; reflexivity. Qed. + (** A focused slot that is [stuck] makes the whole interpreted pool + raw-equivalent to [stuck]; no other slot ever runs. *) + Lemma interp_schedule_nd_stuck + (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) sigma : + (ts $ i) ≅ stuck -> + interp_schedule_nd handler (S n) ts (Some i) sigma ≅ stuck. + Proof. + intro Hstuck. + rewrite (interp_schedule_nd_equ handler (S n) ts (ts @ i := stuck) (Some i) sigma) + by (intro j; destruct (Fin.eq_dec j i) as [->|Hne]; + [rewrite Vector.nth_replace_eq; exact Hstuck + |rewrite Vector.nth_replace_neq by congruence; reflexivity]). + apply equ_guard_stuck. + unfold interp_schedule_nd at 1. + assert (Hnode : schedule (S n) (ts @ i := stuck) (Some i) ≅ + Guard (schedule (S n) ((ts @ i := stuck) @ i := stuck) (Some i))). + { rewrite (ictree_eta (schedule (S n) (ts @ i := stuck) (Some i))), + (schedule_focused_guard n (ts @ i := stuck) i stuck) + by (rewrite Vector.nth_replace_eq; reflexivity); reflexivity. } + rewrite Vector.replace_replace_eq in Hnode. + rewrite Hnode, interp_erase_guard, interp_state_tau; reflexivity. + Qed. + (** Keep one scheduler continuation fixed while interpreting a raw user event. *) Lemma interp_schedule_nd_user_bind (handler : E ~> stateT Sigma (ictree F)) n (ts : pool E (S n)) @@ -172,6 +196,18 @@ Section NondeterministicInterpretation. apply sbisim_clo_bind_eq; [reflexivity | intros [x sigma']]. rewrite Vector.replace_replace_eq; reflexivity. Qed. + + (** Guard-equivalent pools are bisimilar under nondeterministic + scheduling, for every focus and state. *) + Lemma interp_schedule_nd_guard_equ + (handler : E ~> stateT Sigma (ictree F)) n (ts us : pool E n) focus sigma : + pool_guard_equ ts us -> + interp_schedule_nd handler n ts focus sigma ~ + interp_schedule_nd handler n us focus sigma. + Proof. + intro H; unfold interp_schedule_nd. + apply galigned_sbisim, interp_state_galigned, erased_schedule_galigned, H. + Qed. End NondeterministicInterpretation. Arguments interp_schedule_nd {E F HE HF Sigma} handler n ts focus sigma. diff --git a/theories/ICTree/Interp/Yield/RoundRobin.v b/theories/ICTree/Interp/Yield/RoundRobin.v index d7aa9cb..69f7741 100644 --- a/theories/ICTree/Interp/Yield/RoundRobin.v +++ b/theories/ICTree/Interp/Yield/RoundRobin.v @@ -1,4 +1,5 @@ From Stdlib Require Import Fin Vector. +From Coinduction Require Import coinduction lattice tactics. From TICL Require Import ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Events.Yield ICTree.Interp.Refine ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim @@ -124,6 +125,28 @@ Section RoundRobinInterpretation. interp_state_tau, sb_guard; reflexivity. Qed. + (** A focused slot that is [stuck] makes the whole interpreted pool + raw-equivalent to [stuck]; no other slot ever runs. *) + Lemma interp_schedule_rr_stuck + (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) + (i : Fin.t (S n)) m σ : + (ts $ i) ≅ stuck -> + interp_schedule_rr handler (S n) ts (Some i) m σ ≅ stuck. + Proof. + intro Hstuck. + rewrite (interp_schedule_rr_equ handler (S n) ts (ts @ i := stuck) (Some i) m σ) + by (intro j; destruct (Fin.eq_dec j i) as [->|Hne]; + [rewrite Vector.nth_replace_eq; exact Hstuck + |rewrite Vector.nth_replace_neq by congruence; reflexivity]). + apply equ_guard_stuck. + unfold interp_schedule_rr at 1. + rewrite unfold_run_round_robin. + rewrite (schedule_focused_guard n (ts @ i := stuck) i stuck) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq. + rewrite interp_erase_guard, interp_state_tau; reflexivity. + Qed. + (** Keep one scheduler continuation fixed while interpreting a raw user event. *) Lemma interp_schedule_rr_user_bind (handler : E ~> stateT Σ (ictree F)) n (ts : pool E (S n)) @@ -150,3 +173,75 @@ Section RoundRobinInterpretation. End RoundRobinInterpretation. Arguments interp_schedule_rr {E F HE HF Σ} handler n ts focus cursor σ. + +(** ** Round-robin refinement preserves guard alignment *) +Section RoundRobinAlign. + Context {E : Type} {HE : Encode E} {X : Type}. + Local Typeclasses Transparent equ. + + Lemma run_round_robin_guards n (t : ictree E X) c : + run_round_robin (guards n t) c ≅ guards n (run_round_robin t c). + Proof. + induction n; cbn [guards]; [reflexivity|]. + rewrite unfold_run_round_robin; cbn [observe _observe]. + apply guard_equ_node; exact IHn. + Qed. + + Inductive rr_rel : ictree E X -> ictree E X -> Prop := + | rr_rel_at n m (t u : ictree E X) c T U : + galigned t u -> T ≅ guards n (run_round_robin t c) -> + U ≅ guards m (run_round_robin u c) -> rr_rel T U. + + Lemma rr_rel_step T U : rr_rel T U -> galignF rr_rel T U. + Proof. + intros [n m t u c T' U' A ET EU]. + destruct A as [t u a b t' u' Et Eu A|t u a b r Et Eu + |t u a b k kk kk' Et Eu Hk|t u a b e kk kk' Et Eu Hk]. + - apply (galignF_guard _ T' U' (n + a) (m + b) + (run_round_robin t' c) (run_round_robin u' c)). + + rewrite ET, Et, run_round_robin_guards, guards_shift; reflexivity. + + rewrite EU, Eu, run_round_robin_guards, guards_shift; reflexivity. + + apply (rr_rel_at 0 0 t' u' c); [exact A|reflexivity|reflexivity]. + - apply (galignF_ret _ T' U' (n + a) (m + b) r). + + rewrite ET, Et, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; reflexivity. + + rewrite EU, Eu, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; reflexivity. + - apply (galignF_guard _ T' U' (n + a) (m + b) + (run_round_robin (kk (rr_pick k c)) (S c)) + (run_round_robin (kk' (rr_pick k c)) (S c))). + + rewrite ET, Et, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; cbn [observe _observe]. + rewrite <- guards_guard; reflexivity. + + rewrite EU, Eu, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; cbn [observe _observe]. + rewrite <- guards_guard; reflexivity. + + apply (rr_rel_at 0 0 (kk (rr_pick k c)) (kk' (rr_pick k c)) (S c)); [apply Hk|reflexivity|reflexivity]. + - apply (galignF_vis _ T' U' (n + a) (m + b) e + (fun x => run_round_robin (kk x) c) (fun x => run_round_robin (kk' x) c)). + + rewrite ET, Et, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; reflexivity. + + rewrite EU, Eu, run_round_robin_guards, <- guards_add, + unfold_run_round_robin; reflexivity. + + intro x; apply (rr_rel_at 0 0 (kk x) (kk' x) c); [apply Hk|reflexivity|reflexivity]. + Qed. + + Lemma run_round_robin_galigned (t u : ictree E X) c : + galigned t u -> galigned (run_round_robin t c) (run_round_robin u c). + Proof. + intro H; apply (galigned_coind rr_rel rr_rel_step). + apply (rr_rel_at 0 0 t u c); [exact H|reflexivity|reflexivity]. + Qed. +End RoundRobinAlign. + +(** Guard-equivalent pools are bisimilar under round-robin scheduling, for + every focus, cursor and state. *) +Lemma interp_schedule_rr_guard_equ {E F : Type} {HE : Encode E} {HF : Encode F} {Σ : Type} + (handler : E ~> stateT Σ (ictree F)) n (ts us : pool E n) focus m σ : + pool_guard_equ ts us -> + interp_schedule_rr handler n ts focus m σ ~ interp_schedule_rr handler n us focus m σ. +Proof. + intro H; unfold interp_schedule_rr, interp_yield, interp_spawn. + apply galigned_sbisim, interp_state_galigned, interp_galigned, interp_galigned, + run_round_robin_galigned, schedule_galigned, H. +Qed. diff --git a/theories/ICTree/Interp/Yield/SBisim.v b/theories/ICTree/Interp/Yield/SBisim.v index 66a550c..262460d 100644 --- a/theories/ICTree/Interp/Yield/SBisim.v +++ b/theories/ICTree/Interp/Yield/SBisim.v @@ -1,4 +1,5 @@ -From Stdlib Require Import Fin Vector Program.Equality. +From Stdlib Require Import Fin Vector Program.Equality Arith.PeanoNat. +From Coinduction Require Import coinduction lattice tactics. From TICL Require Import ICTree.Core ICTree.Trans @@ -855,3 +856,598 @@ Section PoolGuardEqu. intros Eq H i; eapply guard_equ_trans; [apply guard_equ_equ, Eq|apply H]. Qed. End PoolGuardEqu. + +Local Typeclasses Transparent equ. + + +(** * Alignment up to finitely many leading guards. + + [galigned t u] relates two trees whose every node agrees, except that + each side may carry finitely many extra guards before a node. A pure + guard round consumes at least one guard on BOTH sides, so silent + divergence is only ever aligned with silent divergence. The relation is + preserved by the erasure and state interpreters, by round-robin + refinement, and by the scheduler on guard-equivalent pools, and it + implies strong bisimulation. *) + +Fixpoint guards {E} {HE : Encode E} {X} (n : nat) (t : ictree E X) : ictree E X := + match n with 0 => t | S n => Guard (guards n t) end. + +Section Guards. + Context {E : Type} {HE : Encode E} {X : Type}. + + Lemma guards_equ n (t u : ictree E X) : t ≅ u -> guards n t ≅ guards n u. + Proof. intro H; induction n; cbn [guards]; [exact H|apply guard_equ_node; exact IHn]. Qed. + + Lemma guards_add n m (t : ictree E X) : guards (n + m)%nat t = guards n (guards m t). + Proof. induction n; cbn [guards Nat.add]; [reflexivity|now rewrite IHn]. Qed. + + Lemma guards_guard n (t : ictree E X) : guards n (Guard t) = guards (S n) t. + Proof. induction n; cbn [guards]; [reflexivity|now rewrite IHn]. Qed. + + Lemma guards_trans n l (t u : ictree E X) : trans l t u -> trans l (guards n t) u. + Proof. intro H; induction n; cbn [guards]; [exact H|now apply trans_guard]. Qed. + + (** Guard prefixes are cancellative. *) + Lemma guards_cancel : forall b c (x y : ictree E X), + guards b x ≅ guards c y -> + (exists d, x ≅ guards d y /\ c = (b + d)%nat) \/ (exists d, y ≅ guards d x /\ b = (c + d)%nat). + Proof. + induction b as [|b IH]; intros c x y H. + - left; exists c; split; [exact H|reflexivity]. + - destruct c as [|c]. + + right; exists (S b); split; [symmetry; exact H|reflexivity]. + + cbn [guards] in H; apply equ_guard_invE in H. + destruct (IH c x y H) as [(d & Hd & ->)|(d & Hd & ->)]; + [left|right]; exists d; split; auto. + Qed. + + (** [guard_equ] is exactly "the same tree after finitely many guards". *) + Lemma guard_equ_guards (t u : ictree E X) : + guard_equ t u -> exists a b x, t ≅ guards a x /\ u ≅ guards b x. + Proof. + intro H; induction H as [t u [Eq|Eg]|t|t u H IH|t u v H1 IH1 H2 IH2]. + - exists 0, 0, u; split; [exact Eq|reflexivity]. + - exists 1, 0, u; split; [exact Eg|reflexivity]. + - exists 0, 0, t; split; reflexivity. + - destruct IH as (a & b & x & Ht & Hu); exists b, a, x; split; assumption. + - destruct IH1 as (a & b & x & Ht & Hu), IH2 as (c & d & y & Hu' & Hv). + assert (Hxy : guards b x ≅ guards c y) by (rewrite <- Hu, <- Hu'; reflexivity). + destruct (guards_cancel b c x y Hxy) as [(e & Hx & ->)|(e & Hy & ->)]. + + exists (a + e)%nat, d, y; split; [|exact Hv]. + rewrite Ht, (guards_equ a _ _ Hx), guards_add; reflexivity. + + exists a, (d + e)%nat, x; split; [exact Ht|]. + rewrite Hv, (guards_equ d _ _ Hy), guards_add; reflexivity. + Qed. +End Guards. + +CoInductive galigned {E} {HE : Encode E} {X} : ictree E X -> ictree E X -> Prop := +| galign_guard t u n m t' u' : + t ≅ guards (S n) t' -> u ≅ guards (S m) u' -> + galigned t' u' -> galigned t u +| galign_ret t u n m r : + t ≅ guards n (Ret r) -> u ≅ guards m (Ret r) -> galigned t u +| galign_br t u n m c (k k' : fin' c -> ictree E X) : + t ≅ guards n (Br c k) -> u ≅ guards m (Br c k') -> + (forall i, galigned (k i) (k' i)) -> galigned t u +| galign_vis t u n m (e : E) (k k' : encode e -> ictree E X) : + t ≅ guards n (Vis e k) -> u ≅ guards m (Vis e k') -> + (forall x, galigned (k x) (k' x)) -> galigned t u. + +Section GuardAlignment. + Context {E : Type} {HE : Encode E} {X : Type}. + + Lemma galigned_equ (t u a b : ictree E X) : + t ≅ a -> u ≅ b -> galigned t u -> galigned a b. + Proof. + intros Et Eu H; destruct H as + [t u n m t' u' El Er H|t u n m r El Er|t u n m c k k' El Er H + |t u n m e k k' El Er H]. + - eapply galign_guard; [rewrite <- Et; exact El|rewrite <- Eu; exact Er|exact H]. + - eapply galign_ret; [rewrite <- Et; exact El|rewrite <- Eu; exact Er]. + - eapply galign_br; [rewrite <- Et; exact El|rewrite <- Eu; exact Er|exact H]. + - eapply galign_vis; [rewrite <- Et; exact El|rewrite <- Eu; exact Er|exact H]. + Qed. + + Lemma galigned_sym : forall t u : ictree E X, galigned t u -> galigned u t. + Proof. + cofix IH; intros t u H; destruct H as + [t u n m t' u' El Er H|t u n m r El Er|t u n m c k k' El Er H + |t u n m e k k' El Er H]. + - eapply galign_guard; [exact Er|exact El|apply IH; exact H]. + - eapply galign_ret; [exact Er|exact El]. + - eapply galign_br; [exact Er|exact El|intro i; apply IH, H]. + - eapply galign_vis; [exact Er|exact El|intro x; apply IH, H]. + Qed. + + Lemma galigned_stuck : galigned (stuck : ictree E X) stuck. + Proof. + cofix IH. + apply (galign_guard stuck stuck 0 0 stuck stuck); + [exact unfold_stuck|exact unfold_stuck|exact IH]. + Qed. + + Lemma galigned_refl : forall t : ictree E X, galigned t t. + Proof. + cofix IH; intro t. + destruct (observe t) as [r|c k|g|e k] eqn:Ht. + - pose proof (observe_eq_equ t (Ret r) Ht) as Et. + apply (galign_ret _ _ 0 0 r); exact Et. + - pose proof (observe_eq_equ t (Br c k) Ht) as Et. + apply (galign_br _ _ 0 0 c k k); [exact Et|exact Et|intro i; apply IH]. + - pose proof (observe_eq_equ t (Guard g) Ht) as Et. + apply (galign_guard _ _ 0 0 g g); [exact Et|exact Et|apply IH]. + - pose proof (observe_eq_equ t (Vis e k) Ht) as Et. + apply (galign_vis _ _ 0 0 e k k); [exact Et|exact Et|intro x; apply IH]. + Qed. + + Local Ltac head_absurd H := step in H; cbn in H; inversion H. + + Lemma galigned_match l T U : + @trans_ E HE X l T U -> + forall u, galigned (go T) u -> + exists u', trans l u u' /\ galigned (go U) u'. + Proof. + intro TR; induction TR as + [l inner target TR IH + |c pick k result Eresult + |e k answer result Eresult + |result value Eresult]; intros u A. + - inversion A as + [left right n m tl tr El Er Hnext|left right n m r El Er + |left right n m c k k' El Er Hnext|left right n m e k k' El Er Hnext]; + subst; clear A. + + cbn [guards] in El; apply equ_guard_invE in El; destruct n as [|n]. + * cbn [guards] in El. + assert (Ai : galigned (go (observe inner)) tr). + { eapply galigned_equ; [|reflexivity|exact Hnext]. + transitivity inner; [symmetry; exact El|apply ictree_eta]. } + destruct (IH tr Ai) as (next & Tnext & Anext). + exists next; split; [rewrite Er; now apply guards_trans|exact Anext]. + * apply IH; eapply galigned_equ; [apply ictree_eta|reflexivity|]. + eapply galign_guard; eassumption. + + destruct n as [|n]; [head_absurd El|]. + cbn [guards] in El; apply equ_guard_invE in El. + apply IH; eapply galigned_equ; [apply ictree_eta|reflexivity|]. + eapply galign_ret; eassumption. + + destruct n as [|n]; [head_absurd El|]. + cbn [guards] in El; apply equ_guard_invE in El. + apply IH; eapply galigned_equ; [apply ictree_eta|reflexivity|]. + eapply galign_br; eassumption. + + destruct n as [|n]; [head_absurd El|]. + cbn [guards] in El; apply equ_guard_invE in El. + apply IH; eapply galigned_equ; [apply ictree_eta|reflexivity|]. + eapply galign_vis; eassumption. + - inversion A as + [left right n m tl tr El Er Hnext|left right n m r El Er + |left right n m c' kk kk' El Er Hnext|left right n m e kk kk' El Er Hnext]; + subst; clear A. + + head_absurd El. + + destruct n; head_absurd El. + + destruct n as [|n]; [|head_absurd El]. + cbn [guards] in El. + pose proof (equ_br_invT El) as Ec; subst c'. + pose proof (equ_br_invE El pick) as Ek. + exists (kk' pick); split. + * rewrite Er; apply guards_trans; eapply trans_br; reflexivity. + * eapply galigned_equ; [|reflexivity|exact (Hnext pick)]. + transitivity (k pick); [symmetry; exact Ek|]. + transitivity result; [exact Eresult|apply ictree_eta]. + + destruct n; head_absurd El. + - inversion A as + [left right n m tl tr El Er Hnext|left right n m r El Er + |left right n m c kk kk' El Er Hnext|left right n m e' kk kk' El Er Hnext]; + subst; clear A. + + head_absurd El. + + destruct n; head_absurd El. + + destruct n; head_absurd El. + + destruct n as [|n]; [|head_absurd El]. + cbn [guards] in El. + pose proof (equ_vis_invT El) as [_ Ee]; subst e'. + pose proof (equ_vis_invE El answer) as Ek. + exists (kk' answer); split. + * rewrite Er; apply guards_trans; apply trans_vis. + * eapply galigned_equ; [|reflexivity|exact (Hnext answer)]. + transitivity (k answer); [symmetry; exact Ek|]. + transitivity result; [exact Eresult|apply ictree_eta]. + - inversion A as + [left right n m tl tr El Er Hnext|left right n m r El Er + |left right n m c kk kk' El Er Hnext|left right n m e kk kk' El Er Hnext]; + subst; clear A. + + head_absurd El. + + destruct n as [|n]; [|head_absurd El]. + cbn [guards] in El; apply equ_ret_inv in El; subst r. + exists stuck; split. + * rewrite Er; apply guards_trans, trans_ret. + * eapply galigned_equ; [|reflexivity|exact galigned_stuck]. + transitivity result; [exact Eresult|apply ictree_eta]. + + destruct n; head_absurd El. + + destruct n; head_absurd El. + Qed. + + Lemma galigned_trans (t u next : ictree E X) l : + galigned t u -> trans l t next -> + exists other, trans l u other /\ galigned next other. + Proof. + intros A TR. + assert (Ae : galigned (go (observe t)) u). + { eapply galigned_equ; [apply ictree_eta|reflexivity|exact A]. } + destruct (galigned_match l (observe t) (observe next) TR u Ae) + as (other & To & Ao). + exists other; split; [exact To|]. + eapply galigned_equ; [symmetry; apply ictree_eta|reflexivity|exact Ao]. + Qed. + + Lemma galigned_sbisim : forall t u : ictree E X, galigned t u -> t ~ u. + Proof. + unfold sbisim; apply_coinduction; fold_sbisim. + intros R IH t u A; split; intros l next TR. + - destruct (galigned_trans t u next l A TR) as (other & To & Ao). + exists l, other; split; [exact To|]; split; [now apply IH|reflexivity]. + - destruct (galigned_trans u t next l (galigned_sym t u A) TR) + as (other & To & Ao). + exists l, other; split; [exact To|]; split. + + apply IH, galigned_sym; exact Ao. + + reflexivity. + Qed. +End GuardAlignment. + +(** ** A coinduction principle for guard alignment *) + +Inductive galignF {E} {HE : Encode E} {X} (R : ictree E X -> ictree E X -> Prop) + : ictree E X -> ictree E X -> Prop := +| galignF_guard t u n m t' u' : + t ≅ guards (S n) t' -> u ≅ guards (S m) u' -> R t' u' -> galignF R t u +| galignF_ret t u n m r : + t ≅ guards n (Ret r) -> u ≅ guards m (Ret r) -> galignF R t u +| galignF_br t u n m c (k k' : fin' c -> ictree E X) : + t ≅ guards n (Br c k) -> u ≅ guards m (Br c k') -> + (forall i, R (k i) (k' i)) -> galignF R t u +| galignF_vis t u n m (e : E) (k k' : encode e -> ictree E X) : + t ≅ guards n (Vis e k) -> u ≅ guards m (Vis e k') -> + (forall x, R (k x) (k' x)) -> galignF R t u. + +Lemma galigned_coind {E} {HE : Encode E} {X} (R : ictree E X -> ictree E X -> Prop) : + (forall t u, R t u -> galignF R t u) -> forall t u, R t u -> galigned t u. +Proof. + intro Hstep; cofix CIH; intros t u H. + destruct (Hstep t u H) as + [t u n m t' u' El Er H'|t u n m r El Er|t u n m c k k' El Er H' + |t u n m e k k' El Er H']. + - exact (galign_guard t u n m t' u' El Er (CIH t' u' H')). + - exact (galign_ret t u n m r El Er). + - exact (galign_br t u n m c k k' El Er (fun i => CIH (k i) (k' i) (H' i))). + - exact (galign_vis t u n m e k k' El Er (fun x => CIH (k x) (k' x) (H' x))). +Qed. + +#[global] Instance guards_proper {E} {HE : Encode E} {X} n : + Proper (equ eq ==> equ eq) (@guards E HE X n). +Proof. intros t u H; apply guards_equ, H. Qed. + +Lemma guards_shift {E} {HE : Encode E} {X} n a (t : ictree E X) : + guards n (guards (S a) t) = guards (S (n + a)) t. +Proof. rewrite <- guards_add, Nat.add_succ_r; reflexivity. Qed. + + +(** ** Interpretation preserves guard alignment *) +Section InterpAlign. + Context {E F : Type} {HE : Encode E} {HF : Encode F} (h : E ~> ictree F) {X : Type}. + + Lemma interp_guards n (t : ictree E X) : interp h (guards n t) ≅ guards n (interp h t). + Proof. + induction n; cbn [guards]; [reflexivity|]. + rewrite interp_guard_node; apply guard_equ_node; exact IHn. + Qed. + + Inductive interp_rel : ictree F X -> ictree F X -> Prop := + | interp_rel_tree n m (t u : ictree E X) T U : + galigned t u -> T ≅ guards n (interp h t) -> U ≅ guards m (interp h u) -> + interp_rel T U + | interp_rel_bind n m (A : Type) (a : ictree F A) (k k' : A -> ictree E X) T U : + (forall x, galigned (k x) (k' x)) -> + T ≅ guards n (a >>= fun x => Guard (interp h (k x))) -> + U ≅ guards m (a >>= fun x => Guard (interp h (k' x))) -> interp_rel T U. + + Lemma interp_rel_bind_step n m A (a : ictree F A) (k k' : A -> ictree E X) T U : + (forall x, galigned (k x) (k' x)) -> + T ≅ guards n (a >>= fun x => Guard (interp h (k x))) -> + U ≅ guards m (a >>= fun x => Guard (interp h (k' x))) -> galignF interp_rel T U. + Proof. + intros Hk ET EU. + destruct (observe a) as [x|c kk|g|e kk] eqn:Ha. + - pose proof (observe_eq_equ a (Ret x) Ha) as Ea. + apply (galignF_guard _ T U n m (interp h (k x)) (interp h (k' x))). + + rewrite ET, Ea, bind_ret_l, guards_guard; reflexivity. + + rewrite EU, Ea, bind_ret_l, guards_guard; reflexivity. + + apply (interp_rel_tree 0 0 (k x) (k' x)); [apply Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Br c kk) Ha) as Ea. + apply (galignF_br _ T U n m c (fun i => kk i >>= fun x => Guard (interp h (k x))) + (fun i => kk i >>= fun x => Guard (interp h (k' x)))). + + rewrite ET, Ea, bind_br; reflexivity. + + rewrite EU, Ea, bind_br; reflexivity. + + intro i; apply (interp_rel_bind 0 0 A (kk i) k k'); [exact Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Guard g) Ha) as Ea. + apply (galignF_guard _ T U n m (g >>= fun x => Guard (interp h (k x))) + (g >>= fun x => Guard (interp h (k' x)))). + + rewrite ET, Ea, bind_guard, guards_guard; reflexivity. + + rewrite EU, Ea, bind_guard, guards_guard; reflexivity. + + apply (interp_rel_bind 0 0 A g k k'); [exact Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Vis e kk) Ha) as Ea. + apply (galignF_vis _ T U n m e (fun y => kk y >>= fun x => Guard (interp h (k x))) + (fun y => kk y >>= fun x => Guard (interp h (k' x)))). + + rewrite ET, Ea, bind_vis; reflexivity. + + rewrite EU, Ea, bind_vis; reflexivity. + + intro y; apply (interp_rel_bind 0 0 A (kk y) k k'); [exact Hk|reflexivity|reflexivity]. + Qed. + + Lemma interp_rel_step T U : interp_rel T U -> galignF interp_rel T U. + Proof. + intros [n m t u T' U' A ET EU|n m B a k k' T' U' Hk ET EU]. + - destruct A as [t u a b t' u' Et Eu A|t u a b r Et Eu + |t u a b c kk kk' Et Eu Hk|t u a b e kk kk' Et Eu Hk]. + + apply (galignF_guard _ T' U' (n + a) (m + b) (interp h t') (interp h u')). + * rewrite ET, Et, interp_guards, guards_shift; reflexivity. + * rewrite EU, Eu, interp_guards, guards_shift; reflexivity. + * apply (interp_rel_tree 0 0 t' u'); [exact A|reflexivity|reflexivity]. + + apply (galignF_ret _ T' U' (n + a) (m + b) r). + * rewrite ET, Et, interp_guards, interp_ret_node, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_guards, interp_ret_node, <- guards_add; reflexivity. + + apply (galignF_br _ T' U' (n + a) (m + b) c + (fun i => Guard (interp h (kk i))) (fun i => Guard (interp h (kk' i)))). + * rewrite ET, Et, interp_guards, interp_br_node, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_guards, interp_br_node, <- guards_add; reflexivity. + * intro i; apply (interp_rel_tree 1 1 (kk i) (kk' i)); [apply Hk|reflexivity|reflexivity]. + + apply (interp_rel_bind_step (n + a) (m + b) _ (h e) kk kk' T' U' Hk). + * rewrite ET, Et, interp_guards, interp_vis_node, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_guards, interp_vis_node, <- guards_add; reflexivity. + - exact (interp_rel_bind_step n m B a k k' T' U' Hk ET EU). + Qed. + + Lemma interp_galigned (t u : ictree E X) : + galigned t u -> galigned (interp h t) (interp h u). + Proof. + intro H; apply (galigned_coind interp_rel interp_rel_step). + apply (interp_rel_tree 0 0 t u); [exact H|reflexivity|reflexivity]. + Qed. +End InterpAlign. + +(** ** State interpretation preserves guard alignment *) +Section InterpStateAlign. + Context {E F S : Type} {HE : Encode E} {HF : Encode F} + (h : E ~> stateT S (ictree F)) {X : Type}. + + Lemma interp_state_guards n (t : ictree E X) s : + interp_state h (guards n t) s ≅ guards n (interp_state h t s). + Proof. + induction n; cbn [guards]; [reflexivity|]. + rewrite interp_state_tau; apply guard_equ_node; exact IHn. + Qed. + + Inductive istate_rel : ictree F (X * S) -> ictree F (X * S) -> Prop := + | istate_rel_tree n m (t u : ictree E X) s T U : + galigned t u -> T ≅ guards n (interp_state h t s) -> + U ≅ guards m (interp_state h u s) -> istate_rel T U + | istate_rel_bind n m (A : Type) (a : ictree F (A * S)) (k k' : A -> ictree E X) T U : + (forall x, galigned (k x) (k' x)) -> + T ≅ guards n (a >>= fun '(x, s') => Guard (interp_state h (k x) s')) -> + U ≅ guards m (a >>= fun '(x, s') => Guard (interp_state h (k' x) s')) -> + istate_rel T U. + + Lemma istate_rel_bind_step n m A (a : ictree F (A * S)) (k k' : A -> ictree E X) T U : + (forall x, galigned (k x) (k' x)) -> + T ≅ guards n (a >>= fun '(x, s') => Guard (interp_state h (k x) s')) -> + U ≅ guards m (a >>= fun '(x, s') => Guard (interp_state h (k' x) s')) -> + galignF istate_rel T U. + Proof. + intros Hk ET EU. + destruct (observe a) as [[x s']|c kk|g|e kk] eqn:Ha. + - pose proof (observe_eq_equ a (Ret (x, s')) Ha) as Ea. + apply (galignF_guard _ T U n m (interp_state h (k x) s') (interp_state h (k' x) s')). + + rewrite ET, Ea, bind_ret_l; cbv beta iota; rewrite guards_guard; reflexivity. + + rewrite EU, Ea, bind_ret_l; cbv beta iota; rewrite guards_guard; reflexivity. + + apply (istate_rel_tree 0 0 (k x) (k' x) s'); [apply Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Br c kk) Ha) as Ea. + apply (galignF_br _ T U n m c + (fun i => kk i >>= fun '(x, s') => Guard (interp_state h (k x) s')) + (fun i => kk i >>= fun '(x, s') => Guard (interp_state h (k' x) s'))). + + rewrite ET, Ea, bind_br; reflexivity. + + rewrite EU, Ea, bind_br; reflexivity. + + intro i; apply (istate_rel_bind 0 0 A (kk i) k k'); [exact Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Guard g) Ha) as Ea. + apply (galignF_guard _ T U n m + (g >>= fun '(x, s') => Guard (interp_state h (k x) s')) + (g >>= fun '(x, s') => Guard (interp_state h (k' x) s'))). + + rewrite ET, Ea, bind_guard, guards_guard; reflexivity. + + rewrite EU, Ea, bind_guard, guards_guard; reflexivity. + + apply (istate_rel_bind 0 0 A g k k'); [exact Hk|reflexivity|reflexivity]. + - pose proof (observe_eq_equ a (Vis e kk) Ha) as Ea. + apply (galignF_vis _ T U n m e + (fun y => kk y >>= fun '(x, s') => Guard (interp_state h (k x) s')) + (fun y => kk y >>= fun '(x, s') => Guard (interp_state h (k' x) s'))). + + rewrite ET, Ea, bind_vis; reflexivity. + + rewrite EU, Ea, bind_vis; reflexivity. + + intro y; apply (istate_rel_bind 0 0 A (kk y) k k'); [exact Hk|reflexivity|reflexivity]. + Qed. + + Lemma istate_rel_step T U : istate_rel T U -> galignF istate_rel T U. + Proof. + intros [n m t u s T' U' A ET EU|n m B a k k' T' U' Hk ET EU]. + - destruct A as [t u a b t' u' Et Eu A|t u a b r Et Eu + |t u a b c kk kk' Et Eu Hk|t u a b e kk kk' Et Eu Hk]. + + apply (galignF_guard _ T' U' (n + a) (m + b) + (interp_state h t' s) (interp_state h u' s)). + * rewrite ET, Et, interp_state_guards, guards_shift; reflexivity. + * rewrite EU, Eu, interp_state_guards, guards_shift; reflexivity. + * apply (istate_rel_tree 0 0 t' u' s); [exact A|reflexivity|reflexivity]. + + apply (galignF_ret _ T' U' (n + a) (m + b) (r, s)). + * rewrite ET, Et, interp_state_guards, interp_state_ret, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_state_guards, interp_state_ret, <- guards_add; reflexivity. + + apply (galignF_br _ T' U' (n + a) (m + b) c + (fun i => Guard (interp_state h (kk i) s)) + (fun i => Guard (interp_state h (kk' i) s))). + * rewrite ET, Et, interp_state_guards, interp_state_br, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_state_guards, interp_state_br, <- guards_add; reflexivity. + * intro i; apply (istate_rel_tree 1 1 (kk i) (kk' i) s); + [apply Hk|reflexivity|reflexivity]. + + apply (istate_rel_bind_step (n + a) (m + b) _ (runStateT (h e) s) kk kk' T' U' Hk). + * rewrite ET, Et, interp_state_guards, interp_state_vis, <- guards_add; reflexivity. + * rewrite EU, Eu, interp_state_guards, interp_state_vis, <- guards_add; reflexivity. + - exact (istate_rel_bind_step n m B a k k' T' U' Hk ET EU). + Qed. + + Lemma interp_state_galigned (t u : ictree E X) s : + galigned t u -> galigned (interp_state h t s) (interp_state h u s). + Proof. + intro H; apply (galigned_coind istate_rel istate_rel_step). + apply (istate_rel_tree 0 0 t u s); [exact H|reflexivity|reflexivity]. + Qed. +End InterpStateAlign. + +(** ** The scheduler maps guard-equivalent pools to aligned trees *) +Section ScheduleAlign. + Context {E : Type} {HE : Encode E}. + + Lemma schedule_focus_guards : forall a N (ts : pool E (S N)) i (x : thread E), + (ts $ i) ≅ guards a x -> + schedule (S N) ts (Some i) ≅ guards a (schedule (S N) (ts @ i := x) (Some i)). + Proof. + induction a as [|a IH]; intros N ts i x Hx; cbn [guards] in *. + - apply schedule_pool_proper. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + + rewrite Vector.nth_replace_eq; exact Hx. + + rewrite Vector.nth_replace_neq by congruence; reflexivity. + - transitivity (schedule (S N) (ts @ i := Guard (guards a x)) (Some i)). + { apply schedule_pool_proper. + intro j; destruct (Fin.eq_dec j i) as [->|Hne]. + + rewrite Vector.nth_replace_eq; exact Hx. + + rewrite Vector.nth_replace_neq by congruence; reflexivity. } + rewrite (observe_eq_equ _ (Guard (schedule (S N) + ((ts @ i := Guard (guards a x)) @ i := guards a x) (Some i))) + (schedule_focused_guard N (ts @ i := Guard (guards a x)) i (guards a x) + ltac:(rewrite Vector.nth_replace_eq; reflexivity))). + rewrite Vector.replace_replace_eq. + apply guard_equ_node. + rewrite (IH N (ts @ i := guards a x) i x) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. + Qed. + + Lemma observe_equ_go {F} {HF : Encode F} {X} (t : ictree F X) ot : + observe t = ot -> t ≅ go ot. + Proof. intro H; apply observe_eq_equ; exact H. Qed. + + Lemma pool_guard_equ_replace {N} (ts us : pool E N) i x : + pool_guard_equ ts us -> pool_guard_equ (ts @ i := x) (us @ i := x). + Proof. + unfold pool_guard_equ; intros H; apply vector_replace_pointwise; [intros j _; apply H|reflexivity]. + Qed. + + Lemma pool_guard_equ_remove {N} (ts us : pool E (S N)) i : + pool_guard_equ ts us -> pool_guard_equ (ts -- i) (us -- i). + Proof. unfold pool_guard_equ; intros H; apply vector_remove_pointwise; intros j _; apply H. Qed. + + Lemma pool_guard_equ_cons {N} x (ts us : pool E N) : + pool_guard_equ ts us -> pool_guard_equ (x :: ts) (x :: us). + Proof. unfold pool_guard_equ; intros H; apply vector_cons_pointwise; [reflexivity|exact H]. Qed. + + Inductive sched_rel : completed E -> completed E -> Prop := + | sched_rel_at n m N (ts us : pool E N) f T U : + pool_guard_equ ts us -> + T ≅ guards n (schedule N ts f) -> U ≅ guards m (schedule N us f) -> + sched_rel T U + | sched_rel_pick n m N (ts us : pool E (S N)) T U : + pool_guard_equ ts us -> + T ≅ guards n (Br N (fun i => schedule (S N) ts (Some i))) -> + U ≅ guards m (Br N (fun i => schedule (S N) us (Some i))) -> + sched_rel T U. + + Lemma sched_rel_step T U : sched_rel T U -> galignF sched_rel T U. + Proof. + intros [n m N ts us f T' U' Hp ET EU|n m N ts us T' U' Hp ET EU]. + 2: { apply (galignF_br _ T' U' n m N + (fun i => schedule (S N) ts (Some i)) (fun i => schedule (S N) us (Some i))); + [exact ET|exact EU|]. + intro i; apply (sched_rel_at 0 0 (S N) ts us (Some i)); [exact Hp|reflexivity|reflexivity]. } + destruct f as [i|]. + 2: { destruct N as [|N]. + - apply (galignF_ret _ T' U' n m tt). + + rewrite ET, (observe_eq_equ _ (Ret tt) (schedule_empty_none ts)); reflexivity. + + rewrite EU, (observe_eq_equ _ (Ret tt) (schedule_empty_none us)); reflexivity. + - apply (galignF_vis _ T' U' n m (inl Yield) + (fun _ => Br N (fun i => schedule (S N) ts (Some i))) + (fun _ => Br N (fun i => schedule (S N) us (Some i)))). + + rewrite ET, (observe_equ_go _ _ (schedule_no_focus_nonempty N ts)); reflexivity. + + rewrite EU, (observe_equ_go _ _ (schedule_no_focus_nonempty N us)); reflexivity. + + intros _; apply (sched_rel_pick 0 0 N ts us); [exact Hp|reflexivity|reflexivity]. } + destruct N as [|N]; [inversion i|]. + destruct (guard_equ_guards _ _ (Hp i)) as (a & b & x & Ea & Eb). + pose proof (pool_guard_equ_replace ts us i x Hp) as Hp'. + set (ts' := ts @ i := x) in *; set (us' := us @ i := x) in *. + assert (ET' : T' ≅ guards (n + a) (schedule (S N) ts' (Some i))) + by (rewrite ET, (schedule_focus_guards a N ts i x Ea), <- guards_add; reflexivity). + assert (EU' : U' ≅ guards (m + b) (schedule (S N) us' (Some i))) + by (rewrite EU, (schedule_focus_guards b N us i x Eb), <- guards_add; reflexivity). + assert (Hts : observe (ts' $ i) = observe x) by (unfold ts'; now rewrite Vector.nth_replace_eq). + assert (Hus : observe (us' $ i) = observe x) by (unfold us'; now rewrite Vector.nth_replace_eq). + clearbody ts' us'; clear ET EU. + destruct (observe x) as [[]|c k|y|e k] eqn:Hx. + - apply (galignF_guard _ T' U' (n + a) (m + b) + (schedule N (ts' -- i) None) (schedule N (us' -- i) None)). + + rewrite ET', (observe_equ_go _ _ (schedule_focused_ret N ts' i Hts)); rewrite <- guards_guard; reflexivity. + + rewrite EU', (observe_equ_go _ _ (schedule_focused_ret N us' i Hus)); rewrite <- guards_guard; reflexivity. + + apply (sched_rel_at 0 0 N (ts' -- i) (us' -- i) None); + [apply pool_guard_equ_remove, Hp'|reflexivity|reflexivity]. + - apply (galignF_br _ T' U' (n + a) (m + b) c + (fun j => schedule (S N) (ts' @ i := k j) (Some i)) + (fun j => schedule (S N) (us' @ i := k j) (Some i))). + + rewrite ET', (observe_equ_go _ _ (schedule_focused_br N ts' i c k Hts)); reflexivity. + + rewrite EU', (observe_equ_go _ _ (schedule_focused_br N us' i c k Hus)); reflexivity. + + intro j; eapply (sched_rel_at 0 0 (S N) _ _ (Some i)); + [|cbn [guards]; reflexivity|cbn [guards]; reflexivity]; apply pool_guard_equ_replace, Hp'. + - apply (galignF_guard _ T' U' (n + a) (m + b) + (schedule (S N) (ts' @ i := y) (Some i)) (schedule (S N) (us' @ i := y) (Some i))). + + rewrite ET', (observe_equ_go _ _ (schedule_focused_guard N ts' i y Hts)); rewrite <- guards_guard; reflexivity. + + rewrite EU', (observe_equ_go _ _ (schedule_focused_guard N us' i y Hus)); rewrite <- guards_guard; reflexivity. + + eapply (sched_rel_at 0 0 (S N) _ _ (Some i)); + [|cbn [guards]; reflexivity|cbn [guards]; reflexivity]; apply pool_guard_equ_replace, Hp'. + - destruct e as [[]|[[]|e']]. + + apply (galignF_guard _ T' U' (n + a) (m + b) + (schedule (S N) (ts' @ i := k tt) None) (schedule (S N) (us' @ i := k tt) None)). + * rewrite ET', (observe_equ_go _ _ (schedule_focused_yield N ts' i k Hts)); rewrite <- guards_guard; reflexivity. + * rewrite EU', (observe_equ_go _ _ (schedule_focused_yield N us' i k Hus)); rewrite <- guards_guard; reflexivity. + * eapply (sched_rel_at 0 0 (S N) _ _ None); + [|cbn [guards]; reflexivity|cbn [guards]; reflexivity]; + apply pool_guard_equ_replace, Hp'. + + apply (galignF_vis _ T' U' (n + a) (m + b) (inr (inl Spawn)) + (fun _ => schedule (S (S N)) (k true :: (ts' @ i := k false)) (Some (Fin.FS i))) + (fun _ => schedule (S (S N)) (k true :: (us' @ i := k false)) (Some (Fin.FS i)))). + * rewrite ET', (observe_equ_go _ _ (schedule_focused_fork N ts' i k Hts)); reflexivity. + * rewrite EU', (observe_equ_go _ _ (schedule_focused_fork N us' i k Hus)); reflexivity. + * intros _; eapply (sched_rel_at 0 0 (S (S N)) _ _ (Some (Fin.FS i))); + [|cbn [guards]; reflexivity|cbn [guards]; reflexivity]; apply pool_guard_equ_cons, pool_guard_equ_replace, Hp'. + + apply (galignF_vis _ T' U' (n + a) (m + b) (inr (inr e')) + (fun z => schedule (S N) (ts' @ i := k z) (Some i)) + (fun z => schedule (S N) (us' @ i := k z) (Some i))). + * rewrite ET', (observe_equ_go _ _ (schedule_focused_user_event N ts' i e' k Hts)); reflexivity. + * rewrite EU', (observe_equ_go _ _ (schedule_focused_user_event N us' i e' k Hus)); reflexivity. + * intro z; eapply (sched_rel_at 0 0 (S N) _ _ (Some i)); + [|cbn [guards]; reflexivity|cbn [guards]; reflexivity]; apply pool_guard_equ_replace, Hp'. + Qed. + + Lemma schedule_galigned N (ts us : pool E N) f : + pool_guard_equ ts us -> galigned (schedule N ts f) (schedule N us f). + Proof. + intro H; apply (galigned_coind sched_rel sched_rel_step). + apply (sched_rel_at 0 0 N ts us f); [exact H|reflexivity|reflexivity]. + Qed. + + (** The erased scheduled view of guard-equivalent pools is aligned. *) + Lemma erased_schedule_galigned N (ts us : pool E N) f : + pool_guard_equ ts us -> + galigned (interp_yield (interp_spawn (schedule N ts f))) + (interp_yield (interp_spawn (schedule N us f))). + Proof. + intro H; unfold interp_yield, interp_spawn. + apply interp_galigned, interp_galigned, schedule_galigned, H. + Qed. +End ScheduleAlign. diff --git a/theories/ICTree/Interp/Yield/Segments.v b/theories/ICTree/Interp/Yield/Segments.v index 09c93dc..602b9bb 100644 --- a/theories/ICTree/Interp/Yield/Segments.v +++ b/theories/ICTree/Interp/Yield/Segments.v @@ -759,3 +759,56 @@ Section ExactRoundRobinPrefix. replace_pool_equ; [apply pool_equ_refl|exact Eout]. Qed. End ExactRoundRobinPrefix. + + +(** ** Closed turns. + + A focused first-yield segment that returns its slot to the SAME thread + (up to finitely many leading guards) leaves the same pool behind: + the focused interpreted pool is its logs followed by the unfocused pool + at the final state. *) +Section SegmentPoolLoop. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)). + + Notation Rexact := (fun X (t u : ictreeW W X) => t ≅ u). + Notation Rsb := (fun X (t u : ictreeW W X) => t ~ u). + + Local Lemma closed_pool_guard_equ {n} (ts : pool E n) i residual : + guard_equ residual (ts $ i) -> pool_guard_equ (ts @ i := residual) ts. + Proof. + intros Htail j; destruct (Fin.eq_dec j i) as [->|Hne]. + - rewrite Vector.nth_replace_eq; exact Htail. + - rewrite Vector.nth_replace_neq by congruence; reflexivity. + Qed. + + Lemma segment_pool_nd_loop n (ts : pool E (S n)) (i : Fin.t (S n)) + sigma logs sigma' : + segment_to handler Rexact (ts $ i) sigma logs (ts $ i) sigma' -> + interp_schedule_nd handler (S n) ts (Some i) sigma ~ + emit_list logs (interp_schedule_nd handler (S n) ts None sigma'). + Proof. + intros (residual & Hseg & Htail). + etransitivity. + - apply (segment_interp_nd handler Rsb (fun Y t u (H : t ~ u) => H)). + exact (ThreadSegment_mono handler Rexact Rsb (fun Y t u => equ_sbisim t u) + _ _ _ _ _ Hseg). + - apply emit_list_sbisim, interp_schedule_nd_guard_equ. + apply closed_pool_guard_equ, Htail. + Qed. + + Lemma segment_pool_rr_loop n (ts : pool E (S n)) (i : Fin.t (S n)) + m sigma logs sigma' : + segment_to handler Rexact (ts $ i) sigma logs (ts $ i) sigma' -> + interp_schedule_rr handler (S n) ts (Some i) m sigma ~ + emit_list logs (interp_schedule_rr handler (S n) ts None m sigma'). + Proof. + intros (residual & Hseg & Htail). + etransitivity. + - apply (segment_interp_rr handler Rsb (fun Y t u (H : t ~ u) => H)). + exact (ThreadSegment_mono handler Rexact Rsb (fun Y t u => equ_sbisim t u) + _ _ _ _ _ Hseg). + - apply emit_list_sbisim, interp_schedule_rr_guard_equ. + apply closed_pool_guard_equ, Htail. + Qed. +End SegmentPoolLoop. diff --git a/theories/ICTree/Logic/Yield.v b/theories/ICTree/Logic/Yield.v index dd53301..5511807 100644 --- a/theories/ICTree/Logic/Yield.v +++ b/theories/ICTree/Logic/Yield.v @@ -5,7 +5,10 @@ From Stdlib Require Import Classes.RelationPairs Fin Vector - Program.Equality. + Program.Equality + Wellfounded.Inverse_Image. + +From Coinduction Require Import coinduction. From ExtLib Require Import Data.Option. @@ -21,7 +24,12 @@ From TICL Require Import ICTree.Interp.State.Mod ICTree.Interp.Yield.Mod ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Yield.RoundRobin + ICTree.Interp.Yield.Segments ICTree.Interp.Yield.Execution + ICTree.Trace + ICTree.Logic.Trans + ICTree.Logic.AG ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.Bind @@ -47,6 +55,100 @@ Local Open Scope ticl_scope. [interp_schedule_nd h_stateW], so the modal rules below only combine those equations with the tree-level [AX]/[AN]/log rules. *) +(** ** Rules for raw threads under an arbitrary state handler. *) +Section ThreadStateRules. + Context {E W S : Type} {HE : Encode E} (h : E ~> stateT S (ictreeW W)). + + Lemma axr_ithread_ret {X} : forall (r : X) (s : S) w R, + not_done w -> + R (r, s) w -> + <[ {interp_state h (interp_thread (Ret r : ictree (yieldE + (forkE + E)) X)) s}, + w |= AX done R ]>. + Proof with eauto with ticl. + intros r s w R Hnd HR. + rewrite interp_state_thread_ret. + apply axr_ret... + Qed. + + Lemma anr_ithread_bind_r_eq {A B} : + forall (t : ictree (yieldE + (forkE + E)) A) + (k : A -> ictree (yieldE + (forkE + E)) B) + (s s' : S) (r : A) w w' φ ψ, + <[ {interp_state h (interp_thread t) s}, w |= φ AN done= {(r, s')} w' ]> -> + <[ {interp_state h (interp_thread (k r)) s'}, w' |= φ AN ψ ]> -> + <[ {interp_state h (interp_thread (x <- t ;; k x)) s}, w |= φ AN ψ ]>. + Proof. + intros t k s s' r w w' φ ψ Ht Hk. + rewrite interp_state_thread_bind. + eapply anr_bind_r_eq; eauto. + Qed. + + Lemma aur_ithread_bind_r_eq {A B} : + forall (t : ictree (yieldE + (forkE + E)) A) + (k : A -> ictree (yieldE + (forkE + E)) B) + (s s' : S) (r : A) w w' φ ψ, + <[ {interp_state h (interp_thread t) s}, w |= φ AU AX done= {(r, s')} w' ]> -> + <[ {interp_state h (interp_thread (k r)) s'}, w' |= φ AU ψ ]> -> + <[ {interp_state h (interp_thread (x <- t ;; k x)) s}, w |= φ AU ψ ]>. + Proof. + intros t k s s' r w w' φ ψ Ht Hk. + rewrite interp_state_thread_bind. + eapply aur_bind_r_eq; eauto. + Qed. + + Lemma aul_ithread_bind_r_eq {A B} : + forall (t : ictree (yieldE + (forkE + E)) A) + (k : A -> ictree (yieldE + (forkE + E)) B) + (s s' : S) (r : A) w w' φ ψ, + <[ {interp_state h (interp_thread t) s}, w |= φ AU AX done= {(r, s')} w' ]> -> + <( {interp_state h (interp_thread (k r)) s'}, w' |= φ AU ψ )> -> + <( {interp_state h (interp_thread (x <- t ;; k x)) s}, w |= φ AU ψ )>. + Proof. + intros t k s s' r w w' φ ψ Ht Hk. + rewrite interp_state_thread_bind. + eapply aul_bind_r_eq; eauto. + Qed. +End ThreadStateRules. + +(** ** Singleton scheduler rules under an arbitrary state handler. *) +Section ScheduleStateRules. + Context {E W S : Type} {HE : Encode E} (h : E ~> stateT S (ictreeW W)). + + Lemma axr_schedule_nd_ret : forall (s : S) w R, + not_done w -> + R (tt, s) w -> + <[ {interp_schedule_nd h 1 [(Ret tt : thread E)]%vector (Some Fin.F1) s}, + w |= AX done R ]>. + Proof with eauto with ticl. + intros s w R Hnd HR. + rewrite (interp_schedule_nd_ret h 0 [(Ret tt : thread E)]%vector Fin.F1 s eq_refl). + rewrite interp_schedule_nd_empty. + apply axr_ret... + Qed. + + Lemma axax_schedule_nd_yield : forall (s : S) w R, + not_done w -> + R (tt, s) w -> + <[ {interp_schedule_nd h 1 + [Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => Ret tt)]%vector + (Some Fin.F1) s}, w |= AX AX done R ]>. + Proof with eauto with ticl. + intros s w R Hnd HR. + rewrite (interp_schedule_nd_yield h 0 + [Vis ((inl Yield) : yieldE + (forkE + E)) (fun _ : unit => Ret tt)]%vector + Fin.F1 (fun _ : unit => (Ret tt : thread E)) s eq_refl). + rewrite interp_schedule_nd_select. + apply anr_br; split. + - csplit... + - intro i; dependent destruction i. + + rewrite (interp_schedule_nd_ret h 0 _ Fin.F1 s) + by (now rewrite Vector.nth_replace_eq). + rewrite interp_schedule_nd_empty. + apply axr_ret... + + inversion i. + Qed. +End ScheduleStateRules. + (** ** Raw thread rules. *) (** A finished raw thread terminates in one step with the unchanged state. *) @@ -54,11 +156,7 @@ Lemma axr_thread_ret {Σ X} : forall (r : X) (σ : Σ) w R, not_done w -> R (r, σ) w -> <[ {instr_thread (Ret r) σ}, w |= AX done R ]>. -Proof with eauto with ticl. - intros r σ w R Hnd HR. - rewrite instr_thread_ret. - apply axr_ret... -Qed. +Proof. exact (axr_ithread_ret h_stateW). Qed. (** Sequential composition of raw threads, suffix [AN]. *) Lemma anr_thread_bind_r_eq {Σ A B} : @@ -68,11 +166,7 @@ Lemma anr_thread_bind_r_eq {Σ A B} : <[ {instr_thread t σ}, w |= φ AN done= {(r, σ')} w' ]> -> <[ {instr_thread (k r) σ'}, w' |= φ AN ψ ]> -> <[ {instr_thread (x <- t ;; k x) σ}, w |= φ AN ψ ]>. -Proof. - intros t k σ σ' r w w' φ ψ Ht Hk. - rewrite instr_thread_bind. - eapply anr_bind_r_eq; eauto. -Qed. +Proof. exact (anr_ithread_bind_r_eq h_stateW). Qed. (** Sequential composition of raw threads, suffix [AU]. *) Lemma aur_thread_bind_r_eq {Σ A B} : @@ -82,11 +176,7 @@ Lemma aur_thread_bind_r_eq {Σ A B} : <[ {instr_thread t σ}, w |= φ AU AX done= {(r, σ')} w' ]> -> <[ {instr_thread (k r) σ'}, w' |= φ AU ψ ]> -> <[ {instr_thread (x <- t ;; k x) σ}, w |= φ AU ψ ]>. -Proof. - intros t k σ σ' r w w' φ ψ Ht Hk. - rewrite instr_thread_bind. - eapply aur_bind_r_eq; eauto. -Qed. +Proof. exact (aur_ithread_bind_r_eq h_stateW). Qed. (** Sequential composition of raw threads, prefix [AU]. *) Lemma aul_thread_bind_r_eq {Σ A B} : @@ -96,11 +186,7 @@ Lemma aul_thread_bind_r_eq {Σ A B} : <[ {instr_thread t σ}, w |= φ AU AX done= {(r, σ')} w' ]> -> <( {instr_thread (k r) σ'}, w' |= φ AU ψ )> -> <( {instr_thread (x <- t ;; k x) σ}, w |= φ AU ψ )>. -Proof. - intros t k σ σ' r w w' φ ψ Ht Hk. - rewrite instr_thread_bind. - eapply aul_bind_r_eq; eauto. -Qed. +Proof. exact (aul_ithread_bind_r_eq h_stateW). Qed. (** A raw state update [σ ↦ f σ] leaves exactly one [Log] observation and then returns [r]; suffix [AU] version. *) @@ -156,15 +242,7 @@ Lemma axr_schedule_ret {Σ} : forall (σ : Σ) w R, <[ {instr_schedule 1 [(Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)]%vector (Some Fin.F1) σ}, w |= AX done R ]>. -Proof with eauto with ticl. - intros σ w R Hnd HR. - rewrite (interp_schedule_nd_ret h_stateW 0 - [(Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)]%vector - Fin.F1 σ eq_refl - : instr_schedule 1 _ (Some Fin.F1) σ ~ _). - rewrite interp_schedule_nd_empty. - apply axr_ret... -Qed. +Proof. exact (axr_schedule_nd_ret h_stateW). Qed. (** A cooperative [Yield] in a singleton pool costs two steps: the scheduler emits the scheduling point and then chooses the (single) runnable slot. *) @@ -175,25 +253,7 @@ Lemma axax_schedule_yield {Σ} : forall (σ : Σ) w R, [Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) (fun _ : unit => Ret tt)]%vector (Some Fin.F1) σ}, w |= AX AX done R ]>. -Proof with eauto with ticl. - intros σ w R Hnd HR. - rewrite (interp_schedule_nd_yield h_stateW 0 - [Vis ((inl Yield) : yieldE + (forkE + stateE Σ)) - (fun _ : unit => Ret tt)]%vector - Fin.F1 - (fun _ : unit => (Ret tt : ictree (yieldE + (forkE + stateE Σ)) unit)) - σ eq_refl - : instr_schedule 1 _ (Some Fin.F1) σ ~ _). - rewrite interp_schedule_nd_select. - apply anr_br; split. - - csplit... - - intro i; dependent destruction i. - + rewrite (interp_schedule_nd_ret h_stateW 0 _ Fin.F1 σ) - by (now rewrite Vector.nth_replace_eq). - rewrite interp_schedule_nd_empty. - apply axr_ret... - + inversion i. -Qed. +Proof. exact (axax_schedule_nd_yield h_stateW). Qed. (** A scheduled singleton state update leaves exactly one [Log]; suffix [AU]. *) Lemma aur_schedule_update {Σ} : @@ -282,3 +342,164 @@ Section ModelRRRecurrence. exact (emit_batches_agaf batch next Inv rank P Hnext Hnonempty Hprogress i w Hi Hd). Qed. End ModelRRRecurrence. + + +(** ** Structural invariance and eventuality over yielding pools. + + A pool of threads, each of which -- from every invariant state -- closes + an exact, finite turn with exactly one observation and returns to the + same thread, satisfies [AG] of any formula holding at all invariant + configurations ([ClosedTurns]); if moreover every turn either emits a + target observation or decreases a well-founded rank of ghost data + ([RankedTurns]), then [AF] of the target holds. The nondeterministic + rules require this of EVERY selectable slot: no fair selection is + assumed. The certificates live in [Prop]; no choice function over the + ghost witnesses is used. *) +Section PoolRules. + Context {E W Sigma : Type} {HE : Encode E} + (handler : E ~> stateT Sigma (ictreeW W)). + + Notation exactW := (fun X (t u : ictreeW W X) => t ≅ u). + + Definition ClosedTurns {G n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) : Prop := + forall g sigma (i : Fin.t (S n)), Inv g sigma -> + exists g' sigma' o, + segment_to handler exactW (ts $ i) sigma (List.cons o List.nil) (ts $ i) sigma' /\ + Inv g' sigma'. + + Definition RankedTurns {G V n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) (rank : G -> V) + (ltV : V -> V -> Prop) (P : W -> Prop) : Prop := + forall g sigma (i : Fin.t (S n)), Inv g sigma -> + exists g' sigma' o, + segment_to handler exactW (ts $ i) sigma (List.cons o List.nil) (ts $ i) sigma' /\ + Inv g' sigma' /\ (P o \/ ltV (rank g') (rank g)). + + Lemma ranked_turns_closed {G V n} (ts : pool E (S n)) Inv (rank : G -> V) ltV P : + RankedTurns ts Inv rank ltV P -> ClosedTurns ts Inv. + Proof. + intros H g sigma i Hinv. + destruct (H g sigma i Hinv) as (g' & sigma' & o & Hseg & Hinv' & _). + exists g', sigma', o; split; assumption. + Qed. + + Local Lemma log_vis {X} (o : W) (k : ictreeW W X) : + emit_list (List.cons o List.nil) k ≅ Vis (Log o) (fun _ => k). + Proof. + cbn [emit_list List.fold_right]; unfold log, ICtree.trigger. + rewrite bind_vis; apply vis_equ_node; intros []; apply bind_ret_l. + Qed. + + Lemma ag_pool_nd_invariance {G n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) (φ : ticllW W) : + ClosedTurns ts Inv -> + (forall g sigma focus w, Inv g sigma -> not_done w -> + <( {interp_schedule_nd handler (S n) ts focus sigma}, {w} |= φ )>) -> + forall g sigma focus w, Inv g sigma -> not_done w -> + <( {interp_schedule_nd handler (S n) ts focus sigma}, {w} |= AG φ )>. + Proof. + intros Hclosed Hφ. + coinduction R CIH; intros g sigma focus w Hinv Hw. + pose proof (Hφ g sigma focus w Hinv Hw) as Hnow. + destruct focus as [i|]. + - destruct (Hclosed g sigma i Hinv) as (g' & sigma' & o & Hseg & Hinv'). + rewrite (segment_pool_nd_loop handler n ts i sigma (List.cons o List.nil) sigma' Hseg), + log_vis in Hnow |- *. + split; [exact Hnow|]; split. + + apply can_step_vis; [exact tt|exact Hw]. + + intros t' w' Htr. + apply ktrans_vis in Htr as ([] & -> & <- & _). + apply (CIH g' sigma' None); [exact Hinv'|constructor]. + - rewrite (interp_schedule_nd_select handler) in Hnow |- *. + split; [exact Hnow|]; split. + + apply can_step_br; exact Hw. + + intros t' w' Htr. + apply ktrans_br in Htr as (i & -> & <- & _). + apply (CIH g sigma (Some i)); assumption. + Qed. + + Lemma ag_pool_rr_invariance {G n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) (φ : ticllW W) : + ClosedTurns ts Inv -> + (forall g sigma focus cursor w, Inv g sigma -> not_done w -> + <( {interp_schedule_rr handler (S n) ts focus cursor sigma}, {w} |= φ )>) -> + forall g sigma focus cursor w, Inv g sigma -> not_done w -> + <( {interp_schedule_rr handler (S n) ts focus cursor sigma}, {w} |= AG φ )>. + Proof. + intros Hclosed Hφ. + coinduction R CIH; intros g sigma focus cursor w Hinv Hw. + pose proof (Hφ g sigma focus cursor w Hinv Hw) as Hnow. + destruct focus as [i|]; + [|rewrite (interp_schedule_rr_select handler n ts cursor sigma) in Hnow |- *]. + all: lazymatch goal with + | |- context [interp_schedule_rr _ _ _ (Some ?j) ?c ?s] => + destruct (Hclosed g s j Hinv) as (g' & sigma' & o & Hseg & Hinv'); + rewrite (segment_pool_rr_loop handler n ts j c s (List.cons o List.nil) sigma' Hseg), + log_vis in Hnow |- *; + split; [exact Hnow|]; split; + [apply can_step_vis; [exact tt|exact Hw] + |intros t' w' Htr; + apply ktrans_vis in Htr as ([] & -> & <- & _); + apply (CIH g' sigma' None c); [exact Hinv'|constructor]] + end. + Qed. + + Lemma aul_pool_nd_eventually {G V n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) (rank : G -> V) + (ltV : V -> V -> Prop) (P : W -> Prop) : + well_founded ltV -> RankedTurns ts Inv rank ltV P -> + forall g sigma focus w, Inv g sigma -> not_done w -> + <( {interp_schedule_nd handler (S n) ts focus sigma}, {w} |= AF visW {P} )>. + Proof. + intros Hwf Hranked g. + induction g as [g IH] using + (well_founded_induction (wf_inverse_image G V ltV rank Hwf)). + intros sigma focus w Hinv Hw. + assert (Hsome : forall i w, not_done w -> + <( {interp_schedule_nd handler (S n) ts (Some i) sigma}, {w} |= AF visW {P} )>). + { intros i w0 Hw0. + destruct (Hranked g sigma i Hinv) as (g' & sigma' & o & Hseg & Hinv' & [HP|Hlt]). + - rewrite (segment_pool_nd_loop handler n ts i sigma (List.cons o List.nil) sigma' Hseg). + cbn [emit_list List.fold_right]. + apply afl_log; [exact Hw0|]. + cleft; apply ticll_vis; constructor; exact HP. + - rewrite (segment_pool_nd_loop handler n ts i sigma (List.cons o List.nil) sigma' Hseg). + cbn [emit_list List.fold_right]. + apply afl_log; [exact Hw0|]. + apply (IH g' Hlt sigma' None); [exact Hinv'|constructor]. } + destruct focus as [i|]; [apply Hsome, Hw|]. + rewrite (interp_schedule_nd_select handler). + apply aul_br; right; split. + - apply ticll_top; exact Hw. + - intro i; apply Hsome, Hw. + Qed. + + Lemma aul_pool_rr_eventually {G V n} (ts : pool E (S n)) + (Inv : G -> Sigma -> Prop) (rank : G -> V) + (ltV : V -> V -> Prop) (P : W -> Prop) : + well_founded ltV -> RankedTurns ts Inv rank ltV P -> + forall g sigma focus cursor w, Inv g sigma -> not_done w -> + <( {interp_schedule_rr handler (S n) ts focus cursor sigma}, {w} |= AF visW {P} )>. + Proof. + intros Hwf Hranked g. + induction g as [g IH] using + (well_founded_induction (wf_inverse_image G V ltV rank Hwf)). + intros sigma focus cursor w Hinv Hw. + assert (Hsome : forall i c w, not_done w -> + <( {interp_schedule_rr handler (S n) ts (Some i) c sigma}, {w} |= AF visW {P} )>). + { intros i c w0 Hw0. + destruct (Hranked g sigma i Hinv) as (g' & sigma' & o & Hseg & Hinv' & [HP|Hlt]). + - rewrite (segment_pool_rr_loop handler n ts i c sigma (List.cons o List.nil) sigma' Hseg). + cbn [emit_list List.fold_right]. + apply afl_log; [exact Hw0|]. + cleft; apply ticll_vis; constructor; exact HP. + - rewrite (segment_pool_rr_loop handler n ts i c sigma (List.cons o List.nil) sigma' Hseg). + cbn [emit_list List.fold_right]. + apply afl_log; [exact Hw0|]. + apply (IH g' Hlt sigma' None c); [exact Hinv'|constructor]. } + destruct focus as [i|]; [apply Hsome, Hw|]. + rewrite (interp_schedule_rr_select handler n ts cursor sigma). + apply Hsome, Hw. + Qed. +End PoolRules. diff --git a/theories/Lang/CSL/Mod.v b/theories/Lang/CSL/Mod.v index 1c64ec4..2e7adbf 100644 --- a/theories/Lang/CSL/Mod.v +++ b/theories/Lang/CSL/Mod.v @@ -1,16 +1,28 @@ (** * The canonical CSL source language. - Syntax ([CProg]), its denotation into threads over the CSL effects, the - source-instruction execution equations under both schedulers, the - exact first-yield segment rules, and the structural Ticl rules stated over - source programs. Every law here specializes an effect-level law of - [ICTree.Interp.CSL.Mod]. *) + Syntax ([CExp], [CProg]), its denotation into threads over the CSL + effects, the source-instruction execution equations under both + schedulers, the exact first-yield segment rules, and the structural Ticl + rules stated over source programs. Every law here specializes an + effect-level law of [ICTree.Interp.CSL.Mod]. *) From TICL Require Export ICTree.Interp.CSL.Mod. -From Stdlib Require Import List Arith.PeanoNat Lia Fin Vector +(** The generic Yield event, scheduler, bisimulation, observed-scheduler and + logic layers, re-exported for source-level clients. *) +From TICL Require Export + ICTree.Events.Yield + Utils.Vectors + ICTree.Interp.Yield.Mod + ICTree.Interp.Yield.SBisim + ICTree.Interp.Yield.Observed + ICTree.Logic.Yield + ICTree.Logic.SchedulerFairness. + +From Stdlib Require Import List Arith.PeanoNat Lia Fin Vector Strings.String Classes.Morphisms Classes.RelationClasses Program.Equality. -From ExtLib Require Import Data.Monads.StateMonad. +From ExtLib Require Import Data.Monads.StateMonad + Structures.Maps Data.Map.FMapAList Data.String. From Coinduction Require Import coinduction lattice tactics. From TICL Require Import ICTree.Core ICTree.Equ ICTree.SBisim ICTree.Trans ICTree.Trace @@ -19,8 +31,8 @@ From TICL Require Import ICTree.Interp.Yield.Mod ICTree.Interp.Yield.SBisim ICTree.Interp.Yield.RoundRobin ICTree.Interp.Yield.Nondeterministic ICTree.Logic.Trans ICTree.Logic.AX ICTree.Logic.AF ICTree.Logic.AG - ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep - Logic.World Logic.Core Utils.Vectors. + ICTree.Logic.Bind ICTree.Logic.State ICTree.Logic.CanStep ICTree.Logic.Iter + ICTree.Interp.Core Logic.World Logic.Core Logic.Kripke Utils.Vectors. Import ICtree ICTreeNotations TiclNotations ListNotations VectorNotations. Local Open Scope ictree_scope. @@ -29,6 +41,14 @@ Local Open Scope fin_vector_scope. (** ** Syntax *) Module CSLSyntax. + (** Natural-number expressions over the shared variable context. *) + Inductive CExp : Type := + | CVar (name : string) + | CLit (value : nat) + | CPlus (a b : CExp) + | CMinus (a b : CExp) + | CMult (a b : CExp). + Inductive CProg : Type -> Type := | CRead (a : nat) : CProg nat | CWrite (a v : nat) : CProg unit @@ -40,12 +60,36 @@ Module CSLSyntax. | CUntilNone {A : Type} (body : CProg (option A)) : CProg unit | CAlloc (size : nat) : CProg nat | CFree (base : nat) : CProg unit - | CCAS (a expected desired : nat) : CProg bool. + | CCAS (a expected desired : nat) : CProg bool + | CEval (e : CExp) : CProg nat + | CAssign (name : string) (e : CExp) : CProg unit + | CIf {A : Type} (test : CExp) (yes no : CProg A) : CProg A + | CWhile (test : CExp) (body : CProg unit) : CProg unit. + + (** Any non-zero natural is true. *) + Definition is_true (v : nat) : bool := negb (Nat.eqb v 0). End CSLSyntax. Export CSLSyntax. (** ** Denotation *) +(** Expressions evaluate left to right. A successful variable read yields + once before returning the value it captured; a missing variable is + stuck. *) +Fixpoint denote_exp (e : CExp) : ictree CEff nat := + match e with + | CVar name => + ctx <- source_get;; + match lookup name ctx with + | Some value => source_yield;; Ret value + | None => stuck + end + | CLit n => Ret n + | CPlus a b => x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat + | CMinus a b => x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat + | CMult a b => x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat + end. + Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := match p in CProg A return ictree CEff (option A) with | CRead a => x <- heap_read (E:=CEff) a;; Ret (Some x) @@ -72,15 +116,70 @@ Fixpoint denote_flow {A : Type} (p : CProg A) : ictree CEff (option A) := | CFree base => heap_free (E:=CEff) base;; Ret (Some tt) | CCAS a expected desired => b <- heap_cas (E:=CEff) a expected desired;; Ret (Some b) + | CEval e => value <- denote_exp e;; Ret (Some value) + | CAssign name e => + value <- denote_exp e;; + ctx <- source_get;; + source_put (add name value ctx);; + Ret (Some tt) + | CIf test yes no => + value <- denote_exp test;; + if CSLSyntax.is_true value then denote_flow yes else denote_flow no + | CWhile test body => + ICtree.iter + (fun _ : unit => + value <- denote_exp test;; + if CSLSyntax.is_true value then + flow <- denote_flow body;; + match flow with + | Some _ => Ret (inl tt) + | None => Ret (inr None) + end + else Ret (inr (Some tt))) tt end. +(** One guarded [CWhile] iteration: a false test exits with [Some tt], a + completed body continues, and a halted body propagates [None]. *) +Definition cwhile_iteration (test : CExp) (body : CProg unit) (_ : unit) + : ictree CEff (unit + option unit) := + value <- denote_exp test;; + if CSLSyntax.is_true value then + flow <- denote_flow body;; + match flow with + | Some _ => Ret (inl tt) + | None => Ret (inr None) + end + else Ret (inr (Some tt)). + +Lemma denote_flow_cwhile (test : CExp) (body : CProg unit) : + denote_flow (CWhile test body) = ICtree.iter (cwhile_iteration test body) tt. +Proof. reflexivity. Qed. + Definition denote (p : CProg unit) : thread sE := denote_flow p;; Ret tt. +Lemma denote_exp_branchfree (e : CExp) : BranchFree (denote_exp e). +Proof. + induction e as [name|n|a IHa b IHb|a IHa b IHb|a IHa b IHb]; cbn [denote_exp]. + - apply branchfree_bind. + + unfold source_get, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. + + intro ctx; destruct (lookup name ctx). + * apply branchfree_bind; [unfold source_yield; apply bf_vis; intros []; apply bf_ret|]. + intros []; apply bf_ret. + * apply bf_stuck. + - apply bf_ret. + - apply branchfree_bind; [exact IHa|intro x]. + apply branchfree_bind; [exact IHb|intro y; apply bf_ret]. + - apply branchfree_bind; [exact IHa|intro x]. + apply branchfree_bind; [exact IHb|intro y; apply bf_ret]. + - apply branchfree_bind; [exact IHa|intro x]. + apply branchfree_bind; [exact IHb|intro y; apply bf_ret]. +Qed. + Lemma denote_flow_branchfree {A} (p : CProg A) : BranchFree (denote_flow p). Proof. induction p as [a|a v|q v| |body IH|A x|A B body IH next IHnext|A body IH|size|base - |a expected desired]; + |a expected desired|e|name e|A test yes IHyes no IHno|test body IH]; cbn [denote_flow]. - apply branchfree_bind. + unfold heap_read, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. @@ -114,6 +213,20 @@ Proof. - apply branchfree_bind. + unfold heap_cas, ICtree.trigger; apply bf_vis; intro b; apply bf_ret. + intro b; apply bf_ret. + - apply branchfree_bind; [apply denote_exp_branchfree|intro v; apply bf_ret]. + - apply branchfree_bind; [apply denote_exp_branchfree|intro v]. + apply branchfree_bind. + + unfold source_get, ICtree.trigger; apply bf_vis; intro x; apply bf_ret. + + intro ctx; apply branchfree_bind. + * unfold source_put, ICtree.trigger; apply bf_vis; intros []; apply bf_ret. + * intros []; apply bf_ret. + - apply branchfree_bind; [apply denote_exp_branchfree|intro v]. + destruct (CSLSyntax.is_true v); assumption. + - apply branchfree_iter; intros []. + apply branchfree_bind; [apply denote_exp_branchfree|intro v]. + destruct (CSLSyntax.is_true v); [|apply bf_ret]. + apply branchfree_bind; [exact IH|]. + intros [[]|]; apply bf_ret. Qed. Lemma denote_branchfree (p : CProg unit) : BranchFree (denote p). @@ -170,7 +283,7 @@ Qed. Lemma source_raw_emit_head tag value (K : option unit -> thread sE) : (denote_flow (CEmit tag value) >>= K) ≅ - Vis (inr (inr (inr (Log (tag,value))))) (fun _ => K (Some tt)). + Vis (inr (inr (inr (inr (Log (tag,value)))))) (fun _ => K (Some tt)). Proof. cbn [denote_flow]; unfold ICtree.trigger, resum, resum_ret, ReSum_tagged_CEff, ReSumRet_tagged_CEff. @@ -286,15 +399,208 @@ Proof. + etransitivity; [apply bind_ret_l|]. apply bind_ret_l. Qed. -(** Runners start from explicit managed memory: [managed_empty] for a fresh - program, or an explicit [(h,allocs)] for preallocated data. *) -Definition run_rr (p : CProg unit) (memory : ManagedHeap) (c : nat) - : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 (memory,c). +(** Yield-style expression and control statements, as raw CPS equations. *) +Lemma source_raw_eval (e : CExp) (K : option nat -> thread sE) : + (denote_flow (CEval e) >>= K) ≅ + (denote_exp e >>= fun value => K (Some value)). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intro value; apply bind_ret_l. +Qed. + +Lemma source_raw_assign (name : string) (e : CExp) + (K : option unit -> thread sE) : + (denote_flow (CAssign name e) >>= K) ≅ + (value <- denote_exp e;; ctx <- source_get;; + source_put (add name value ctx);; K (Some tt)). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intro value; rewrite bind_bind. + apply equ_clo_bind_eq; intro ctx; rewrite bind_bind. + apply equ_clo_bind_eq; intros []; apply bind_ret_l. +Qed. + +Lemma source_raw_if {A} (test : CExp) (yes no : CProg A) + (K : option A -> thread sE) : + (denote_flow (CIf test yes no) >>= K) ≅ + (value <- denote_exp test;; + if CSLSyntax.is_true value then denote_flow yes >>= K + else denote_flow no >>= K). +Proof. + cbn [denote_flow]; rewrite bind_bind. + apply equ_clo_bind_eq; intro value; destruct (CSLSyntax.is_true value); reflexivity. +Qed. + +Lemma source_raw_while (test : CExp) (body : CProg unit) + (K : option unit -> thread sE) : + (denote_flow (CWhile test body) >>= K) ≅ + (ICtree.iter (cwhile_iteration test body) tt >>= K). +Proof. rewrite denote_flow_cwhile; reflexivity. Qed. + +(** ** Runners + + A pool of source programs runs under either scheduler from an explicit + full state [((h,allocs),(ctx,c))]; the singleton runners start focused, + and round robin starts at cursor [0]. *) +Definition csl_pool {n} (ps : Vector.t (CProg unit) n) : pool sE n := + Vector.map denote ps. + +Definition run_nd_pool {n} (ps : Vector.t (CProg unit) n) + (focus : option (Fin.t n)) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (unit * SSig) := + interp_schedule_nd sh n (csl_pool ps) focus s. + +Definition run_rr_pool {n} (ps : Vector.t (CProg unit) n) + (focus : option (Fin.t n)) (cursor : nat) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (unit * SSig) := + interp_schedule_rr sh n (csl_pool ps) focus cursor s. + +Definition run_nd (p : CProg unit) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (unit * SSig) := + run_nd_pool [p]%vector (Some Fin.F1) s. + +Definition run_rr (p : CProg unit) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (unit * SSig) := + run_rr_pool [p]%vector (Some Fin.F1) 0 s. + +Lemma run_nd_unfold (p : CProg unit) (s : SSig) : + run_nd p s = interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) s. +Proof. reflexivity. Qed. + +Lemma run_rr_unfold (p : CProg unit) (s : SSig) : + run_rr p s = interp_schedule_rr sh 1 [denote p]%vector (Some Fin.F1) 0 s. +Proof. reflexivity. Qed. + +(** ** Expression execution + + A literal is pure. A variable reads the shared context, and on success + yields once before returning the captured value; a missing variable is + stuck, faulting the whole run. *) + +Lemma source_raw_lit {X} n (K : nat -> ictree CEff X) : + (denote_exp (CLit n) >>= K) ≅ K n. +Proof. cbn [denote_exp]; rewrite bind_ret_l; reflexivity. Qed. + +Lemma source_raw_var {X} name (K : nat -> ictree CEff X) : + (denote_exp (CVar name) >>= K) ≅ + (source_get >>= fun ctx => + match lookup name ctx with + | Some value => Vis (inl Yield : CEff) (fun _ => K value) + | None => stuck + end). +Proof. + cbn [denote_exp]; rewrite bind_bind. + apply equ_clo_bind_eq; intro ctx. + destruct (lookup name ctx) as [value|]. + - unfold source_yield; rewrite bind_bind, bind_vis. + apply vis_equ_node; intros []; cbv beta. + etransitivity; [apply bind_ret_l|]; cbv beta. + apply bind_ret_l. + - apply bind_stuck_equ. +Qed. + +Lemma interp_rr_lit n (ts : pool sE (S n)) (i : Fin.t (S n)) + v (K : nat -> thread sE) m (s : SSig) : + interp_schedule_rr sh (S n) (ts @ i := (denote_exp (CLit v) >>= K)) (Some i) m s ≅ + interp_schedule_rr sh (S n) (ts @ i := K v) (Some i) m s. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_lit. +Qed. + +Lemma interp_nd_lit n (ts : pool sE (S n)) (i : Fin.t (S n)) + v (K : nat -> thread sE) (s : SSig) : + interp_schedule_nd sh (S n) (ts @ i := (denote_exp (CLit v) >>= K)) (Some i) s ≅ + interp_schedule_nd sh (S n) (ts @ i := K v) (Some i) s. +Proof. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_lit. +Qed. + +(** Assignment evaluates its expression, then performs a late + read-modify-write of the shared context. *) +Lemma interp_rr_assign n (ts : pool sE (S n)) (i : Fin.t (S n)) + name e (K : option unit -> thread sE) m (s : SSig) : + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CAssign name e) >>= K)) (Some i) m s ≅ + interp_schedule_rr sh (S n) + (ts @ i := (denote_exp e >>= fun value => + source_get >>= fun ctx => source_put (add name value ctx) >>= fun _ => K (Some tt))) + (Some i) m s. +Proof. + apply interp_schedule_rr_equ, replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_assign. +Qed. + +Lemma interp_nd_assign n (ts : pool sE (S n)) (i : Fin.t (S n)) + name e (K : option unit -> thread sE) (s : SSig) : + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CAssign name e) >>= K)) (Some i) s ≅ + interp_schedule_nd sh (S n) + (ts @ i := (denote_exp e >>= fun value => + source_get >>= fun ctx => source_put (add name value ctx) >>= fun _ => K (Some tt))) + (Some i) s. +Proof. + apply (interp_schedule_nd_equ sh), replace_pool_equ; [apply pool_equ_refl|]. + apply source_raw_assign. +Qed. + +Lemma interp_rr_var n (ts : pool sE (S n)) (i : Fin.t (S n)) + name value (K : nat -> thread sE) m (s : SSig) : + lookup name (csl_context s) = Some value -> + interp_schedule_rr sh (S n) (ts @ i := (denote_exp (CVar name) >>= K)) (Some i) m s ~ + interp_schedule_rr sh (S n) (ts @ i := K value) None m s. +Proof. + intro Hlookup. + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) m s + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_var name K))). + rewrite interp_rr_get_ctx; cbv beta; rewrite Hlookup. + erewrite interp_schedule_rr_yield by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_nd_var n (ts : pool sE (S n)) (i : Fin.t (S n)) + name value (K : nat -> thread sE) (s : SSig) : + lookup name (csl_context s) = Some value -> + interp_schedule_nd sh (S n) (ts @ i := (denote_exp (CVar name) >>= K)) (Some i) s ~ + interp_schedule_nd sh (S n) (ts @ i := K value) None s. +Proof. + intro Hlookup. + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) s + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_var name K))). + rewrite interp_nd_get_ctx; cbv beta; rewrite Hlookup. + erewrite (interp_schedule_nd_yield sh) + by (rewrite Vector.nth_replace_eq; reflexivity). + rewrite Vector.replace_replace_eq; reflexivity. +Qed. + +Lemma interp_rr_var_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + name (K : nat -> thread sE) m (s : SSig) : + lookup name (csl_context s) = None -> + interp_schedule_rr sh (S n) (ts @ i := (denote_exp (CVar name) >>= K)) (Some i) m s ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + intro Hlookup. + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) m s + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_var name K))). + rewrite interp_rr_get_ctx; cbv beta; rewrite Hlookup. + rewrite (interp_schedule_rr_stuck sh n _ i m s) + by (rewrite Vector.nth_replace_eq; reflexivity). + reflexivity. +Qed. -Definition run_nd (p : CProg unit) (memory : ManagedHeap) (c : nat) - : ictreeW (indexed (nat * nat)) (unit * SSig) := - interp_schedule_nd sh 1 [denote p]%vector (Some Fin.F1) (memory,c). +Lemma interp_nd_var_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) + name (K : nat -> thread sE) (s : SSig) : + lookup name (csl_context s) = None -> + interp_schedule_nd sh (S n) (ts @ i := (denote_exp (CVar name) >>= K)) (Some i) s ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + intro Hlookup. + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) s + (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_raw_var name K))). + rewrite interp_nd_get_ctx; cbv beta; rewrite Hlookup. + rewrite (interp_schedule_nd_stuck sh n _ i s) + by (rewrite Vector.nth_replace_eq; reflexivity). + reflexivity. +Qed. Lemma interp_rr_ret {A} n (ts : pool sE (S n)) (i : Fin.t (S n)) (x : A) (K : option A -> thread sE) m σ : @@ -358,7 +664,7 @@ Lemma interp_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (semit q v) σ >>= fun '(_,σ') => interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) (Some i) m σ'). Proof. - apply ((interp_schedule_rr_user_bind sh) n ts i _ (inr (Log (q,v))) + apply ((interp_schedule_rr_user_bind sh) n ts i _ (inr (inr (Log (q,v)))) (fun _ => K (Some tt)) m σ). apply source_raw_emit_head. Qed. @@ -426,17 +732,17 @@ Proof. apply source_raw_until. Qed. -Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) memory c : - run_rr (CBind (CFork p) next) memory c ~ +Lemma run_rr_fork_bind (p : CProg unit) (next : unit -> CProg unit) (s : SSig) : + run_rr (CBind (CFork p) next) s ~ interp_schedule_rr sh 2 [denote p; denote (next tt)]%vector - (Some (Fin.FS Fin.F1)) 0 (memory,c). + (Some (Fin.FS Fin.F1)) 0 s. Proof. - unfold run_rr. + rewrite run_rr_unfold. assert (Hpool : pool_equ [denote (CBind (CFork p) next)]%vector [Vis (inr (inl Fork)) (fun child : bool => if child then denote p else denote (next tt))]%vector). { apply cons_pool_equ; [apply denote_fork_bind|apply pool_equ_refl]. } - rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 (memory,c) Hpool). + rewrite (interp_schedule_rr_equ sh 1 _ _ (Some Fin.F1) 0 s Hpool). erewrite interp_schedule_rr_fork by reflexivity. reflexivity. Qed. @@ -503,7 +809,7 @@ Lemma interp_nd_source_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) (interp_state sh (semit q v) σ >>= fun '(_,σ') => interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) (Some i) σ'). Proof. - apply ((interp_schedule_nd_user_bind sh) n ts i _ (inr (Log (q,v))) + apply ((interp_schedule_nd_user_bind sh) n ts i _ (inr (inr (Log (q,v)))) (fun _ => K (Some tt)) σ). apply source_raw_emit_head. Qed. @@ -576,15 +882,15 @@ Qed. used here. *) Lemma interp_rr_write_present n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c : + a v (K : option unit -> thread sE) m h allocs ctx c : h a <> None -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) m ((upd h a v,allocs),c). + (Some i) m ((upd h a v,allocs),(ctx,c)). Proof. intro Present. - pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c v + pose proof ((interp_heap_wr_present (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs (ctx,c) v (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_write. @@ -599,15 +905,15 @@ Qed. Lemma interp_nd_source_write_present n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c : + a v (K : option unit -> thread sE) h allocs ctx c : h a <> None -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) ((upd h a v,allocs),c). + (Some i) ((upd h a v,allocs),(ctx,c)). Proof. intro Present. - pose proof ((interp_heap_wr_present (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c v + pose proof ((interp_heap_wr_present (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs (ctx,c) v (fun x : unit => (Ret x : ictree sE unit)) Present) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_write. @@ -621,14 +927,14 @@ Proof. Qed. Lemma interp_rr_read_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c : + a value (K : option nat -> thread sE) m h allocs ctx c : h a = Some value -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c) ~ - interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m ((h,allocs),c). + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c)). Proof. intro Lookup. - pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c value + pose proof ((interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs (ctx,c) value (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_read. @@ -643,14 +949,14 @@ Qed. Lemma interp_nd_source_read_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c : + a value (K : option nat -> thread sE) h allocs ctx c : h a = Some value -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c) ~ - interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) ((h,allocs),c). + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c)). Proof. intro Lookup. - pose proof ((interp_heap_rd (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c value + pose proof ((interp_heap_rd (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs (ctx,c) value (fun x : nat => (Ret x : ictree sE nat)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_read. @@ -666,18 +972,18 @@ Qed. (** Checked operations with their scheduler continuation held fixed. *) Lemma interp_rr_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c : + tag value (K : option unit -> thread sE) m memory ctx c : interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c) ~ - (log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c)) ~ + (log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))). Proof. - pose proof (interp_indexed_emit heap_handler (tag,value) memory c + pose proof (interp_csl_emit (tag,value) memory ctx c (fun x : unit => (Ret x : ictree sE unit))) as Hemit. rewrite bind_ret_r in Hemit. - assert (Hstate : interp_state sh (semit tag value) (memory,c) ~ - (log (stamp (tag,value) c);; Ret (tt,(memory,S c)))). + assert (Hstate : interp_state sh (semit tag value) (memory,(ctx,c)) ~ + (log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; Ret (tt,(memory,(ctx,S c))))). { etransitivity; [exact Hemit |]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. eapply equ_clos_sbisim_goal; @@ -695,21 +1001,21 @@ Proof. Qed. Lemma interp_rr_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c : h a = Some current -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ (if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))). Proof. intro Lookup; rewrite interp_rr_cas. destruct (Nat.eqb current expected) eqn:Cmp. - apply Nat.eqb_eq in Cmp; subst current. - pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired h allocs c + pose proof ((interp_heap_cas_success (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a expected desired h allocs (ctx,c) (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -720,7 +1026,7 @@ Proof. end. rewrite bind_ret_l; reflexivity. - apply Nat.eqb_neq in Cmp. - pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired current h allocs c + pose proof ((interp_heap_cas_failure (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a expected desired current h allocs (ctx,c) (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -733,16 +1039,16 @@ Proof. Qed. Lemma interp_rr_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c : + size base (K : option nat -> thread sE) m h allocs ctx c : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c) ~ + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c)). Proof. intros Pos Base Free First. - pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) h allocs size base c + pose proof ((interp_heap_alloc_first (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) h allocs size base (ctx,c) (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_rr_alloc. @@ -756,15 +1062,15 @@ Proof. Qed. Lemma interp_rr_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) m h allocs c : + a (K : option nat -> thread sE) m h allocs ctx c : h a = None -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) - a h allocs c Missing) as Hstate. + pose proof ((interp_heap_rd_stuck (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) + a h allocs (ctx,c) Missing) as Hstate. rewrite interp_rr_read. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -776,15 +1082,15 @@ Proof. Qed. Lemma interp_rr_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c : + a v (K : option unit -> thread sE) m h allocs ctx c : h a = None -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) - a v h allocs c Missing) as Hstate. + pose proof ((interp_heap_wr_stuck (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) + a v h allocs (ctx,c) Missing) as Hstate. rewrite interp_rr_write. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -796,15 +1102,15 @@ Proof. Qed. Lemma interp_rr_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) m h allocs c : + a expected desired (K : option bool -> thread sE) m h allocs ctx c : h a = None -> interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) - a expected desired h allocs c (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. + pose proof ((interp_heap_cas_missing (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) + a expected desired h allocs (ctx,c) (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. rewrite bind_ret_r in Hstate. rewrite interp_rr_cas. lazymatch goal with @@ -817,18 +1123,18 @@ Qed. Lemma interp_nd_source_emit_log n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c : + tag value (K : option unit -> thread sE) memory ctx c : interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c) ~ - (log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c)) ~ + (log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))). Proof. - pose proof (interp_indexed_emit heap_handler (tag,value) memory c + pose proof (interp_csl_emit (tag,value) memory ctx c (fun x : unit => (Ret x : ictree sE unit))) as Hemit. rewrite bind_ret_r in Hemit. - assert (Hstate : interp_state sh (semit tag value) (memory,c) ~ - (log (stamp (tag,value) c);; Ret (tt,(memory,S c)))). + assert (Hstate : interp_state sh (semit tag value) (memory,(ctx,c)) ~ + (log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; Ret (tt,(memory,(ctx,S c))))). { etransitivity; [exact Hemit |]. apply sbisim_clo_bind_eq; [reflexivity | intros []]. eapply equ_clos_sbisim_goal; @@ -846,21 +1152,21 @@ Proof. Qed. Lemma interp_nd_source_cas_value n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c : + a expected desired current (K : option bool -> thread sE) h allocs ctx c : h a = Some current -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ (if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))). Proof. intro Lookup; rewrite interp_nd_source_cas. destruct (Nat.eqb current expected) eqn:Cmp. - apply Nat.eqb_eq in Cmp; subst current. - pose proof ((interp_heap_cas_success (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired h allocs c + pose proof ((interp_heap_cas_success (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a expected desired h allocs (ctx,c) (fun x : bool => (Ret x : ictree sE bool)) Lookup) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -871,7 +1177,7 @@ Proof. end. rewrite bind_ret_l; reflexivity. - apply Nat.eqb_neq in Cmp. - pose proof ((interp_heap_cas_failure (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a expected desired current h allocs c + pose proof ((interp_heap_cas_failure (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a expected desired current h allocs (ctx,c) (fun x : bool => (Ret x : ictree sE bool)) Lookup Cmp) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. lazymatch goal with @@ -884,16 +1190,16 @@ Proof. Qed. Lemma interp_nd_source_alloc_first n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c : + size base (K : option nat -> thread sE) h allocs ctx c : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c) ~ + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c)). Proof. intros Pos Base Free First. - pose proof ((interp_heap_alloc_first (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) h allocs size base c + pose proof ((interp_heap_alloc_first (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) h allocs size base (ctx,c) (fun x : nat => (Ret x : ictree sE nat)) Pos Base Free First) as Hstate. rewrite bind_ret_r, interp_state_ret in Hstate. rewrite interp_nd_source_alloc. @@ -907,14 +1213,14 @@ Proof. Qed. Lemma interp_nd_source_read_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a (K : option nat -> thread sE) h allocs c : + a (K : option nat -> thread sE) h allocs ctx c : h a = None -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_rd_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) a h allocs c Missing) as Hstate. + pose proof ((interp_heap_rd_stuck (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) a h allocs (ctx,c) Missing) as Hstate. rewrite interp_nd_source_read. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -926,15 +1232,15 @@ Proof. Qed. Lemma interp_nd_source_write_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c : + a v (K : option unit -> thread sE) h allocs ctx c : h a = None -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_wr_stuck (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) - a v h allocs c Missing) as Hstate. + pose proof ((interp_heap_wr_stuck (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) + a v h allocs (ctx,c) Missing) as Hstate. rewrite interp_nd_source_write. lazymatch goal with | |- (interp_state sh _ _ >>= ?next) ~ _ => @@ -946,15 +1252,15 @@ Proof. Qed. Lemma interp_nd_source_cas_missing n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired (K : option bool -> thread sE) h allocs c : + a expected desired (K : option bool -> thread sE) h allocs ctx c : h a = None -> interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Missing. - pose proof ((interp_heap_cas_missing (h_indexed (A:=(nat * nat)) (Sigma:=ManagedHeap))) - a expected desired h allocs c (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. + pose proof ((interp_heap_cas_missing (h_sum csl_context_handler (csl_emit_handler (A:=nat * nat)))) + a expected desired h allocs (ctx,c) (fun b : bool => (Ret b : ictree sE bool)) Missing) as Hstate. rewrite bind_ret_r in Hstate. rewrite interp_nd_source_cas. lazymatch goal with @@ -979,57 +1285,57 @@ Proof. Qed. Lemma interp_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) base - (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c : + (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c : managed_free memory base = Some memory' -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) - (Some i) cursor (memory,c) ~ + (Some i) cursor (memory,(ctx,c)) ~ interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) - (Some i) cursor (memory',c). + (Some i) cursor (memory',(ctx,c)). Proof. intro Free. - rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,c) + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). - exact (interp_rr_heap_free n ts i base (fun _ => K (Some tt)) cursor memory memory' c Free). + exact (interp_rr_heap_free n ts i base (fun _ => K (Some tt)) cursor memory memory' ctx c Free). Qed. Lemma interp_rr_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) base - (K : option unit -> thread sE) cursor (memory : ManagedHeap) c : + (K : option unit -> thread sE) cursor (memory : ManagedHeap) ctx c : managed_free memory base = None -> interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) - (Some i) cursor (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (Some i) cursor (memory,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Invalid. - rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,c) + rewrite (interp_schedule_rr_equ sh (S n) _ _ (Some i) cursor (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). - exact (interp_rr_heap_free_invalid n ts i base (fun _ => K (Some tt)) cursor memory c Invalid). + exact (interp_rr_heap_free_invalid n ts i base (fun _ => K (Some tt)) cursor memory ctx c Invalid). Qed. Lemma interp_nd_source_free n (ts : pool sE (S n)) (i : Fin.t (S n)) base - (K : option unit -> thread sE) (memory memory' : ManagedHeap) c : + (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c : managed_free memory base = Some memory' -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) - (Some i) (memory,c) ~ + (Some i) (memory,(ctx,c)) ~ interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) - (Some i) (memory',c). + (Some i) (memory',(ctx,c)). Proof. intro Free. - rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,c) + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). - exact (interp_nd_heap_free n ts i base (fun _ => K (Some tt)) memory memory' c Free). + exact (interp_nd_heap_free n ts i base (fun _ => K (Some tt)) memory memory' ctx c Free). Qed. Lemma interp_nd_source_free_invalid n (ts : pool sE (S n)) (i : Fin.t (S n)) base - (K : option unit -> thread sE) (memory : ManagedHeap) c : + (K : option unit -> thread sE) (memory : ManagedHeap) ctx c : managed_free memory base = None -> interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) - (Some i) (memory,c) ~ - (stuck : ictreeW (indexed (nat * nat)) (unit * SSig)). + (Some i) (memory,(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). Proof. intro Invalid. - rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,c) + rewrite ((interp_schedule_nd_equ sh) (S n) _ _ (Some i) (memory,(ctx,c)) (replace_pool_equ ts ts i _ _ (pool_equ_refl ts) (source_free_raw_heap_free base K))). - exact (interp_nd_heap_free_invalid n ts i base (fun _ => K (Some tt)) memory c Invalid). + exact (interp_nd_heap_free_invalid n ts i base (fun _ => K (Some tt)) memory ctx c Invalid). Qed. @@ -1067,10 +1373,10 @@ Proof. Qed. Lemma exact_source_read a v (K : option nat -> thread sE) - h allocs c logs target sigma' : + h allocs ctx c logs target sigma' : h a = Some v -> - segment_to sh csl_equ (K (Some v)) ((h,allocs),c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CRead a) >>= K) ((h,allocs),c) logs target sigma'. + segment_to sh csl_equ (K (Some v)) ((h,allocs),(ctx,c)) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CRead a) >>= K) ((h,allocs),(ctx,c)) logs target sigma'. Proof. intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. eapply segment_equ with (u' := residual) @@ -1078,17 +1384,17 @@ Proof. - apply source_raw_read_head. - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HRead a)))) (fun v => K (Some v))) - ((h,allocs),c) ([] ++ logs) residual sigma'). + ((h,allocs),(ctx,c)) ([] ++ logs) residual sigma'). eapply segment_user; [|exact Hseg]. - cbn [emit_list]; rewrite (heap_handler_rd_some a h allocs c v Hr); reflexivity. + cbn [emit_list]; rewrite (heap_handler_rd_some a h allocs (ctx,c) v Hr); reflexivity. - reflexivity. Qed. Lemma exact_source_write a v (K : option unit -> thread sE) - h allocs c logs target sigma' : + h allocs ctx c logs target sigma' : h a <> None -> - segment_to sh csl_equ (K (Some tt)) ((upd h a v,allocs),c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CWrite a v) >>= K) ((h,allocs),c) logs target sigma'. + segment_to sh csl_equ (K (Some tt)) ((upd h a v,allocs),(ctx,c)) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CWrite a v) >>= K) ((h,allocs),(ctx,c)) logs target sigma'. Proof. intros Hp (residual & Hseg & Htail). destruct (h a) as [w|] eqn:Hw; [|contradiction]. @@ -1098,40 +1404,40 @@ Proof. - apply source_raw_write_head. - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HWrite a v)))) (fun _ => K (Some tt))) - ((h,allocs),c) ([] ++ logs) residual sigma'). + ((h,allocs),(ctx,c)) ([] ++ logs) residual sigma'). eapply segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (heap_handler_wr_some a h allocs c v w Hw); reflexivity. + cbn [emit_list]; rewrite (heap_handler_wr_some a h allocs (ctx,c) v w Hw); reflexivity. - reflexivity. Qed. -(** The raw handler equation [h_indexed_log] is the response certificate here; - [interp_indexed_emit] is an interpretation equation and cannot discharge - this premise. *) +(** The raw handler equation [csl_emit_handler_log] is the response + certificate here; [interp_csl_emit] is an interpretation equation and + cannot discharge this premise. *) Lemma exact_source_emit tag block (K : option unit -> thread sE) - (memory : ManagedHeap) c logs target sigma' : - segment_to sh csl_equ (K (Some tt)) (memory,S c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CEmit tag block) >>= K) (memory,c) - (stamp (tag,block) c :: logs) target sigma'. + (memory : ManagedHeap) ctx c logs target sigma' : + segment_to sh csl_equ (K (Some tt)) (memory,(ctx,S c)) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CEmit tag block) >>= K) (memory,(ctx,c)) + (inr (stamp (tag,block) c) :: logs) target sigma'. Proof. intros (residual & Hseg & Htail); exists residual; split; [|exact Htail]. eapply segment_equ with (u' := residual) - (u := Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))). + (u := Vis (inr (inr (inr (inr (Log (tag,block)))))) (fun _ => K (Some tt))). - apply source_raw_emit_head. - change (ThreadSegment sh csl_equ - (Vis (inr (inr (inr (Log (tag,block))))) (fun _ => K (Some tt))) - (memory,c) ([stamp (tag,block) c] ++ logs) residual sigma'). + (Vis (inr (inr (inr (inr (Log (tag,block)))))) (fun _ => K (Some tt))) + (memory,(ctx,c)) ([inr (stamp (tag,block) c)] ++ logs) residual sigma'). eapply segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (h_indexed_log (Sigma:=ManagedHeap) (tag,block) memory c); + cbn [emit_list]; rewrite (csl_emit_handler_log (tag,block) memory ctx c); reflexivity. - reflexivity. Qed. Lemma exact_source_cas_success a expected desired - (K : option bool -> thread sE) h allocs c logs target sigma' : + (K : option bool -> thread sE) h allocs ctx c logs target sigma' : h a = Some expected -> - segment_to sh csl_equ (K (Some true)) ((upd h a desired,allocs),c) logs target sigma' -> + segment_to sh csl_equ (K (Some true)) ((upd h a desired,allocs),(ctx,c)) logs target sigma' -> segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) - ((h,allocs),c) logs target sigma'. + ((h,allocs),(ctx,c)) logs target sigma'. Proof. intros Hr (residual & Hseg & Htail); exists residual; split; [|exact Htail]. eapply segment_equ with (u' := residual) @@ -1139,19 +1445,19 @@ Proof. - apply source_raw_cas_head. - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) - ((h,allocs),c) ([] ++ logs) residual sigma'). + ((h,allocs),(ctx,c)) ([] ++ logs) residual sigma'). eapply segment_user; [|exact Hseg]. cbn [emit_list]; - rewrite (heap_handler_cas_success a expected desired h allocs c Hr); reflexivity. + rewrite (heap_handler_cas_success a expected desired h allocs (ctx,c) Hr); reflexivity. - reflexivity. Qed. Lemma exact_source_cas_failure a expected desired current - (K : option bool -> thread sE) h allocs c logs target sigma' : + (K : option bool -> thread sE) h allocs ctx c logs target sigma' : h a = Some current -> current <> expected -> - segment_to sh csl_equ (K (Some false)) ((h,allocs),c) logs target sigma' -> + segment_to sh csl_equ (K (Some false)) ((h,allocs),(ctx,c)) logs target sigma' -> segment_to sh csl_equ (denote_flow (CCAS a expected desired) >>= K) - ((h,allocs),c) logs target sigma'. + ((h,allocs),(ctx,c)) logs target sigma'. Proof. intros Hr Hne (residual & Hseg & Htail); exists residual; split; [|exact Htail]. eapply segment_equ with (u' := residual) @@ -1159,19 +1465,19 @@ Proof. - apply source_raw_cas_head. - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HCAS a expected desired)))) (fun b => K (Some b))) - ((h,allocs),c) ([] ++ logs) residual sigma'). + ((h,allocs),(ctx,c)) ([] ++ logs) residual sigma'). eapply segment_user; [|exact Hseg]. cbn [emit_list]; - rewrite (heap_handler_cas_failure a expected desired current h allocs c Hr Hne); + rewrite (heap_handler_cas_failure a expected desired current h allocs (ctx,c) Hr Hne); reflexivity. - reflexivity. Qed. Lemma exact_source_free base (K : option unit -> thread sE) - (memory memory' : ManagedHeap) c logs target sigma' : + (memory memory' : ManagedHeap) ctx c logs target sigma' : managed_free memory base = Some memory' -> - segment_to sh csl_equ (K (Some tt)) (memory',c) logs target sigma' -> - segment_to sh csl_equ (denote_flow (CFree base) >>= K) (memory,c) logs target sigma'. + segment_to sh csl_equ (K (Some tt)) (memory',(ctx,c)) logs target sigma' -> + segment_to sh csl_equ (denote_flow (CFree base) >>= K) (memory,(ctx,c)) logs target sigma'. Proof. intros Free (residual & Hseg & Htail). exists residual; split; [|exact Htail]. @@ -1180,9 +1486,9 @@ Proof. - apply source_raw_free_head. - change (ThreadSegment sh csl_equ (Vis (inr (inr (inl (HFree base)))) (fun _ => K (Some tt))) - (memory,c) ([] ++ logs) residual sigma'). + (memory,(ctx,c)) ([] ++ logs) residual sigma'). eapply segment_user with (result := tt); [|exact Hseg]. - cbn [emit_list]; rewrite (heap_handler_free base memory memory' c Free); reflexivity. + cbn [emit_list]; rewrite (heap_handler_free base memory memory' (ctx,c) Free); reflexivity. - reflexivity. Qed. @@ -1228,1464 +1534,1464 @@ Local Typeclasses Transparent equ sbisim. (** ** Checked silent effects *) Lemma anl_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_read_value n ts i a value K h allocs ctx c Lookup); reflexivity. Qed. Lemma anr_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a value (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_read_value n ts i a value K h allocs ctx c Lookup); reflexivity. Qed. Lemma aul_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_read_value n ts i a value K h allocs ctx c Lookup); reflexivity. Qed. Lemma aur_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a value (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_read_value n ts i a value K h allocs ctx c Lookup); reflexivity. Qed. Lemma ag_csl_nd_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some value)) (Some i) ((h,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some value)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_read_value n ts i a value K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_read_value n ts i a value K h allocs ctx c Lookup); reflexivity. Qed. Lemma anl_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_read_value n ts i a value K m h allocs ctx c Lookup); reflexivity. Qed. Lemma anr_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a value (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_read_value n ts i a value K m h allocs ctx c Lookup); reflexivity. Qed. Lemma aul_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_read_value n ts i a value K m h allocs ctx c Lookup); reflexivity. Qed. Lemma aur_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a value (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some value -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_read_value n ts i a value K m h allocs ctx c Lookup); reflexivity. Qed. Lemma ag_csl_rr_read n (ts : pool sE (S n)) (i : Fin.t (S n)) - a value (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a value (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a = Some value -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CRead a) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some value)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some value)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Lookup. - rewrite (interp_rr_read_value n ts i a value K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_read_value n ts i a value K m h allocs ctx c Lookup); reflexivity. Qed. Lemma anl_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. + rewrite (interp_nd_source_write_present n ts i a v K h allocs ctx c Present); reflexivity. Qed. Lemma anr_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a v (K : option unit -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. + rewrite (interp_nd_source_write_present n ts i a v K h allocs ctx c Present); reflexivity. Qed. Lemma aul_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. + rewrite (interp_nd_source_write_present n ts i a v K h allocs ctx c Present); reflexivity. Qed. Lemma aur_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a v (K : option unit -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. + rewrite (interp_nd_source_write_present n ts i a v K h allocs ctx c Present); reflexivity. Qed. Lemma ag_csl_nd_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) ((upd h a v,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Present. - rewrite (interp_nd_source_write_present n ts i a v K h allocs c Present); reflexivity. + rewrite (interp_nd_source_write_present n ts i a v K h allocs ctx c Present); reflexivity. Qed. Lemma anl_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Present. - rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. + rewrite (interp_rr_write_present n ts i a v K m h allocs ctx c Present); reflexivity. Qed. Lemma anr_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a v (K : option unit -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Present. - rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. + rewrite (interp_rr_write_present n ts i a v K m h allocs ctx c Present); reflexivity. Qed. Lemma aul_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Present. - rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. + rewrite (interp_rr_write_present n ts i a v K m h allocs ctx c Present); reflexivity. Qed. Lemma aur_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a v (K : option unit -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a <> None -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Present. - rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. + rewrite (interp_rr_write_present n ts i a v K m h allocs ctx c Present); reflexivity. Qed. Lemma ag_csl_rr_write n (ts : pool sE (S n)) (i : Fin.t (S n)) - a v (K : option unit -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a v (K : option unit -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a <> None -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CWrite a v) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) m ((upd h a v,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Present. - rewrite (interp_rr_write_present n ts i a v K m h allocs c Present); reflexivity. + rewrite (interp_rr_write_present n ts i a v K m h allocs ctx c Present); reflexivity. Qed. (** ** Valid whole-block free; [managed_free] covers the null no-op. *) Lemma anl_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some tt)) (Some i) (memory',(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Free. - rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. + rewrite (interp_nd_source_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma anr_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some tt)) (Some i) (memory',(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Free. - rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. + rewrite (interp_nd_source_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma aul_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some tt)) (Some i) (memory',(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Free. - rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. + rewrite (interp_nd_source_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma aur_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some tt)) (Some i) (memory',(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Free. - rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. + rewrite (interp_nd_source_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma ag_csl_nd_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory',c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) (memory',(ctx,c))}, {w} |= AG φ )>)). Proof. intros Free. - rewrite (interp_nd_source_free n ts i base K memory memory' c Free); reflexivity. + rewrite (interp_nd_source_free n ts i base K memory memory' ctx c Free); reflexivity. Qed. Lemma anl_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some tt)) (Some i) cursor (memory',(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Free. - rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. + rewrite (interp_rr_free n ts i base K cursor memory memory' ctx c Free); reflexivity. Qed. Lemma anr_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some tt)) (Some i) cursor (memory',(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Free. - rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. + rewrite (interp_rr_free n ts i base K cursor memory memory' ctx c Free); reflexivity. Qed. Lemma aul_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w - (φ ψ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some tt)) (Some i) cursor (memory',(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Free. - rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. + rewrite (interp_rr_free n ts i base K cursor memory memory' ctx c Free); reflexivity. Qed. Lemma aur_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : managed_free memory base = Some memory' -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some tt)) (Some i) cursor (memory',(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Free. - rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. + rewrite (interp_rr_free n ts i base K cursor memory memory' ctx c Free); reflexivity. Qed. Lemma ag_csl_rr_free n (ts : pool sE (S n)) (i : Fin.t (S n)) - base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) c w - (φ : ticllW (indexed (nat * nat))) : + base (K : option unit -> thread sE) cursor (memory memory' : ManagedHeap) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : managed_free memory base = Some memory' -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CFree base) >>= K)) (Some i) cursor (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) cursor (memory',c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) cursor (memory',(ctx,c))}, {w} |= AG φ )>)). Proof. intros Free. - rewrite (interp_rr_free n ts i base K cursor memory memory' c Free); reflexivity. + rewrite (interp_rr_free n ts i base K cursor memory memory' ctx c Free); reflexivity. Qed. Lemma anl_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma anr_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size base (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma aul_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma aur_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size base (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma ag_csl_nd_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= AG φ )>)). Proof. intros Pos Base Free First. - rewrite (interp_nd_source_alloc_first n ts i size base K h allocs c Pos Base Free First); reflexivity. + rewrite (interp_nd_source_alloc_first n ts i size base K h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma anl_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma anr_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size base (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma aul_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma aur_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size base (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma ag_csl_rr_alloc n (ts : pool sE (S n)) (i : Fin.t (S n)) - size base (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) : + size base (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : Nat.lt 0 size -> Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= AG φ )>)). Proof. intros Pos Base Free First. - rewrite (interp_rr_alloc_first n ts i size base K m h allocs c Pos Base Free First); reflexivity. + rewrite (interp_rr_alloc_first n ts i size base K m h allocs ctx c Pos Base Free First); reflexivity. Qed. Lemma anl_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs ctx c Lookup); reflexivity. Qed. Lemma anr_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a expected desired current (K : option bool -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs ctx c Lookup); reflexivity. Qed. Lemma aul_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs ctx c Lookup); reflexivity. Qed. Lemma aur_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a expected desired current (K : option bool -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs ctx c Lookup); reflexivity. Qed. Lemma ag_csl_nd_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {if Nat.eqb current expected then interp_schedule_nd sh (S n) - (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) ((upd h a desired,allocs),(ctx,c)) else interp_schedule_nd sh (S n) - (ts @ i := K (Some false)) (Some i) ((h,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some false)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Lookup. - rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs c Lookup); reflexivity. + rewrite (interp_nd_source_cas_value n ts i a expected desired current K h allocs ctx c Lookup); reflexivity. Qed. Lemma anl_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )>)). Proof. intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs ctx c Lookup); reflexivity. Qed. Lemma anr_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs ctx c Lookup); reflexivity. Qed. Lemma aul_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )>)). Proof. intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs ctx c Lookup); reflexivity. Qed. Lemma aur_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : h a = Some current -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs ctx c Lookup); reflexivity. Qed. Lemma ag_csl_rr_cas n (ts : pool sE (S n)) (i : Fin.t (S n)) - a expected desired current (K : option bool -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) : + a expected desired current (K : option bool -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : h a = Some current -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CCAS a expected desired) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> (<( {if Nat.eqb current expected then interp_schedule_rr sh (S n) - (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),c) + (ts @ i := K (Some true)) (Some i) m ((upd h a desired,allocs),(ctx,c)) else interp_schedule_rr sh (S n) - (ts @ i := K (Some false)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )>)). + (ts @ i := K (Some false)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )>)). Proof. intros Lookup. - rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs c Lookup); reflexivity. + rewrite (interp_rr_cas_value n ts i a expected desired current K m h allocs ctx c Lookup); reflexivity. Qed. (** ** Source flow and pool structure *) Lemma anl_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. + rewrite (interp_nd_source_ret n ts i x K (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (x : A) (K : option A -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. + rewrite (interp_nd_source_ret n ts i x K (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. + rewrite (interp_nd_source_ret n ts i x K (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (x : A) (K : option A -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. + rewrite (interp_nd_source_ret n ts i x K (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_nd_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := K (Some x)) (Some i) (memory,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_nd_source_ret n ts i x K (memory,c)); reflexivity. + rewrite (interp_nd_source_ret n ts i x K (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some x)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. + rewrite (interp_rr_ret n ts i x K m (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (x : A) (K : option A -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some x)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. + rewrite (interp_rr_ret n ts i x K m (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some x)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. + rewrite (interp_rr_ret n ts i x K m (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (x : A) (K : option A -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some x)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. + rewrite (interp_rr_ret n ts i x K m (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_rr_ret {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (x : A) (K : option A -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + (x : A) (K : option A -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CRet x) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some x)) (Some i) m (memory,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some x)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_rr_ret n ts i x K m (memory,c)); reflexivity. + rewrite (interp_rr_ret n ts i x K m (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. + rewrite (interp_nd_source_bind n ts i p next K (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. + rewrite (interp_nd_source_bind n ts i p next K (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. + rewrite (interp_nd_source_bind n ts i p next K (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. + rewrite (interp_nd_source_bind n ts i p next K (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_nd_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,c)}, {w} |= AG φ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_nd_source_bind n ts i p next K (memory,c)); reflexivity. + rewrite (interp_nd_source_bind n ts i p next K (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. + rewrite (interp_rr_bind n ts i p next K m (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. + rewrite (interp_rr_bind n ts i p next K m (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. + rewrite (interp_rr_bind n ts i p next K m (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. + rewrite (interp_rr_bind n ts i p next K m (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_rr_bind {A B : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + (p : CProg A) (next : A -> CProg B) (K : option B -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CBind p next) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) (ts @ i := (denote_flow p >>= fun flow => - match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,c)}, {w} |= AG φ )>)). + match flow with None => K None | Some x => denote_flow (next x) >>= K end)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_rr_bind n ts i p next K m (memory,c)); reflexivity. + rewrite (interp_rr_bind n ts i p next K m (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AN ψ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. + rewrite (interp_nd_source_until_none n ts i body K (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (body : CProg (option A)) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. + rewrite (interp_nd_source_until_none n ts i body K (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AU ψ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. + rewrite (interp_nd_source_until_none n ts i body K (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (body : CProg (option A)) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. + rewrite (interp_nd_source_until_none n ts i body K (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_nd_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,c)}, {w} |= AG φ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_nd_source_until_none n ts i body K (memory,c)); reflexivity. + rewrite (interp_nd_source_until_none n ts i body K (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. + rewrite (interp_rr_until_none n ts i body K m (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (body : CProg (option A)) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. + rewrite (interp_rr_until_none n ts i body K m (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. + rewrite (interp_rr_until_none n ts i body K m (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (body : CProg (option A)) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. + rewrite (interp_rr_until_none n ts i body K m (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_rr_until_none {A : Type} n (ts : pool sE (S n)) (i : Fin.t (S n)) - (body : CProg (option A)) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + (body : CProg (option A)) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CUntilNone body) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,c)}, {w} |= AG φ )>)). + (ts @ i := (denote_flow body >>= until_tail body K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_rr_until_none n ts i body K m (memory,c)); reflexivity. + rewrite (interp_rr_until_none n ts i body K m (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AN ψ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. + rewrite (interp_nd_source_fork n ts i child K (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (child : CProg unit) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AN ψ ]>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. + rewrite (interp_nd_source_fork n ts i child K (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AU ψ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. + rewrite (interp_nd_source_fork n ts i child K (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (child : CProg unit) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= φ AU ψ ]>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. + rewrite (interp_nd_source_fork n ts i child K (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_nd_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_nd sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,c)}, {w} |= AG φ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_nd_source_fork n ts i child K (memory,c)); reflexivity. + rewrite (interp_nd_source_fork n ts i child K (memory,(ctx,c))); reflexivity. Qed. Lemma anl_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AN ψ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. - rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. + rewrite (interp_rr_fork n ts i child K m (memory,(ctx,c))); reflexivity. Qed. Lemma anr_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (child : CProg unit) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AN ψ ]>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. - rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. + rewrite (interp_rr_fork n ts i child K m (memory,(ctx,c))); reflexivity. Qed. Lemma aul_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AU ψ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. - rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. + rewrite (interp_rr_fork n ts i child K m (memory,(ctx,c))); reflexivity. Qed. Lemma aur_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (child : CProg unit) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= φ AU ψ ]>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. - rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. + rewrite (interp_rr_fork n ts i child K m (memory,(ctx,c))); reflexivity. Qed. Lemma ag_csl_rr_fork n (ts : pool sE (S n)) (i : Fin.t (S n)) - (child : CProg unit) (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + (child : CProg unit) (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CFork child) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S (S n)) - ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,c)}, {w} |= AG φ )>)). + ((denote_flow child >>= fun _ => K None) :: (ts @ i := K (Some tt)))%vector (Some (Fin.FS i)) m (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. - rewrite (interp_rr_fork n ts i child K m (memory,c)); reflexivity. + rewrite (interp_rr_fork n ts i child K m (memory,(ctx,c))); reflexivity. Qed. (** ** Observable emission and cooperative selection *) Lemma anl_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= ψ )>)). Proof. rewrite interp_nd_source_emit_log. apply anl_log_iff. Qed. Lemma anr_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + tag value (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= φ )> /\ <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= ψ ]>)). Proof. rewrite interp_nd_source_emit_log. apply anr_log_iff. Qed. Lemma aul_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= ψ )> \/ - (<( {log (stamp (tag,value) c);; + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= ψ )> \/ + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= φ AU ψ )>))). Proof. rewrite interp_nd_source_emit_log. apply aul_log_iff. Qed. Lemma aur_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + tag value (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= ψ ]> \/ - (<( {log (stamp (tag,value) c);; + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= ψ ]> \/ + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= φ )> /\ <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= φ AU ψ ]>))). Proof. rewrite interp_nd_source_emit_log. apply aur_log_iff. Qed. Lemma ag_csl_nd_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some i) (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= AG φ )>)). Proof. rewrite interp_nd_source_emit_log. apply ag_log_iff. Qed. Lemma anl_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ )>)). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= ψ )>)). Proof. rewrite interp_rr_emit_log. apply anl_log_iff. Qed. Lemma anr_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + tag value (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= φ )> /\ <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= ψ ]>)). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= ψ ]>)). Proof. rewrite interp_rr_emit_log. apply anr_log_iff. Qed. Lemma aul_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= ψ )> \/ - (<( {log (stamp (tag,value) c);; + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= ψ )> \/ + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ )>))). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= φ AU ψ )>))). Proof. rewrite interp_rr_emit_log. apply aul_log_iff. Qed. Lemma aur_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + tag value (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> - (<[ {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= ψ ]> \/ - (<( {log (stamp (tag,value) c);; + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= ψ ]> \/ + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= φ )> /\ <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= φ AU ψ ]>))). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= φ AU ψ ]>))). Proof. rewrite interp_rr_emit_log. apply aur_log_iff. Qed. Lemma ag_csl_rr_emit n (ts : pool sE (S n)) (i : Fin.t (S n)) - tag value (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + tag value (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> - (<( {log (stamp (tag,value) c);; + (ts @ i := (denote_flow (CEmit tag value) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> + (<( {log (inr (stamp (tag,value) c) : CSLObs (nat * nat));; interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {w} |= φ )> /\ <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some i) m (memory,S c)}, {Obs (Log (stamp (tag,value) c)) tt} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some i) m (memory,(ctx,S c))}, {Obs (Log (inr (stamp (tag,value) c) : CSLObs (nat * nat))) tt} |= AG φ )>)). Proof. rewrite interp_rr_emit_log. apply ag_log_iff. Qed. Lemma anl_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= ψ )>)). + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c))}, {w} |= ψ )>)). Proof. rewrite interp_nd_source_yield. apply anl_csl_nd_select. Qed. Lemma anr_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= ψ ]>)). + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c))}, {w} |= ψ ]>)). Proof. rewrite interp_nd_source_yield. apply anr_csl_nd_select. Qed. Lemma aul_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= ψ )> \/ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= ψ )> \/ (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= φ AU ψ )>))). + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c))}, {w} |= φ AU ψ )>))). Proof. rewrite interp_nd_source_yield. apply aul_csl_nd_select. Qed. Lemma aur_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= ψ ]> \/ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= ψ ]> \/ (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= φ AU ψ ]>))). + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c))}, {w} |= φ AU ψ ]>))). Proof. rewrite interp_nd_source_yield. apply aur_csl_nd_select. Qed. Lemma ag_csl_nd_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) memory c w - (φ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {Br n (fun j : Fin.t (S n) => interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c))}, {w} |= φ )> /\ + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ forall j : Fin.t (S n), <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some tt)) (Some j) (memory,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some j) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. rewrite interp_nd_source_yield. apply ag_csl_nd_select. Qed. Lemma anl_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ )>)). + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AN ψ )>)). Proof. rewrite interp_rr_yield. apply anl_csl_rr_select. Qed. Lemma anr_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AN ψ ]>)). + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). Proof. rewrite interp_rr_yield. apply anr_csl_rr_select. Qed. Lemma aul_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m memory c w - (φ ψ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) m memory ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ )>)). + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AU ψ )>)). Proof. rewrite interp_rr_yield. apply aul_csl_rr_select. Qed. Lemma aur_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> (<[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= φ AU ψ ]>)). + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). Proof. rewrite interp_rr_yield. apply aur_csl_rr_select. Qed. Lemma ag_csl_rr_yield n (ts : pool sE (S n)) (i : Fin.t (S n)) - (K : option unit -> thread sE) m memory c w - (φ : ticllW (indexed (nat * nat))) : + (K : option unit -> thread sE) m memory ctx c w + (φ : ticllW (CSLObs (nat * nat))) : (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CYield) >>= K)) (Some i) m (memory,(ctx,c))}, {w} |= AG φ )> <-> (<( {interp_schedule_rr sh (S n) - (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,c)}, {w} |= AG φ )>)). + (ts @ i := K (Some tt)) (Some (rr_pick n m)) (S m) (memory,(ctx,c))}, {w} |= AG φ )>)). Proof. rewrite interp_rr_yield. apply ag_csl_rr_select. @@ -2694,234 +3000,234 @@ Qed. (** ** Finite heaps supply their constructive first-fit witness *) Lemma anl_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (anl_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (anl_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (anl_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (anl_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma anr_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (anr_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (anr_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (anr_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (anr_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma aul_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (aul_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (aul_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (aul_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (aul_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma aur_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <[ {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (aur_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (aur_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (aur_csl_nd_alloc n ts i size base K h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (aur_csl_nd_alloc n ts i size base K h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma ag_csl_nd_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) h allocs c w - (φ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_nd sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_nd sh (S n) - (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>). + (ts @ i := K (Some base)) (Some i) (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= AG φ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (ag_csl_nd_alloc n ts i size base K h allocs c w φ Pos Base Free First)); exact Hsource. + apply (proj1 (ag_csl_nd_alloc n ts i size base K h allocs ctx c w φ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (ag_csl_nd_alloc n ts i size base K h allocs c w φ Pos Base Free First)). + apply (proj2 (ag_csl_nd_alloc n ts i size base K h allocs ctx c w φ Pos Base Free First)). apply Hall; assumption. Qed. Lemma anl_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ )>). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (anl_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (anl_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (anl_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (anl_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma anr_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AN ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AN ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AN ψ ]>). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AN ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (anr_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (anr_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (anr_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (anr_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma aul_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h allocs c w - (φ ψ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) m h allocs ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ )>). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (aul_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (aul_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (aul_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (aul_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma aur_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) (ψ : ticlrW (indexed (nat * nat)) (unit * SSig)) : + size (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : heap_finite h -> Nat.lt 0 size -> (<[ {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= φ AU ψ ]> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= φ AU ψ ]> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <[ {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= φ AU ψ ]>). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= φ AU ψ ]>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (aur_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)); exact Hsource. + apply (proj1 (aur_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (aur_csl_rr_alloc n ts i size base K m h allocs c w φ ψ Pos Base Free First)). + apply (proj2 (aur_csl_rr_alloc n ts i size base K m h allocs ctx c w φ ψ Pos Base Free First)). apply Hall; assumption. Qed. Lemma ag_csl_rr_alloc_finite n (ts : pool sE (S n)) (i : Fin.t (S n)) - size (K : option nat -> thread sE) m h allocs c w - (φ : ticllW (indexed (nat * nat))) : + size (K : option nat -> thread sE) m h allocs ctx c w + (φ : ticllW (CSLObs (nat * nat))) : heap_finite h -> Nat.lt 0 size -> (<( {interp_schedule_rr sh (S n) - (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),c)}, {w} |= AG φ )> <-> + (ts @ i := (denote_flow (CAlloc size) >>= K)) (Some i) m ((h,allocs),(ctx,c))}, {w} |= AG φ )> <-> forall base, Nat.lt 0 base -> block_free h base size -> (forall j, Nat.lt 0 j -> Nat.lt j base -> ~ block_free h j size) -> <( {interp_schedule_rr sh (S n) - (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,c)}, {w} |= AG φ )>). + (ts @ i := K (Some base)) (Some i) m (managed_alloc (h,allocs) base size,(ctx,c))}, {w} |= AG φ )>). Proof. intros Finite Pos; split. - intros Hsource base Base Free First. - apply (proj1 (ag_csl_rr_alloc n ts i size base K m h allocs c w φ Pos Base Free First)); exact Hsource. + apply (proj1 (ag_csl_rr_alloc n ts i size base K m h allocs ctx c w φ Pos Base Free First)); exact Hsource. - intro Hall. - destruct (heap_handler_alloc_finite h allocs size c Finite Pos) + destruct (heap_handler_alloc_finite h allocs size (ctx,c) Finite Pos) as (base & Base & Free & First & _). - apply (proj2 (ag_csl_rr_alloc n ts i size base K m h allocs c w φ Pos Base Free First)). + apply (proj2 (ag_csl_rr_alloc n ts i size base K m h allocs ctx c w φ Pos Base Free First)). apply Hall; assumption. Qed. (** ** Source loops: actual observations sustain AG; guard-only divergence does not *) -Lemma run_nd_emit_loop_ag tag value memory c w : +Lemma run_nd_emit_loop_ag tag value memory ctx c w : not_done w -> <( {run_nd (CUntilNone (CBind (CEmit tag value) - (fun _ => CRet (Some tt : option unit)))) memory c}, {w} |= AG ⊤ )>. + (fun _ => CRet (Some tt : option unit)))) (memory,(ctx,c))}, {w} |= AG ⊤ )>. Proof. revert c w; coinduction R CIH; intros c w Hw. - unfold run_nd, denote. + unfold run_nd, run_nd_pool, csl_pool, denote. change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R (interp_schedule_nd sh 1 (([Ret tt] : pool sE 1) @ Fin.F1 := @@ -2929,7 +3235,7 @@ Proof. (CUntilNone (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) >>= fun _ => Ret tt)) - (Some Fin.F1) (memory,c)) w). + (Some Fin.F1) (memory,(ctx,c))) w). rewrite interp_nd_source_until_none, interp_nd_source_bind, interp_nd_source_emit_log. unfold log, ICtree.trigger. @@ -2947,13 +3253,13 @@ Proof. constructor. Qed. -Lemma run_rr_emit_loop_ag tag value memory c w : +Lemma run_rr_emit_loop_ag tag value memory ctx c w : not_done w -> <( {run_rr (CUntilNone (CBind (CEmit tag value) - (fun _ => CRet (Some tt : option unit)))) memory c}, {w} |= AG ⊤ )>. + (fun _ => CRet (Some tt : option unit)))) (memory,(ctx,c))}, {w} |= AG ⊤ )>. Proof. revert c w; coinduction R CIH; intros c w Hw. - unfold run_rr, denote. + unfold run_rr, run_rr_pool, csl_pool, denote. change (agcbt (entailsL (unit * SSig) <[ ⊤ ]>) R (interp_schedule_rr sh 1 (([Ret tt] : pool sE 1) @ Fin.F1 := @@ -2961,7 +3267,7 @@ Proof. (CUntilNone (CBind (CEmit tag value) (fun _ => CRet (Some tt : option unit)))) >>= fun _ => Ret tt)) - (Some Fin.F1) 0 (memory,c)) w). + (Some Fin.F1) 0 (memory,(ctx,c))) w). rewrite interp_rr_until_none, interp_rr_bind, interp_rr_emit_log. unfold log, ICtree.trigger. rewrite bind_vis. @@ -2980,8 +3286,8 @@ Qed. (** The silent loop starts focused, so the whole run is raw-equivalent to its own guard and hence to [stuck]; no scheduler tau is erased. *) -Lemma run_nd_silent_loop_no_ag memory c w : - ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) memory c}, {w} |= AG ⊤ )>. +Lemma run_nd_silent_loop_no_ag (s : SSig) w : + ~ <( {run_nd (CUntilNone (CRet (Some tt : option unit))) s}, {w} |= AG ⊤ )>. Proof. set (p := CUntilNone (CRet (Some tt : option unit))). assert (Hraw : denote p ≅ Guard (denote p)). @@ -2989,8 +3295,8 @@ Proof. etransitivity; [apply source_raw_until |]. etransitivity; [apply source_raw_ret |]. reflexivity. } - assert (Hguard : run_nd p memory c ≅ Guard (run_nd p memory c)). - { unfold run_nd. + assert (Hguard : run_nd p s ≅ Guard (run_nd p s)). + { rewrite run_nd_unfold. etransitivity. - apply ((interp_schedule_nd_equ sh) 1 _ [Guard (denote p)]). apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. @@ -3003,8 +3309,8 @@ Proof. apply ag_stuck. Qed. -Lemma run_rr_silent_loop_no_ag memory c w : - ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) memory c}, {w} |= AG ⊤ )>. +Lemma run_rr_silent_loop_no_ag (s : SSig) w : + ~ <( {run_rr (CUntilNone (CRet (Some tt : option unit))) s}, {w} |= AG ⊤ )>. Proof. set (p := CUntilNone (CRet (Some tt : option unit))). assert (Hraw : denote p ≅ Guard (denote p)). @@ -3012,8 +3318,8 @@ Proof. etransitivity; [apply source_raw_until |]. etransitivity; [apply source_raw_ret |]. reflexivity. } - assert (Hguard : run_rr p memory c ≅ Guard (run_rr p memory c)). - { unfold run_rr. + assert (Hguard : run_rr p s ≅ Guard (run_rr p s)). + { rewrite run_rr_unfold. etransitivity. - apply (interp_schedule_rr_equ sh 1 _ [Guard (denote p)]). apply SBisim.cons_pool_equ; [exact Hraw | apply SBisim.pool_equ_refl]. @@ -3025,3 +3331,757 @@ Proof. rewrite (equ_guard_stuck _ Hguard). apply ag_stuck. Qed. + +(** ** Yield-language structural surface + + The Yield-style expression and control fragment of [CProg] is reasoned + about through three views, all built from the generic eraser and state + interpreter: + + - [scheduled_visible]: the scheduled program with scheduler [Spawn], + cooperative [Yield] and user effects visible; + - [instr_exp_erased]/[instr_flow_erased]: a standalone erased thread run + through [sh], exposing the outer option flow; + - [run_nd]: the erased nondeterministic singleton schedule. *) + +Definition scheduled_visible (p : CProg unit) : completed sE := + schedule 1 [denote p]%vector (Some Fin.F1). + +Definition instr_exp_erased (e : CExp) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (nat * SSig) := + interp_state sh (interp_thread (denote_exp e)) s. + +Definition instr_flow_erased {A} (p : CProg A) (s : SSig) + : ictreeW (CSLObs (nat * nat)) (option A * SSig) := + interp_state sh (interp_thread (denote_flow p)) s. + +(** *** Constructor unfold equations *) + +Lemma denote_exp_cvar name : + denote_exp (CVar name) = + (ctx <- source_get;; + match lookup name ctx with + | Some value => source_yield;; Ret value + | None => stuck + end). +Proof. reflexivity. Qed. + +Lemma denote_exp_clit n : denote_exp (CLit n) = Ret n. +Proof. reflexivity. Qed. + +Lemma denote_exp_cplus a b : + denote_exp (CPlus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_cminus a b : + denote_exp (CMinus a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_exp_cmult a b : + denote_exp (CMult a b) = + (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). +Proof. reflexivity. Qed. + +Lemma denote_unfold (p : CProg unit) : + denote p = (_ <- denote_flow p;; Ret tt). +Proof. reflexivity. Qed. + +Lemma denote_flow_cassign name e : + denote_flow (CAssign name e) = + (value <- denote_exp e;; + ctx <- source_get;; + source_put (add name value ctx);; + Ret (Some tt)). +Proof. reflexivity. Qed. + +Lemma denote_flow_cbind_unit (a b : CProg unit) : + denote_flow (CBind a (fun _ => b)) = + (flow <- denote_flow a;; + match flow with + | None => Ret None + | Some _ => denote_flow b + end). +Proof. reflexivity. Qed. + +Lemma denote_flow_cif {A} test (yes no : CProg A) : + denote_flow (CIf test yes no) = + (value <- denote_exp test;; + if CSLSyntax.is_true value then denote_flow yes else denote_flow no). +Proof. reflexivity. Qed. + +Lemma denote_flow_cret_unit : denote_flow (CRet tt) = Ret (Some tt). +Proof. reflexivity. Qed. + +Lemma denote_flow_cyield : denote_flow CYield = (source_yield;; Ret (Some tt)). +Proof. reflexivity. Qed. + +(** *** Startup normalizations used by the singleton rules *) + +Local Lemma source_yield_bind {X} (k : unit -> ictree CEff X) : + (source_yield >>= k) ≅ Vis (inl Yield) k. +Proof. + unfold source_yield; rewrite bind_vis. + apply vis_equ_node; intros []; apply bind_ret_l. +Qed. + +Local Lemma denote_ret_unit : denote (CRet tt) ≅ Ret tt. +Proof. unfold denote; cbn [denote_flow]; step; cbn; constructor; reflexivity. Qed. + +Local Lemma denote_yield_vis : + denote CYield ≅ Vis (inl Yield : CEff) (fun _ : unit => Ret tt). +Proof. + unfold denote; cbn [denote_flow]; unfold source_yield. + step; cbn; constructor; intros []. + step; cbn; constructor; reflexivity. +Qed. + +Local Lemma denote_assign_lit name n : + denote (CAssign name (CLit n)) ≅ + (source_get >>= fun ctx => source_put (add name n ctx) >>= fun _ => Ret tt). +Proof. + unfold denote; cbn [denote_flow denote_exp]. + rewrite bind_bind, bind_ret_l, bind_bind. + apply equ_clo_bind_eq; intro ctx. + rewrite bind_bind. + apply equ_clo_bind_eq; intros []. + rewrite bind_ret_l; reflexivity. +Qed. + +(** *** Expression rules *) + +Lemma axr_csl_exp_lit : forall n n' s s' w w', + n = n' -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CLit n) s}, w |= AX done= {(n', s')} w' ]>. +Proof. + intros; subst. + unfold instr_exp_erased; cbn [denote_exp]. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma axr_csl_exp_var_some : forall name value s s' w w', + lookup name (csl_context s) = Some value -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CVar name) s}, w |= AX done= {(value, s')} w' ]>. +Proof. + intros name value s s' w w' Hlookup Hs Hw Hnd; subst. + unfold instr_exp_erased; cbn [denote_exp]. + rewrite interp_thread_get_ctx, Hlookup, source_yield_bind. + rewrite interp_state_thread_yield. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma axr_csl_exp_plus : forall a b x y value s s' w w', + <[ {instr_exp_erased a s}, w |= AX done= {(x, s)} w ]> -> + <[ {instr_exp_erased b s}, w |= AX done= {(y, s)} w ]> -> + value = (x + y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CPlus a b) s}, w |= AX done= {(value, s')} w' ]>. +Proof. + intros a b x y value s s' w w' Ha Hb Hvalue Hs Hw Hnd; subst. + unfold instr_exp_erased in *; cbn [denote_exp]. + eapply anr_ithread_bind_r_eq; [exact Ha | cbv beta]. + eapply anr_ithread_bind_r_eq; [exact Hb | cbv beta]. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma axr_csl_exp_minus : forall a b x y value s s' w w', + <[ {instr_exp_erased a s}, w |= AX done= {(x, s)} w ]> -> + <[ {instr_exp_erased b s}, w |= AX done= {(y, s)} w ]> -> + value = (x - y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CMinus a b) s}, w |= AX done= {(value, s')} w' ]>. +Proof. + intros a b x y value s s' w w' Ha Hb Hvalue Hs Hw Hnd; subst. + unfold instr_exp_erased in *; cbn [denote_exp]. + eapply anr_ithread_bind_r_eq; [exact Ha | cbv beta]. + eapply anr_ithread_bind_r_eq; [exact Hb | cbv beta]. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma axr_csl_exp_mult : forall a b x y value s s' w w', + <[ {instr_exp_erased a s}, w |= AX done= {(x, s)} w ]> -> + <[ {instr_exp_erased b s}, w |= AX done= {(y, s)} w ]> -> + value = (x * y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CMult a b) s}, w |= AX done= {(value, s')} w' ]>. +Proof. + intros a b x y value s s' w w' Ha Hb Hvalue Hs Hw Hnd; subst. + unfold instr_exp_erased in *; cbn [denote_exp]. + eapply anr_ithread_bind_r_eq; [exact Ha | cbv beta]. + eapply anr_ithread_bind_r_eq; [exact Hb | cbv beta]. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma axr_csl_exp_plus_lit_lit : forall x y value s s' w w', + value = (x + y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CPlus (CLit x) (CLit y)) s}, + w |= AX done= {(value, s')} w' ]>. +Proof. + intros; subst. + eapply axr_csl_exp_plus; eauto; apply axr_csl_exp_lit; auto. +Qed. + +Lemma axr_csl_exp_minus_lit_lit : forall x y value s s' w w', + value = (x - y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CMinus (CLit x) (CLit y)) s}, + w |= AX done= {(value, s')} w' ]>. +Proof. + intros; subst. + eapply axr_csl_exp_minus; eauto; apply axr_csl_exp_lit; auto. +Qed. + +Lemma axr_csl_exp_mult_lit_lit : forall x y value s s' w w', + value = (x * y)%nat -> + s = s' -> + w = w' -> + not_done w -> + <[ {instr_exp_erased (CMult (CLit x) (CLit y)) s}, + w |= AX done= {(value, s')} w' ]>. +Proof. + intros; subst. + eapply axr_csl_exp_mult; eauto; apply axr_csl_exp_lit; auto. +Qed. + +(** *** Scheduled singleton rules (nondeterministic scheduler) *) + +Lemma axr_csl_nd_skip : forall s s' w w', + s = s' -> + w = w' -> + not_done w -> + <[ {run_nd (CRet tt) s}, w |= AX done= {(tt, s')} w' ]>. +Proof. + intros s s' w w' Hs Hw Hnd; subst. + rewrite run_nd_unfold. + rewrite ((interp_schedule_nd_equ sh) 1 _ _ (Some Fin.F1) s' + (cons_pool_equ _ _ _ _ denote_ret_unit (pool_equ_refl _))). + apply axr_schedule_nd_ret; [assumption | split; reflexivity]. +Qed. + +(** The [AX AX] count is specific to the nondeterministic scheduler: its + scheduling point is a real branch, whereas round robin selects + deterministically. *) +Lemma axax_csl_nd_yield : forall s s' w w', + s = s' -> + w = w' -> + not_done w -> + <[ {run_nd CYield s}, w |= AX AX done= {(tt, s')} w' ]>. +Proof. + intros s s' w w' Hs Hw Hnd; subst. + rewrite run_nd_unfold. + rewrite ((interp_schedule_nd_equ sh) 1 _ _ (Some Fin.F1) s' + (cons_pool_equ _ _ _ _ denote_yield_vis (pool_equ_refl _))). + apply axax_schedule_nd_yield; [assumption | split; reflexivity]. +Qed. + +Lemma aur_csl_nd_yield_done : forall s s' w w' ψ, + s = s' -> + w = w' -> + not_done w -> + <[ {run_nd CYield s}, w |= ψ AU AX AX done= {(tt, s')} w' ]>. +Proof. + intros; subst. + cleft. + now apply axax_csl_nd_yield. +Qed. + +(** *** Flow-preserving statement rules *) + +Lemma aur_csl_flow_assign : forall name expr value s w ψ R, + <[ {instr_exp_erased expr s}, w |= AX done= {(value, s)} w ]> -> + <( {log (inl (add name value (csl_context s)) : CSLObs (nat * nat))}, w |= ψ )> -> + R (Some tt, csl_set_context s (add name value (csl_context s))) + (Obs (Log (inl (add name value (csl_context s)) : CSLObs (nat * nat))) tt) -> + <[ {instr_flow_erased (CAssign name expr) s}, w |= ψ AU AX done R ]>. +Proof. + intros name expr value s w ψ R Hexp Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + unfold instr_flow_erased, instr_exp_erased in *. + rewrite denote_flow_cassign. + eapply aur_ithread_bind_r_eq; [cleft; exact Hexp | cbv beta]. + rewrite (interp_thread_ctx_update (add name value)). + eapply aur_log. + - cleft; apply axr_ret; [constructor | exact HR]. + - now apply ticll_bind_l. +Qed. + +Lemma aul_csl_flow_assign : forall name expr value s w ψ φ, + <[ {instr_exp_erased expr s}, w |= AX done= {(value, s)} w ]> -> + <( {log (inl (add name value (csl_context s)) : CSLObs (nat * nat))}, w |= ψ )> -> + <( {Ret (Some tt, csl_set_context s (add name value (csl_context s)))}, + {Obs (Log (inl (add name value (csl_context s)) : CSLObs (nat * nat))) tt} + |= φ )> -> + <( {instr_flow_erased (CAssign name expr) s}, w |= ψ AU φ )>. +Proof. + intros name expr value s w ψ φ Hexp Hlog Hret. + unfold instr_flow_erased, instr_exp_erased in *. + rewrite denote_flow_cassign. + eapply aul_ithread_bind_r_eq; [cleft; exact Hexp | cbv beta]. + rewrite (interp_thread_ctx_update (add name value)). + cright. + apply anl_log. + - cleft; exact Hret. + - now apply ticll_bind_l. +Qed. + +Lemma anr_csl_flow_bind_fallthrough : forall (a b : CProg unit) s s' w w' φ ψ, + <[ {instr_flow_erased a s}, w |= φ AN done= {(Some tt, s')} w' ]> -> + <[ {instr_flow_erased b s'}, w' |= φ AN ψ ]> -> + <[ {instr_flow_erased (CBind a (fun _ => b)) s}, w |= φ AN ψ ]>. +Proof. + intros a b s s' w w' φ ψ Ha Hb. + unfold instr_flow_erased in *. + rewrite denote_flow_cbind_unit. + eapply anr_ithread_bind_r_eq; eauto. +Qed. + +Lemma aur_csl_flow_bind : forall (a b : CProg unit) s s' w w' φ ψ, + <[ {instr_flow_erased a s}, w |= φ AU AX done= {(Some tt, s')} w' ]> -> + <[ {instr_flow_erased b s'}, w' |= φ AU ψ ]> -> + <[ {instr_flow_erased (CBind a (fun _ => b)) s}, w |= φ AU ψ ]>. +Proof. + intros a b s s' w w' φ ψ Ha Hb. + unfold instr_flow_erased in *. + rewrite denote_flow_cbind_unit. + eapply aur_ithread_bind_r_eq; eauto. +Qed. + +Lemma aul_csl_flow_bind : forall (a b : CProg unit) s s' w w' φ ψ, + <[ {instr_flow_erased a s}, w |= φ AU AX done= {(Some tt, s')} w' ]> -> + <( {instr_flow_erased b s'}, w' |= φ AU ψ )> -> + <( {instr_flow_erased (CBind a (fun _ => b)) s}, w |= φ AU ψ )>. +Proof. + intros a b s s' w w' φ ψ Ha Hb. + unfold instr_flow_erased in *. + rewrite denote_flow_cbind_unit. + eapply aul_ithread_bind_r_eq; eauto. +Qed. + +(** A halted first statement skips the second: the halt flow propagates. *) +Lemma aur_csl_flow_bind_halt : forall (a b : CProg unit) s s' w w' φ, + <[ {instr_flow_erased a s}, w |= φ AU AX done= {(None, s')} w' ]> -> + not_done w' -> + <[ {instr_flow_erased (CBind a (fun _ => b)) s}, + w |= φ AU AX done= {(None, s')} w' ]>. +Proof. + intros a b s s' w w' φ Ha Hnd. + unfold instr_flow_erased in *. + rewrite denote_flow_cbind_unit. + eapply aur_ithread_bind_r_eq; [exact Ha | cbv beta]. + cleft. + apply axr_ithread_ret; [assumption | split; reflexivity]. +Qed. + +Lemma aul_csl_flow_if {A} : forall test (yes no : CProg A) condition s w φ ψ, + <[ {instr_exp_erased test s}, w |= AX done= {(condition, s)} w ]> -> + (if CSLSyntax.is_true condition then + <( {instr_flow_erased yes s}, w |= φ AU ψ )> + else + <( {instr_flow_erased no s}, w |= φ AU ψ )>) -> + <( {instr_flow_erased (CIf test yes no) s}, w |= φ AU ψ )>. +Proof. + intros test yes no condition s w φ ψ Htest Hbranch. + unfold instr_flow_erased, instr_exp_erased in *. + rewrite denote_flow_cif. + eapply aul_ithread_bind_r_eq; [cleft; exact Htest | cbv beta]. + destruct (CSLSyntax.is_true condition); exact Hbranch. +Qed. + +Lemma aur_csl_flow_if {A} : forall test (yes no : CProg A) condition s w φ ψ, + <[ {instr_exp_erased test s}, w |= AX done= {(condition, s)} w ]> -> + (if CSLSyntax.is_true condition then + <[ {instr_flow_erased yes s}, w |= φ AU ψ ]> + else + <[ {instr_flow_erased no s}, w |= φ AU ψ ]>) -> + <[ {instr_flow_erased (CIf test yes no) s}, w |= φ AU ψ ]>. +Proof. + intros test yes no condition s w φ ψ Htest Hbranch. + unfold instr_flow_erased, instr_exp_erased in *. + rewrite denote_flow_cif. + eapply aur_ithread_bind_r_eq; [cleft; exact Htest | cbv beta]. + destruct (CSLSyntax.is_true condition); exact Hbranch. +Qed. + +(** *** Raw source-flow while rules + + These are stated over raw [World CEff] events and expose the option + flow directly; they make no claim about scheduled liveness. *) + +Lemma aul_csl_raw_while : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + CSLSyntax.is_true condition = true -> + <[ {denote_flow body}, w |= φ AU AX done= {Some tt} w' ]> -> + not_done w' -> + <( {denote_flow (CWhile test body)}, w' |= φ AU ψ )> -> + <( {denote_flow (CWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. + rewrite denote_flow_cwhile in *. + eapply aul_iter_next with (R := fun (_ : unit) w0 => w0 = w'). + - unfold cwhile_iteration. + eapply aur_bind_r_eq; [exact Htest |]. + rewrite Htrue. + eapply aur_bind_r_eq; [exact Hbody |]. + cleft; apply axr_ret; auto. + exists tt; split; auto. + - intros [] w0 ->; exact Hloop. +Qed. + +Lemma aul_csl_raw_while_false : forall test body condition w φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + CSLSyntax.is_true condition = false -> + <( {Ret (Some tt) : ictree CEff (option unit)}, w |= ψ )> -> + <( {denote_flow (CWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w φ ψ Htest Hfalse Hret. + pose proof Htest as Htest_not_done. + apply aur_not_done in Htest_not_done. + rewrite denote_flow_cwhile, unfold_iter. + eapply aul_bind_r_eq. + - unfold cwhile_iteration. + eapply aur_bind_r_eq; [exact Htest |]. + rewrite Hfalse. + cleft; apply axr_ret; [exact Htest_not_done | split; reflexivity]. + - cbn; cleft; exact Hret. +Qed. + +Lemma aul_csl_raw_while_halt : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + CSLSyntax.is_true condition = true -> + <[ {denote_flow body}, w |= φ AU AX done= {None} w' ]> -> + not_done w' -> + <( {Ret None : ictree CEff (option unit)}, w' |= ψ )> -> + <( {denote_flow (CWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hret. + rewrite denote_flow_cwhile, unfold_iter. + eapply aul_bind_r_eq. + - unfold cwhile_iteration. + eapply aur_bind_r_eq; [exact Htest |]. + rewrite Htrue. + eapply aur_bind_r_eq; [exact Hbody |]. + cleft; apply axr_ret; auto. + - cbn; cleft; exact Hret. +Qed. + +Lemma aur_csl_raw_while : forall test body condition w w' φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + CSLSyntax.is_true condition = true -> + <[ {denote_flow body}, w |= φ AU AX done= {Some tt} w' ]> -> + not_done w' -> + <[ {denote_flow (CWhile test body)}, w' |= φ AU AX ψ ]> -> + <[ {denote_flow (CWhile test body)}, w |= φ AU AX ψ ]>. +Proof. + intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. + rewrite denote_flow_cwhile in *. + eapply aur_iter_next with (R := fun (_ : unit) w0 => w0 = w'). + - unfold cwhile_iteration. + eapply aur_bind_r_eq; [exact Htest |]. + rewrite Htrue. + eapply aur_bind_r_eq; [exact Hbody |]. + cleft; apply axr_ret; auto. + exists tt; split; auto. + - intros [] w0 ->; exact Hloop. +Qed. + +Lemma aur_csl_raw_while_false : forall test body condition w φ ψ, + <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> + CSLSyntax.is_true condition = false -> + <[ {Ret (Some tt) : ictree CEff (option unit)}, w |= AX ψ ]> -> + <[ {denote_flow (CWhile test body)}, w |= φ AU AX ψ ]>. +Proof. + intros test body condition w φ ψ Htest Hfalse Hret. + pose proof Htest as Htest_not_done. + apply aur_not_done in Htest_not_done. + rewrite denote_flow_cwhile, unfold_iter. + eapply aur_bind_r_eq. + - unfold cwhile_iteration. + eapply aur_bind_r_eq; [exact Htest |]. + rewrite Hfalse. + cleft; apply axr_ret; [exact Htest_not_done | split; reflexivity]. + - cbn; cleft; exact Hret. +Qed. + +Lemma ag_csl_raw_while : forall test body (R : World CEff -> Prop) w φ, + R w -> + (forall w, + R w -> + <( {denote_flow (CWhile test body)}, w |= φ )> /\ + <[ {cwhile_iteration test body tt}, w |= AX (φ AU AX done + {fun lr w' => exists i' : unit, lr = inl i' /\ R w'}) ]>) -> + <( {denote_flow (CWhile test body)}, w |= AG φ )>. +Proof. + intros test body R w φ HR Hstep. + rewrite denote_flow_cwhile. + eapply ag_iter with (R := fun (_ : unit) w => R w); eauto. + intros [] w0 HR0. + specialize (Hstep w0 HR0) as [Hφ Hnext]. + rewrite denote_flow_cwhile in Hφ. + split; [exact Hφ | exact Hnext]. +Qed. + +(** A ranked raw while rule: every iteration either establishes the goal or + returns to the loop head at a smaller natural rank. *) +Lemma aul_csl_raw_while_nat : forall test body (Ri : World CEff -> Prop) + (f : World CEff -> nat) w φ ψ, + not_done w -> + Ri w -> + (forall w, + not_done w -> + Ri w -> + <( {cwhile_iteration test body tt}, w |= φ AU ψ )> \/ + <[ {cwhile_iteration test body tt}, w |= φ AU AX done + {fun lr w' => exists i' : unit, + lr = inl i' /\ not_done w' /\ Ri w' /\ f w' < f w} ]>) -> + <( {denote_flow (CWhile test body)}, w |= φ AU ψ )>. +Proof. + intros test body Ri f w φ ψ Hnd HRi Hstep. + rewrite denote_flow_cwhile. + apply (aul_iter_nat (fun (_ : unit) w => Ri w) (fun _ w => f w) tt w + (cwhile_iteration test body)); auto. +Qed. + +(** *** Scheduled assignment rules *) + +Lemma aur_csl_nd_assign_lit : forall name n s w ψ R, + <( {log (inl (add name n (csl_context s)) : CSLObs (nat * nat))}, w |= ψ )> -> + R (tt, csl_set_context s (add name n (csl_context s))) + (Obs (Log (inl (add name n (csl_context s)) : CSLObs (nat * nat))) tt) -> + <[ {run_nd (CAssign name (CLit n)) s}, w |= ψ AU AX done R ]>. +Proof. + intros name n s w ψ R Hlog HR. + pose proof (ticll_not_done unit _ _ _ Hlog) as Hnd. + rewrite run_nd_unfold. + rewrite ((interp_schedule_nd_equ sh) 1 _ + ([Ret tt]%vector @ Fin.F1 := + (source_get >>= fun ctx => source_put (add name n ctx) >>= fun _ => Ret tt)) + (Some Fin.F1) s + (cons_pool_equ _ _ _ _ (denote_assign_lit name n) (pool_equ_refl _))). + rewrite interp_nd_get_ctx; cbv beta. + rewrite interp_nd_put_ctx. + eapply aur_log. + - rewrite (interp_schedule_nd_ret sh 0 _ Fin.F1 _) by reflexivity. + rewrite interp_schedule_nd_empty. + cleft; apply axr_ret; [constructor | exact HR]. + - now apply ticll_bind_l. +Qed. + +Lemma aul_csl_nd_assign_lit : forall name n s w ψ φ, + <( {log (inl (add name n (csl_context s)) : CSLObs (nat * nat))}, w |= ψ )> -> + <( {Ret (tt, csl_set_context s (add name n (csl_context s)))}, + {Obs (Log (inl (add name n (csl_context s)) : CSLObs (nat * nat))) tt} |= φ )> -> + <( {run_nd (CAssign name (CLit n)) s}, w |= ψ AU φ )>. +Proof. + intros name n s w ψ φ Hlog Hret. + rewrite run_nd_unfold. + rewrite ((interp_schedule_nd_equ sh) 1 _ + ([Ret tt]%vector @ Fin.F1 := + (source_get >>= fun ctx => source_put (add name n ctx) >>= fun _ => Ret tt)) + (Some Fin.F1) s + (cons_pool_equ _ _ _ _ (denote_assign_lit name n) (pool_equ_refl _))). + rewrite interp_nd_get_ctx; cbv beta. + rewrite interp_nd_put_ctx. + cright. + apply anl_log. + - rewrite (interp_schedule_nd_ret sh 0 _ Fin.F1 _) by reflexivity. + rewrite interp_schedule_nd_empty. + cleft; exact Hret. + - now apply ticll_bind_l. +Qed. + +(** *** Scheduler-visible and observed-scheduler bridges *) + +Corollary sbisim_scheduled_visible (p q : CProg unit) : + denote p ~ denote q -> + scheduled_visible p ~ scheduled_visible q. +Proof. + intro Hpq. + unfold scheduled_visible. + apply sbisim_schedule. + intro i. + dependent destruction i. + - exact Hpq. + - inversion i. +Qed. + +Definition scheduled_observed (p : CProg unit) : observed_completed sE := + schedule_with_offers 1 [denote p]%vector (Some Fin.F1). + +Theorem forget_scheduled_observed_is_scheduled_visible (p : CProg unit) : + forget_scheduler_offers (scheduled_observed p) ~ scheduled_visible p. +Proof. + unfold scheduled_observed, scheduled_visible. + apply forget_scheduler_offers_preserves_schedule. +Qed. + +(** Conditional on scheduler progress; this is about scheduling-point offers, + not fair thread selection. *) +Theorem scheduled_observed_every_live_slot_eventually_offered (p : CProg unit) : + SchedulerProgress (scheduled_observed p) Pure -> + agc scheduling_point_offer_obligation (scheduled_observed p) Pure. +Proof. + unfold scheduled_observed. + apply every_live_slot_is_eventually_offered_at_scheduling_points. +Qed. + + +(** ** Source pools: closed turns, selection, and structural rules + + The generic pool rules of [ICTree.Logic.Yield] specialized to source + pools [csl_pool ps]. A turn certificate is an exact first-yield segment + of the slot's own denotation that returns to that same denotation. *) + +Lemma run_nd_pool_turn {n} (ps : Vector.t (CProg unit) (S n)) (i : Fin.t (S n)) + (s s' : SSig) logs : + segment_to sh csl_equ (csl_pool ps $ i) s logs (csl_pool ps $ i) s' -> + run_nd_pool ps (Some i) s ~ emit_list logs (run_nd_pool ps None s'). +Proof. exact (segment_pool_nd_loop sh n (csl_pool ps) i s logs s'). Qed. + +Lemma run_rr_pool_turn {n} (ps : Vector.t (CProg unit) (S n)) (i : Fin.t (S n)) + cursor (s s' : SSig) logs : + segment_to sh csl_equ (csl_pool ps $ i) s logs (csl_pool ps $ i) s' -> + run_rr_pool ps (Some i) cursor s ~ emit_list logs (run_rr_pool ps None cursor s'). +Proof. exact (segment_pool_rr_loop sh n (csl_pool ps) i cursor s logs s'). Qed. + +Lemma run_nd_pool_select {n} (ps : Vector.t (CProg unit) (S n)) (s : SSig) : + run_nd_pool ps None s ~ Br n (fun i => run_nd_pool ps (Some i) s). +Proof. exact (interp_schedule_nd_select sh n (csl_pool ps) s). Qed. + +Lemma run_rr_pool_select {n} (ps : Vector.t (CProg unit) (S n)) cursor (s : SSig) : + run_rr_pool ps None cursor s ~ run_rr_pool ps (Some (rr_pick n cursor)) (S cursor) s. +Proof. exact (interp_schedule_rr_select sh n (csl_pool ps) cursor s). Qed. + +Lemma ag_csl_nd_invariance {G n} (ps : Vector.t (CProg unit) (S n)) + (Inv : G -> SSig -> Prop) (φ : ticllW (CSLObs (nat * nat))) : + ClosedTurns sh (csl_pool ps) Inv -> + (forall g s focus w, Inv g s -> not_done w -> + <( {run_nd_pool ps focus s}, {w} |= φ )>) -> + forall g s focus w, Inv g s -> not_done w -> + <( {run_nd_pool ps focus s}, {w} |= AG φ )>. +Proof. exact (ag_pool_nd_invariance sh (csl_pool ps) Inv φ). Qed. + +Lemma ag_csl_rr_invariance {G n} (ps : Vector.t (CProg unit) (S n)) + (Inv : G -> SSig -> Prop) (φ : ticllW (CSLObs (nat * nat))) : + ClosedTurns sh (csl_pool ps) Inv -> + (forall g s focus cursor w, Inv g s -> not_done w -> + <( {run_rr_pool ps focus cursor s}, {w} |= φ )>) -> + forall g s focus cursor w, Inv g s -> not_done w -> + <( {run_rr_pool ps focus cursor s}, {w} |= AG φ )>. +Proof. exact (ag_pool_rr_invariance sh (csl_pool ps) Inv φ). Qed. + +Lemma aul_csl_nd_eventually {G V n} (ps : Vector.t (CProg unit) (S n)) + (Inv : G -> SSig -> Prop) (rank : G -> V) (ltV : V -> V -> Prop) + (P : CSLObs (nat * nat) -> Prop) : + well_founded ltV -> RankedTurns sh (csl_pool ps) Inv rank ltV P -> + forall g s focus w, Inv g s -> not_done w -> + <( {run_nd_pool ps focus s}, {w} |= AF visW {P} )>. +Proof. exact (aul_pool_nd_eventually sh (csl_pool ps) Inv rank ltV P). Qed. + +Lemma aul_csl_rr_eventually {G V n} (ps : Vector.t (CProg unit) (S n)) + (Inv : G -> SSig -> Prop) (rank : G -> V) (ltV : V -> V -> Prop) + (P : CSLObs (nat * nat) -> Prop) : + well_founded ltV -> RankedTurns sh (csl_pool ps) Inv rank ltV P -> + forall g s focus cursor w, Inv g s -> not_done w -> + <( {run_rr_pool ps focus cursor s}, {w} |= AF visW {P} )>. +Proof. exact (aul_pool_rr_eventually sh (csl_pool ps) Inv rank ltV P). Qed. + +(** *** Two-child startup + + [fork p; fork q; skip]: each fork prepends its child and keeps the + parent focused, and the parent then terminates. What remains is the + unfocused pool [q; p] at the unchanged state and cursor. *) + +Local Lemma replace_cons {A n} (c : A) (ts : Vector.t A n) (i : Fin.t n) x : + (c :: (ts @ i := x))%vector = ((c :: ts)%vector @ Fin.FS i := x). +Proof. reflexivity. Qed. + +Lemma run_nd_two_forks (p q : CProg unit) (s : SSig) : + run_nd (CBind (CFork p) (fun _ => CBind (CFork q) (fun _ => CRet tt))) s ~ + run_nd_pool [q; p]%vector None s. +Proof. + rewrite run_nd_unfold. + change (interp_schedule_nd sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CFork p) (fun _ => CBind (CFork q) (fun _ => CRet tt))) + >>= fun _ => Ret tt)) (Some Fin.F1) s ~ run_nd_pool [q; p]%vector None s). + rewrite interp_nd_source_bind, interp_nd_source_fork; cbv beta iota. + rewrite replace_cons, interp_nd_source_bind, interp_nd_source_fork; cbv beta iota. + rewrite replace_cons, interp_nd_source_ret; cbv beta iota. + rewrite (interp_schedule_nd_ret sh 2 _ (Fin.FS (Fin.FS Fin.F1)) s) by reflexivity. + cbn [Vector.replace Vector.caseS']. + rewrite !vector_remove_tail, vector_remove_head. + reflexivity. +Qed. + +Lemma run_rr_two_forks (p q : CProg unit) (s : SSig) : + run_rr (CBind (CFork p) (fun _ => CBind (CFork q) (fun _ => CRet tt))) s ~ + run_rr_pool [q; p]%vector None 0 s. +Proof. + rewrite run_rr_unfold. + change (interp_schedule_rr sh 1 + ([Ret tt]%vector @ Fin.F1 := + (denote_flow (CBind (CFork p) (fun _ => CBind (CFork q) (fun _ => CRet tt))) + >>= fun _ => Ret tt)) (Some Fin.F1) 0 s ~ run_rr_pool [q; p]%vector None 0 s). + rewrite interp_rr_bind, interp_rr_fork; cbv beta iota. + rewrite replace_cons, interp_rr_bind, interp_rr_fork; cbv beta iota. + rewrite replace_cons, interp_rr_ret; cbv beta iota. + rewrite (interp_schedule_rr_ret sh 2 _ (Fin.FS (Fin.FS Fin.F1)) 0 s) by reflexivity. + cbn [Vector.replace Vector.caseS']. + rewrite !vector_remove_tail, vector_remove_head. + reflexivity. +Qed. + +(** The scheduler-visible view exhibits both [Spawn] events before the + unfocused two-worker pool. *) +Lemma scheduled_visible_two_forks (p q : CProg unit) : + scheduled_visible (CBind (CFork p) (fun _ => CBind (CFork q) (fun _ => CRet tt))) ~ + Vis (inr (inl Spawn) : yieldE + (spawnE + sE)) (fun _ => + Vis (inr (inl Spawn) : yieldE + (spawnE + sE)) (fun _ => + schedule 2 [denote q; denote p]%vector None)). +Proof. + unfold scheduled_visible. + rewrite (schedule_pool_proper 1 _ _ (Some Fin.F1) + (cons_pool_equ _ _ _ _ (denote_fork_bind p (fun _ => CBind (CFork q) (fun _ => CRet tt))) + (pool_equ_refl _))). + rewrite (ictree_eta (schedule 1 _ (Some Fin.F1))). + erewrite schedule_focused_fork by reflexivity. + apply sb_vis; intros []. + cbn [Vector.replace Vector.caseS']. + rewrite (schedule_pool_proper 2 _ + [denote p; Vis (inr (inl Fork)) + (fun child : bool => if child then denote q else denote (CRet tt))]%vector + (Some (Fin.FS Fin.F1)) + (cons_pool_equ _ _ _ _ (reflexivity _) + (cons_pool_equ _ _ _ _ (denote_fork_bind q (fun _ => CRet tt)) (pool_equ_refl _)))). + rewrite (ictree_eta (schedule 2 _ (Some (Fin.FS Fin.F1)))). + erewrite schedule_focused_fork by reflexivity. + apply sb_vis; intros []. + cbn [Vector.replace Vector.caseS']. + rewrite (schedule_pool_proper 3 _ [denote q; denote p; Ret tt]%vector + (Some (Fin.FS (Fin.FS Fin.F1))) + (cons_pool_equ _ _ _ _ (reflexivity _) + (cons_pool_equ _ _ _ _ (reflexivity _) + (cons_pool_equ _ _ _ _ denote_ret_unit (pool_equ_refl _))))). + rewrite (ictree_eta (schedule 3 _ (Some (Fin.FS (Fin.FS Fin.F1))))). + erewrite schedule_focused_ret by reflexivity. + rewrite sb_guard, !vector_remove_tail, vector_remove_head. + reflexivity. +Qed. diff --git a/theories/Lang/HeapImp.v b/theories/Lang/HeapImp.v index 49fbf19..68dad16 100644 --- a/theories/Lang/HeapImp.v +++ b/theories/Lang/HeapImp.v @@ -27,7 +27,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State - Lang.Maps. + Utils.Maps. Generalizable All Variables. diff --git a/theories/Lang/MeS.v b/theories/Lang/MeS.v index 8eca0ac..0b7a2a6 100644 --- a/theories/Lang/MeS.v +++ b/theories/Lang/MeS.v @@ -24,7 +24,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State - Lang.Maps. + Utils.Maps. Generalizable All Variables. diff --git a/theories/Lang/StImp.v b/theories/Lang/StImp.v index 6be3876..a935235 100644 --- a/theories/Lang/StImp.v +++ b/theories/Lang/StImp.v @@ -23,7 +23,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State - Lang.Maps. + Utils.Maps. Generalizable All Variables. diff --git a/theories/Lang/Yield.v b/theories/Lang/Yield.v deleted file mode 100644 index 045aeda..0000000 --- a/theories/Lang/Yield.v +++ /dev/null @@ -1,18 +0,0 @@ -(** Yield language façade. - - Both proof levels are exposed: first the reusable results over interpreted - [ictree] values, then the source-syntax layer that instantiates them. *) -From TICL Require Export - ICTree.Events.Yield - Utils.Vectors - ICTree.Interp.Yield.Mod - ICTree.Interp.Yield.SBisim - ICTree.Interp.Yield.Observed - ICTree.Logic.Yield - ICTree.Logic.SchedulerFairness - Lang.Yield.Syntax - Lang.Yield.Denote - Lang.Yield.Interp - Lang.Yield.Ticl - Lang.Yield.SBisim - Lang.Yield.SchedulerFairness. diff --git a/theories/Lang/Yield/Denote.v b/theories/Lang/Yield/Denote.v deleted file mode 100644 index 8baeccf..0000000 --- a/theories/Lang/Yield/Denote.v +++ /dev/null @@ -1,177 +0,0 @@ -From Stdlib Require Import Nat Strings.String. -From ExtLib Require Import Data.Map.FMapAList Data.String Structures.Maps. -From TICL Require Import - ICTree.Core - Events.StateE - ICTree.Events.Yield - Lang.Maps - Lang.Yield.Syntax. - -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. - -Definition Mem := stateE Ctx.Ctx. - -(** Raw Yield denotations can yield, fork, and access memory. *) -Definition YEff := yieldE + (forkE + Mem). - -Definition ytrigger (e : YEff) : ictree YEff (encode e) := - @ICtree.trigger YEff YEff _ _ ReSum_refl ReSumRet_refl e. -Definition yget : ictree YEff Ctx.Ctx := ytrigger (inr (inr Get)). -Definition yput (m : Ctx.Ctx) : ictree YEff unit := - ytrigger (inr (inr (Put m))). -Definition yyield : ictree YEff unit := ytrigger (inl Yield). -Definition yfork : ictree YEff bool := ytrigger (inr (inl Fork)). - -(** Denotation of expressions. Successful variable reads yield once before - returning the value; missing variables remain stuck. *) -Fixpoint denote_exp (e : YExp) : ictree YEff nat := - match e with - | YVar name => - ctx <- yget;; - match lookup name ctx with - | Some value => yyield;; Ret value - | None => stuck - end - | YLit n => Ret n - | YPlus a b => - x <- denote_exp a;; - y <- denote_exp b;; - Ret (x + y)%nat - | YMinus a b => - x <- denote_exp a;; - y <- denote_exp b;; - Ret (x - y)%nat - | YMult a b => - x <- denote_exp a;; - y <- denote_exp b;; - Ret (x * y)%nat - end. - -(** Internal result used to prevent child threads from inheriting source - continuations outside their fork body. - - [Fallthrough] means the current thread should continue with the enclosing - source continuation. [HaltThread] means a spawned child has finished its - declared body and must not inherit enclosing continuations. *) -Inductive YStmtFlow : Type := -| Fallthrough -| HaltThread. - -(** Flow-sensitive denotation of statements. *) -Fixpoint denote_stmt_flow (s : YStmt) : ictree YEff YStmtFlow := - match s with - | YAssign name expr => - value <- denote_exp expr;; - ctx <- yget;; - yput (add name value ctx);; - Ret Fallthrough - | YSeq a b => - flow <- denote_stmt_flow a;; - match flow with - | Fallthrough => denote_stmt_flow b - | HaltThread => Ret HaltThread - end - | YIf test then_branch else_branch => - condition_value <- denote_exp test;; - if is_true condition_value then - denote_stmt_flow then_branch - else - denote_stmt_flow else_branch - | YWhile test body => - ICtree.iter - (fun _ => - condition_value <- denote_exp test;; - if is_true condition_value then - flow <- denote_stmt_flow body;; - match flow with - | Fallthrough => Ret (inl tt) - | HaltThread => Ret (inr HaltThread) - end - else - Ret (inr Fallthrough)) tt - | YFork body => - in_child <- yfork;; - if in_child then - _ <- denote_stmt_flow body;; - Ret HaltThread - else - Ret Fallthrough - | YSkip => Ret Fallthrough - | YYield => - yyield;; - Ret Fallthrough - end. - -(** Public denotation of statements to unscheduled Yield threads. *) -Definition denote_stmt (s : YStmt) : ictree YEff unit := - _ <- denote_stmt_flow s;; - Ret tt. - -(** * Constructor unfold facts *) - -(** Expression denotation constructor unfold facts. *) -Lemma denote_exp_yvar name : - denote_exp (YVar name) = - (ctx <- yget;; - match lookup name ctx with - | Some value => yyield;; Ret value - | None => stuck - end). -Proof. reflexivity. Qed. - -Lemma denote_exp_ylit n : denote_exp (YLit n) = Ret n. -Proof. reflexivity. Qed. - -Lemma denote_exp_yplus a b : - denote_exp (YPlus a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x + y)%nat). -Proof. reflexivity. Qed. - -Lemma denote_exp_yminus a b : - denote_exp (YMinus a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x - y)%nat). -Proof. reflexivity. Qed. - -Lemma denote_exp_ymult a b : - denote_exp (YMult a b) = - (x <- denote_exp a;; y <- denote_exp b;; Ret (x * y)%nat). -Proof. reflexivity. Qed. - -(** Flow-sensitive statement denotation constructor unfold facts. *) -Lemma denote_stmt_unfold s : - denote_stmt s = (_ <- denote_stmt_flow s;; Ret tt). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yassign name expr : - denote_stmt_flow (YAssign name expr) = - (value <- denote_exp expr;; - ctx <- yget;; - yput (add name value ctx);; - Ret Fallthrough). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yseq a b : - denote_stmt_flow (YSeq a b) = - (flow <- denote_stmt_flow a;; - match flow with - | Fallthrough => denote_stmt_flow b - | HaltThread => Ret HaltThread - end). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yif test then_branch else_branch : - denote_stmt_flow (YIf test then_branch else_branch) = - (condition_value <- denote_exp test;; - if YieldSyntax.is_true condition_value then - denote_stmt_flow then_branch - else - denote_stmt_flow else_branch). -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yskip : denote_stmt_flow YSkip = Ret Fallthrough. -Proof. reflexivity. Qed. - -Lemma denote_stmt_flow_yyield : - denote_stmt_flow YYield = (yyield;; Ret Fallthrough). -Proof. reflexivity. Qed. diff --git a/theories/Lang/Yield/Interp.v b/theories/Lang/Yield/Interp.v deleted file mode 100644 index e0f17eb..0000000 --- a/theories/Lang/Yield/Interp.v +++ /dev/null @@ -1,52 +0,0 @@ -From Stdlib Require Import Fin Vector. -From ExtLib Require Import - Structures.Monad - Data.Monads.StateMonad - Structures.MonadState - Data.Map.FMapAList - Data.String. -From TICL Require Import - ICTree.Core - ICTree.Interp.Core - ICTree.Interp.State.Mod - ICTree.Interp.Yield.Mod - ICTree.Events.Yield - ICTree.Events.State - ICTree.Events.Writer - Events.Core - Events.StateE - Lang.Maps - Lang.Yield.Syntax - Lang.Yield.Denote - Utils.Vectors. - -Import ICtree ICTreeNotations VectorNotations. -Local Open Scope ictree_scope. - -(** * Source-level startup and instrumentation wrappers *) -(** Every definition below is a direct instantiation of the raw interpreter - layer in [ICTree.Interp.Yield.Mod] at the Yield source denotations. *) - -(** Start a source statement as a singleton pool focused on its only thread. - This is the scheduler-visible view: source [Fork] events have been - scheduled into scheduler [Spawn] observations, and cooperative [Yield] - observations remain visible alongside memory effects. *) -Definition scheduled_visible (s : YStmt) : completed Mem := - schedule 1 [denote_stmt s]%vector (Some Fin.F1). - -(** Erased expression instrumentation: raw thread-level [Yield] observations - are erased before state instrumentation. *) -Definition instr_exp_erased (e : YExp) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (nat * Ctx.Ctx) := - instr_thread (denote_exp e) ctx. - -(** Flow-preserving erased statement instrumentation for structural facts whose - contracts must expose [Fallthrough] versus [HaltThread]. The public - [instr_stmt_erased] remains the scheduled unit-returning view. *) -Definition instr_stmt_flow_erased - (s : YStmt) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (YStmtFlow * Ctx.Ctx) := - instr_thread (denote_stmt_flow s) ctx. - -(** Erased statement instrumentation: scheduler [Spawn] and cooperative [Yield] - observations are erased before state instrumentation. *) -Definition instr_stmt_erased (s : YStmt) (ctx : Ctx.Ctx) : ictreeW Ctx.Ctx (unit * Ctx.Ctx) := - instr_schedule 1 [denote_stmt s]%vector (Some Fin.F1) ctx. diff --git a/theories/Lang/Yield/SBisim.v b/theories/Lang/Yield/SBisim.v deleted file mode 100644 index 201a269..0000000 --- a/theories/Lang/Yield/SBisim.v +++ /dev/null @@ -1,35 +0,0 @@ -From Stdlib Require Import Fin Program.Equality. - -From TICL Require Export - ICTree.Interp.Yield.SBisim. - -From TICL Require Import - ICTree.Core - ICTree.Equ - ICTree.SBisim - ICTree.Events.Yield - ICTree.Interp.Yield.Mod - Lang.Yield.Syntax - Lang.Yield.Denote - Lang.Yield.Interp. - -Import ICtree ICTreeNotations. -Local Open Scope ictree_scope. - -(** * Scheduler-visible denotation respects thread bisimilarity *) - -(** Two source statements with strongly-bisimilar thread denotations yield - strongly-bisimilar scheduler-visible computations. This is the singleton - instance of [sbisim_schedule] for the start-up pool of [scheduled_visible]. *) -Corollary sbisim_scheduled_visible (s1 s2 : YStmt) : - denote_stmt s1 ~ denote_stmt s2 -> - scheduled_visible s1 ~ scheduled_visible s2. -Proof. - intro Hs. - unfold scheduled_visible. - apply sbisim_schedule. - intro i. - dependent destruction i. - - exact Hs. - - inversion i. -Qed. diff --git a/theories/Lang/Yield/SchedulerFairness.v b/theories/Lang/Yield/SchedulerFairness.v deleted file mode 100644 index 61fe6e2..0000000 --- a/theories/Lang/Yield/SchedulerFairness.v +++ /dev/null @@ -1,49 +0,0 @@ -From Stdlib Require Import - Fin - Vector - Program.Equality. - -From TICL Require Import - ICTree.Interp.Yield.Observed - ICTree.Logic.SchedulerFairness. - -From TICL Require Import - ICTree.Core - ICTree.Equ - ICTree.SBisim - ICTree.Events.Yield - ICTree.Interp.Yield.Mod - Logic.Core - Logic.Kripke - Lang.Yield.Syntax - Lang.Yield.Denote - Lang.Yield.Interp - Utils.Vectors. - -Import ICtree ICTreeNotations TiclNotations VectorNotations. -Local Open Scope ictree_scope. -Local Open Scope ticl_scope. - -(** * Source-level observed scheduler *) -(** The observation tier is entirely generic; a source program only supplies - the start-up pool. Nothing below discharges [SchedulerProgress]: the - fairness result stays conditional on scheduler progress, and it speaks - about scheduling-point offers, not about fair thread selection. *) - -Definition scheduled_observed (s : YStmt) : observed_completed Mem := - schedule_with_offers 1 [denote_stmt s]%vector (Some Fin.F1). - -Theorem forget_scheduled_observed_is_scheduled_visible (s : YStmt) : - forget_scheduler_offers (scheduled_observed s) ~ scheduled_visible s. -Proof. - unfold scheduled_observed, scheduled_visible. - apply forget_scheduler_offers_preserves_schedule. -Qed. - -Theorem scheduled_observed_every_live_slot_eventually_offered (s : YStmt) : - SchedulerProgress (scheduled_observed s) Pure -> - agc scheduling_point_offer_obligation (scheduled_observed s) Pure. -Proof. - unfold scheduled_observed. - apply every_live_slot_is_eventually_offered_at_scheduling_points. -Qed. diff --git a/theories/Lang/Yield/Syntax.v b/theories/Lang/Yield/Syntax.v deleted file mode 100644 index 5c6a554..0000000 --- a/theories/Lang/Yield/Syntax.v +++ /dev/null @@ -1,29 +0,0 @@ -From Stdlib Require Import Nat Strings.String. - -Module YieldSyntax. - Definition var := string. - Definition value := nat. - - Inductive YExp : Type := - | YVar (_ : var) - | YLit (_ : value) - | YPlus (_ _ : YExp) - | YMinus (_ _ : YExp) - | YMult (_ _ : YExp). - - Inductive YStmt : Type := - | YAssign (x : var) (e : YExp) - | YSeq (a b : YStmt) - | YIf (i : YExp) (t e : YStmt) - | YWhile (t : YExp) (b : YStmt) - (** [YFork body] spawns [body] as the child-side statement. - The parent path performs no source statement at the fork node; it - continues through the surrounding sequence. *) - | YFork (body : YStmt) - | YSkip - | YYield. - - (** Yield treats any non-zero natural as true. *) - Definition is_true (v : value) : bool := negb (v =? 0). -End YieldSyntax. -Export YieldSyntax. diff --git a/theories/Lang/Yield/Ticl.v b/theories/Lang/Yield/Ticl.v deleted file mode 100644 index 55f6eff..0000000 --- a/theories/Lang/Yield/Ticl.v +++ /dev/null @@ -1,647 +0,0 @@ -(** TICL-facing Yield surface. - - Public tiers exported by this façade: - - - [ICTree.Events.Yield], [Lang.Yield.Syntax], and [Lang.Yield.Denote] expose - raw source-level threads with [Yield], [Fork], and memory effects. - - [ICTree.Interp.Yield.Mod] exposes the scheduler, and [scheduled_visible] - exposes scheduled programs with scheduler [Spawn], cooperative [Yield], - and memory effects visible. - - [instr_exp_erased], [instr_stmt_flow_erased], and [instr_stmt_erased] - expose the state-only TICL view where scheduler/yield observations are - intentionally erased. - - Every temporal lemma below is an instantiation of a raw rule from - [ICTree.Logic.Yield] at the Yield denotations. *) -From Stdlib Require Import - Fin - Morphisms - Nat - Program.Equality - Strings.String - Vector. - -From ExtLib Require Import - Data.Map.FMapAList - Data.String - Structures.Maps. - -From TICL Require Export - ICTree.Logic.Yield - Lang.Yield.Syntax - Lang.Yield.Denote - Lang.Yield.Interp. - -From TICL Require Import - ICTree.Core - ICTree.Equ - ICTree.Eq.Bind - ICTree.Events.Yield - ICTree.Events.State - ICTree.Events.Writer - ICTree.Interp.Core - ICTree.Interp.State.Mod - ICTree.Interp.Yield.Mod - ICTree.Interp.Yield.SBisim - ICTree.Logic.AX - ICTree.Logic.AF - ICTree.Logic.Bind - ICTree.Logic.CanStep - ICTree.Logic.Iter - ICTree.Logic.State - ICTree.SBisim - Lang.Maps - Logic.Core - Utils.Vectors. - -Import ICtree ICTreeNotations TiclNotations VectorNotations. -Local Open Scope ticl_scope. -Local Open Scope ictree_scope. -Local Open Scope fin_vector_scope. - -(** * Source trigger normalizations *) -(** These expose a source trigger followed by a continuation as the single - [Vis] node the raw rules expect. They unfold only source denotations and - triggers; no interpreter is unfolded here. *) - -Local Lemma yget_bind {X} (k : Ctx.Ctx -> ictree YEff X) : - (x <- yget;; k x) ≅ Vis ((inr (inr Get)) : YEff) k. -Proof. - unfold yget, ytrigger, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. - reflexivity. -Qed. - -Local Lemma yput_bind {X} (m : Ctx.Ctx) (k : unit -> ictree YEff X) : - (x <- yput m;; k x) ≅ Vis ((inr (inr (Put m))) : YEff) k. -Proof. - unfold yput, ytrigger, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. - reflexivity. -Qed. - -Local Lemma yyield_bind {X} (k : unit -> ictree YEff X) : - (x <- yyield;; k x) ≅ Vis ((inl Yield) : YEff) k. -Proof. - unfold yyield, ytrigger, ICtree.trigger. - rewrite bind_vis. - setoid_rewrite bind_ret_l. - unfold resum, ReSum_refl, resum_ret, ReSumRet_refl. - reflexivity. -Qed. - -(** The assignment tail is exactly the raw state-update node. *) -Local Lemma denote_yassign_tail name value : - (ctx <- yget;; yput (add name value ctx);; Ret Fallthrough) - ≅ Vis ((inr (inr Get)) : YEff) - (fun σ0 : Ctx.Ctx => - Vis ((inr (inr (Put (add name value σ0)))) : YEff) - (fun _ : unit => Ret Fallthrough)). -Proof. - rewrite yget_bind. - apply vis_equ_node; intro σ0. - apply yput_bind. -Qed. - -(** Singleton startup denotations, normalized for the raw scheduler rules. *) -Local Lemma denote_stmt_yskip_ret : denote_stmt YSkip ≅ Ret tt. -Proof. - rewrite denote_stmt_unfold, denote_stmt_flow_yskip. - rewrite bind_ret_l. - reflexivity. -Qed. - -Local Lemma denote_stmt_yyield_vis : - denote_stmt YYield ≅ Vis ((inl Yield) : YEff) (fun _ : unit => Ret tt). -Proof. - rewrite denote_stmt_unfold, denote_stmt_flow_yyield. - unfold yyield, ytrigger, ICtree.trigger, - resum, ReSum_refl, resum_ret, ReSumRet_refl. - rewrite bind_bind, bind_vis. - apply vis_equ_node; intro x. - cbv beta. - repeat (setoid_rewrite bind_ret_l; cbv beta). - reflexivity. -Qed. - -Local Lemma denote_stmt_yassign_ylit_update name n : - denote_stmt (YAssign name (YLit n)) - ≅ Vis ((inr (inr Get)) : YEff) - (fun σ0 : Ctx.Ctx => - Vis ((inr (inr (Put (add name n σ0)))) : YEff) - (fun _ : unit => Ret tt)). -Proof. - rewrite denote_stmt_unfold, denote_stmt_flow_yassign, denote_exp_ylit. - unfold yget, yput, ytrigger, ICtree.trigger, - resum, ReSum_refl, resum_ret, ReSumRet_refl. - rewrite bind_bind, bind_ret_l; cbv beta. - rewrite bind_bind, bind_vis. - apply vis_equ_node; intro σ0. - cbv beta. - setoid_rewrite bind_ret_l; cbv beta. - rewrite bind_bind, bind_vis. - apply vis_equ_node; intro x. - cbv beta. - repeat (setoid_rewrite bind_ret_l; cbv beta). - reflexivity. -Qed. - -(** * Expression rules *) - -Lemma axr_yexp_ylit : forall n n' ctx ctx' w w', - n = n' -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YLit n) ctx}, - w |= AX done= {(n', ctx')} w' ]>. -Proof. - intros; subst. - unfold instr_exp_erased. - rewrite denote_exp_ylit. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axr_yexp_yvar_some : forall name value ctx ctx' w w', - lookup name ctx = Some value -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YVar name) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros name value ctx ctx' w w' Hlookup Hctx Hw Hnd; subst. - unfold instr_exp_erased. - rewrite denote_exp_yvar, yget_bind. - rewrite instr_thread_get; cbv beta. - rewrite Hlookup. - rewrite yyield_bind. - rewrite instr_thread_yield; cbv beta. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axr_yexp_yplus : forall a b x y value ctx ctx' w w', - <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> - <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> - value = (x + y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YPlus a b) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. - unfold instr_exp_erased in *. - rewrite denote_exp_yplus. - eapply anr_thread_bind_r_eq. - - exact Ha. - - cbv beta. - eapply anr_thread_bind_r_eq. - + exact Hb. - + cbv beta. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axr_yexp_yminus : forall a b x y value ctx ctx' w w', - <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> - <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> - value = (x - y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YMinus a b) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. - unfold instr_exp_erased in *. - rewrite denote_exp_yminus. - eapply anr_thread_bind_r_eq. - - exact Ha. - - cbv beta. - eapply anr_thread_bind_r_eq. - + exact Hb. - + cbv beta. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axr_yexp_ymult : forall a b x y value ctx ctx' w w', - <[ {instr_exp_erased a ctx}, w |= AX done= {(x, ctx)} w ]> -> - <[ {instr_exp_erased b ctx}, w |= AX done= {(y, ctx)} w ]> -> - value = (x * y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YMult a b) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros a b x y value ctx ctx' w w' Ha Hb Hvalue Hctx Hw Hnd; subst. - unfold instr_exp_erased in *. - rewrite denote_exp_ymult. - eapply anr_thread_bind_r_eq. - - exact Ha. - - cbv beta. - eapply anr_thread_bind_r_eq. - + exact Hb. - + cbv beta. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axr_yexp_yplus_ylit_ylit : forall x y value ctx ctx' w w', - value = (x + y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YPlus (YLit x) (YLit y)) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros; subst. - eapply axr_yexp_yplus; eauto; apply axr_yexp_ylit; auto. -Qed. - -Lemma axr_yexp_yminus_ylit_ylit : forall x y value ctx ctx' w w', - value = (x - y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YMinus (YLit x) (YLit y)) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros; subst. - eapply axr_yexp_yminus; eauto; apply axr_yexp_ylit; auto. -Qed. - -Lemma axr_yexp_ymult_ylit_ylit : forall x y value ctx ctx' w w', - value = (x * y)%nat -> - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_exp_erased (YMult (YLit x) (YLit y)) ctx}, - w |= AX done= {(value, ctx')} w' ]>. -Proof. - intros; subst. - eapply axr_yexp_ymult; eauto; apply axr_yexp_ylit; auto. -Qed. - -(** * Scheduled statement rules *) - -Lemma axr_ystmt_yskip_erased : forall ctx ctx' w w', - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_stmt_erased YSkip ctx}, - w |= AX done= {(tt, ctx')} w' ]>. -Proof. - intros ctx ctx' w w' Hctx Hw Hnd; subst. - unfold instr_stmt_erased. - rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' - (cons_pool_equ _ _ _ _ denote_stmt_yskip_ret (pool_equ_refl _))). - apply axr_schedule_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma axax_ystmt_yyield_erased : forall ctx ctx' w w', - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_stmt_erased YYield ctx}, - w |= AX AX done= {(tt, ctx')} w' ]>. -Proof. - intros ctx ctx' w w' Hctx Hw Hnd; subst. - unfold instr_stmt_erased. - rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx' - (cons_pool_equ _ _ _ _ denote_stmt_yyield_vis (pool_equ_refl _))). - apply axax_schedule_yield; [ assumption | split; reflexivity ]. -Qed. - -Lemma aur_ystmt_yyield_erased : forall ctx ctx' w w' ψ, - ctx = ctx' -> - w = w' -> - not_done w -> - <[ {instr_stmt_erased YYield ctx}, - w |= ψ AU AX AX done= {(tt, ctx')} w' ]>. -Proof. - intros; subst. - cleft. - now apply axax_ystmt_yyield_erased. -Qed. - -(** * Flow-preserving statement rules *) - -Lemma aur_ystmt_yassign : forall name expr value ctx w ψ R, - <[ {instr_exp_erased expr ctx}, w |= AX done= {(value, ctx)} w ]> -> - <( {log (add name value ctx)}, w |= ψ )> -> - R (Fallthrough, add name value ctx) - (Obs (Log (add name value ctx)) tt) -> - <[ {instr_stmt_flow_erased (YAssign name expr) ctx}, - w |= ψ AU AX done R ]>. -Proof. - intros name expr value ctx w ψ R Hexp Hlog HR. - unfold instr_stmt_flow_erased, instr_exp_erased in *. - rewrite denote_stmt_flow_yassign. - eapply aur_thread_bind_r_eq. - - cleft. exact Hexp. - - cbv beta. - rewrite (denote_yassign_tail name value). - now apply (aur_thread_update (add name value) Fallthrough ctx). -Qed. - -Lemma aul_ystmt_yassign : forall name expr value ctx w ψ φ, - <[ {instr_exp_erased expr ctx}, w |= AX done= {(value, ctx)} w ]> -> - <( {log (add name value ctx)}, w |= ψ )> -> - <( {Ret (Fallthrough, add name value ctx)}, - {Obs (Log (add name value ctx)) tt} |= φ )> -> - <( {instr_stmt_flow_erased (YAssign name expr) ctx}, w |= ψ AU φ )>. -Proof. - intros name expr value ctx w ψ φ Hexp Hlog Hret. - unfold instr_stmt_flow_erased, instr_exp_erased in *. - rewrite denote_stmt_flow_yassign. - eapply aul_thread_bind_r_eq. - - cleft. exact Hexp. - - cbv beta. - rewrite (denote_yassign_tail name value). - now apply (aul_thread_update (add name value) Fallthrough ctx). -Qed. - -Lemma anr_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, - <[ {instr_stmt_flow_erased a ctx}, - w |= φ AN done= {(Fallthrough, ctx')} w' ]> -> - <[ {instr_stmt_flow_erased b ctx'}, w' |= φ AN ψ ]> -> - <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AN ψ ]>. -Proof. - intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased in *. - rewrite denote_stmt_flow_yseq. - eapply anr_thread_bind_r_eq; eauto. -Qed. - -Lemma aur_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, - <[ {instr_stmt_flow_erased a ctx}, - w |= φ AU AX done= {(Fallthrough, ctx')} w' ]> -> - <[ {instr_stmt_flow_erased b ctx'}, w' |= φ AU ψ ]> -> - <[ {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ ]>. -Proof. - intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased in *. - rewrite denote_stmt_flow_yseq. - eapply aur_thread_bind_r_eq; eauto. -Qed. - -Lemma aul_ystmt_yseq_fallthrough : forall a b ctx ctx' w w' φ ψ, - <[ {instr_stmt_flow_erased a ctx}, - w |= φ AU AX done= {(Fallthrough, ctx')} w' ]> -> - <( {instr_stmt_flow_erased b ctx'}, w' |= φ AU ψ )> -> - <( {instr_stmt_flow_erased (YSeq a b) ctx}, w |= φ AU ψ )>. -Proof. - intros a b ctx ctx' w w' φ ψ Ha Hb. - unfold instr_stmt_flow_erased in *. - rewrite denote_stmt_flow_yseq. - eapply aul_thread_bind_r_eq; eauto. -Qed. - -Lemma yseq_halt_propagates : forall a b ctx ctx' w w' φ, - <[ {instr_stmt_flow_erased a ctx}, - w |= φ AU AX done= {(HaltThread, ctx')} w' ]> -> - not_done w' -> - <[ {instr_stmt_flow_erased (YSeq a b) ctx}, - w |= φ AU AX done= {(HaltThread, ctx')} w' ]>. -Proof. - intros a b ctx ctx' w w' φ Ha Hnd. - unfold instr_stmt_flow_erased in *. - rewrite denote_stmt_flow_yseq. - eapply aur_thread_bind_r_eq. - - exact Ha. - - cbv beta. - cleft. - apply axr_thread_ret; [ assumption | split; reflexivity ]. -Qed. - -Lemma aul_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, - <[ {instr_exp_erased test ctx}, w |= AX done= {(condition, ctx)} w ]> -> - (if YieldSyntax.is_true condition then - <( {instr_stmt_flow_erased then_branch ctx}, w |= φ AU ψ )> - else - <( {instr_stmt_flow_erased else_branch ctx}, w |= φ AU ψ )>) -> - <( {instr_stmt_flow_erased (YIf test then_branch else_branch) ctx}, - w |= φ AU ψ )>. -Proof. - intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. - unfold instr_stmt_flow_erased, instr_exp_erased in *. - rewrite denote_stmt_flow_yif. - eapply aul_thread_bind_r_eq. - - cleft; exact Htest. - - cbv beta. - destruct (YieldSyntax.is_true condition); exact Hbranch. -Qed. - -Lemma aur_ystmt_yif : forall test then_branch else_branch condition ctx w φ ψ, - <[ {instr_exp_erased test ctx}, w |= AX done= {(condition, ctx)} w ]> -> - (if YieldSyntax.is_true condition then - <[ {instr_stmt_flow_erased then_branch ctx}, w |= φ AU ψ ]> - else - <[ {instr_stmt_flow_erased else_branch ctx}, w |= φ AU ψ ]>) -> - <[ {instr_stmt_flow_erased (YIf test then_branch else_branch) ctx}, - w |= φ AU ψ ]>. -Proof. - intros test then_branch else_branch condition ctx w φ ψ Htest Hbranch. - unfold instr_stmt_flow_erased, instr_exp_erased in *. - rewrite denote_stmt_flow_yif. - eapply aur_thread_bind_r_eq. - - cleft; exact Htest. - - cbv beta. - destruct (YieldSyntax.is_true condition); exact Hbranch. -Qed. - -(** * Raw source-flow while unrolling facts *) -(** These expose [YStmtFlow] directly, avoiding any claim that the scheduled - erased unit layer can distinguish loop fallthrough from child-thread - halt. *) -Definition ywhile_iteration (test : YExp) (body : YStmt) : - ictree YEff (unit + YStmtFlow) := - condition_value <- denote_exp test;; - if YieldSyntax.is_true condition_value then - flow <- denote_stmt_flow body;; - match flow with - | Fallthrough => Ret (inl tt) - | HaltThread => Ret (inr HaltThread) - end - else - Ret (inr Fallthrough). - -Lemma aul_ystmt_ywhile_true : forall test body condition w w' φ ψ, - <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> - YieldSyntax.is_true condition = true -> - <[ {denote_stmt_flow body}, - w |= φ AU AX done= Fallthrough w' ]> -> - not_done w' -> - <( {denote_stmt_flow (YWhile test body)}, w' |= φ AU ψ )> -> - <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. -Proof. - intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. - cbn. - eapply aul_iter_next with (R := fun (_ : unit) w0 => w0 = w'). - - eapply aur_bind_r_eq. - + exact Htest. - + rewrite Htrue. - eapply aur_bind_r_eq. - * exact Hbody. - * cbn. - cleft. - apply axr_ret; auto. - exists tt; split; auto. - - intros [] w0 ->. - exact Hloop. -Qed. - -Lemma aul_ystmt_ywhile_false : forall test body condition w φ ψ, - <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> - YieldSyntax.is_true condition = false -> - <( {Ret Fallthrough}, w |= ψ )> -> - <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. -Proof. - intros test body condition w φ ψ Htest Hfalse Hret. - pose proof Htest as Htest_not_done. - apply aur_not_done in Htest_not_done. - cbn. - rewrite unfold_iter. - eapply aul_bind_r_eq. - - eapply aur_bind_r_eq. - + exact Htest. - + rewrite Hfalse. - cbn. - cleft. - apply axr_ret. - * exact Htest_not_done. - * split; reflexivity. - - cbn. - cleft. - exact Hret. -Qed. - -Lemma aul_ystmt_ywhile_halt : forall test body condition w w' φ ψ, - <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> - YieldSyntax.is_true condition = true -> - <[ {denote_stmt_flow body}, - w |= φ AU AX done= HaltThread w' ]> -> - not_done w' -> - <( {Ret HaltThread}, w' |= ψ )> -> - <( {denote_stmt_flow (YWhile test body)}, w |= φ AU ψ )>. -Proof. - intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hret. - cbn. - rewrite unfold_iter. - eapply aul_bind_r_eq. - - eapply aur_bind_r_eq. - + exact Htest. - + rewrite Htrue. - eapply aur_bind_r_eq. - * exact Hbody. - * cbn. - cleft. - apply axr_ret; auto. - - cbn. - cleft. - exact Hret. -Qed. - -Lemma aur_ystmt_ywhile_true : forall test body condition w w' φ ψ, - <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> - YieldSyntax.is_true condition = true -> - <[ {denote_stmt_flow body}, - w |= φ AU AX done= Fallthrough w' ]> -> - not_done w' -> - <[ {denote_stmt_flow (YWhile test body)}, w' |= φ AU AX ψ ]> -> - <[ {denote_stmt_flow (YWhile test body)}, w |= φ AU AX ψ ]>. -Proof. - intros test body condition w w' φ ψ Htest Htrue Hbody Hnd Hloop. - cbn. - eapply aur_iter_next with (R := fun (_ : unit) w0 => w0 = w'). - - eapply aur_bind_r_eq. - + exact Htest. - + rewrite Htrue. - eapply aur_bind_r_eq. - * exact Hbody. - * cbn. - cleft. - apply axr_ret; auto. - exists tt; split; auto. - - intros [] w0 ->. - exact Hloop. -Qed. - -Lemma aur_ystmt_ywhile_false : forall test body condition w φ ψ, - <[ {denote_exp test}, w |= φ AU AX done= condition w ]> -> - YieldSyntax.is_true condition = false -> - <[ {Ret Fallthrough}, w |= AX ψ ]> -> - <[ {denote_stmt_flow (YWhile test body)}, w |= φ AU AX ψ ]>. -Proof. - intros test body condition w φ ψ Htest Hfalse Hret. - pose proof Htest as Htest_not_done. - apply aur_not_done in Htest_not_done. - cbn. - rewrite unfold_iter. - eapply aur_bind_r_eq. - - eapply aur_bind_r_eq. - + exact Htest. - + rewrite Hfalse. - cbn. - cleft. - apply axr_ret. - * exact Htest_not_done. - * split; reflexivity. - - cbn. - cleft. - exact Hret. -Qed. - -Lemma ag_ystmt_ywhile : forall test body (R : World YEff -> Prop) w φ, - R w -> - (forall w, - R w -> - <( {denote_stmt_flow (YWhile test body)}, w |= φ )> /\ - <[ {ywhile_iteration test body}, w |= AX (φ AU AX done - {fun lr w' => exists i' : unit, lr = inl i' /\ R w'}) ]>) -> - <( {denote_stmt_flow (YWhile test body)}, w |= AG φ )>. -Proof. - intros test body R w φ HR Hstep. - cbn. - change (ICtree.iter (fun _ : unit => ywhile_iteration test body) tt) - with (denote_stmt_flow (YWhile test body)). - eapply ag_iter with (R := fun (_ : unit) w => R w); eauto. - intros [] w0 HR0. - specialize (Hstep w0 HR0) as [Hφ Hnext]. - split. - - exact Hφ. - - cbn. - exact Hnext. -Qed. - -(** * Scheduled assignment rules *) - -Lemma aur_ystmt_yassign_ylit_erased : forall name n ctx w ψ R, - <( {log (add name n ctx)}, w |= ψ )> -> - R (tt, add name n ctx) (Obs (Log (add name n ctx)) tt) -> - <[ {instr_stmt_erased (YAssign name (YLit n)) ctx}, - w |= ψ AU AX done R ]>. -Proof. - intros name n ctx w ψ R Hlog HR. - unfold instr_stmt_erased. - rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx - (cons_pool_equ _ _ _ _ (denote_stmt_yassign_ylit_update name n) (pool_equ_refl _))). - now apply (aur_schedule_update (add name n) ctx). -Qed. - -Lemma aul_ystmt_yassign_ylit_erased : forall name n ctx w ψ φ, - <( {log (add name n ctx)}, w |= ψ )> -> - <( {Ret (tt, add name n ctx)}, - {Obs (Log (add name n ctx)) tt} |= φ )> -> - <( {instr_stmt_erased (YAssign name (YLit n)) ctx}, w |= ψ AU φ )>. -Proof. - intros name n ctx w ψ φ Hlog Hret. - unfold instr_stmt_erased. - rewrite (instr_schedule_pool_equ 1 _ _ (Some Fin.F1) ctx - (cons_pool_equ _ _ _ _ (denote_stmt_yassign_ylit_update name n) (pool_equ_refl _))). - now apply (aul_schedule_update (add name n) ctx). -Qed. diff --git a/theories/Lang/Maps.v b/theories/Utils/Maps.v similarity index 100% rename from theories/Lang/Maps.v rename to theories/Utils/Maps.v From c11204cca520ec063bc1e7862a0a381dda82671e Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Fri, 2 Oct 2026 12:31:39 +0000 Subject: [PATCH 13/14] graft --- .claude/helpers/graft-hooks.cjs | 67 ++++++++++++ .claude/helpers/graft-statusline.cjs | 67 ++++++++++++ .claude/settings.json | 78 ++++++++++++++ .claude/skills/graft/SKILL.md | 156 +++++++++++++++++++++++++++ .github/copilot-instructions.md | 41 +++++++ .gitignore | 3 + .ignore | 5 + .mcp.json | 10 ++ 8 files changed, 427 insertions(+) create mode 100755 .claude/helpers/graft-hooks.cjs create mode 100755 .claude/helpers/graft-statusline.cjs create mode 100644 .claude/settings.json create mode 100644 .claude/skills/graft/SKILL.md create mode 100644 .github/copilot-instructions.md create mode 100644 .ignore create mode 100644 .mcp.json diff --git a/.claude/helpers/graft-hooks.cjs b/.claude/helpers/graft-hooks.cjs new file mode 100755 index 0000000..25ed83b --- /dev/null +++ b/.claude/helpers/graft-hooks.cjs @@ -0,0 +1,67 @@ +#!/usr/bin/env node +const path = require('path'); +const fs = require('fs'); +const { pathToFileURL } = require('url'); +const { execFileSync } = require('child_process'); +const dir = process.env.CLAUDE_PROJECT_DIR || process.cwd(); +const BAKED = "/home/eioannidis/.npm-global/lib/node_modules/@nanonets/graft/dist/claude"; + +// The dist/claude dir of @nanonets/graft resolved from a base whose node_modules is searched. +function fromPkg(base) { + try { + const pkg = require.resolve('@nanonets/graft/package.json', { paths: [base] }); + return path.join(path.dirname(pkg), 'dist', 'claude'); + } catch { return null; } +} + +// The global node_modules dir per npm (handles Homebrew/Windows/volta). Queried on demand. +function globalRoot() { + try { + const root = execFileSync('npm', ['root', '-g'], { encoding: 'utf8', stdio: ['ignore', 'pipe', 'ignore'], shell: process.platform === 'win32' }).trim(); + return root || null; + } catch { return null; /* npm unavailable */ } +} + +// The version of the package a dist/claude dir belongs to, or null if unreadable. +function versionOf(distClaude) { + try { + return JSON.parse(fs.readFileSync(path.join(distClaude, '..', '..', 'package.json'), 'utf8')).version || null; + } catch { return null; } +} + +// Numeric-dotted compare of the release part; an unreadable version loses to any known one. +function newer(a, b) { + if (!a) return false; + if (!b) return true; + const p = (v) => String(v).split('-')[0].split('.').map((n) => Number(n) || 0); + const pa = p(a), pb = p(b); + for (let i = 0; i < Math.max(pa.length, pb.length); i++) { + const d = (pa[i] || 0) - (pb[i] || 0); + if (d !== 0) return d > 0; + } + return false; +} + +// The highest-versioned dir in `dirs` that actually contains `name`, or null. +function best(dirs, name) { + let bestDir = null, bestVer = null; + for (const d of dirs) { + if (!d || !fs.existsSync(path.join(d, name))) continue; + const v = versionOf(d); + if (bestDir === null || newer(v, bestVer)) { bestDir = d; bestVer = v; } + } + return bestDir; +} + +function entry(name) { + // Cheap candidates first, and only shell out to npm when every one of them misses. + const cheap = [BAKED, fromPkg(dir), fromPkg(path.join(path.dirname(process.execPath), '..', 'lib'))]; + const hit = best(cheap, name); + if (hit) return path.join(hit, name); + const gr = globalRoot(); + const global = gr && path.join(gr, '@nanonets', 'graft', 'dist', 'claude'); + if (global && fs.existsSync(path.join(global, name))) return path.join(global, name); + return path.join(dir, 'dist', 'claude', name); // last-ditch; import will no-op if absent +} + +import(pathToFileURL(entry("hooks.js")).href).then((m) => m.main(process.argv[2])).catch(() => { /* graft unavailable — no-op */ }); diff --git a/.claude/helpers/graft-statusline.cjs b/.claude/helpers/graft-statusline.cjs new file mode 100755 index 0000000..218d8a4 --- /dev/null +++ b/.claude/helpers/graft-statusline.cjs @@ -0,0 +1,67 @@ +#!/usr/bin/env node +const path = require('path'); +const fs = require('fs'); +const { pathToFileURL } = require('url'); +const { execFileSync } = require('child_process'); +const dir = process.env.CLAUDE_PROJECT_DIR || process.cwd(); +const BAKED = "/home/eioannidis/.npm-global/lib/node_modules/@nanonets/graft/dist/claude"; + +// The dist/claude dir of @nanonets/graft resolved from a base whose node_modules is searched. +function fromPkg(base) { + try { + const pkg = require.resolve('@nanonets/graft/package.json', { paths: [base] }); + return path.join(path.dirname(pkg), 'dist', 'claude'); + } catch { return null; } +} + +// The global node_modules dir per npm (handles Homebrew/Windows/volta). Queried on demand. +function globalRoot() { + try { + const root = execFileSync('npm', ['root', '-g'], { encoding: 'utf8', stdio: ['ignore', 'pipe', 'ignore'], shell: process.platform === 'win32' }).trim(); + return root || null; + } catch { return null; /* npm unavailable */ } +} + +// The version of the package a dist/claude dir belongs to, or null if unreadable. +function versionOf(distClaude) { + try { + return JSON.parse(fs.readFileSync(path.join(distClaude, '..', '..', 'package.json'), 'utf8')).version || null; + } catch { return null; } +} + +// Numeric-dotted compare of the release part; an unreadable version loses to any known one. +function newer(a, b) { + if (!a) return false; + if (!b) return true; + const p = (v) => String(v).split('-')[0].split('.').map((n) => Number(n) || 0); + const pa = p(a), pb = p(b); + for (let i = 0; i < Math.max(pa.length, pb.length); i++) { + const d = (pa[i] || 0) - (pb[i] || 0); + if (d !== 0) return d > 0; + } + return false; +} + +// The highest-versioned dir in `dirs` that actually contains `name`, or null. +function best(dirs, name) { + let bestDir = null, bestVer = null; + for (const d of dirs) { + if (!d || !fs.existsSync(path.join(d, name))) continue; + const v = versionOf(d); + if (bestDir === null || newer(v, bestVer)) { bestDir = d; bestVer = v; } + } + return bestDir; +} + +function entry(name) { + // Cheap candidates first, and only shell out to npm when every one of them misses. + const cheap = [BAKED, fromPkg(dir), fromPkg(path.join(path.dirname(process.execPath), '..', 'lib'))]; + const hit = best(cheap, name); + if (hit) return path.join(hit, name); + const gr = globalRoot(); + const global = gr && path.join(gr, '@nanonets', 'graft', 'dist', 'claude'); + if (global && fs.existsSync(path.join(global, name))) return path.join(global, name); + return path.join(dir, 'dist', 'claude', name); // last-ditch; import will no-op if absent +} + +import(pathToFileURL(entry("statusline.js")).href).then((m) => m.main()).catch(() => { /* graft unavailable — no-op */ }); diff --git a/.claude/settings.json b/.claude/settings.json new file mode 100644 index 0000000..cfda485 --- /dev/null +++ b/.claude/settings.json @@ -0,0 +1,78 @@ +{ + "statusLine": { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-statusline.cjs\"" + }, + "subagentStatusLine": { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-statusline.cjs\"" + }, + "hooks": { + "PostToolUse": [ + { + "matcher": "Write|Edit|MultiEdit", + "hooks": [ + { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-hooks.cjs\" post-edit", + "timeout": 10000 + } + ] + }, + { + "matcher": "Bash|mcp__graft__|Read|Grep|Glob", + "hooks": [ + { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-hooks.cjs\" tool-savings", + "timeout": 8000 + } + ] + } + ], + "UserPromptSubmit": [ + { + "hooks": [ + { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-hooks.cjs\" prompt", + "timeout": 15000 + } + ] + } + ], + "SessionStart": [ + { + "hooks": [ + { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-hooks.cjs\" session-start", + "timeout": 8000 + } + ] + } + ], + "Stop": [ + { + "hooks": [ + { + "type": "command", + "command": "node \"${CLAUDE_PROJECT_DIR:-.}/.claude/helpers/graft-hooks.cjs\" stop", + "timeout": 8000 + } + ] + } + ] + }, + "footerLinksRegexes": [ + "graft/[\\w./-]+\\.md" + ], + "permissions": { + "allow": [ + "Bash(graft:*)", + "Bash(npx graft:*)", + "Bash(graft-dev:*)", + "Bash(node dist/cli.js:*)" + ] + } +} diff --git a/.claude/skills/graft/SKILL.md b/.claude/skills/graft/SKILL.md new file mode 100644 index 0000000..d4cbc72 --- /dev/null +++ b/.claude/skills/graft/SKILL.md @@ -0,0 +1,156 @@ +--- +name: graft +description: This repo is indexed by graft/. For ANY task here, whether + understanding how something works, finding where code lives, tracing what + calls a symbol or what a change breaks, or scoping an edit, get your context + from graft before grepping or reading source files. +--- + +# graft + +`graft/` holds a graph of this repo: small markdown nodes that each explain one +part in prose and name the exact `file:line` spans they cover, plus a wiring +graph of who-calls-what. Querying a node costs a few hundred tokens; rebuilding +that understanding by reading source costs thousands, and misses the edges. + +Every command below is `$0`, needs no API key, and returns in under a second. +There are six of them. **Pick the one that fits the task, run it, act on the +answer; don't chain tools hoping for more. Most tasks need one call.** + +## The tools + +### 1 · `graft ask "" --source`: locate + understand (the default) +Ranked retrieval over the graph, routed automatically between prose nodes and +the wiring graph, returning the top hits with exact `file:line`. +- `--source` inlines the code at each hit, the ≤8-line **crux** of each + definition, so the result IS the code you need, no follow-up file read. Add + `--full` only when the crux is too small to act on. +- `--in ` narrows to a subtree before ranking; `-n N` caps results (default 8). +- **Use it when** the question is conceptual or locational: "how does auth + work", "where is rate-limiting handled", "what assembles the request pipeline". +- One ask usually answers. A genuinely multi-part question needs one ask per + distinct sub-aspect, never the same question reworded. Few or weak hits mean + switch tool (grep / skeleton / callers), don't re-ask. + +### 2 · `graft grep ""`: exhaustive find +Regex (or `--fixed` for a literal) over every indexed file, hits **grouped by +enclosing symbol** and ranked by coupling; it also reports files it couldn't read. +- **Use it when** you need every occurrence: all call sites, all uses of a + constant, all providers. `ask` is ranked top-N and *will* miss instances; + grep won't. One grep replaces a spray of asks. +- Search a **short symbol name or literal**, not a full guessed signature: an + over-specific regex (`func (s *Server) GenerateHandler`) returns nothing even + when the code is indexed. If a grep misses, **loosen it** (drop the receiver + and signature, keep the bare name) and retry `graft grep` — do NOT switch to + raw `grep -rn`, which is slower and unranked. +- `-i` case-insensitive; `--in ` scopes to a subtree. Raw `grep -rn` is + only for files graft genuinely doesn't index (docs, configs, brand-new files). + +### 3 · `graft skeleton `: a file's API at a glance +Signatures-only view of one file (every function / method / type with its span) +in ~200 tokens, ~10x cheaper than reading the file. +- **Use it when** you need "what's in this file / what can I call here" before + editing or wiring into it. One skeleton is the whole answer for a file; don't + re-skeleton the same file, and don't skeleton every file `map` already named. + +### 4 · `graft callers `: the exact edges +Precomputed call/reference edges, not a text search. Symbol can be bare +(`Foo`), qualified (`Class.method`), or package-qualified (`pkg.Fn`). +- default `--direction in`: **who calls/references** this; run before you + rename, delete, or change its signature. +- `--direction out`: **what this symbol itself calls/depends on** (the old `callees`). +- `--depth N`: walk transitively N hops for the **full blast radius** (the old + `impact`); `--depth 2` is the usual "what breaks if I touch this". +- `--depth all`: the **entire connected closure** — every source reachable + through the edges. Reach for this before a **refactor, rename, or any + multi-file change**: it surfaces the sibling and downstream files (platform + variants, a module you must split out) that a single-file edit would miss. + +### 5 · `graft map`: orientation for an unfamiliar repo or area +A token-budgeted tour: directory clusters, per-directory hubs, and global +hotspots, straight from the wiring graph. +- **Use it when** you land in a repo cold or are asked for "the architecture". + `map` alone is the answer: read the hub cards it names; do NOT then skeleton + or ask your way through every subsystem it lists. `--max-dirs N` widens it. + +### 6 · Lifecycle: `graft build` / `graft check` +Every tool above refreshes the graph itself before answering, so what those tools +return always describes the code as it is right now — including edits you just made +and have not committed. You do **not** need to run `build` after editing. + +One caveat, if you `grep` the markdown under `graft/` directly: those cards are a +projection, rebuilt at the end of the turn rather than on each query, so after an edit +they can lag. The tools above never do — prefer them, and treat a card's spans as +stale if you have edited that file this turn. + +`build` is for the LLM layer (`--deep` adds a concept map; skip unless asked); +`check` fails when `graft/` is stale, for CI. + +## Scenarios: the shortest path through a coding task + +| When you're… | Reach for | Calls | +|---|---|---| +| Onboarding / "explain this codebase" | `graft map`, then read the named hub cards | 1 | +| Understanding a flow ("how does X work") | `graft ask "" --source` | 1 | +| Finding where a change belongs | `graft ask "where is " --source` | 1 | +| Editing a symbol you can already name | `graft grep ""`, edit at the `file:line` (skip `ask` — you know where it is) | 1 | +| Renaming / deleting / changing a signature | `graft callers --depth 2` first | 1 | +| Refactor / multi-file change (before editing) | `graft callers --depth all` — map every connected file, don't stop at the first | 1 | +| "What does this depend on?" | `graft callers --direction out` | 1 | +| Finding every occurrence of a pattern | `graft grep ""` | 1 | +| "What's the API of this file?" | `graft skeleton ` | 1 | +| Debugging a failure in area X | `graft ask "" --source`, then `callers` on the suspect | 1–2 | +| Judging a diff's risk before merge | `graft callers --depth 2` | 1 / symbol | +| Working inside one repo of a monorepo | add `--in /` to ask / grep / callers | n/a | + +In a multi-repo workspace, graft ranks fairly so the biggest repo can't drown +the rest, and every hit carries a `[scope/]` label naming its sub-project; when +you already know where you're working, narrow with `graft ask "" --in /`. + +## Spend the fewest calls +- A node's `covers:` list already gives exact `file:line` for every symbol, so + cite straight from it. The spans are generated from source and authoritative; + don't re-open or re-grep files to "double-check". +- When the task already names the file or symbol to change, go straight there: + `graft grep ""` for the exact `file:line`, then edit. Reserve + `graft ask` for when you don't yet know where the code lives — an `ask` + round-trip is wasted on a target you can already name. +- Trust the answer and act. Reach for a second tool only when the first genuinely + fell short: weak hits, a truncated span, or a need to be exhaustive. +- If graft names a path that isn't on disk, its index is ahead of your checkout + (a branch switch or unpulled move). Don't read the missing file — `graft grep` + the symbol to find where it lives now, or run `graft build` to refresh. + +## Report what graft saved, every turn +Each retrieval tool **opens** its output with a `[graft] tokens saved ≈ N` line: +the estimated tokens that call saved versus reading the files it covers whole. +Whenever you used any graft tool in a turn, close your reply with a one-line +tally summing those numbers across every graft call you made, e.g. +`🌱 graft saved ~12,400 tokens this turn (3 calls)`. A call with no such line +(tiny files, where the pointers cost as much as the source) saved nothing, so +skip it. This is the per-turn figure; the statusline carries the running +session total. + +Once a turn has been billed, each line also states what that call was worth in +dollars, at the rate this session is actually paying for input tokens — include +that total alongside the tokens, e.g. `🌱 graft saved ~12,400 tokens (~$0.04) +this turn`. When a line carries no dollar figure, report tokens alone rather +than pricing them yourself. + +**Never pipe a graft command through `head`, `tail`, or `sed -n`.** Every tool +is already capped and states what it dropped; clipping it costs you hits you +asked for, and it silently drops the savings line the statusline's running +total is parsed from. + +## When graft isn't enough +- Span truncated ("+N more lines"): open the file at that exact range. +- A node lacks a detail: ask a more specific question; only then read source at + the exact `file:line`, never a whole file to rebuild understanding graft gives. +- You may also grep / ls / cat inside `graft/` directly (plain markdown; + `graft/INDEX.md` indexes the nodes), but the tools above are faster and + exhaustive where it matters, so reach for them first. + +When the graft MCP server is connected, these are exposed as tools too: +`graft_find_code`, `graft_find_all`, `graft_file_api`, `graft_trace_calls` (with +`direction` / `depth`), `graft_repo_map`, `graft_check_freshness`. Use whichever surface is +available; the guidance is identical. diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md new file mode 100644 index 0000000..d8af4a5 --- /dev/null +++ b/.github/copilot-instructions.md @@ -0,0 +1,41 @@ + +## Graft — repo context graph + +This repo is indexed in `graft/`: small linked markdown nodes that explain each +system and carry exact file:line spans, kept in sync with the code through git. + +For ANY task here — understanding how something works, finding where code lives, +or scoping a change — get context from the graph before grepping or opening +source files. Re-ask freely (it's cheap) and reuse literal identifiers you +already have (symbol, error string, file name) as the query. New to this repo? +Run `graft map` first — a token-budgeted orientation (dir clusters, hubs, +hotspots), no LLM, no key. + +- Run `graft ask "" --source` → ranked nodes with the relevant + code spans inlined (each hit's ≤8-line crux by default; `--full` for whole + definitions when the crux isn't enough). Match the tool to the task shape: + for understanding or editing, the top node IS the answer — cite its + `covers:` file:line spans and edit straight from `--source`. For + exhaustive tasks ("every occurrence / every caller of this pattern"), ranked + results are top-N, not complete — run `graft grep ""` instead + (exhaustive over indexed files, grouped by enclosing symbol), falling back + to raw `grep -rn` only for unindexed files. +- `graft skeleton ` → every definition's signature + span, ~10× cheaper + than reading the file; use it to skim an API surface. +- `graft callers ` gives precomputed, exact edges — who calls this. + Add `--direction out` for what it calls, or `--depth N` to walk + transitively for the full blast radius. For structural questions, skip + ranking and use this directly. +- Or browse: `graft/INDEX.md` lists every node; follow the links. +- Monorepos and folders of multiple repos rank fairly across sub-projects — + hits carry `[scope/]` labels naming which one they're from. Narrow with + `graft ask "" --in /` once you know where you're working. + +If a returned span is truncated ("+N more lines"), open the file at that exact +range before finalizing. Only open source files when a node genuinely lacks a +needed detail, and then at the exact file:line the node points to — never +re-read whole files. + +After big code changes, refresh the graph with `graft build` (deterministic, +no API key, $0). + diff --git a/.gitignore b/.gitignore index effb9e0..09716be 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,6 @@ _build main.html .omp graphify-out + +# graft's local graph cache — regenerable, not committed (run `graft build`). +/graft/ diff --git a/.ignore b/.ignore new file mode 100644 index 0000000..615e581 --- /dev/null +++ b/.ignore @@ -0,0 +1,5 @@ +# graft's cards are gitignored but should stay greppable: ripgrep reads +# .ignore before .gitignore, so this re-admits the tree to search only. +!graft/ +graft/.cache/ +graft/.graph/ diff --git a/.mcp.json b/.mcp.json new file mode 100644 index 0000000..fcedf6a --- /dev/null +++ b/.mcp.json @@ -0,0 +1,10 @@ +{ + "mcpServers": { + "graft": { + "command": "graft", + "args": [ + "mcp" + ] + } + } +} From 4aa6d597dd4c0fd8d3758fa4263417b5023b0d1b Mon Sep 17 00:00:00 2001 From: Lef Ioannidis Date: Mon, 5 Oct 2026 16:27:56 +0000 Subject: [PATCH 14/14] refactor(proofs): shrink proof scripts by reusing existing lemmas - Observed: prove forget_scheduler_offers_preserves_schedule via galigned/galigned_sbisim; drop transition-matching helpers - Eq/Core: derive equ Proper instances from Equivalence_equ; resum lemmas via unfold_resumICtree - SSim/SBisim: weq_ssim/weq_sbisim via gfp_weq - Trans: trigger transitions via bind_trigger - Congruence: AG/EG and/or lemmas via impl_ticll_global - Ret: single-direction ticll_ret_equiv, applied both ways - State: use deterministic *_bind_r_eq lemmas directly - Frame: qrepX_frame via qrep_agree_fp (moved before it) Statements and axiom sets unchanged; ~980 fewer lines. --- examples/CSL/Queue/Frame.v | 57 +- theories/ICTree/Eq/Core.v | 106 +-- theories/ICTree/Interp/Yield/Observed.v | 985 +++--------------------- theories/ICTree/Logic/Ret.v | 83 +- theories/ICTree/Logic/State.v | 15 +- theories/ICTree/SBisim/Core.v | 10 +- theories/ICTree/SBisim/SSim.v | 10 +- theories/ICTree/Trans.v | 16 +- theories/Logic/Congruence.v | 80 +- 9 files changed, 190 insertions(+), 1172 deletions(-) diff --git a/examples/CSL/Queue/Frame.v b/examples/CSL/Queue/Frame.v index 7fa0d8f..fba363f 100644 --- a/examples/CSL/Queue/Frame.v +++ b/examples/CSL/Queue/Frame.v @@ -66,6 +66,27 @@ Definition qrepX (hdr: nat) (ns vs: list nat) (h: Heap) : Prop := Lemma qrepX_qrep: forall hdr ns vs h, qrepX hdr ns vs h -> qrep hdr ns vs h. Proof. intros ? ? ? ? (H & _); exact H. Qed. +(** [qrep] only looks at the footprint and at the null cell, so it survives any + change that leaves both alone. This is what turns [qstepN_agree] (the + rotating queue touches nothing outside ITS footprint) into "the unused + second queue is still there, at every reachable state". *) +Lemma qrep_agree_fp: forall hdr ns vs h h', + qrep hdr ns vs h -> + (forall x, In x (qcells hdr ns) -> h' x = h x) -> + h' 0 = None -> + qrep hdr ns vs h'. +Proof. + intros hdr ns vs h h' (Hwf & Hhd & Htl & Hch & Hnull & Hfp) Hag H0. + assert (Hcells: forall x, In x (cells ns) -> h' x = h x) + by (intros x Hx; apply Hag, in_cons, in_cons, Hx). + split; [exact Hwf | split; [| split; [| split]]]. + - rewrite Hag; [exact Hhd | apply in_cons, in_eq]. + - unfold tailok in Htl |- *; destruct ns as [| a ns]; + rewrite Hag by apply in_eq; exact Htl. + - eapply chain_mono; [exact Hch | exact Hcells]. + - split; [exact H0 | intros x Hx; rewrite Hag by exact Hx; now apply Hfp]. +Qed. + (** *** The transport theorem on the PRECONDITION. [f] is an arbitrary heap. The two compatibility conditions are exactly @@ -79,17 +100,10 @@ Theorem qrepX_frame: forall hdr ns vs h f, f 0 = None -> qrep hdr ns vs (hunion h f). Proof. - intros hdr ns vs h f ((Hwf & Hhd & Htl & Hch & Hnull & Hfp) & Hex) Hdisj Hf0. - split; [exact Hwf | split; [| split; [| split]]]. - - now apply hunion_some. - - unfold tailok in Htl |- *; destruct ns as [| a ns]. - + now apply hunion_dom. - + now apply hunion_some. - - eapply chain_mono; [exact Hch |]. - intros x Hx; apply hunion_eq; eapply chain_dom; eauto. - - split. - + rewrite hunion_none; assumption. - + intros x Hx; apply hunion_dom, Hfp, Hx. + intros hdr ns vs h f [Hq _] _ Hf0. + eapply qrep_agree_fp; [exact Hq | |]. + - intros x Hx; apply hunion_eq; eapply qrep_fp; eassumption. + - apply hunion_null; [eapply qrep_null; exact Hq | exact Hf0]. Qed. (** A precise queue owns nothing outside its footprint. *) @@ -100,27 +114,6 @@ Proof. [exfalso; apply Hout, Hex; congruence | reflexivity]. Qed. -(** [qrep] only looks at the footprint and at the null cell, so it survives any - change that leaves both alone. This is what turns [qstepN_agree] (the - rotating queue touches nothing outside ITS footprint) into "the unused - second queue is still there, at every reachable state". *) -Lemma qrep_agree_fp: forall hdr ns vs h h', - qrep hdr ns vs h -> - (forall x, In x (qcells hdr ns) -> h' x = h x) -> - h' 0 = None -> - qrep hdr ns vs h'. -Proof. - intros hdr ns vs h h' (Hwf & Hhd & Htl & Hch & Hnull & Hfp) Hag H0. - assert (Hcells: forall x, In x (cells ns) -> h' x = h x) - by (intros x Hx; apply Hag, in_cons, in_cons, Hx). - split; [exact Hwf | split; [| split; [| split]]]. - - rewrite Hag; [exact Hhd | apply in_cons, in_eq]. - - unfold tailok in Htl |- *; destruct ns as [| a ns]; - rewrite Hag by apply in_eq; exact Htl. - - eapply chain_mono; [exact Hch | exact Hcells]. - - split; [exact H0 | intros x Hx; rewrite Hag by exact Hx; now apply Hfp]. -Qed. - (** ** The canonical decomposition, and its uniqueness *) Definition inqb (hdr: nat) (ns: list nat) (x: nat) : bool := diff --git a/theories/ICTree/Eq/Core.v b/theories/ICTree/Eq/Core.v index 2218780..3624239 100644 --- a/theories/ICTree/Eq/Core.v +++ b/theories/ICTree/Eq/Core.v @@ -160,73 +160,17 @@ Local Open Scope ictree_scope. #[global] Instance equ_eq_equ_impl {E R} {HE: Encode E}: Proper (equ eq ==> equ eq ==> flip impl) (@equ E _ R R eq). Proof. - unfold Proper, respectful, flip, impl; cbn. - unfold equ; coinduction RR IH. intros t t' EQt u u' EQu EQ. - step in EQt. - step in EQu. - step in EQ. - cbn*; cbn in *; inv EQt; rewrite <-H0 in EQ. - - inv EQ. - rewrite <-H2 in EQu. - inv EQu; auto. - - dependent destruction EQ. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor. - intro x1; rewrite H1, H0, <- H. - reflexivity. - - dependent destruction EQ. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor. - eapply IH; eauto. - - dependent destruction EQ. - cbn. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor. - intro x1; rewrite H1, H0, <- H. - reflexivity. + transitivity t'; [exact EQt |]. + transitivity u'; [exact EQ | symmetry; exact EQu]. Qed. #[global] Instance equ_eq_equ_goal {E R} {HE: Encode E}: Proper (equ eq ==> equ eq ==> impl) (@equ E _ R R eq). Proof. - unfold Proper, respectful, flip, impl; cbn. - unfold equ; coinduction RR IH. intros t t' EQt u u' EQu EQ. - step in EQt. - step in EQu. - step in EQ. - cbn*; cbn in *; inv EQt; rewrite <- H in EQ. - - inv EQ; auto. - rewrite <- H2 in EQu. - inv EQu; auto. - - dependent destruction EQ. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor. - intro x1. rewrite <- H, <- H1, H0. - reflexivity. - - dependent destruction EQ. - cbn. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor; eauto. - - dependent destruction EQ. - cbn. - rewrite <- x in EQu. - dependent destruction EQu. - rewrite <- x. - constructor. - intro x1; rewrite <- H, <- H1, <- H0. - reflexivity. + symmetry in EQt, EQu. + exact (@equ_eq_equ_impl E R HE t' t EQt u' u EQu EQ). Qed. (** Shallow [observing]: Lift relations through [observe]. *) @@ -357,49 +301,25 @@ Proof. step. cbn. constructor. reflexivity. Qed. Lemma resumICtree_br {E1 E2 : Type} `{ReSumRet E1 E2} {R} (n: nat) (k: fin' n -> ictree E1 R): resumICtree (Br n k) ≅ Br n (fun x => resumICtree (k x)). -Proof. - step. - cbn. - constructor. - intros. - reflexivity. -Qed. +Proof. rewrite unfold_resumICtree; reflexivity. Qed. Lemma resumICtree_guard {E1 E2 : Type} {R} `{ReSumRet E1 E2} (t: ictree E1 R): resumICtree (Guard t) ≅ Guard (resumICtree t). -Proof. - step. - cbn. - constructor. - intros. - reflexivity. -Qed. +Proof. rewrite unfold_resumICtree; reflexivity. Qed. Lemma resumICtree_vis {E1 E2 : Type} `{ReSumRet E1 E2} {R} (e : E1) (k : encode e -> ictree E1 R) : resumICtree (Vis e k) ≅ Vis (resum e) (fun x => resumICtree (k (resum_ret e x))). -Proof. - step. - cbn. - constructor. - intros. - reflexivity. -Qed. +Proof. rewrite unfold_resumICtree; reflexivity. Qed. (** Resum lemmas (void), no events *) Lemma resumICtree_ret' `{Encode E} {R} (r : R) : @resumICtree void E _ H _ _ _ (Ret r) ≅ Ret r. -Proof. step. cbn. constructor. reflexivity. Qed. +Proof. apply resumICtree_ret. Qed. Lemma resumICtree_br' `{Encode E} {R} (t : ictree E R) (n: nat) (k: fin' n -> ictree void R): @resumICtree void E _ H _ _ _ (Br n k) ≅ Br n (fun x => resumICtree (k x)). -Proof. - step. - cbn. - constructor. - intros. - reflexivity. -Qed. +Proof. apply resumICtree_br. Qed. Ltac resum := match goal with @@ -428,13 +348,7 @@ Ltac resum := Lemma resumICtree_Vis {E1 E2 : Type} `{ReSumRet E1 E2} {R} (e : E1) (k : encode e -> ictree E1 R) : resumICtree (Vis e k) ≅ Vis (resum e) (fun x => resumICtree (k (resum_ret e x))). -Proof. - step. - cbn. - constructor. - intros. - reflexivity. -Qed. +Proof. apply resumICtree_vis. Qed. (** Dependent inversion of [equ] and [equb] equations [ret] *) Lemma equ_ret_inv {E R} {HE: Encode E} {r1 r2 : R} : diff --git a/theories/ICTree/Interp/Yield/Observed.v b/theories/ICTree/Interp/Yield/Observed.v index b057dad..9ba1cd2 100644 --- a/theories/ICTree/Interp/Yield/Observed.v +++ b/theories/ICTree/Interp/Yield/Observed.v @@ -420,9 +420,6 @@ Section ObservedScheduler. apply sb_guard. Qed. - Local Notation completed' := (completed E). - Local Notation stR R := (lattice.body (coinduction.t (sb eq)) R). - Local Definition erased_schedule (n : nat) (v : pool E n) (focus : option (Fin.t n)) : completed E := forget_scheduler_offers (schedule_with_offers n v focus). @@ -533,865 +530,105 @@ Section ObservedScheduler. reflexivity. Qed. - Local Lemma guard_residual_from_equ (actual target residual : completed') : - observe actual = GuardF residual -> - actual ≅ Guard target -> - residual ≅ target. - Proof. - intros Hobs Heq. - apply equ_guard_invE. - transitivity actual. - - rewrite (ictree_eta actual). rewrite Hobs. reflexivity. - - exact Heq. - Qed. - - Local Ltac contradiction_from_shape_equ actual Hobs Heq := - exfalso; - rewrite (ictree_eta actual) in Heq; - rewrite <- Hobs in Heq; - step in Heq; inversion Heq. - - Local Lemma erased_schedule_match_left_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ erased_schedule 0 v None -> - trans l actual t' -> - exists u', trans l (schedule 0 v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - - rewrite (trans_schedule_empty_ret v). apply trans_ret. - - rewrite Hsb. rewrite Hmid. reflexivity. - Qed. - - Local Lemma erased_schedule_match_left_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ erased_schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (schedule (S n) v None) u' /\ stR R t' u'. - Proof. - intros Hactual TRactual. - assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n (fun i => - erased_schedule (S n) v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (Br n (fun i => schedule (S n) v (Some i))). split. - - apply trans_schedule_no_focus_nonempty. - - rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n) - ((v @ i := (k j))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - exists (schedule (S n) ((v @ i := (k j))) (Some i)). - split. - - apply trans_schedule_focused_br. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - exists (schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). split. - - apply trans_schedule_focused_fork. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - actual ≅ erased_schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (schedule (S n) v (Some i)) u' /\ stR R t' u'. - Proof. - intros Hvi Hactual TRactual. - assert (Hproj : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n) - ((v @ i := (k x))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - exists (schedule (S n) ((v @ i := (k x))) (Some i)). - split. - - apply trans_schedule_focused_user_event. exact Hvi. - - rewrite Hsb. rewrite Hmid. apply Hch. - Qed. - - Local Lemma schedule_focused_br_equ n - (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - schedule (S n) v (Some i) ≅ - Br b (fun j => schedule (S n) ((v @ i := (k j))) (Some i)). - Proof. - intro Hbr. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_br n v i b k Hbr). - reflexivity. - Qed. - - Local Lemma schedule_focused_fork_equ n - (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - Proof. - intro Hfork. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_fork n v i k Hfork). - reflexivity. - Qed. - - Local Lemma schedule_focused_user_event_equ n - (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - schedule (S n) v (Some i) ≅ - Vis (inr (inr e) : yieldE + (spawnE + E)) - (fun x => schedule (S n) ((v @ i := (k x))) (Some i)). - Proof. - intro Huser. - rewrite (ictree_eta (schedule (S n) v (Some i))). - rewrite (schedule_focused_user_event n v i e k Huser). - reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_empty - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' (v : pool E 0) : - actual ≅ schedule 0 v None -> - trans l actual t' -> - exists u', trans l (erased_schedule 0 v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - assert (Hret : actual ~ Ret tt). - { rewrite Hactual. rewrite (trans_schedule_empty_ret v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hret TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - assert (Hproj : Ret tt ~ erased_schedule 0 v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - destruct (sbisim_trans (Ret tt) _ mid l eq Hproj Hmid) as - [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite <- Hsb_u. reflexivity. - Qed. - - Local Lemma erased_schedule_match_right_no_focus - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) : - actual ≅ schedule (S n) v None -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v None) u' /\ stR R u' t'. - Proof. - intros Hactual TRactual. - set (sres := Br n (fun i => schedule (S n) v (Some i))). - set (lres := Br n (fun i => erased_schedule (S n) v (Some i))). - assert (Hshape : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_no_focus_equ n v). reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans (obs (inl Yield : yieldE + (spawnE + E)) tt) - (Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres)) - lres). - { apply trans_vis. } - assert (Hproj : - Vis (inl Yield : yieldE + (spawnE + E)) (fun _ : unit => lres) ~ - erased_schedule (S n) v None). - { symmetry. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - destruct (sbisim_trans _ _ lres - (obs (inl Yield : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_br - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) b k : - observe (v $ i) = BrF b k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun j => - schedule (S n) ((v @ i := (k j))) (Some i)). - set (lres := fun j => - erased_schedule (S n) ((v @ i := (k j))) (Some i)). - assert (Hshape : actual ~ Br b sres). - { rewrite Hactual. rewrite (schedule_focused_br_equ n v i b k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans tau (Br b lres) (lres j)). - { apply trans_br with (x := j). reflexivity. } - assert (Hproj : Br b lres ~ erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_br_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres j) tau eq Hproj Hstep_lres) - as [l'' [u' [Htru [Hl'' Hsb_u]]]]. subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_fork - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) k : - observe (v $ i) = VisF (inr (inl Fork)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - set (lres := erased_schedule (S (S n)) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). - assert (Hshape : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => sres)). - { rewrite Hactual. rewrite (schedule_focused_fork_equ n v i k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. destruct x. - assert (Hstep_lres : trans - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) - (Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres)) lres). - { apply trans_vis. } - assert (Hproj : - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ : unit => lres) ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_fork_projection. exact Hvi. } - destruct (sbisim_trans _ _ lres - (obs (inr (inl Spawn) : yieldE + (spawnE + E)) tt) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_right_user - (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) - l actual t' n (v : pool E (S n)) (i : Fin.t (S n)) e k : - observe (v $ i) = VisF (inr (inr e)) k -> - actual ≅ schedule (S n) v (Some i) -> - trans l actual t' -> - exists u', trans l (erased_schedule (S n) v (Some i)) u' /\ stR R u' t'. - Proof. - intros Hvi Hactual TRactual. - set (sres := fun x => - schedule (S n) ((v @ i := (k x))) (Some i)). - set (lres := fun x => - erased_schedule (S n) ((v @ i := (k x))) (Some i)). - assert (Hshape : actual ~ - Vis (inr (inr e) : yieldE + (spawnE + E)) sres). - { rewrite Hactual. - rewrite (schedule_focused_user_event_equ n v i e k Hvi). - reflexivity. } - destruct (sbisim_trans actual _ t' l eq Hshape TRactual) as - [l' [mid [Hmid [Hl' Hsb_mid]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid Hlabel]]. - subst l. - assert (Hstep_lres : trans - (obs (inr (inr e) : yieldE + (spawnE + E)) x) - (Vis (inr (inr e) : yieldE + (spawnE + E)) lres) (lres x)). - { apply trans_vis. } - assert (Hproj : Vis (inr (inr e) : yieldE + (spawnE + E)) lres ~ - erased_schedule (S n) v (Some i)). - { symmetry. - apply forget_scheduler_offers_focused_user_event_projection. exact Hvi. } - destruct (sbisim_trans _ _ (lres x) - (obs (inr (inr e) : yieldE + (spawnE + E)) x) eq Hproj - Hstep_lres) as [l'' [u' [Htru [Hl'' Hsb_u]]]]. - subst l''. - exists u'. split. - - exact Htru. - - rewrite Hsb_mid. rewrite Hmid. rewrite <- Hsb_u. apply Hch. - Qed. - - Local Lemma erased_schedule_match_left (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ erased_schedule n v focus -> - exists u', trans l (schedule n v focus) u' /\ stR R t' u'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule n' ((v -- i)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' ((v -- i)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_ret n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * assert (Hproj : actual ~ - Br b (fun j => erased_schedule (S n') - ((v @ i := (k j))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_br_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_br_inv in Hmid as [j [Hmid ->]]. - exists (schedule (S n') ((v @ i := (k j))) (Some i)). - split. - -- apply trans_schedule_focused_br. exact Hvi. - -- rewrite Hsb. rewrite Hmid. apply Hch. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - assert (Ht : t ≅ - erased_schedule (S n') ((v @ i := g)) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (trans_schedule_focused_guard n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ erased_schedule (S n') - ((v @ i := (k tt))) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := (k tt))) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (schedule_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - assert (Hproj : actual ~ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => erased_schedule (S (S n')) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i)))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_fork_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (schedule (S (S n')) - (((k true) :: ((v @ i := (k false))))%vector) - (Some (Fin.FS i))). split. - ++ apply trans_schedule_focused_fork. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - -- assert (Hproj : actual ~ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => erased_schedule (S n') - ((v @ i := (k x))) (Some i))). - { rewrite Hactual. - apply forget_scheduler_offers_focused_user_event_projection. - exact Hvi. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - exists (schedule (S n') ((v @ i := (k x))) (Some i)). - split. - ++ apply trans_schedule_focused_user_event. exact Hvi. - ++ rewrite Hsb. rewrite Hmid. apply Hch. - + destruct nn as [| n']. - * assert (Hproj : actual ~ Ret tt). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_empty_no_focus_projection. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_ret_inv in Hmid as [Hmid ->]. - exists stuck. split. - -- rewrite (trans_schedule_empty_ret v). apply trans_ret. - -- rewrite Hsb. rewrite Hmid. reflexivity. - * assert (Hproj : actual ~ - Vis (inl Yield : yieldE + (spawnE + E)) - (fun _ : unit => Br n' (fun i => - erased_schedule (S n') v (Some i)))). - { rewrite Hactual. - unfold erased_schedule. - apply forget_scheduler_offers_no_focus_projection_to_focused. } - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct (sbisim_trans actual _ t' l eq Hproj TRactual) as - [l' [mid [Hmid [Hl' Hsb]]]]. subst l'. - apply trans_vis_inv in Hmid as [x [Hmid ->]]. - destruct x. - exists (Br n' (fun i => schedule (S n') v (Some i))). split. - -- apply trans_schedule_no_focus_nonempty. - -- rewrite Hsb. rewrite Hmid. - apply (coinduction.bt_t (sb eq)). - apply step_sb_br_id; [reflexivity | intro j]. - apply Hch. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_left_br; eauto. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (((k0 true) :: ((v @ i := (k0 false))))%vector) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - ((v @ i := (k0 x))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - ((v @ i := (k0 j))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_left_fork; eauto. - -- eapply erased_schedule_match_left_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (erased_schedule n' ((v -- i)) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_ret_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * assert (Hbr : actual ≅ - Br b (fun j => Guard (erased_schedule (S n') - ((v @ i := (k0 j))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_br_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hbr. - * assert (Hguard : actual ≅ - Guard (erased_schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_guard_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (erased_schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - assert (Hvis : actual ≅ - Vis (inr (inl Spawn) : yieldE + (spawnE + E)) - (fun _ => Guard (erased_schedule (S (S n')) - (((k0 true) :: ((v @ i := (k0 false))))%vector) - (Some (Fin.FS i))))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_fork_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - -- assert (Hvis : actual ≅ - Vis (inr (inr usr) : yieldE + (spawnE + E)) - (fun x => Guard (erased_schedule (S n') - ((v @ i := (k0 x))) (Some i)))). - { transitivity (erased_schedule (S n') v (Some i)). - - exact Hactual. - - apply erased_focused_user_event_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hvis. - + destruct nn as [| n']. - * eapply erased_schedule_match_left_empty; eauto. - * eapply erased_schedule_match_left_no_focus; eauto. - Qed. - - Local Lemma erased_schedule_match_right (R : rel completed' completed') - (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)) : - forall l os ot', trans_ l os ot' -> - forall actual n (v : pool E n) focus t', - os = observe actual -> - ot' = observe t' -> - actual ≅ schedule n v focus -> - exists u', trans l (erased_schedule n v focus) u' /\ stR R u' t'. - Proof. - intros l os ot' TR. - induction TR; intros actual nn v focus t' Hos Hot Hactual. - - assert (TRactual : trans l actual t'). - { unfold trans. rewrite <- Hos, <- Hot. constructor. exact TR. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k | g | e k] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - assert (Ht : t ≅ schedule n' ((v -- i)) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t n' ((v -- i)) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_ret_equ n' v i Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - assert (Ht : t ≅ - schedule (S n') ((v @ i := g)) (Some i)). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := g)) (Some i) t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - -- rewrite (erased_focused_guard_equ n' v i g Hvi). - apply trans_guard. exact Htru. - -- exact Hres. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - assert (Ht : t ≅ schedule (S n') - ((v @ i := (k tt))) None). - { eapply guard_residual_from_equ. - - symmetry. exact Hos. - - exact Hguard. } - destruct (IHTR t (S n') ((v @ i := (k tt))) None t' - eq_refl Hot Ht) as [u' [Htru Hres]]. - exists u'. split. - ++ rewrite (erased_focused_yield_equ n' v i k Hvi). - apply trans_guard. exact Htru. - ++ exact Hres. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans tau actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Steptau. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (obs e x) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepobs. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r | b k0 | g | e0 k0] eqn:Hvi. - * destruct r. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e0 as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. - - assert (TRactual : trans (val r) actual t'). - { unfold trans. rewrite <- Hos, <- Hot. - eapply Stepval. exact H0. } - destruct focus as [i |]. - + destruct nn as [| n']; [inversion i |]. - destruct (observe (v $ i)) as [r0 | b k0 | g | e k0] eqn:Hvi. - * destruct r0. - assert (Hguard : actual ≅ - Guard (schedule n' ((v -- i)) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_ret. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * eapply erased_schedule_match_right_br; eauto. - * assert (Hguard : actual ≅ - Guard (schedule (S n') ((v @ i := g)) (Some i))). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply trans_schedule_focused_guard. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - * destruct e as [yld | [frk | usr]]. - -- destruct yld. - assert (Hguard : actual ≅ - Guard (schedule (S n') - ((v @ i := (k0 tt))) None)). - { transitivity (schedule (S n') v (Some i)). - - exact Hactual. - - apply schedule_focused_yield_equ. exact Hvi. } - contradiction_from_shape_equ actual Hos Hguard. - -- destruct frk. - eapply erased_schedule_match_right_fork; eauto. - -- eapply erased_schedule_match_right_user; eauto. - + destruct nn as [| n']. - * eapply erased_schedule_match_right_empty; eauto. - * eapply erased_schedule_match_right_no_focus; eauto. + Local Lemma erased_offer_prefix_guards : + forall m r (embed : LiveSlot r -> LiveSlot m) (v : pool E m), + forget_scheduler_offers (schedule_with_offers_offer_prefix m r embed v) ≅ + guards r (forget_scheduler_offers (schedule_with_offers_offer_prefix m 0 + (fun i : LiveSlot 0 => match i with end) v)). + Proof. + intros m r; revert m; induction r as [|r IH]; intros m embed v; + [ destruct m; unfold forget_scheduler_offers; rewrite !unfold_interp; cbn; reflexivity + | cbn [guards]; unfold forget_scheduler_offers at 1; rewrite unfold_interp; + cbn; rewrite bind_ret_l; apply guard_equ_node; apply IH ]. + Qed. + + Local Lemma erased_no_focus_guards : + forall n (v : pool E (S n)), + erased_schedule (S n) v None ≅ + guards (S (S n)) (Vis (inl Yield) (fun _ : unit => + Guard (Br n (fun i => Guard (erased_schedule (S n) v (Some i)))))). + Proof. + intros n v; unfold erased_schedule at 1; + transitivity (Guard (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) (S n) (fun i => i) v))); + [ apply forget_scheduler_offers_no_focus_nonempty_unfold | + apply guard_equ_node; + transitivity (guards (S n) (forget_scheduler_offers + (schedule_with_offers_offer_prefix (S n) 0 (fun i : LiveSlot 0 => match i with end) v))); + [ apply erased_offer_prefix_guards | apply (guards_equ (S n)); unfold forget_scheduler_offers; + rewrite unfold_interp; cbn; + unfold ICtree.trigger, resum, ReSum_refl, resum_ret, ReSumRet_refl; + rewrite bind_vis; setoid_rewrite bind_ret_l; + apply vis_equ_node; intros []; apply guard_equ_node; + rewrite unfold_interp; cbn; reflexivity ] ]. + Qed. + + Local Lemma erased_offers_galigned : + forall n (v : pool E n) focus a b, + galigned (guards a (erased_schedule n v focus)) + (guards b (schedule n v focus)). + Proof. + cofix CH; intros n v focus a b; + destruct focus as [i|]; + [ destruct n as [|n]; [inversion i | + destruct (observe (v $ i)) as [r|c k|g|e k] eqn:Hvi; + [ destruct r; + eapply galign_guard with (n:=a) (m:=b) + (t':=erased_schedule n (v -- i) None) + (u':=schedule n (v -- i) None); + [ rewrite <- guards_guard; apply (guards_equ a); apply erased_focused_ret_equ; exact Hvi + | rewrite <- guards_guard; apply (guards_equ b); apply trans_schedule_focused_ret; exact Hvi + | exact (CH _ _ _ 0 0) ] + | eapply galign_br with (n:=a) (m:=b) (c:=c) + (k:=fun j => Guard (erased_schedule (S n) (v @ i := k j) (Some i))) + (k':=fun j => schedule (S n) (v @ i := k j) (Some i)); + [ apply (guards_equ a); apply erased_focused_br_equ; exact Hvi + | apply (guards_equ b); rewrite (ictree_eta (schedule (S n) v (Some i))); + rewrite (schedule_focused_br n v i c k Hvi); reflexivity + | intro j; exact (CH _ _ _ 1 0) ] + | eapply galign_guard with (n:=a) (m:=b) + (t':=erased_schedule (S n) (v @ i := g) (Some i)) + (u':=schedule (S n) (v @ i := g) (Some i)); + [ rewrite <- guards_guard; apply (guards_equ a); apply erased_focused_guard_equ; exact Hvi + | rewrite <- guards_guard; apply (guards_equ b); apply trans_schedule_focused_guard; exact Hvi + | exact (CH _ _ _ 0 0) ] + | destruct e as [yld|[frk|usr]]; + [ destruct yld; + eapply galign_guard with (n:=a) (m:=b) + (t':=erased_schedule (S n) (v @ i := k tt) None) + (u':=schedule (S n) (v @ i := k tt) None); + [ rewrite <- guards_guard; apply (guards_equ a); apply erased_focused_yield_equ; exact Hvi + | rewrite <- guards_guard; apply (guards_equ b); apply schedule_focused_yield_equ; exact Hvi + | exact (CH _ _ _ 0 0) ] + | destruct frk; + eapply galign_vis with (n:=a) (m:=b) (e:=inr (inl Spawn)) + (k:=fun _ => Guard (erased_schedule (S (S n)) ((k true :: (v @ i := k false))%vector) (Some (Fin.FS i)))) + (k':=fun _ => schedule (S (S n)) ((k true :: (v @ i := k false))%vector) (Some (Fin.FS i))); + [ apply (guards_equ a); apply erased_focused_fork_equ; exact Hvi + | apply (guards_equ b); rewrite (ictree_eta (schedule (S n) v (Some i))); + rewrite (schedule_focused_fork n v i k Hvi); reflexivity + | intros []; exact (CH _ _ _ 1 0) ] + | eapply galign_vis with (n:=a) (m:=b) (e:=(inr (inr usr) : yieldE + (spawnE + E))) + (k:=fun x => Guard (erased_schedule (S n) (v @ i := k x) (Some i))) + (k':=fun x => schedule (S n) (v @ i := k x) (Some i)); + [ apply (guards_equ a); apply erased_focused_user_event_equ; exact Hvi + | apply (guards_equ b); rewrite (ictree_eta (schedule (S n) v (Some i))); + rewrite (schedule_focused_user_event n v i usr k Hvi); reflexivity + | intro x; exact (CH _ _ _ 1 0) ] ] ] ] + | destruct n as [|n]; + [ eapply galign_ret with (n:=a) (m:=b) (r:=tt); + [ apply (guards_equ a); unfold erased_schedule, forget_scheduler_offers; + rewrite unfold_interp; reflexivity + | apply (guards_equ b); apply trans_schedule_empty_ret ] + | eapply galign_vis with (n:=(a + S (S n))%nat) (m:=b) (e:=inl Yield) + (k:=fun _ : unit => Guard (Br n (fun i => Guard (erased_schedule (S n) v (Some i))))) + (k':=fun _ : unit => Br n (fun i => schedule (S n) v (Some i))); + [ rewrite guards_add; apply (guards_equ a); apply erased_no_focus_guards + | apply (guards_equ b); apply schedule_no_focus_equ + | intros []; eapply galign_br with (n:=1) (m:=0) (c:=n) + (k:=fun i => Guard (erased_schedule (S n) v (Some i))) + (k':=fun i => schedule (S n) v (Some i)); + [ reflexivity | reflexivity | intro i; exact (CH _ _ _ 1 0) ] ] ] ]. Qed. Theorem forget_scheduler_offers_preserves_schedule @@ -1399,28 +636,8 @@ Section ObservedScheduler. forget_scheduler_offers (schedule_with_offers n v focus) ~ schedule n v focus. Proof. - change (erased_schedule n v focus ~ schedule n v focus). - revert n v focus. - coinduction R CH. - intros n v focus. - assert (Hch : forall m (w : pool E m) f, - stR R (erased_schedule m w f) (schedule m w f)). - { intros m w f. apply CH. } - split. - - intros l t' TR. - destruct (erased_schedule_match_left R Hch _ _ _ TR - (erased_schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + exact Hres. - + reflexivity. - - intros l t' TR. - destruct (erased_schedule_match_right R Hch _ _ _ TR - (schedule n v focus) n v focus t' - eq_refl eq_refl ltac:(reflexivity)) as [u' [Htru Hres]]. - exists l, u'. split; [exact Htru | split]. - + unfold Basics.flip. exact Hres. - + reflexivity. + apply galigned_sbisim. + exact (erased_offers_galigned n v focus 0 0). Qed. Inductive offered_in_scheduler_prefix (n : nat) (i : LiveSlot n) diff --git a/theories/ICTree/Logic/Ret.v b/theories/ICTree/Logic/Ret.v index 33ff9ea..86f8aba 100644 --- a/theories/ICTree/Logic/Ret.v +++ b/theories/ICTree/Logic/Ret.v @@ -27,67 +27,26 @@ Section RetLemmas. Proof is by induction on the formula. *) Theorem ticll_ret_equiv{X Y}: forall (x: X) (y: Y) (φ: ticll E) w, <( {Ret x}, w |= φ )> <-> <( {Ret y}, w |= φ )>. - Proof with auto with ticl. - split; intros * H. - - assert (Hd: not_done w) by now apply ticll_not_done in H. - assert (Hs: can_step (Ret y) w) by now apply can_step_ret; auto. - generalize dependent w; revert x y. - induction φ; intros. - + (* now *) cdestruct H; csplit... - + (* U *) destruct q. - * eapply aul_ret. - eapply aul_ret in H. - cdestruct H. - -- cleft; apply IHφ2 with x... - -- cright; now apply anl_ret in H. - * apply eul_ret. - apply eul_ret in H. - cdestruct H. - -- cleft; apply IHφ2 with x... - -- cright; now apply enl_ret in H. - + (* X *) destruct q. - * now apply anl_ret in H. - * now apply enl_ret in H. - + (* G *) destruct q. - * now apply ag_ret in H. - * now apply eg_ret in H. - + cdestruct H; csplit. - * apply IHφ1 with x... - * apply IHφ2 with x... - + cdestruct H. - * cleft. - apply IHφ1 with x... - * cright. - apply IHφ2 with x... - - assert (Hd: not_done w) by now apply ticll_not_done in H. - assert (Hs: can_step (Ret x) w) by now apply can_step_ret; auto. - generalize dependent w; revert x y. - induction φ; intros. - + (* now *) cdestruct H; csplit... - + (* U *) destruct q. - * eapply aul_ret. - eapply aul_ret in H. - cdestruct H. - -- cleft; apply IHφ2 with y... - -- cright; now apply anl_ret in H. - * apply eul_ret. - apply eul_ret in H. - cdestruct H. - -- cleft; apply IHφ2 with y... - -- cright; now apply enl_ret in H. - + (* X *) destruct q. - * now apply anl_ret in H. - * now apply enl_ret in H. - + (* G *) destruct q. - * now apply ag_ret in H. - * now apply eg_ret in H. - + cdestruct H; csplit. - * apply IHφ1 with y... - * apply IHφ2 with y... - + cdestruct H. - * cleft. - apply IHφ1 with y... - * cright. - apply IHφ2 with y... + Proof with auto with ticl. + assert (ret_impl : + forall (A B : Type) (a : A) (b : B) (φ : ticll E) w, + <( {Ret a}, w |= φ )> -> <( {Ret b}, w |= φ )>) by + (intros A B a b φ w H; + assert (Hd : not_done w) by (now apply ticll_not_done in H); + assert (Hs : can_step (Ret b) w) by (now apply can_step_ret); + generalize dependent w; revert a b; induction φ; intros; + [ cdestruct H; csplit; auto with ticl + | destruct q; + [ eapply aul_ret; eapply aul_ret in H; cdestruct H; + [ cleft; apply IHφ2 with a; auto with ticl | cright; now apply anl_ret in H ] + | apply eul_ret; apply eul_ret in H; cdestruct H; + [ cleft; apply IHφ2 with a; auto with ticl | cright; now apply enl_ret in H ] ] + | destruct q; [now apply anl_ret in H | now apply enl_ret in H] + | destruct q; [now apply ag_ret in H | now apply eg_ret in H] + | cdestruct H; csplit; [apply IHφ1 with a; auto with ticl | apply IHφ2 with a; auto with ticl] + | cdestruct H; [cleft; apply IHφ1 with a; auto with ticl | cright; apply IHφ2 with a; auto with ticl] ]). + intros x y φ w; split; intro H. + - exact (ret_impl X Y x y φ w H). + - exact (ret_impl Y X y x φ w H). Qed. End RetLemmas. diff --git a/theories/ICTree/Logic/State.v b/theories/ICTree/Logic/State.v index b94babf..c9cc5e0 100644 --- a/theories/ICTree/Logic/State.v +++ b/theories/ICTree/Logic/State.v @@ -136,8 +136,7 @@ From Coinduction Require Import coinduction. Proof with eauto with ticl. intros. rewrite interp_state_bind. - eapply anr_bind_r... - intros [y σ_] w_ (Hinv & HR); inv Hinv; subst... + eapply anr_bind_r_eq... Qed. (** Convenience bind lemma for [interp_state] and prefix [AN], does not require the [R] postcondition if [t] is deterministic. *) @@ -235,8 +234,7 @@ From Coinduction Require Import coinduction. Proof with eauto with ticl. intros. rewrite interp_state_bind. - eapply aul_bind_r... - intros [y σ''] * [Heq ->]; inv Heq... + eapply aul_bind_r_eq... Qed. (** Bind lemma for [interp_state] and suffix [AU] *) @@ -259,8 +257,7 @@ From Coinduction Require Import coinduction. Proof with eauto with ticl. intros. rewrite interp_state_bind. - eapply aur_bind_r... - intros [y σ''] * [Heq ->]; inv Heq... + eapply aur_bind_r_eq... Qed. (** Bind lemma for [interp_state] and suffix [EU] *) @@ -283,8 +280,7 @@ From Coinduction Require Import coinduction. Proof with eauto with ticl. intros. rewrite interp_state_bind. - eapply eul_bind_r... - intros [y σ''] * [Heq ->]; inv Heq... + eapply eul_bind_r_eq... Qed. (** Bind lemma for [interp_state] and prefix [EU] *) @@ -307,8 +303,7 @@ From Coinduction Require Import coinduction. Proof with eauto with ticl. intros. rewrite interp_state_bind. - eapply eur_bind_r... - intros [y σ''] * [Heq ->]; inv Heq... + eapply eur_bind_r_eq... Qed. (** Bind lemma for [interp_state] and [AG], unfolds the [AG] to an [AU] on [t] and an [AG] on the continuation [k r]. diff --git a/theories/ICTree/SBisim/Core.v b/theories/ICTree/SBisim/Core.v index 94c6262..2f5404f 100644 --- a/theories/ICTree/SBisim/Core.v +++ b/theories/ICTree/SBisim/Core.v @@ -77,15 +77,7 @@ Section StrongBisim. #[global] Instance weq_sbisim : Proper (weq ==> weq) sbisim. Proof. - intros. split. - - intro. unfold sbisim. - epose proof (gfp_weq (sb x) (sb y)). lapply H1. - + intro. red in H2. cbn in H2. rewrite <- H2. unfold sbisim in H0. apply H0. - + now rewrite H. - - intro. unfold sbisim. - epose proof (gfp_weq (sb x) (sb y)). lapply H1. - + intro. red in H2. cbn in H2. rewrite H2. unfold sbisim in H0. apply H0. - + now rewrite H. + intros L L' HL; unfold sbisim; apply gfp_weq; apply weq_sb; exact HL. Qed. End StrongBisim. diff --git a/theories/ICTree/SBisim/SSim.v b/theories/ICTree/SBisim/SSim.v index d44666b..1eb2938 100644 --- a/theories/ICTree/SBisim/SSim.v +++ b/theories/ICTree/SBisim/SSim.v @@ -59,15 +59,7 @@ Section StrongSim. #[global] Instance weq_ssim : Proper (weq ==> weq) ssim. Proof. - intros. split. - - intro. unfold ssim. - epose proof (gfp_weq (ss x) (ss y)). lapply H1. - + intro. red in H2. cbn in H2. rewrite <- H2. unfold ssim in H0. apply H0. - + now rewrite H. - - intro. unfold ssim. - epose proof (gfp_weq (ss x) (ss y)). lapply H1. - + intro. red in H2. cbn in H2. rewrite H2. apply H0. - + now rewrite H. + intros L L' HL; unfold ssim; apply gfp_weq; apply weq_ss; exact HL. Qed. End StrongSim. diff --git a/theories/ICTree/Trans.v b/theories/ICTree/Trans.v index f474d59..9e70142 100755 --- a/theories/ICTree/Trans.v +++ b/theories/ICTree/Trans.v @@ -514,11 +514,7 @@ Qed. Lemma trans_trigger : forall {Y} `{HE: Encode E} (e : E) x (k: encode e -> ictree E Y), trans (obs e x) (trigger e >>= k) (k x). Proof. - intros. - unfold ICtree.trigger. - rewrite unfold_bind; cbn. - setoid_rewrite bind_ret_l. - constructor; auto. + intros; rewrite bind_trigger; apply trans_vis. Qed. (** A trigger node can step to [k x], if [k x] can step to [u] and the label is [obs e x] *) @@ -527,15 +523,7 @@ Lemma trans_trigger_inv : forall {Y} `{HE: Encode E} (e : E) trans l (trigger e >>= k) u -> exists x, u ≅ k x /\ l = obs e x. Proof. - intros * TR. - unfold trigger in TR. - apply trans_bind_inv in TR. - destruct TR as [(? & ? & TR & ?) |(? & TR & ?)]. - - apply trans_vis_inv in TR. - destruct TR as (? & ? & ->); eexists; split; eauto. - rewrite H0, H1, bind_ret_l; reflexivity. - - apply trans_vis_inv in TR. - destruct TR as (? & ? & abs); inv abs. + intros * TR; rewrite bind_trigger in TR; now apply trans_vis_inv in TR. Qed. (** [wf_val] states that a [label] is well-formed: diff --git a/theories/Logic/Congruence.v b/theories/Logic/Congruence.v index 80df580..4a886d4 100644 --- a/theories/Logic/Congruence.v +++ b/theories/Logic/Congruence.v @@ -564,20 +564,12 @@ Section TicllEquations. Lemma equivl_and_ag: forall p q, <( AG (p /\ q) )> ⩸ <( AG p /\ AG q )>. Proof with eauto. - split. - - unfold impl_ticll; intros; apply ticll_and; split. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_ag_an, ticll_an in H as (Hp & Hs & Hg). - split2... - now apply ticll_and in Hp as (Hp & Hq). - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_ag_an, ticll_an in H as (Hp & Hs & Hg). - split2... - now apply ticll_and in Hp as (Hp & Hq). + intros p q; split. + - intros t w H; apply ticll_and; split. + + eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hpq; apply ticll_and in Hpq; exact (proj1 Hpq). + + eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hpq; apply ticll_and in Hpq; exact (proj2 Hpq). - unfold impl_ticll; intros; revert H; revert t w. coinduction R CIH; intros. destruct H as (Hp & Hq). @@ -593,20 +585,12 @@ Section TicllEquations. *) Lemma impll_and_eg: forall p q, <( EG (p /\ q) )> ⋖ <( EG p /\ EG q )>. - Proof with eauto. - unfold impl_ticll; intros; apply ticll_and; split. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_eg_en, ticll_en in H as (Hp & t' & w' & TR & Hg). - split... - now apply ticll_and in Hp as (Hp & Hq). - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_eg_en, ticll_en in H as (Hp & t' & w' & TR & Hg). - split... - now apply ticll_and in Hp as (Hp & Hq). + Proof. + intros p q t w H; apply ticll_and; split. + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hpq; apply ticll_and in Hpq; exact (proj1 Hpq). + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hpq; apply ticll_and in Hpq; exact (proj2 Hpq). Qed. (** [AG (p \/ q)] implies [AG p \/ AG q]. @@ -615,20 +599,12 @@ Section TicllEquations. *) Lemma impll_or_ag: forall p q, <( AG p \/ AG q )> ⋖ <( AG (p \/ q) )>. - Proof with eauto. - unfold impl_ticll; intros; apply ticll_or in H as [H|H]. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_ag_an, ticll_an in H as (Hp & Hs & Hg). - split2... - apply ticll_or; now left. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_ag_an, ticll_an in H as (Hp & Hs & Hg). - split2... - apply ticll_or; now right. + Proof. + intros p q t w H; apply ticll_or in H as [H | H]. + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hp; apply ticll_or; left; exact Hp. + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hp; apply ticll_or; right; exact Hp. Qed. (** [EG (p \/ q)] implies [EG p \/ EG q]. @@ -637,20 +613,12 @@ Section TicllEquations. *) Lemma impll_or_eg: forall p q, <( EG p \/ EG q )> ⋖ <( EG (p \/ q) )>. - Proof with eauto. - unfold impl_ticll; intros; apply ticll_or in H as [H|H]. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_eg_en, ticll_en in H as (Hp & t' & w' & TR & Hg). - split... - apply ticll_or; now left. - + generalize dependent t. - generalize dependent w. - coinduction R CIH; intros. - apply equivl_eg_en, ticll_en in H as (Hp & t' & w' & TR & Hg). - split... - apply ticll_or; now right. + Proof. + intros p q t w H; apply ticll_or in H as [H | H]. + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hp; apply ticll_or; left; exact Hp. + - eapply impl_ticll_global; [reflexivity | | exact H]. + intros t' w' Hp; apply ticll_or; right; exact Hp. Qed. End TicllEquations.