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 067460f..09716be 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,8 @@ _build .vok .vo 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" + ] + } + } +} 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 new file mode 100644 index 0000000..3b7f82d --- /dev/null +++ b/examples/CSL/Allocator/Counterexamples.v @@ -0,0 +1,645 @@ +(** * 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 examples Require Import CSL.Allocator.Layout CSL.Allocator.Program + CSL.Allocator.Model CSL.Allocator.Execution CSL.Allocator.Liveness. +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. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +Section Starvation. + +Let starvation_cycle : list Actor := + [Remote1; Remote1; Remote0; Remote0; Remote0; Remote0; Remote1; + Owner; Owner; Owner; Owner; Owner; Owner]. +Let starvation_prefix : list Actor := + [Owner; Owner; Owner; Owner; Owner; Remote1] ++ starvation_cycle. + +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. *) +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. +Let starve_boundary (c : nat) : AState := + {| aheap := starve_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RPoll; + remote1_state := RRead 8 |}. + +(** The observation of each individual turn, including every silent turn. *) +Let starve_prefix_event (c i : nat) : option (CSLObs (nat * nat)) := + match i with + | 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 (CSLObs (nat * nat)) := + match i with + | 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. + +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. + 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. + +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. + 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. + +Local Lemma starve_cycle_run_actual c s : + state_equiv s (starve_boundary c) -> + exists last, + 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_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. + +Local Lemma starve_prefix_position c i : i < 19 -> + exists middle logs next, + 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). +Proof. + intro Hi. + do 19 (destruct i as [|i]; + [eexists; eexists; eexists; split; vm_compute; reflexivity|]). + lia. +Qed. + +Local Lemma starve_cycle_position c i : i < 13 -> + exists middle logs next, + 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 = + 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. + +(** 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 (CSLObs (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. + 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. + +Local 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_round; exact Hi. +Qed. + +Local Lemma starve_cycle_script n : + List.map (selected starvation_execution) + (List.seq (19+13*n) (List.length starvation_cycle)) = starvation_cycle. +Proof. + apply (map_seq_eq _ _ _ _ Remote1); [reflexivity|]. + intros i Hi; apply starve_selected_cycle; exact Hi. +Qed. + +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. + +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]. + replace (19+13*0) with (0 + List.length starvation_prefix) by reflexivity. + 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) + by (cbn [starvation_cycle List.length]; lia). + 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) 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_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 -> + 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). + exact (proj2 (execution_script_emitted (turn 1) event_obs + (fun s => s = initial_state 2 0) state_equiv (turn_proper 1) + 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 -> + 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. + +Local Lemma starve_fair : fair_choices (selected 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. + +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_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 -> + 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 (inr (stamp (tag_retire,8) idx)). +Proof. + intro Hi. + do 13 (destruct i as [|i]; [vm_compute; discriminate|]). + lia. +Qed. + +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. + 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. + +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. +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. +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. +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, + allocator_valid 2 0 e /\ fair_choices (selected e) /\ + (forall k, 19 <= k -> held (remote1_state (states e k)) = [8]) /\ + 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) (managed_empty,((List.nil : Ctx.Ctx),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. + +(** 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) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : 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). + 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 (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]. +Qed. + +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]. + +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 (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. *) +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. +Let stalled_boundary (c : nat) : AState := + {| aheap := stalled_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RPoll; + remote1_state := RPoll |}. + +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. + 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. + +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. + +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 (List.nth k owner_stall_prefix Remote0) 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 (CSLObs (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. + 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. + +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. + +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). + 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 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 -> + emitted owner_stall_execution k = + List.nth k stalled_prefix_observations None. +Proof. + intro Hk. + destruct (stalled_prefix_position k Hk) as (before & after & logs & Hrun & Hturn). + 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 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 (inr (stamp (tag_retire,6) 2)). +Proof. exact (stalled_prefix_observation 8 ltac:(lia)). Qed. + +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_nth; reflexivity. +Qed. + +Local 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. + +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. + 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_round; exact Hi. +Qed. + +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]. + - 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. + +Local 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. + +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. + +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. + 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. + +Local Lemma stalled_suffix_silent n : emitted owner_stall_execution (13+n) = None. +Proof. + 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. + +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. + 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. + +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) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + destruct (stalled_prefix_run 0) as (last & Hrun & Hstate). + 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|]. + 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. *) +Theorem stalled_tail_source_tau n + (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. +Proof. + 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, + 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 (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,((List.nil : Ctx.Ctx),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. + +End OwnerStall. diff --git a/examples/CSL/Allocator/Execution.v b/examples/CSL/Allocator/Execution.v new file mode 100644 index 0000000..8b21351 --- /dev/null +++ b/examples/CSL/Allocator/Execution.v @@ -0,0 +1,818 @@ +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.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 examples Require Import CSL.Queue.Representation. +From examples Require Import 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 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 state_agrees (sigma : SSig) (s : AState) : Prop := + heq (fst (fst sigma)) (aheap s) /\ csl_counter sigma = acount s. + + +Definition source_reheap (sigma : SSig) (s : AState) : AState := + {| aheap := fst (fst sigma); acount := csl_counter 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 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 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),(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (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. + - cbn [init_links init_links_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. + + 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. + +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 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),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (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. + - cbn [init_links init_links_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. + + 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. + +(** 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 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),(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) m ((page_heap base capacity h,allocs),(ctx,c)). +Proof. + unfold init_page, page_heap. + do 5 (rewrite interp_rr_bind; etransitivity; + [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_mono. + 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 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),(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) ((page_heap base capacity h,allocs),(ctx,c)). +Proof. + unfold init_page, page_heap. + do 5 (rewrite interp_nd_source_bind; etransitivity; + [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_mono. + 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. 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 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),(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)),(ctx,c)). +Proof. + intros Positive Free First. + 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. +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 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),(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)),(ctx,c)). +Proof. + intros Positive Free First. + 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. +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 ctx 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,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)),(ctx,c)). +Proof. + intro 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 |]. + 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 allocs ctx 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_nd sh (S n) + (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)),(ctx,c)). +Proof. + intro 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 |]. + 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 interp_rr_new_page_hemp n (ts : pool sE (S n)) (i : Fin.t (S n)) + 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,(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)),(ctx,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) ctx c : + interp_schedule_nd sh (S n) + (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)),(ctx,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. *) + +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 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,(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)),(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) 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,(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)),(ctx,c)). +Proof. + intro Lookup; rewrite interp_nd_source_bind, interp_nd_new_page_hemp. + apply interp_nd_source_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 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,(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. +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) 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,(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. +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 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)),(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,(ctx,c)) ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + ((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 + ([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,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)),(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)),(ctx,c)) ~ + interp_schedule_rr sh 3 (source_pool0 1) None 0 + ((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 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)),(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,(ctx,c)) ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((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 + ([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,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)),(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)),(ctx,c)) ~ + interp_schedule_nd sh 3 (source_pool0 1) None + ((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. + +From Stdlib Require Import List Program.Equality Classes.RelationClasses. +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 + 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 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. + + + + + +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; + csl_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 upd_mono; 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 + | |- (segment_to sh csl_equ) (denote_flow (CBind _ _) >>= _) _ _ _ _ => + apply exact_source_bind + | |- (segment_to sh csl_equ) (denote_flow (CRet _) >>= _) _ _ _ _ => + apply exact_source_ret + | |- (segment_to sh csl_equ) (denote_flow (CUntilNone _) >>= _) _ _ _ _ => + apply exact_source_until + | |- (segment_to sh csl_equ) (denote_flow (CRead _) >>= _) _ _ _ _ => + eapply exact_source_read; [eassumption|] + | |- (segment_to sh csl_equ) (denote_flow (CWrite _ _) >>= _) _ _ _ _ => + eapply exact_source_write; [allocator_present|] + | |- (segment_to sh csl_equ) (denote_flow (CEmit _ _) >>= _) _ _ _ _ => + apply exact_source_emit + | |- (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 + | |- (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 + 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 ((segment_to sh csl_equ) src' sigma logs target sigma') + end) ]; + 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 + heap extensionality, freshness assumption, or unchecked CAS is used here. *) +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 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),(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; + [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 event_obs]. + all: lazymatch goal with + | |- exists residual, (ThreadSegment sh csl_equ) ?src ?sigma ?logs residual ?sigma' /\ + guard_equ residual ?target => + 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_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 allocator's pool-simulation certificate. + + 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. + split. + - 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 sigma as [[h allocs] [ctx c]]. + destruct (turn_source_exact_segment base who + (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),(ctx,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,allocs),(ctx,c)) s) actual event + Hactual j Hj) |]. + symmetry; exact (allocator_pool_state_equiv base s' actual Hnext j). +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. + + +(** 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, + with the allocation table unchanged. *) +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),(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),(ctx,acount t))). +Proof. + intros Hinv 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),(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 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),(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),(ctx,acount t))). +Proof. + intros Hinv 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),(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. + +(** 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) -> + 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_nd sh 3 ts (Some (slot_of_actor who)) sigma ~ + emit_list (event_obs event) + (interp_schedule_nd sh 3 (ts @ slot_of_actor who := residual) None sigma'). +Proof. + intros Hpool Hagree Hinv Hturn. + destruct (pool_simulation_turn_nd (allocator_simulation base capacity) + ts s who t event sigma Hinv Hagree Hpool Hturn) + 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. + - exact Hinterp. +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 (event_obs event) + (interp_schedule_rr sh 3 (ts @ slot_of_actor who := residual) None cursor sigma'). +Proof. + intros Hpool Hagree Hinv Hturn. + 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. + - 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. +Local Open Scope nat_scope. + +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),(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 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),(ctx,acount s)) (event_obs event) + residual ((aheap t,allocs),(ctx,acount t)))); exact Hseg. +Qed. + +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 (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)),(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 ctx c : + run_nd (allocator_program capacity) (managed_empty,(ctx,c)) ~ + (model_nd 2 actor_of_slot (turn 1) (initial_state capacity c) + : 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)),(ctx,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 with its recorded extent. *) +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)),(ctx,c)) se. diff --git a/examples/CSL/Allocator/Layout.v b/examples/CSL/Allocator/Layout.v new file mode 100644 index 0000000..b5d5c71 --- /dev/null +++ b/examples/CSL/Allocator/Layout.v @@ -0,0 +1,193 @@ +(** * 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 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 Events.HeapModel Utils.Pcm Utils.Lists. + +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. +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. + +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_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. + + + +(** ** 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. *) + +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)). + +(** ** 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_mono. + 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_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_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_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. diff --git a/examples/CSL/Allocator/Liveness.v b/examples/CSL/Allocator/Liveness.v new file mode 100644 index 0000000..372d31f --- /dev/null +++ b/examples/CSL/Allocator/Liveness.v @@ -0,0 +1,1288 @@ +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.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. + +Import ICtree ICTreeNotations ListNotations. +Local Open Scope ictree_scope. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +(** 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 (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 + | Remote0 => match remote0_state s with RPoll => false | _ => true end + | Remote1 => match remote1_state s with RPoll => false | _ => true end + end. +Definition owner_selected (who : Actor) : bool := + match who with Owner => true | _ => false end. + +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 (inr (stamp (tag,block) idx)). +Proof. + 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. + - split; [discriminate|intros (b & i & H); discriminate]. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat. +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. +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). + +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 [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; + 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) -> + event_is tag_retire event = false -> + (if remote_pending who s then 1 else 0) + contention_pending_rank t <= + contention_pending_rank s /\ + (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 (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. + - 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 [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. + 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 [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. + 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 [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. + 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 : + 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 (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 (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 (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 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 : + 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) + as [_ Hbound]. + pose proof (contention_failure_rank_bound (states e lo)); lia. +Qed. + +Theorem no_publication_pending_bound 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 <= 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. + + + +Theorem remote_free_lockfree capacity c e : + 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 (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. +Qed. + +From Stdlib Require Import List Lia Arith.PeanoNat Fin Vector Program.Equality. +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. +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. + +(** ** 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. + rewrite <- (slot_of_actor_of_slot i); destruct (actor_of_slot i); + cbn [source_pool0 slot_of_actor Vector.nth]; apply denote_branchfree. +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 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)),(ctx,c))) + (ts,sigma) -> + BranchFree (ts $ i) /\ + (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. + 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 (allocator_simulation 1 capacity) + (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) + as (s & Hinv & Hagree & Hpool). + rewrite <- (slot_of_actor_of_slot i). + split. + - 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 + (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 + (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 ctx c e : + allocator_valid capacity c e -> + realizes (fun j => turn_labels (emitted e j)) 0 + (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 + 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. *) +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,(ctx,c))) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : 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 ctx c) as Esource; symmetry in Esource. + destruct (finite_steps_sbisim _ _ _ Hsteps _ Esource) + as (residual & Hsource & Eresidual). + exists labels, residual; split; [rewrite Hlabels; reflexivity|]. + repeat split; try assumption. + transitivity model; [symmetry; exact Eresidual|exact Emodel]. +Qed. + +(** 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 : 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) + | Remote1 => raw_remote_pending 1 true (fst (states se k) $ slot_of_actor Remote1) + end. + +Definition remote_first_event base client pc : sE := + match pc with + | 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 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. + + +(** 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 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). +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 (allocator_simulation 1 capacity) + (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 + (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. + +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 (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)),(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 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). + exists k; split; [exact Hnk|]; exists block, idx. + destruct (Halign k) as (_ & _ & _ & Hlogs). + 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.Mod. +From examples Require Import CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout CSL.Allocator.Model + CSL.Allocator.Execution. +Import ListNotations. +Local Open Scope nat_scope. +Local Open Scope list_scope. + +(** 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 : + 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. + 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 : + allocator_view 1 capacity s L R D -> In b (R ++ D) -> ~ In b L. +Proof. + intros (_ & _ & m0 & m1 & _ & _ & _ & _ & _ & _ & _ & _ & Hp & _) Hrd Hl. + 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]. + - 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_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 (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' -> + 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 (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_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_selected owner_rank owner_after_offer]; + unfold owner_round_bound; lia. + - destruct client; cbn [owner_boundary owner_selected owner_rank owner_after_offer]; + unfold owner_round_bound; lia. + - 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:? + 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_lists_step_bounded capacity who s t event 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', 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 (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'. + 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 : + 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. + 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|]. + 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 (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 + 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', 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. + 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 : + allocator_valid capacity c e -> + (forall j, lo <= j < lo + len -> ~ round_completion e j) -> + 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). + 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. + +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 : + 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 (fun k => owner_selected (selected e k)) lo (S j - lo) <= 3 * capacity + 5. +Proof. + intros Hv Hcount. + 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 := +| 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' /\ + (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_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_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_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_selected owner_rank collection_phase]; lia. + - inversion Hcredit; subst. + + eexists; split; [apply reclaim_remote; eassumption|]. + 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_selected List.length]; lia. + - inversion Hcredit; subst; cbn [List.In] in *; try contradiction. + eexists; split; [apply reclaim_remote; eassumption|]. + 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_selected owner_rank collection_phase owner_after_offer]; + unfold owner_round_bound; lia. + - exists credit; split; [exact Hcredit|]. + destruct who; cbn [owner_selected]; [contradiction|lia|lia]. + - inversion Hcredit; subst. + + eexists; split; [apply reclaim_remote; now right|]. + 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_selected]; [contradiction|lia|lia]. +Qed. + +Lemma execution_retired_credit capacity c e k 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 /\ + 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 (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. + 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. + +(** 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', + 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 (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 [[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. + + 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 : + 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. + 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 : + 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 (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. + 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 csl_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 : + allocator_valid capacity c e -> + infinitely (fun k => selected e k = Owner) -> + forall k block idx, + emitted e k = Some (inr (stamp (tag_retire,block) idx)) -> + exists j idx', k < j /\ idx < 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)). + { 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'. +Qed. + +Theorem retired_not_reallocated_before_reclaim capacity c e k block idx j : + allocator_valid capacity c e -> + 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) + 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 (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 : + allocator_valid capacity c e -> k < j -> + 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 (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)) + (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 (turn 1) + (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 csl_index (turn_counter 1) e q j _ _ Hv ltac:(lia) Hreclaim Halloc). +Qed. + +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 (inr (stamp (tag_retire,block) idx)) (emitted se k) -> + exists j idx', k < j /\ idx < idx' /\ + 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)),(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 (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; + [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. + +From Stdlib Require Import List Lia Arith.PeanoNat. +From Coinduction Require Import coinduction rel tactics. +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. +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. + +(** ** 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]. *) +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 => + 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. +Let demo_boundary (c : nat) : AState := + {| aheap := demo_boundary_heap; acount := c; + owner_state := ORead; remote0_state := RRead 6; + remote1_state := RPoll |}. + +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. + 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. + +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. + 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. + +Local Lemma demo_cycle_fresh_member c kind : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> + 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]; + repeat split; intuition lia. + - exists (stamp (tag_retire,6) c); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; + repeat split; intuition lia. + - exists (stamp (tag_reclaim,8) (3+c)); cbn [demo_cycle_logs List.In indexed_value indexed_index fst]; + repeat split; intuition lia. +Qed. + +Local Lemma demo_cycle_logs_nonempty : forall n : nat, True -> demo_cycle_logs n <> []. +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 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 (CSLObs (nat * nat)) (unit * SSig)). +Proof. + 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 ctx c kind kb : + List.In kind [tag_alloc;tag_retire;tag_reclaim] -> + <( {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) /\ + 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 (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). + rewrite (model_rr_run_turns 2 actor_of_slot (turn 1) 57 0 _ _ _ Hrun). + apply agaf_emit_list; [constructor|]. + 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) (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. + +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 (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), + 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) (managed_empty,((List.nil : Ctx.Ctx),0))) labels residual /\ + residual ~ (model_nd 2 actor_of_slot (turn 1) last + : 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 (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. + +End ABASafety. diff --git a/examples/CSL/Allocator/Model.v b/examples/CSL/Allocator/Model.v new file mode 100644 index 0000000..68155f4 --- /dev/null +++ b/examples/CSL/Allocator/Model.v @@ -0,0 +1,745 @@ +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.Mod ICTree.Core ICTree.Equ ICTree.SBisim + ICTree.Events.Writer ICTree.Interp.Refine. +From examples Require Import CSL.Queue.Representation. +From examples Require Import 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 (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 (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 + 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 |}. + +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. + +(** 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 (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) /\ + 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 ++ + 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 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. + +Lemma initial_state_inv capacity c : + allocator_inv 1 capacity (initial_state capacity c). +Proof. + 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 0, 0. + split; [apply page_heap_remote|]. + split; [apply page_heap_local_blocks|]. + split; [apply page_heap_drain|]. + split. + + 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|]. + 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) /\ csl_index 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 Classes.RelationPairs Program.Equality. +From ExtLib Require Import Data.Option. +From Coinduction Require Import coinduction rel tactics. +From TICL Require Import Lang.CSL.Mod 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. + +(** Both faults and successful turns are preserved. In particular this + statement does not assume the ownership invariant or heap finiteness. *) +#[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]. + 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]; + cbn [turn]. + all: repeat first + [ progress (rewrite upd_unfold) + | 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: constructor. + all: split; unfold RelCompFun; cbn [fst snd]; [|reflexivity]. + all: unfold state_equiv; + cbn [aheap acount owner_state remote0_state remote1_state]. + all: split; + [ repeat apply upd_heq; exact Hh + | repeat split; 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. + +From Stdlib Require Import List Lia Arith.PeanoNat Sorting.Permutation. +From TICL Require Import Lang.CSL.Mod. +From examples Require Import CSL.Queue.Representation. +From examples Require Import CSL.Allocator.Layout. + +Import ListNotations. +Local Open Scope list_scope. +Local Open Scope nat_scope. + +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_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. + +(* 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 _ _) => + eapply Permutation_in; [exact 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 + 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 + | 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 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 | + 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] + | 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 head_not_in; + [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]. + +(** ** 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 (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 [] +| 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 (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 (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 (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 (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 + 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; 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_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. + - 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 [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. + 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 [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; + 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 [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; + 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_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. + 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. + +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 (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 (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 (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 + | 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/Program.v b/examples/CSL/Allocator/Program.v new file mode 100644 index 0000000..c641104 --- /dev/null +++ b/examples/CSL/Allocator/Program.v @@ -0,0 +1,126 @@ +From Stdlib Require Import Arith.PeanoNat. +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: + 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/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 new file mode 100644 index 0000000..855793b --- /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 (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 s. +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,((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. +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,((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. + 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) 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 ctx c eq_refl). + rr_finish. +Qed. + +(** ** Faults *) + +Theorem invalid_interior_stuck : + 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. + cbn beta iota zeta. + apply interp_rr_free_invalid; vm_compute; reflexivity. +Qed. + +Theorem invalid_double_stuck : + 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. + 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,((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. + 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,((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. + 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,((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. + 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 new file mode 100644 index 0000000..98b5052 --- /dev/null +++ b/examples/CSL/Overlap.v @@ -0,0 +1,117 @@ +(** * 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. + + 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 + List + Lia + Arith.PeanoNat. + +From examples Require Import CSL.Queue.Representation CSL.Queue.Trace + CSL.Queue.Frame CSL.Queue.Layout. + +Import ListNotations. +Local Open Scope list_scope. + +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 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. + +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]. + - 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 + 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. *) +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 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 [fst snd] in H. + rewrite (proj1 rot_changes_head_pointer) in H; discriminate. +Qed. + +(** ** C2: the null address *) + +(** (a) The compatibility check rejects it. *) +Theorem null_frame_rejected: fnull 0 <> None. +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 2 [4;6] [7;9] (hunion h1 fnull). +Proof. + split. + - intro x; destruct (h1 x) eqn:E; [| now left]. + right; unfold fnull, hsingle. + destruct (Nat.eq_dec 0 x) as [Ex | Hne]; [| reflexivity]. + exfalso; rewrite <- Ex in E. + 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, 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. + +End Overlap. diff --git a/examples/CSL/Queue.v b/examples/CSL/Queue.v new file mode 100644 index 0000000..06289d4 --- /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 CSL.Queue.Shared. diff --git a/examples/CSL/Queue/Alternating.v b/examples/CSL/Queue/Alternating.v new file mode 100644 index 0000000..fe2f747 --- /dev/null +++ b/examples/CSL/Queue/Alternating.v @@ -0,0 +1,164 @@ +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 ICTree.Interp.CSL.Mod. +From examples Require Import CSL.Queue.Representation CSL.Queue.Operations. + +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 := + queue_turn (semit q) hdr kt. + +Definition turn (q hdr: nat) : ictree sE unit := turnk q hdr (Ret tt). + +(** *** The turn correspondence. + + 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 ctx c (kt: ictree sE X), + qrep hdr (a :: ns) (pv :: vs) h -> + 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 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. +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) (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 ctx c, + qrep (hdrof u v n) (a :: ns) (pv :: vs) h -> + 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), + (ctx, S c)))). +Proof. + 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 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 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. +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 + + 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 + [indexed_after (fun x => x = (q,nl)) kb]. + + 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) : + turnk q hdr kt ≅ (turn q hdr;; kt). +Proof. + unfold turn, turnk. + rewrite queue_turn_bind. + apply queue_turn_equ; symmetry; apply bind_ret_l. +Qed. + +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. + 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 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 new file mode 100644 index 0000000..457855a --- /dev/null +++ b/examples/CSL/Queue/Composition.v @@ -0,0 +1,427 @@ +(** * Recurring per-queue progress for two active queues. + + 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 + 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 [Separation.foreign_pres], not a frame rule. + + - the temporal layer reuses the structural iteration rules + ([ICTree.Logic.State.ag_state_iter] for the outer [AG] and + [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 ([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. + + 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.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. + +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_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. + 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 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 -> + Disj fh (a :: nsf) gh nsg -> + qrep fh (nsf ++ [a]) (vsf ++ [pv]) + (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. + 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 (List.hd 0 nsg) (zof gh nsg) h) + /\ qrep gh (nsg ++ [b]) (vsg ++ [pw]) + (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. + 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_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). + 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 (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 - csl_counter 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: (indexed (nat * nat)) -> Prop) + (HP: forall j, Nat.le kb j -> P (stamp (fq,nlf) j)). + + 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), (ctx, c))}, w |= AF visW {csl_indexed P} )>. + Proof. + 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), (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 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), (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 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) + as (Hqf' & Hqg' & Hdj'). + assert (Hstep: forall 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' + /\ <[ {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), (ctx, S c)), + (Obs (Log (inr (stamp (fq,pv) c) : CSLObs (nat * nat))) 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_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. + 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_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_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. + ++ 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 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) + as (Hqf' & Hqg' & Hdj'). + 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 (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; + [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 allocs ctx c w, + not_done w -> + Iq nlf nlg h -> + <( {interp_state sh (sched u v n) ((h, allocs), (ctx, c))}, w |= AG (AF visW {csl_indexed P}) )>. + Proof. + intros n h allocs ctx c w Hd HI. + unfold sched. + 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 ctx c w Hd HI. + intros n s w Hd 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). + 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 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) + as (Hqf' & Hqg' & Hdj'). + 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]. + 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 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) + as (Hqf' & Hqg' & Hdj'). + 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]. + 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. *) + + +(** *** Queue 1 (the one the scheduler serves on even turns) *) + +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 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), (ctx, c))}, Pure |= AG (AF visW {csl_indexed P}) )>. +Proof. + 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 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 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), (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 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), (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))); + [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: (indexed (nat * nat)) -> Prop), + (forall j, Nat.le kb j -> P (stamp (2,nl2) j)) -> + 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), (ctx, c))}, Pure |= AG (AF visW {csl_indexed P}) )>. +Proof. + 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 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 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), (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 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), (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))); + [intros j Hj; split; [reflexivity | exact Hj] + | eassumption .. ]. +Qed. diff --git a/examples/CSL/Queue/Frame.v b/examples/CSL/Queue/Frame.v new file mode 100644 index 0000000..fba363f --- /dev/null +++ b/examples/CSL/Queue/Frame.v @@ -0,0 +1,364 @@ +(** * Separation and framing of heap-backed queue recurrence. + + 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 + 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; + + - 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 + 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". + + All frame heaps are parameters; concrete fixtures remain in examples. *) + +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.Queue.Representation CSL.Queue.Sequential CSL.Queue.Recurrence + CSL.Queue.Trace CSL.Queue.Layout. + +From Coinduction Require Import coinduction. + +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. + +(** [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 + [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 [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. *) +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. + +(** ** 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. + + 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 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), (ctx, c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = nlv)}) )>. +Proof. + 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 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), (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 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 ctx c, + qrepX hdr ns vs h -> + hdisj h f -> + f 0 = None -> + ns <> [] -> + ~ In nlv vs -> + <( {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 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 ctx c w phi, + qrepX hdr [] vs h -> + hdisj h f -> + f 0 = None -> + ~ <( {run hdr ((hunion h f, allocs), (ctx, c))}, w |= AG phi )>. +Proof. + intros hdr vs h f allocs ctx 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. + + +(** 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/Queue/Layout.v b/examples/CSL/Queue/Layout.v new file mode 100644 index 0000000..2460f2f --- /dev/null +++ b/examples/CSL/Queue/Layout.v @@ -0,0 +1,297 @@ +From Stdlib Require Import List Lia Arith.PeanoNat. +From TICL Require Import Events.HeapModel. +From examples Require Import 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 (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 (List.hd 0 ns) + 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; [apply chain_nil |]. + destruct (qwf_node_cells _ _ _ Hwf) as (Hanc & Hsanc). + apply (proj2 (chain_cons _ _ _ _ _ _)). + cbn [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 (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). + { 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 + + 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. + +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) (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 queue_nodes_length hdr count : length (queue_nodes hdr count) = count. +Proof. apply node_addrs_length. 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 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; [apply chain_nil | 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/Queue/Operations.v b/examples/CSL/Queue/Operations.v new file mode 100644 index 0000000..3447ebb --- /dev/null +++ b/examples/CSL/Queue/Operations.v @@ -0,0 +1,90 @@ +From Stdlib Require Import List Arith.PeanoNat. +From examples Require Import CSL.Queue.Representation. +From TICL Require Import + 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 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),(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),(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),(ctx,S c))). +Proof. + 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). + 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 queue_turn. + 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 (ctx,S c) (List.hd 0 ns) _ Hsa)|]. + etransitivity; + [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 (ctx,S c) a _ + (upd_mono _ _ _ _ Hzdom))|]. + 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 (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 new file mode 100644 index 0000000..402e2ba --- /dev/null +++ b/examples/CSL/Queue/Program.v @@ -0,0 +1,745 @@ +From Stdlib Require Import Arith.PeanoNat Fin Vector List Lia. +From TICL Require Import + 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 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. +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) (List.hd 0 ns)) (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)). + +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);; + 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]. + 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 (s : SSig) : + interp_schedule_rr sh (S n) + (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. + 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 (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 + | 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 s ~ rhs) + end. + rewrite interp_rr_bind. + etransitivity; [apply interp_rr_rotate_once|]. + 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)) + (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 s' Hpark) as Hdone. + eapply equ_clos_sbisim_goal; [exact Hdone | reflexivity | reflexivity]. +Qed. + +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 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) s'). +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 s ~ rhs) + end. + all: etransitivity; [apply interp_rr_worker|]. + 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; + [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 s ~ rhs) + end. + all: etransitivity; [apply interp_rr_worker|]. + all: apply sbisim_clo_bind_eq; [reflexivity | intros [ignored s']]. + 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 ?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,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_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 (s : SSig), + interp_schedule_rr sh 2 (queue_workers u v g2 g1) + (Some (queue_slot n)) n s ~ srun u v n s. +Proof. + 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_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_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 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 s']; 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 u v (s : SSig) : + run_rr (parallel_queues u v) s ~ srun u v 0 s. +Proof. + 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 s ~ srun u v 0 s). + 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, ?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; + 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, allocs), (ctx, 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 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),(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. + 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,allocs),(ctx,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 (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 s ~ + (stuck : ictreeW (CSLObs (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 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. + 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 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),(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (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. + - 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 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),(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (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. + - 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_first n (ts : pool sE (S n)) (i : Fin.t (S n)) + 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),(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))),(ctx,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). + 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 ctx c : + interp_schedule_rr sh (S n) + (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))),(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 ctx 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,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))),(ctx,c)). +Proof. + intro Finite. + 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. + - split; [now apply new_queue_heap_owned |]. + apply interp_rr_new_queue_first; assumption. +Qed. + +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,(ctx,c)) ~ + run_rr (parallel_queues u v) ((h,allocs),(ctx,c)). +Proof. + intros values1 values2 ctx 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 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))). + 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 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. + - 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. + 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),(ctx,c)) ~ + run_rr (parallel_queues u v) + ((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. + 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 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 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_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 new file mode 100644 index 0000000..bdea153 --- /dev/null +++ b/examples/CSL/Queue/Recurrence.v @@ -0,0 +1,334 @@ +(** * Recurrence: the heap-backed [AG AF] theorem and its freshness companion. + + The reference theorem is [examples/Queue.v], [rotate_agaf_pop]: + + 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]. + 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. + + 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] 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 + 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.Queue.Representation CSL.Queue.Sequential + CSL.Queue.Operations. +From TICL Require Import Utils.Relations. + +From Coinduction Require Import coinduction. + +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 observation projection. + + [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. + (** [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: (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: 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 ctx c w, + qrep hdr (a :: ns) (v :: vs) h -> + not_done 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), (ctx, S c)))} + {Obs (Log (inr (stamp v c) : CSLObs nat)) tt} ]>. + Proof. + 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. + 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 [aul_state_iter_ghost] plus a body case analysis. *) + 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 - csl_counter s, d). + + 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), (ctx, c))}, w |= AF visW {csl_indexed P} )>. + Proof. + 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), (ctx, c)) w Hd). + - exists ns, vs, d; split; [exact Hq | split; [exact Hf | reflexivity]]. + - 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), (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 *) + 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' + /\ <[ {interp_state (sh (A:=nat)) + ((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), (ctx, S c)), + (Obs (Log (inr (stamp v c) : CSLObs nat)) 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_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. + 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 *) + right. + 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_index_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 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), (ctx, c))}, w |= AG (AF visW {csl_indexed P}) )>. + Proof. + intros h allocs ctx c ns vs d w Hd Hq Hf. + unfold rotate. + 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), (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 ctx1 c1 Hq1). + apply anr_log; [| apply ticll_top; assumption]. + cleft; apply axr_ret; [constructor |]. + exists tt; split; [reflexivity | split; [constructor |]]. + 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''. + 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_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 + 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 ([indexed_excludes_retained]). *) + +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), (ctx, c))}, Pure |= AG (AF visW {csl_indexed (fun o => indexed_value o = nl)}) )>. +Proof. + 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 ctx c ns vs d k, + qrep hdr ns vs h -> + find_index Nat.eqb nl vs = Some d -> + <( {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 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 ]. +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. *) + +(** *** 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_index Nat.eqb nl vs = Some d] (which forces + a non-empty queue) buys. *) +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 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), (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_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. + +(** *** 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 (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 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), (ctx, c))}, w |= AG (now {obs_sat Q}) )>. +Proof. + 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), (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) + 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, 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 ctx1 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 allocs ctx c ns vs nl, + qrep hdr ns vs h -> + ns <> [] -> + ~ In nl vs -> + <( {run hdr ((h, allocs), (ctx, c))}, Pure |= AG (now {obs_sat (fun x => x <> nl)}) )>. +Proof. + intros hdr h allocs ctx c ns vs nl Hq Hne Hnin. + unfold run. + 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 ]. +Qed. diff --git a/examples/CSL/Queue/Representation.v b/examples/CSL/Queue/Representation.v new file mode 100644 index 0000000..78b9447 --- /dev/null +++ b/examples/CSL/Queue/Representation.v @@ -0,0 +1,750 @@ +(** * Heap-backed queue representation and pure resource 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 + and the footprint permutation, using the generic [Utils.Lists] theory. + + 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. 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 ([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. *) + +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 ICTree.Interp.CSL.Mod Utils.Lists. + +(** ** Footprints and well-formedness + + 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. + + +(** 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 *) + +(** [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. + + 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. + 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. + 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 := + 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 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 (List.hd f ns2) -> + chain h ns2 vs2 f -> + chain h (ns1 ++ ns2) (vs1 ++ vs2) f. +Proof. + 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 (List.hd f ns2) /\ chain h ns2 vs2 f. +Proof. + 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 *) + +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 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 (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). + +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 -> (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. + - exfalso; apply H0; cbn; tauto. + - discriminate. +Qed. + +(** ** Rotation on the abstract lists *) + + +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; unfold cells; rewrite flat_map_app. + cbn; rewrite in_app_iff; cbn; 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. + + +(** ** 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 (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)]). + 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. + 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 (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 (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) (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 (List.hd 0 ns) 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 (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]]]. + + 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) (List.hd 0 ns)) (hunion hq hn) + /\ qrep hdr ns vs hq + /\ 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 cells_mono_app: forall x l1 l2, In x (cells l1) -> In x (cells (l1 ++ l2)). +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. + +(** ** 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 (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). + 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. + 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]; [| 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). + 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 [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). + 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, 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, !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 & _). + assert (Hszdom: h (S zz) <> None) by (rewrite Hszv; discriminate). + 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']. + 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 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. + + 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 [app List.hd]; apply (proj2 (chain_cons _ _ _ _ _ _)); split; [| split]. + ++ rewrite rot_heap_other by (first [congruence | lia]); exact Hzv. + ++ 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. + -- cbn [List.hd]; apply rot_heap_sa; congruence. + -- apply chain_nil. + + split. + * 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). + apply qcells_rot; exact Hx. +Qed. + +(** ** Two facts the language layer needs about the rotation's footprint. *) + + +(** 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 (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 [List.hd]. + destruct (Nat.eqb_spec b 0) as [-> | Hb]; [exfalso; apply H0; cbn; tauto |]. + reflexivity. +Qed. + diff --git a/examples/CSL/Queue/Separation.v b/examples/CSL/Queue/Separation.v new file mode 100644 index 0000000..6b89e9a --- /dev/null +++ b/examples/CSL/Queue/Separation.v @@ -0,0 +1,180 @@ +(** * 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 + 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 + 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]). + + 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. *) + +From Stdlib Require Import + List + Lia + Arith.PeanoNat. + +From examples Require Import CSL.Queue.Representation CSL.Queue.Trace + CSL.Queue.Layout CSL.Queue.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 (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 (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). +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. *) + +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. + +(** ** 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/examples/CSL/Queue/Sequential.v b/examples/CSL/Queue/Sequential.v new file mode 100644 index 0000000..43d904b --- /dev/null +++ b/examples/CSL/Queue/Sequential.v @@ -0,0 +1,140 @@ +(** * 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 (fun o => indexed_value o = payload) together with an occurrence index, so the world + never mentions an address. + + 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 (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 [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 => indexed_value 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 + ICTree.Interp.CSL.Mod. + +From examples Require Import CSL.Queue.Representation CSL.Queue.Operations. + +From Coinduction Require Import coinduction. + +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. + + 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 *) + +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 qE qE _ _ ReSum_refl ReSumRet_refl (inr (inr (Log v))). + +(** ** 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. + +(** [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)], 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) (s: SSig) : ictreeW (CSLObs nat) (unit * SSig) := + interp_state (sh (A:=nat)) (rotate hdr) s. + +(** ** 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 [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 ctx c, + qrep hdr (a :: ns) (v :: vs) h -> + 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 ctx c Hq; unfold rot_body. + etransitivity. + - 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. +Qed. 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 new file mode 100644 index 0000000..3d059b2 --- /dev/null +++ b/examples/CSL/Queue/Ticl.v @@ -0,0 +1,147 @@ +From Stdlib Require Import List. +From TICL Require Import + Lang.CSL.Mod ICTree.Core ICTree.Equ ICTree.Events.Writer ICTree.SBisim + ICTree.Logic.Trans ICTree.Logic.State ICTree.Logic.AG Logic.Core. +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. +Local Open Scope ticl_scope. +Local Typeclasses Transparent equ sbisim. + +Theorem rotate_agaf_pop_rr : + 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),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. +Proof. + 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 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),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (2,nl2))}) )>. +Proof. + 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 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),(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 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 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),(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 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 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 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),(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. +Proof. + 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 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,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (1,nl1))}) )>. +Proof. + 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. + 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 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,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (fun o => indexed_value o = (2,nl2))}) )>. +Proof. + 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. + 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 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,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (1,nl1)) k)}) )>. +Proof. + 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. + 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 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,(ctx,c))}, Pure + |= AG (AF visW {csl_indexed (indexed_after (fun x => x = (2,nl2)) k)}) )>. +Proof. + 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. + 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 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 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 new file mode 100644 index 0000000..6ed4a0b --- /dev/null +++ b/examples/CSL/Queue/Trace.v @@ -0,0 +1,127 @@ +(** * 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.Queue.Representation CSL.Queue.Sequential. + +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 [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 ctx c, + qrep hdr (a :: ns) (v :: vs) h -> + 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 ctx c Hq. + unfold run, rotate. + rewrite interp_state_unfold_iter. + cbv beta. + 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. + 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 (List.hd 0 ns') (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. + + +(** 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 (CSLObs nat) (unit * SSig)) : ictreeW (CSLObs nat) (unit * SSig) := + match n with + | 0 => k + | 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. + + +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 allocs ctx c, + qrep hdr ns vs h -> ns <> [] -> + 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 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 ctx 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/CSL/README.md b/examples/CSL/README.md new file mode 100644 index 0000000..71924fd --- /dev/null +++ b/examples/CSL/README.md @@ -0,0 +1,396 @@ +# Cooperative heap queues + +`TICL.Lang.CSL.Mod` is a typed cooperative fork/yield language over a disjoint heap +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 +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 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. + +| 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` | 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 | +| `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 | +| `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 +`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. + +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 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. + +## 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.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. + +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 (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 `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. + +`examples.CSL.Queue.Ticl` exposes recurrence directly for +`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. +- `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 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: + +- `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,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 +`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. 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 * (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 + (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 +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 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 +`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 +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, +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; +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. + +## Structural temporal interface + +`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` 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 (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 +fairness or unconditional loop termination. + +`interp_nd_source_` and `interp_rr_` expose the checked success and fault normal +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. + +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 +`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 | Current owner | +| --- | --- | +| `P/Pcm.v`, complete | `theories/Utils/Pcm.v` (interface), `theories/Events/HeapModel.v` (heap model) | +| `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` | `examples/CSL/Queue/Composition.v` | +| `Q/Overlap.v` | `examples/CSL/Overlap.v` | + +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. `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`. +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 + +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), `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.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 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/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 + `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 + `Let`s, discharged into the public statements. + +`dune build` compiles all of them. + +## Assumptions + +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/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..3eb49e7 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,10 +9,11 @@ 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. + Lang.MeQ + Utils.Lists. From ExtLib Require Export Structures.MonadState @@ -45,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. @@ -149,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)... @@ -190,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... @@ -220,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/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..93535d2 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,10 +12,10 @@ 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 + Utils.Maps Lang.StImp. From ExtLib Require Import 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/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/Events/HeapModel.v b/theories/Events/HeapModel.v new file mode 100644 index 0000000..a982a33 --- /dev/null +++ b/theories/Events/HeapModel.v @@ -0,0 +1,877 @@ +(** * 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, 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. *) + +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. + +(** ** 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 + 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/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..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. @@ -409,6 +416,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/ICTree/Eq/Core.v b/theories/ICTree/Eq/Core.v index d372595..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]. *) @@ -351,55 +295,31 @@ 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} {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/Equ.v b/theories/ICTree/Equ.v index 6d7ea6d..1b013e3 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,76 @@ Ltac observe_equ_all := 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 + 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/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/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/Events/Yield.v b/theories/ICTree/Events/Yield.v new file mode 100644 index 0000000..1f7063a --- /dev/null +++ b/theories/ICTree/Events/Yield.v @@ -0,0 +1,35 @@ +From TICL Require Import + ICTree.Core + Utils.Vectors. + +From TICL Require Export + Events.Core + Events.YieldE. + +Generalizable All Variables. + +(** * 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. + +(** 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 vectors of threads. *) +Definition pool (E : Type) `{Encode E} (n : nat) := vec n (thread E). diff --git a/theories/ICTree/Interp/CSL/Mod.v b/theories/ICTree/Interp/CSL/Mod.v new file mode 100644 index 0000000..1ad78ed --- /dev/null +++ b/theories/ICTree/Interp/CSL/Mod.v @@ -0,0 +1,762 @@ +(** * The canonical CSL effect interpreter. + + This module owns the CSL effect sum, its interpretation state and the one + 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. + + 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.Events.State + ICTree.Interp.Heap + ICTree.Logic.Heap + ICTree.Trace + ICTree.Interp.Refine + ICTree.Interp.Yield.Nondeterministic + ICTree.Interp.Yield.Segments + Utils.Maps. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Trans + 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 + (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), 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 + 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 + (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 *) + +#[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 (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 (CSLObs (nat * nat)) X) => t ~ u). +Notation csl_equ := + (fun X (t u : ictreeW (CSLObs (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) 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,(ctx,c)) ~ + interp_schedule_rr sh (S n) + (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,(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) + 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' (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) 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,(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,(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) + 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 (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) 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,(ctx,c)) ~ + interp_schedule_nd sh (S n) + (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,(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) + 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' (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) ctx c : + managed_free memory base = None -> + interp_schedule_nd sh (S n) + (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,(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) + 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 (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) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + 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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + 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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + 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) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + 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,(ctx,c)))}, {w} |= ψ )> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_nd sh (S n) + 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,(ctx,c)))}, {w} |= ψ ]> \/ + (<( {Br n (fun j : Fin.t (S n) => + interp_schedule_nd sh (S n) + ts (Some j) (memory,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + 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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + 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) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (memory,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + 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) ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) (ψ : ticlrW (CSLObs (nat * nat)) (unit * SSig)) : + (<[ {interp_schedule_rr sh (S n) + ts (None) m (memory,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + 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) ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + ts (None) m (memory,(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + ts (Some (rr_pick n m)) (S m) (memory,(ctx,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) 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,(ctx,c))}, {w} |= φ AN ψ )> <-> + <( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + <[ {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ )> <-> + <( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + <[ {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= AG φ )> <-> + <( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ )> <-> + <( {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ )> <-> + <( {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + <[ {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= AG φ )> <-> + <( {interp_schedule_rr sh (S n) + (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' ctx c Free); reflexivity. +Qed. diff --git a/theories/ICTree/Interp/Core.v b/theories/ICTree/Interp/Core.v index cc64223..68d83f6 100644 --- a/theories/ICTree/Interp/Core.v +++ b/theories/ICTree/Interp/Core.v @@ -58,29 +58,75 @@ Proof. rewrite ?bind_ret_l. reflexivity. - reflexivity. + +From Coinduction Require Import coinduction. - setoid_rewrite bind_ret_l. 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/Heap.v b/theories/ICTree/Interp/Heap.v new file mode 100644 index 0000000..8753d11 --- /dev/null +++ b/theories/ICTree/Interp/Heap.v @@ -0,0 +1,441 @@ +(** * 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 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 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 + 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. + +(** 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 (ManagedHeap * Sigma) (ictree F) := + fun e => + mkStateT (fun s => + 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 (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 + | HCAS a expected desired => + match fst (fst s) a with + | None => stuck + | Some current => + if Nat.eqb current expected + then Ret (true,((upd (fst (fst s)) a desired,snd (fst s)),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 allocs (aux : Sigma) v, + h a = Some v -> + 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 allocs (aux : Sigma), + h a = None -> + 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 allocs (aux : Sigma) v w, + h a = Some w -> + 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 allocs (aux : Sigma) v, + h a = None -> + 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 allocs (aux : Sigma) : + h a = Some expected -> + 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 allocs (aux : Sigma) : + h a = Some current -> current <> expected -> + 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 allocs (aux : Sigma) : + h a = None -> + 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. + + (** 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 *) +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 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. + + (** 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,allocs),aux) ~ + Ret (base, (managed_alloc (h,allocs) base size, aux)). + Proof. + intros Pos B Free First. + 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 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,allocs),aux) ~ + Ret (base, (managed_alloc (h,allocs) base size, 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 (ManagedHeap * Sigma) (ictree F)). + + 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,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k v) ((h,allocs),aux). + Proof. + 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 allocs aux v H), bind_ret_l. + apply sb_guard. + Qed. + + 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,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k tt) ((upd h a v,allocs),aux). + Proof. + 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 allocs aux v w H), bind_ret_l. + apply sb_guard. + Qed. + + 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,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k tt) ((upd h a v,allocs),aux). + Proof. + 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 allocs (aux : Sigma) : + h a = None -> + 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 allocs aux H). + apply bind_stuck_equ. + Qed. + + 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,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 allocs aux v H). + apply bind_stuck_equ. + Qed. + + 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,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 allocs aux H), + bind_ret_l. + apply sb_guard. + Qed. + + 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,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 allocs aux H N), + bind_ret_l. + apply sb_guard. + Qed. + + 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,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 allocs aux H). + rewrite bind_stuck_equ; reflexivity. + Qed. + + 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 allocs aux). + apply bind_stuck_equ. + Qed. + + 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,allocs),aux) ~ + interp_state (h_sum heap_handler other) (k base) + (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 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/Interp/Refine.v b/theories/ICTree/Interp/Refine.v new file mode 100644 index 0000000..9b2d358 --- /dev/null +++ b/theories/ICTree/Interp/Refine.v @@ -0,0 +1,256 @@ +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)). + +(** 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 + | 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_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. + + (** [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. + 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 ->]. + 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. + +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 ->]. + transitivity (rr_pick 1 1); [apply rr_pick_mod_congr|reflexivity]. + change ((2 * k + 1) mod 2 = 1). + 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.v b/theories/ICTree/Interp/State/Mod.v similarity index 69% rename from theories/ICTree/Interp/State.v rename to theories/ICTree/Interp/State/Mod.v index 995a134..fe65ee1 100644 --- a/theories/ICTree/Interp/State.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. @@ -123,6 +122,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) : @@ -135,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. @@ -220,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} @@ -281,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) : @@ -311,18 +243,26 @@ 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. +(** * Interpreting one indexed emission. -(** [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. + [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..4303466 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Execution.v @@ -0,0 +1,731 @@ +(** * 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. + + 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)} + (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. + + (** 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. *) + 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 (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') + (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/Mod.v b/theories/ICTree/Interp/Yield/Mod.v new file mode 100644 index 0000000..3ff2bd4 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Mod.v @@ -0,0 +1,502 @@ +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. + +(** * 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. + +(** * 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_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. + +(** ** 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} : + 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. 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. 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. exact (interp_state_thread_yield h_stateW k σ). 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_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_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/Nondeterministic.v b/theories/ICTree/Interp/Yield/Nondeterministic.v new file mode 100644 index 0000000..21b9ec4 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Nondeterministic.v @@ -0,0 +1,240 @@ +(** * 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. + + (** 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)) + (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. + + (** 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. + +(** 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/Observed.v b/theories/ICTree/Interp/Yield/Observed.v new file mode 100644 index 0000000..9ba1cd2 --- /dev/null +++ b/theories/ICTree/Interp/Yield/Observed.v @@ -0,0 +1,766 @@ +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 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 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 + n (v : pool E n) focus : + forget_scheduler_offers (schedule_with_offers n v focus) ~ + schedule n v focus. + Proof. + apply galigned_sbisim. + exact (erased_offers_galigned n v focus 0 0). + 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 new file mode 100644 index 0000000..69f7741 --- /dev/null +++ b/theories/ICTree/Interp/Yield/RoundRobin.v @@ -0,0 +1,247 @@ +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 + 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. + + (** 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)) + (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 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 σ. + +(** ** 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 new file mode 100644 index 0000000..262460d --- /dev/null +++ b/theories/ICTree/Interp/Yield/SBisim.v @@ -0,0 +1,1453 @@ +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 + 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_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. + 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)) : + 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. + 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]. *) + 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. + 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)) : + 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. + exact (vector_cons_pointwise (fun a b : thread E => a ≅ b) t1 t2 v1 v2). + 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_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. + + (** ** [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. + +(** * 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_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. + +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 new file mode 100644 index 0000000..602b9bb --- /dev/null +++ b/theories/ICTree/Interp/Yield/Segments.v @@ -0,0 +1,814 @@ +(** * 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_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. + +(** 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. + +(** ** 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 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)) + 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 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)) + 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 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 + 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')). + { + 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)) + (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. + + +(** ** 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/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/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/CanStep.v b/theories/ICTree/Logic/CanStep.v index a0ed70c..140413a 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 @@ -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/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/Heap.v b/theories/ICTree/Logic/Heap.v new file mode 100644 index 0000000..3b5973a --- /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 (ManagedHeap * Sigma) (ictree F)). + + (** An out-of-footprint read cannot step, regardless of its continuation. *) + 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,allocs),aux)) w. + Proof. + 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 allocs 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/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/SchedulerFairness.v b/theories/ICTree/Logic/SchedulerFairness.v new file mode 100644 index 0000000..a89b109 --- /dev/null +++ b/theories/ICTree/Logic/SchedulerFairness.v @@ -0,0 +1,627 @@ +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.Interp.Yield.Observed + ICTree.SBisim. + +Import ICtree ICTreeNotations TiclNotations VectorNotations. +Local Open Scope ictree_scope. +Local Open Scope fin_vector_scope. +Local Open Scope ticl_scope. + +(** 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). + + +Section ObservedScheduler. + Context {E : Type} `{Encode E}. + + 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 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. + + 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. + + 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 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 observe_eq_equ. + 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 observe_eq_equ. + 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 observe_eq_equ. + 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 observe_eq_equ. + 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 observe_eq_equ. + 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 observe_eq_equ. + 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..c9cc5e0 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. @@ -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 -> @@ -134,8 +136,7 @@ Section StateLemmas. 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. *) @@ -233,8 +234,7 @@ Section StateLemmas. 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] *) @@ -257,8 +257,7 @@ Section StateLemmas. 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] *) @@ -281,8 +280,7 @@ Section StateLemmas. 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] *) @@ -305,8 +303,7 @@ Section StateLemmas. 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]. @@ -1000,6 +997,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..a56935d --- /dev/null +++ b/theories/ICTree/Logic/Trace.v @@ -0,0 +1,154 @@ +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.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. +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. + +(** * 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 new file mode 100644 index 0000000..5511807 --- /dev/null +++ b/theories/ICTree/Logic/Yield.v @@ -0,0 +1,505 @@ +From Stdlib Require Import + List + Arith.PeanoNat + Classes.Morphisms + Classes.RelationPairs + Fin + Vector + Program.Equality + Wellfounded.Inverse_Image. + +From Coinduction Require Import coinduction. + +From ExtLib Require Import Data.Option. + +From TICL Require Import + ICTree.Core + ICTree.Equ + ICTree.SBisim + ICTree.Events.Yield + 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.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 + ICTree.Logic.CanStep + ICTree.Logic.State + ICTree.Logic.Trace + Logic.Core + Utils.Execution + 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. *) + +(** 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. *) + +(** ** 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. *) +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. exact (axr_ithread_ret h_stateW). 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. exact (anr_ithread_bind_r_eq h_stateW). 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. exact (aur_ithread_bind_r_eq h_stateW). 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. 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. *) +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. 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. *) +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. exact (axax_schedule_nd_yield h_stateW). 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 (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 + : instr_schedule 1 _ (Some Fin.F1) σ ~ _). + 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 (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 + : 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. + + +(** ** 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/ICTree/SBisim.v b/theories/ICTree/SBisim.v index c8d2821..54f2acc 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,33 @@ 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. + +(** 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/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/Trace.v b/theories/ICTree/Trace.v new file mode 100644 index 0000000..00d0f95 --- /dev/null +++ b/theories/ICTree/Trace.v @@ -0,0 +1,449 @@ +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_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. + +(** * 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 := + 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. + +(** * 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. 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/Lang/CSL/Mod.v b/theories/Lang/CSL/Mod.v new file mode 100644 index 0000000..2e7adbf --- /dev/null +++ b/theories/Lang/CSL/Mod.v @@ -0,0 +1,4087 @@ +(** * The canonical CSL source language. + + 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. + +(** 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 + 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 + 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 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. +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 + | 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 + | 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) + | 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) + | 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|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. + + 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. + - 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). +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 (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. + +(** 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. + +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 σ : + 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 (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) (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 s. +Proof. + 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 s 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 (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 ctx c : + h a <> None -> + interp_schedule_rr sh (S n) + (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),(ctx,c)). +Proof. + intro Present. + 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. + 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 ctx c : + h a <> None -> + interp_schedule_nd sh (S n) + (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),(ctx,c)). +Proof. + intro Present. + 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. + 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 ctx c : + h a = Some value -> + interp_schedule_rr sh (S n) + (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_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. + 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 ctx c : + h a = Some value -> + interp_schedule_nd sh (S n) + (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_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. + 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 ctx c : + interp_schedule_rr sh (S n) + (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,(ctx,S c))). +Proof. + 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,(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; + [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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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_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 + | |- (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_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 + | |- (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 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),(ctx,c)) ~ + interp_schedule_rr sh (S n) + (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_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. + 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 ctx c : + h a = None -> + interp_schedule_rr sh (S n) + (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_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) ~ _ => + 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 ctx c : + h a = None -> + interp_schedule_rr sh (S n) + (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_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) ~ _ => + 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 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),(ctx,c)) ~ + (stuck : ictreeW (CSLObs (nat * nat)) (unit * SSig)). +Proof. + intro Missing. + 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 + | |- (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 ctx c : + interp_schedule_nd sh (S n) + (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,(ctx,S c))). +Proof. + 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,(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; + [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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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_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 + | |- (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_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 + | |- (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 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),(ctx,c)) ~ + interp_schedule_nd sh (S n) + (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_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. + 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 ctx c : + h a = None -> + interp_schedule_nd sh (S n) + (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_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) ~ _ => + 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 ctx c : + h a = None -> + interp_schedule_nd sh (S n) + (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_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) ~ _ => + 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 ctx c : + h a = None -> + interp_schedule_nd sh (S n) + (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_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 + | |- (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) 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,(ctx,c)) ~ + interp_schedule_rr sh (S n) (ts @ i := K (Some tt)) + (Some i) cursor (memory',(ctx,c)). +Proof. + intro Free. + 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' 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) ctx c : + managed_free memory base = None -> + interp_schedule_rr sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (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,(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 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) ctx c : + managed_free memory base = Some memory' -> + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (Some i) (memory,(ctx,c)) ~ + interp_schedule_nd sh (S n) (ts @ i := K (Some tt)) + (Some i) (memory',(ctx,c)). +Proof. + intro Free. + 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' 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) ctx c : + managed_free memory base = None -> + interp_schedule_nd sh (S n) (ts @ i := (denote_flow (CFree base) >>= K)) + (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,(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 ctx 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 ctx c logs target sigma' : + h a = Some v -> + 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) + (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),(ctx,c)) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + 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 ctx c logs target sigma' : + h a <> None -> + 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]. + 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),(ctx,c)) ([] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_wr_some a h allocs (ctx,c) v w Hw); reflexivity. + - reflexivity. +Qed. + +(** 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) 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 (inr (Log (tag,block)))))) (fun _ => K (Some tt))). + - apply source_raw_emit_head. + - change (ThreadSegment sh csl_equ + (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 (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 ctx c logs target sigma' : + h a = Some expected -> + 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),(ctx,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),(ctx,c)) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + 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 ctx c logs target sigma' : + h a = Some current -> current <> expected -> + 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),(ctx,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),(ctx,c)) ([] ++ logs) residual sigma'). + eapply segment_user; [|exact Hseg]. + cbn [emit_list]; + 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) ctx c logs target sigma' : + managed_free memory base = Some memory' -> + 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]. + 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,(ctx,c)) ([] ++ logs) residual sigma'). + eapply segment_user with (result := tt); [|exact Hseg]. + cbn [emit_list]; rewrite (heap_handler_free base memory memory' (ctx,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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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) 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,(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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' 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) 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,(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (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' 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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_nd sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 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 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),(ctx,c))}, {w} |= AG φ )> <-> + (<( {interp_schedule_rr sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_nd sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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 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 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),(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),(ctx,c)) + else + interp_schedule_rr sh (S n) + (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 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AN ψ ]>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (ts @ i := K (Some x)) (Some i) (memory,(ctx,c))}, {w} |= φ AU ψ ]>)). +Proof. + 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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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,(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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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,(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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AN ψ ]>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AU ψ ]>)). +Proof. + 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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AN ψ ]>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AU ψ ]>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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,(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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_nd sh (S n) + (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,(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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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,(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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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,(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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AN ψ ]>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AU ψ ]>)). +Proof. + 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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AN ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AN ψ ]>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= φ AU ψ )>)). +Proof. + 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 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,(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,(ctx,c))}, {w} |= φ AU ψ ]>)). +Proof. + 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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,c))}, {w} |= AG φ )>)). +Proof. + 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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (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 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,(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,(ctx,S c))}, {w} |= φ )> /\ + <[ {interp_schedule_nd sh (S n) + (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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (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 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,(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,(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,(ctx,S c))}, {w} |= φ )> /\ + <[ {interp_schedule_nd sh (S n) + (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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_nd sh (S n) + (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 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,(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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (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 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,(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,(ctx,S c))}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (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 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,(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,(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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (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 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,(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,(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,(ctx,S c))}, {w} |= φ )> /\ + <[ {interp_schedule_rr sh (S n) + (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 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,(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,(ctx,S c))}, {w} |= φ )> /\ + <( {interp_schedule_rr sh (S n) + (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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (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 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,(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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + (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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (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 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,(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,(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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <[ {interp_schedule_nd sh (S n) + (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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_nd sh (S n) + (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,(ctx,c)))}, {w} |= φ )> /\ + forall j : Fin.t (S n), + <( {interp_schedule_nd sh (S n) + (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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(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 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,(ctx,c))}, {w} |= φ AN ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 ctx c w + (φ ψ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(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 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,(ctx,c))}, {w} |= φ AU ψ ]> <-> + (<[ {interp_schedule_rr sh (S n) + (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 ctx c w + (φ : ticllW (CSLObs (nat * nat))) : + (<( {interp_schedule_rr sh (S n) + (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,(ctx,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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ ψ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 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),(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,(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 ctx c w φ Pos Base Free First)); exact Hsource. + - intro Hall. + 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 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 ctx c w : + not_done w -> + <( {run_nd (CUntilNone (CBind (CEmit tag value) + (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, run_nd_pool, csl_pool, 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,(ctx,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 ctx c w : + not_done w -> + <( {run_rr (CUntilNone (CBind (CEmit tag value) + (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, run_rr_pool, csl_pool, 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,(ctx,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 (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)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + 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]. + - 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 (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)). + { unfold p, denote. + etransitivity; [apply source_raw_until |]. + etransitivity; [apply source_raw_ret |]. + reflexivity. } + 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]. + - 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. + +(** ** 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 0623cf5..68dad16 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 @@ -13,10 +14,11 @@ From TICL Require Import ICTree.Core ICTree.SBisim ICTree.Equ - ICTree.Interp.State + ICTree.Interp.State.Mod + ICTree.Events.Heap ICTree.Events.State ICTree.Events.Writer - Logic.Trans + ICTree.Logic.Trans Logic.Core ICTree.Logic.AX ICTree.Logic.AF @@ -25,7 +27,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State - Lang.Maps. + Utils.Maps. Generalizable All Variables. @@ -110,6 +112,133 @@ 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. + + (** 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 @@ -129,18 +258,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 +291,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/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..0b7a2a6 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 @@ -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 178e3b2..a935235 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 @@ -23,7 +23,7 @@ From TICL Require Import ICTree.Logic.Bind ICTree.Logic.CanStep ICTree.Logic.State - Lang.Maps. + Utils.Maps. Generalizable All Variables. @@ -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/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. diff --git a/theories/Utils/Execution.v b/theories/Utils/Execution.v new file mode 100644 index 0000000..06e53b4 --- /dev/null +++ b/theories/Utils/Execution.v @@ -0,0 +1,438 @@ +(** * 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. + + (** 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. + +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 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. + +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. + +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. + +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. + + (** 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. + + 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. + +(** ** 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 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/Lang/Maps.v b/theories/Utils/Maps.v similarity index 100% rename from theories/Lang/Maps.v rename to theories/Utils/Maps.v diff --git a/theories/Utils/Pcm.v b/theories/Utils/Pcm.v new file mode 100644 index 0000000..b5a261f --- /dev/null +++ b/theories/Utils/Pcm.v @@ -0,0 +1,268 @@ +(** * 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. + +(** ** 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 + 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 new file mode 100644 index 0000000..bc2f124 --- /dev/null +++ b/theories/Utils/Relations.v @@ -0,0 +1,191 @@ +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. + +(** * 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 7c0ca81..5c4c951 100644 --- a/theories/Utils/Vectors.v +++ b/theories/Utils/Vectors.v @@ -53,6 +53,73 @@ 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. + +(** 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); @@ -137,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