diff --git a/.github/workflows/stack-test.yml b/.github/workflows/stack-test.yml index 63f8978..e2ac000 100644 --- a/.github/workflows/stack-test.yml +++ b/.github/workflows/stack-test.yml @@ -9,7 +9,7 @@ on: jobs: build: runs-on: ubuntu-latest - timeout-minutes: 60 + timeout-minutes: 90 steps: - name: Checkout code diff --git a/benchmark/bench_blake2b b/benchmark/bench_blake2b index e8377ff..ffc0d24 100755 Binary files a/benchmark/bench_blake2b and b/benchmark/bench_blake2b differ diff --git a/benchmark/bench_chacha20 b/benchmark/bench_chacha20 index 3d555e1..7ed08bb 100755 Binary files a/benchmark/bench_chacha20 and b/benchmark/bench_chacha20 differ diff --git a/benchmark/bench_sha256 b/benchmark/bench_sha256 index caadbd5..e6351cf 100755 Binary files a/benchmark/bench_sha256 and b/benchmark/bench_sha256 differ diff --git a/benchmark/bench_sodium_memcmp b/benchmark/bench_sodium_memcmp index 61dcc21..90d77b5 100755 Binary files a/benchmark/bench_sodium_memcmp and b/benchmark/bench_sodium_memcmp differ diff --git a/benchmark/bench_vuln_memcmp b/benchmark/bench_vuln_memcmp index 1958dc0..48ba3ed 100755 Binary files a/benchmark/bench_vuln_memcmp and b/benchmark/bench_vuln_memcmp differ diff --git a/benchmark/bench_x25519 b/benchmark/bench_x25519 index 012b9f7..9da12ce 100755 Binary files a/benchmark/bench_x25519 and b/benchmark/bench_x25519 differ diff --git a/benchmark/eval.py b/benchmark/eval.py new file mode 100755 index 0000000..e842c4c --- /dev/null +++ b/benchmark/eval.py @@ -0,0 +1,106 @@ +#!/usr/bin/env python3 +"""Rerun the checker on the benchmark binaries and print its verdicts. + +Each program proof under proof/Proof/SMT/Stepper passes only if the +checker returns the verdict its name states, so a green build is the result. +This script deletes those modules' compiled files so that GHC rebuilds them, +runs the build with Bitwuzla, and prints one row per checker run with its +time. GHC compares source hashes, so touching the sources would not do. + +Usage: benchmark/eval.py [--bitwuzla PATH] [--csv FILE] +""" + +import argparse +import csv +import os +import re +import shutil +import subprocess +import sys +from pathlib import Path + +ROOT = Path(__file__).resolve().parent.parent +PROOF_SOURCES = ROOT / "proof" +CHECKER_PROOFS = {"Relational", "RelMem", "Invariant"} +PROGRAM_PROOFS = sorted( + path.relative_to(PROOF_SOURCES).with_suffix("") + for path in (PROOF_SOURCES / "Proof/SMT/Stepper").rglob("*.hs") + if path.stem not in CHECKER_PROOFS +) +COMPILED_SUFFIXES = [".hi", ".o", ".dyn_hi", ".dyn_o"] + +VERDICTS = [ + ("NoLeak", "no leak"), + ("Leaks", "leak"), + ("OutOfFuel", "out of fuel"), + ("OneStepShort", "out of fuel"), +] + +COMPILING = re.compile(r"Compiling (Proof\.SMT\.Stepper\.\S+)") +EVALUATING = re.compile(r"SymFC evaluating '([^']+)'") +ELAPSED = re.compile(r"\*\*\* SymFC: Elapsed time: ([0-9.]+)") + + +def verdict_of(proof): + for marker, verdict in VERDICTS: + if marker in proof: + return verdict + return None + + +def run_build(bitwuzla): + env = dict(os.environ, SBV_Z3=bitwuzla, SBV_Z3_OPTIONS="--produce-models") + for build_dir in ROOT.glob(".stack-work/dist/*/*/build"): + for module in PROGRAM_PROOFS: + for suffix in COMPILED_SUFFIXES: + build_dir.joinpath(module).with_suffix(suffix).unlink(missing_ok=True) + build = subprocess.Popen( + ["stack", "build", "--test", "--no-run-tests", "--force-dirty"], + cwd=ROOT, + env=env, + stdout=subprocess.PIPE, + stderr=subprocess.STDOUT, + text=True, + errors="replace", + ) + rows = [] + module = proof = None + for line in build.stdout: + if found := COMPILING.search(line): + module = found.group(1).removeprefix("Proof.SMT.Stepper.") + if module in CHECKER_PROOFS: + module = None + elif found := EVALUATING.search(line): + proof = found.group(1) + elif (found := ELAPSED.search(line)) and proof: + verdict = verdict_of(proof) + if verdict and module: + rows.append((module, proof, verdict, float(found.group(1)))) + proof = None + return build.wait(), rows + + +def main(): + parser = argparse.ArgumentParser(description=__doc__.splitlines()[0]) + parser.add_argument("--bitwuzla", default=shutil.which("bitwuzla")) + parser.add_argument("--csv", type=Path) + args = parser.parse_args() + if not args.bitwuzla: + sys.exit("bitwuzla not found; pass --bitwuzla PATH") + + status, rows = run_build(args.bitwuzla) + rows.sort() + width = max((len(proof) for _, proof, _, _ in rows), default=10) + for module, proof, verdict, seconds in rows: + print(f"{module:14} {proof:{width}} {verdict:12} {seconds:8.1f} s") + if args.csv: + with args.csv.open("w", newline="") as out: + writer = csv.writer(out) + writer.writerow(["program", "check", "verdict", "seconds"]) + writer.writerows(rows) + if status != 0: + sys.exit("the build failed, so at least one verdict is not the one its proof states") + + +if __name__ == "__main__": + main() diff --git a/benchmark/libsodium b/benchmark/libsodium index 9511c98..77e1ce5 160000 --- a/benchmark/libsodium +++ b/benchmark/libsodium @@ -1 +1 @@ -Subproject commit 9511c982fb1d046470a8b42aa36556cdb7da15de +Subproject commit 77e1ce5d6dee871c49ef211222ba18ef0c486bda diff --git a/benchmark/secure_memory.o b/benchmark/secure_memory.o index e857f0f..a0209bf 100644 Binary files a/benchmark/secure_memory.o and b/benchmark/secure_memory.o differ diff --git a/package.yaml b/package.yaml index 4ef1ca0..63644c9 100644 --- a/package.yaml +++ b/package.yaml @@ -21,7 +21,8 @@ description: Please see the README on GitHub at RegIdx -> Word -> Pantomime.Bool -arrRoundTripP a i v = Pantomime.boolean $ loadRA (storeRA a i v) i == v +{-# ANN arrRoundTripP (SymFC ['arrayEmbeddings]) #-} +arrRoundTripP :: SymFC.Sym () +arrRoundTripP = do + a <- freshRA + i <- SymFC.fresh + v <- SymFC.fresh + expectValid $ loadRA (storeRA a i v) i == v -- | The shift embeddings: identities that would fail if the three shifts were -- mixed up, the zero-extension of the amount were wrong, or the arithmetic -- shift lost its sign. -{-# ANN shiftsSaneP (Theory arrayAxioms) #-} -shiftsSaneP :: Word -> Pantomime.Bool -shiftsSaneP x = - Pantomime.boolean $ +{-# ANN shiftsSaneP (SymFC ['arrayEmbeddings]) #-} +shiftsSaneP :: SymFC.Sym () +shiftsSaneP = do + x <- SymFC.fresh @Word + let sign = slice d31 d31 x + expectValid $ Core.Alu.sllWord x 0 == x && Core.Alu.srlWord x 0 == x && Core.Alu.sraWord x 0 == x && Core.Alu.sllWord x 1 == x + x && Core.Alu.srlWord x 31 == (if sign == 1 then 1 else 0) && Core.Alu.sraWord x 31 == (if sign == 1 then 0xFFFFFFFF else 0) - where - sign = slice d31 d31 x -- The driver ------------------------------------------------------------------- -- | The driver is 0 to 3, on any system. -{-# ANN driverValuesP (Theory arrayAxioms) #-} -driverValuesP :: KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -driverValuesP ss i ra ma = - Pantomime.boolean $ driverValues (sysOf ss i ra ma) +{-# ANN driverValuesP (SymFC ['arrayEmbeddings]) #-} +driverValuesP :: SymFC.Sym () +driverValuesP = do + sys <- freshSys + expectValid $ driverValues sys + +type IsaObligation = RegIdx -> Address -> IsaStateG RegArrF MemArr -> SysG RegArrF MemArr -> Bool + +-- | Checked for any ISA state, not only one derived from the core. +holdsForFreeIsa :: IsaObligation -> SymFC.Sym () +holdsForFreeIsa obligation = do + wr <- SymFC.fresh + wa <- SymFC.fresh + isa <- freshIsa + sys <- freshSys + expectValid $ obligation wr wa isa sys + +freshIsa :: SymFC.Sym (IsaStateG RegArrF MemArr) +freshIsa = IsaState <$> SymFC.fresh <*> (RegArrF <$> freshRA) <*> freshMA -- | On states the invariant relates to a free ISA state, the driver agrees -- with its operational reading. -{-# ANN driverMatchesSpecP (Theory arrayAxioms) #-} -driverMatchesSpecP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -driverMatchesSpecP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ - driverMatchesSpec wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) +{-# ANN driverMatchesSpecP (SymFC ['arrayEmbeddings]) #-} +driverMatchesSpecP :: SymFC.Sym () +driverMatchesSpecP = holdsForFreeIsa driverMatchesSpec -- | On the initial system, the driver agrees with its operational reading, for -- any start PC, register file and memory. -{-# ANN driverMatchesSpecInitP (Theory arrayAxioms) #-} -driverMatchesSpecInitP :: Address -> RegArr -> MemArr -> Pantomime.Bool -driverMatchesSpecInitP pc ra ma = - Pantomime.boolean $ driverMatchesSpecInit pc (RegArrF ra) ma +{-# ANN driverMatchesSpecInitP (SymFC ['arrayEmbeddings]) #-} +driverMatchesSpecInitP :: SymFC.Sym () +driverMatchesSpecInitP = do + pc <- SymFC.fresh + ra <- freshRA + ma <- freshMA + expectValid $ driverMatchesSpecInit pc (RegArrF ra) ma -- The invariant and the architectural state ------------------------------------- -- | The invariant relating the core to the ISA implies that the ISA's PC is -- the core's architectural one. The ISA state is free, not derived from the -- core. -{-# ANN pcUnderInvP (Theory arrayAxioms) #-} -pcUnderInvP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -pcUnderInvP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ - pcUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) +{-# ANN pcUnderInvP (SymFC ['arrayEmbeddings]) #-} +pcUnderInvP :: SymFC.Sym () +pcUnderInvP = holdsForFreeIsa pcUnderInv -- | The invariant relating the core to the ISA implies that the ISA's register -- file is the core's architectural one. The ISA state is free, not derived from -- the core. -{-# ANN regFileUnderInvP (Theory arrayAxioms) #-} -regFileUnderInvP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -regFileUnderInvP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ - regFileUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) +{-# ANN regFileUnderInvP (SymFC ['arrayEmbeddings]) #-} +regFileUnderInvP :: SymFC.Sym () +regFileUnderInvP = holdsForFreeIsa regFileUnderInv -- | The invariant relating the core to the ISA implies that the ISA's memory is -- the core's architectural one. -{-# ANN memUnderInvP (Theory arrayAxioms) #-} -memUnderInvP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -memUnderInvP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ - memUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) +{-# ANN memUnderInvP (SymFC ['arrayEmbeddings]) #-} +memUnderInvP :: SymFC.Sym () +memUnderInvP = holdsForFreeIsa memUnderInv -- | The invariant is functional: two ISA states, both free, related to the -- same system are equal. -{-# ANN invFunctionalP (Theory arrayAxioms) #-} -invFunctionalP :: - RegIdx -> Address -> - Address -> RegArr -> MemArr -> - Address -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -invFunctionalP wr wa ipc1 ira1 ima1 ipc2 ira2 ima2 ss i ra ma = - Pantomime.boolean $ - invFunctional - wr - wa - (IsaState ipc1 (RegArrF ira1) ima1) - (IsaState ipc2 (RegArrF ira2) ima2) - (sysOf ss i ra ma) +{-# ANN invFunctionalP (SymFC ['arrayEmbeddings]) #-} +invFunctionalP :: SymFC.Sym () +invFunctionalP = do + wr <- SymFC.fresh + wa <- SymFC.fresh + isa1 <- freshIsa + isa2 <- freshIsa + sys <- freshSys + expectValid $ invFunctional wr wa isa1 isa2 sys -- The base case ---------------------------------------------------------------- -{-# ANN baseCaseP (Theory arrayAxioms) #-} -baseCaseP :: RegIdx -> Address -> Address -> RegArr -> MemArr -> Pantomime.Bool -baseCaseP wr wa pc ra ma = - Pantomime.boolean $ baseCase wr wa pc (RegArrF ra) ma +{-# ANN baseCaseP (SymFC ['arrayEmbeddings]) #-} +baseCaseP :: SymFC.Sym () +baseCaseP = do + wr <- SymFC.fresh + wa <- SymFC.fresh + pc <- SymFC.fresh + ra <- freshRA + ma <- freshMA + expectValid $ baseCase wr wa pc (RegArrF ra) ma -- The inductive steps ---------------------------------------------------------- +type HopObligation = RegIdx -> Address -> SysG RegArrF MemArr -> Bool + +holdsOnEveryHop :: HopObligation -> SymFC.Sym () +holdsOnEveryHop obligation = do + wr <- SymFC.fresh + wa <- SymFC.fresh + sys <- freshSys + expectValid $ obligation wr wa sys + -- | @k = 0@: the one-cycle hop (steady, writeback non-memory). -{-# ANN indStep0P (Theory arrayAxioms) #-} -indStep0P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -indStep0P wr wa ss i ra ma = - Pantomime.boolean $ indStep0 wr wa (sysOf ss i ra ma) +{-# ANN indStep0P (SymFC ['arrayEmbeddings]) #-} +indStep0P :: SymFC.Sym () +indStep0P = holdsOnEveryHop indStep0 -- | @k = 1@: the two-cycle hop (a memory instruction in writeback). -{-# ANN indStep1P (Theory arrayAxioms) #-} -indStep1P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -indStep1P wr wa ss i ra ma = - Pantomime.boolean $ indStep1 wr wa (sysOf ss i ra ma) +{-# ANN indStep1P (SymFC ['arrayEmbeddings]) #-} +indStep1P :: SymFC.Sym () +indStep1P = holdsOnEveryHop indStep1 -- | @k = 2@: the three-cycle hop (environment, taken jump, store hazard with a -- non-memory execute instruction, or memory instructions in both older stages). -- The hop on which the ISA enters a halt; a halted state then sits at k = 0. -{-# ANN indStep2P (Theory arrayAxioms) #-} -indStep2P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -indStep2P wr wa ss i ra ma = - Pantomime.boolean $ indStep2 wr wa (sysOf ss i ra ma) +{-# ANN indStep2P (SymFC ['arrayEmbeddings]) #-} +indStep2P :: SymFC.Sym () +indStep2P = holdsOnEveryHop indStep2 -- | @k = 3@: the four-cycle hop (store hazard with a memory execute -- instruction, load hazard, or all three stages holding memory instructions). -{-# ANN indStep3P (Theory arrayAxioms) #-} -indStep3P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -indStep3P wr wa ss i ra ma = - Pantomime.boolean $ indStep3 wr wa (sysOf ss i ra ma) - -results :: [(String, Maybe String)] -results = - [ ("arrRoundTripP", $(pantomime 'arrRoundTripP)), - ("shiftsSaneP", $(pantomime 'shiftsSaneP)), - ("driverMatchesSpecP", $(pantomime 'driverMatchesSpecP)), - ("driverMatchesSpecInitP", $(pantomime 'driverMatchesSpecInitP)), - ("driverValuesP", $(pantomime 'driverValuesP)), - ("baseCaseP", $(pantomime 'baseCaseP)), - ("indStep0P", $(pantomime 'indStep0P)), - ("indStep1P", $(pantomime 'indStep1P)), - ("indStep2P", $(pantomime 'indStep2P)), - ("indStep3P", $(pantomime 'indStep3P)), - ("pcUnderInvP", $(pantomime 'pcUnderInvP)), - ("regFileUnderInvP", $(pantomime 'regFileUnderInvP)), - ("memUnderInvP", $(pantomime 'memUnderInvP)), - ("invFunctionalP", $(pantomime 'invFunctionalP)) - ] +{-# ANN indStep3P (SymFC ['arrayEmbeddings]) #-} +indStep3P :: SymFC.Sym () +indStep3P = holdsOnEveryHop indStep3 diff --git a/proof/Proof/Core/Functional/System.hs b/proof/Proof/Core/Functional/System.hs index 2eed781..f5d5186 100644 --- a/proof/Proof/Core/Functional/System.hs +++ b/proof/Proof/Core/Functional/System.hs @@ -2,20 +2,18 @@ -- -- The pipeline registers are passed as an ADT of scalars ('KState'), and the -- register file and memory as SMT arrays: an ADT of scalars can be a fresh --- symbolic argument, a record containing a function cannot, and the Clash +-- symbolic value, a record containing a function cannot, and the Clash -- @Vec@ API is opaque to the plugin (see "Proof.SMT.Array"). 'sysOf' assembles --- the pieces into a 'Proof.Core.Functional.Machine.SysG'. +-- the pieces into a 'Proof.Core.Functional.Machine.SysG', and 'freshSys' makes +-- one from fresh pieces. -- -- Shared by the functional and the leakage inductions, so that neither imports -- the other: their obligations are discharged while GHC compiles them, and an -- import between them would re-run one proof whenever the other changes. module Proof.Core.Functional.System - ( -- | Exported because nothing in Haskell ever applies the constructor: the - -- plugin synthesises a 'KState' as a fresh symbolic input to each property, - -- and 'sysOf' only reads it back through the field accessors. Without this - -- the constructor looks dead to @-Wunused-top-binds@. - KState (..), + ( KState (..), sysOf, + freshSys, ) where @@ -25,6 +23,8 @@ import Core.Instruction (Instruction) import Proof.Core.Functional.Machine import Proof.Core.SMT.Array import Proof.SMT.Array +import Proof.SMT.Symbolic () +import qualified SymFC.BuiltIn as SymFC import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) @@ -43,6 +43,9 @@ data KState = KState kCtrl :: Core.Control, kHalt :: Maybe Core.HaltState } + deriving (Generic) + +instance SymFC.Symbolic KState -- | Assemble a system state from the symbolic pieces. sysOf :: KState -> Core.Input -> RegArr -> MemArr -> SysG RegArrF MemArr @@ -67,3 +70,7 @@ sysOf ss i ra ma = sysInput = i, sysMem = ma } + +-- | A system state whose every part is a fresh symbolic value. +freshSys :: SymFC.Sym (SysG RegArrF MemArr) +freshSys = sysOf <$> SymFC.fresh <*> SymFC.fresh <*> freshRA <*> freshMA diff --git a/proof/Proof/Core/Leakage/Model.hs b/proof/Proof/Core/Leakage/Model.hs index 14ce822..d15caeb 100644 --- a/proof/Proof/Core/Leakage/Model.hs +++ b/proof/Proof/Core/Leakage/Model.hs @@ -27,6 +27,12 @@ -- Whether a program is constant-time is a property of its leakage trace, -- checked at the ISA level. The hazard bit is not data dependent: -- 'Core.Instruction.loadHazard' compares register /fields/, not their contents. +-- +-- That check is the software checker's job. The relational stepper +-- ("Stepper.Relational") runs two copies of the program that differ only in +-- their secrets and rejects the program if their 'leakOf' values ever differ. +-- It reads instructions from a fixed code table, so it reports a store into +-- that table instead of following it. module Proof.Core.Leakage.Model ( -- * Observation Obs (..), diff --git a/proof/Proof/Core/Leakage/Solver.hs b/proof/Proof/Core/Leakage/Solver.hs index f061b0c..0c91dd9 100644 --- a/proof/Proof/Core/Leakage/Solver.hs +++ b/proof/Proof/Core/Leakage/Solver.hs @@ -2,7 +2,7 @@ -- -- 'baseCaseLeak' plus one property per driver delay: on a hop of that length, -- the corresponding obligation in "Proof.Core.Leakage.Obligation" holds. Split --- by @k@ because the number of unrolled cycles has to be concrete -- Pantomime +-- by @k@ because the number of unrolled cycles has to be concrete -- the plugin -- cannot recurse on a symbolic count -- and each property pins @driver == k@ so -- it carries one unrolling rather than four. -- @@ -16,9 +16,9 @@ -- ones. The statements live in "Proof.Core.Leakage.Obligation"; this module -- only instantiates them. -- --- The system state is passed as a 'KState' plus SMT-array register file and --- memory (see "Proof.Core.Functional.System"); the simulator state is passed --- directly, since it holds no register file or memory. +-- The system state is a 'KState' plus SMT-array register file and memory (see +-- "Proof.Core.Functional.System"); the simulator state is drawn directly, since +-- it holds no register file or memory. -- -- == Running them -- @@ -34,114 +34,104 @@ module Proof.Core.Leakage.Solver indStepLeak1P, indStepLeak2P, indStepLeak3P, - results, ) where -import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import qualified Core.Pipeline as Core -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime +import Proof.Core.Functional.Machine (SysG) +import Proof.Core.Functional.System import Proof.Core.Leakage.Driver ( simDriverMatchesSpec, simDriverMatchesSpecInit, ) import Proof.Core.Leakage.Invariant (simInvFunctional) -import Proof.Core.Leakage.Model (Leak) import Proof.Core.Leakage.Obligation -import Proof.Core.Leakage.Simulator +import Proof.Core.Leakage.Simulator (SimState) import Proof.Core.SMT.Array +import Proof.Core.SMT.Axioms (arrayEmbeddings) import Proof.SMT.Array -import Proof.Core.SMT.Axioms (arrayAxioms) -import Proof.SMT.Logged (pantomime) -import Proof.Core.Functional.System +import Proof.SMT.Symbolic (expectValid) +import SymFC (SymFC (..)) +import qualified SymFC.BuiltIn as SymFC import Types -import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) +import Prelude hiding (Word) -- The driver ------------------------------------------------------------------- -- | On the simulator states the invariant covers, the simulator's driver agrees -- with its operational reading, for the leakage of any instruction. -{-# ANN simDriverMatchesSpecP (Theory arrayAxioms) #-} -simDriverMatchesSpecP :: - RegIdx -> Address -> - Leak -> SimState -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -simDriverMatchesSpecP wr wa leak sim ss i ra ma = - Pantomime.boolean $ simDriverMatchesSpec wr wa leak sim (sysOf ss i ra ma) +{-# ANN simDriverMatchesSpecP (SymFC ['arrayEmbeddings]) #-} +simDriverMatchesSpecP :: SymFC.Sym () +simDriverMatchesSpecP = do + wr <- SymFC.fresh + wa <- SymFC.fresh + leak <- SymFC.fresh + sim <- SymFC.fresh + sys <- freshSys + expectValid $ simDriverMatchesSpec wr wa leak sim sys -- | On the initial simulator, its driver agrees with its operational reading, -- for any start PC. -{-# ANN simDriverMatchesSpecInitP (Theory arrayAxioms) #-} -simDriverMatchesSpecInitP :: Address -> Pantomime.Bool -simDriverMatchesSpecInitP pc = - Pantomime.boolean $ simDriverMatchesSpecInit pc +{-# ANN simDriverMatchesSpecInitP (SymFC ['arrayEmbeddings]) #-} +simDriverMatchesSpecInitP :: SymFC.Sym () +simDriverMatchesSpecInitP = do + pc <- SymFC.fresh + expectValid $ simDriverMatchesSpecInit pc -- The invariant ---------------------------------------------------------------- -- | The invariant is functional: two simulators it relates to the same system -- are equal. -{-# ANN simInvFunctionalP (Theory arrayAxioms) #-} -simInvFunctionalP :: - SimState -> SimState -> KState -> Core.Input -> RegArr -> MemArr -> - Pantomime.Bool -simInvFunctionalP sim1 sim2 ss i ra ma = - Pantomime.boolean $ simInvFunctional sim1 sim2 (sysOf ss i ra ma) +{-# ANN simInvFunctionalP (SymFC ['arrayEmbeddings]) #-} +simInvFunctionalP :: SymFC.Sym () +simInvFunctionalP = do + sim1 <- SymFC.fresh + sim2 <- SymFC.fresh + sys <- freshSys + expectValid $ simInvFunctional sim1 sim2 sys -- The base case ---------------------------------------------------------------- -- | The first hop from the initial state, for any start PC, register file and -- memory. -{-# ANN baseCaseLeakP (Theory arrayAxioms) #-} -baseCaseLeakP :: Address -> RegArr -> MemArr -> Pantomime.Bool -baseCaseLeakP pc ra ma = - Pantomime.boolean $ baseCaseLeak pc (RegArrF ra) ma +{-# ANN baseCaseLeakP (SymFC ['arrayEmbeddings]) #-} +baseCaseLeakP :: SymFC.Sym () +baseCaseLeakP = do + pc <- SymFC.fresh + ra <- freshRA + ma <- freshMA + expectValid $ baseCaseLeak pc (RegArrF ra) ma -- The inductive steps ---------------------------------------------------------- +type HopLeakObligation = RegIdx -> Address -> SysG RegArrF MemArr -> SimState -> Bool + +holdsOnEveryHop :: HopLeakObligation -> SymFC.Sym () +holdsOnEveryHop obligation = do + wr <- SymFC.fresh + wa <- SymFC.fresh + sys <- freshSys + sim <- SymFC.fresh + expectValid $ obligation wr wa sys sim + -- | @k = 0@: the one-cycle hop (steady, writeback non-memory). -{-# ANN indStepLeak0P (Theory arrayAxioms) #-} -indStepLeak0P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> - Pantomime.Bool -indStepLeak0P wr wa ss i ra ma sim = - Pantomime.boolean $ indStepLeak0 wr wa (sysOf ss i ra ma) sim +{-# ANN indStepLeak0P (SymFC ['arrayEmbeddings]) #-} +indStepLeak0P :: SymFC.Sym () +indStepLeak0P = holdsOnEveryHop indStepLeak0 -- | @k = 1@: the two-cycle hop (a memory instruction in writeback). -{-# ANN indStepLeak1P (Theory arrayAxioms) #-} -indStepLeak1P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> - Pantomime.Bool -indStepLeak1P wr wa ss i ra ma sim = - Pantomime.boolean $ indStepLeak1 wr wa (sysOf ss i ra ma) sim +{-# ANN indStepLeak1P (SymFC ['arrayEmbeddings]) #-} +indStepLeak1P :: SymFC.Sym () +indStepLeak1P = holdsOnEveryHop indStepLeak1 -- | @k = 2@: the three-cycle hop (environment, taken jump, store hazard with a -- non-memory execute instruction, or memory instructions in both older stages). -- The hop on which the ISA enters a halt; a halted state then sits at k = 0. -{-# ANN indStepLeak2P (Theory arrayAxioms) #-} -indStepLeak2P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> - Pantomime.Bool -indStepLeak2P wr wa ss i ra ma sim = - Pantomime.boolean $ indStepLeak2 wr wa (sysOf ss i ra ma) sim +{-# ANN indStepLeak2P (SymFC ['arrayEmbeddings]) #-} +indStepLeak2P :: SymFC.Sym () +indStepLeak2P = holdsOnEveryHop indStepLeak2 -- | @k = 3@: the four-cycle hop (store hazard with a memory execute -- instruction, load hazard, or all three stages holding memory instructions). -{-# ANN indStepLeak3P (Theory arrayAxioms) #-} -indStepLeak3P :: - RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> - Pantomime.Bool -indStepLeak3P wr wa ss i ra ma sim = - Pantomime.boolean $ indStepLeak3 wr wa (sysOf ss i ra ma) sim - -results :: [(String, Maybe String)] -results = - [ ("simDriverMatchesSpecP", $(pantomime 'simDriverMatchesSpecP)), - ("simDriverMatchesSpecInitP", $(pantomime 'simDriverMatchesSpecInitP)), - ("simInvFunctionalP", $(pantomime 'simInvFunctionalP)), - ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), - ("indStepLeak0P", $(pantomime 'indStepLeak0P)), - ("indStepLeak1P", $(pantomime 'indStepLeak1P)), - ("indStepLeak2P", $(pantomime 'indStepLeak2P)), - ("indStepLeak3P", $(pantomime 'indStepLeak3P)) - ] +{-# ANN indStepLeak3P (SymFC ['arrayEmbeddings]) #-} +indStepLeak3P :: SymFC.Sym () +indStepLeak3P = holdsOnEveryHop indStepLeak3 diff --git a/proof/Proof/Core/SMT/Array.hs b/proof/Proof/Core/SMT/Array.hs index 527df35..35f24d4 100644 --- a/proof/Proof/Core/SMT/Array.hs +++ b/proof/Proof/Core/SMT/Array.hs @@ -1,9 +1,10 @@ {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MonoLocalBinds #-} -- | The core's register file embedded as an SMT array, in the pattern --- "Proof.SMT.Array" describes for memory, and the ALU's shifts --- ('Core.Alu.sllWord' and friends) as SMT bitvector shifts. +-- "Proof.SMT.Array" describes for memory. The ALU's shifts are embedded in +-- "Stepper.Shift", which the stepper shares. module Proof.Core.SMT.Array ( RegArr (..), RegArrF (..), @@ -16,16 +17,16 @@ module Proof.Core.SMT.Array storeRAE, eqRA, eqRAE, - sllWordE, - srlWordE, - sraWordE, + freshRA, + freshRAE, ) where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Data.Coerce (Coercible, coerce) -import qualified Pantomime.BuiltIn as P -import qualified Pantomime.Clash as Clash +import Data.Coerce (coerce) +import qualified SymFC.BuiltIn as P +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import qualified SymFC.Clash as Clash import Core.RegFile (RegFileOps (..)) import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) @@ -63,20 +64,23 @@ storeRA (RegArr v) i x = RegArr (replace i x v) -- @Coercible (f a) (g a)@ when the head is a variable, but not through a -- concrete constructor with nominal parameter roles. -- --- Second, the array is indexed by the /primitive/ @Pantomime.BuiltIn.BitVec@, --- not by pantomime-clash's @BitVec@. The latter is a GADT admitting +-- Second, the array is indexed by the /primitive/ @SymFC.BuiltIn.BitVec@, +-- not by symfc-clash's @BitVec@. The latter is a GADT admitting -- zero-width vectors, so it is neither coercible to the primitive nor a -- 'P.Primitive' itself, and cannot be an array index or element. So we unwrap -- at the boundary with 'Clash.BitVecP'. loadRAE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible RegArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr RegArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => arr -> bvI 5 -> bvV 32 -loadRAE = coerce go +loadRAE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: RegArrSMT -> Clash.BitVec 5 -> Clash.BitVec 32 go (RegArrSMT arr) (Clash.BitVecP k) = Clash.BitVecP (P.aselect arr k) @@ -84,14 +88,17 @@ loadRAE = coerce go -- | Embedding of 'storeRA' as an array store. storeRAE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible RegArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr RegArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => arr -> bvI 5 -> bvV 32 -> arr -storeRAE = coerce go +storeRAE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: RegArrSMT -> Clash.BitVec 5 -> Clash.BitVec 32 -> RegArrSMT go (RegArrSMT arr) (Clash.BitVecP k) (Clash.BitVecP v) = @@ -107,8 +114,9 @@ instance Eq RegArr where (==) = eqRA -- | Embedding of 'eqRA' as array equality. -eqRAE :: forall arr. (Coercible RegArrSMT arr) => arr -> arr -> Bool -eqRAE = coerce go +eqRAE :: forall arr. Embeddable arr RegArrSMT => arr -> arr -> Bool +eqRAE + | Embedding <- embedding @arr = coerce go where go :: RegArrSMT -> RegArrSMT -> Bool go (RegArrSMT a) (RegArrSMT b) = a == b @@ -125,8 +133,23 @@ zeroRA :: RegArr zeroRA = RegArr (Clash.Prelude.repeat 0) -- | Embedding of 'zeroRA' as a constant array. -zeroRAE :: forall arr. (Coercible RegArrSMT arr) => arr -zeroRAE = coerce (RegArrSMT (P.aconst 0)) +zeroRAE :: forall arr. Embeddable arr RegArrSMT => arr +zeroRAE + | Embedding <- embedding @arr = coerce (RegArrSMT (P.aconst 0)) + +-- | A fresh symbolic register file. +-- +-- A 'Vec' has no symbolic counterpart, so this has no Haskell meaning: the body +-- halts, and 'freshRAE' replaces it under the term axiom. If the axiom ever +-- stops firing, the property halts and the build fails instead of silently +-- checking a concrete register file. +{-# OPAQUE freshRA #-} +freshRA :: P.Sym RegArr +freshRA = P.halt + +-- | Embedding of 'freshRA' as a fresh SMT array. +freshRAE :: forall arr. Embeddable arr RegArrSMT => P.Sym arr +freshRAE | Embedding <- embedding @arr = coerce . RegArrSMT <$> P.fresh -- | The array-backed register file, wrapped so it fits 'RegFileOps'. A -- verification-only representation. @@ -141,58 +164,3 @@ instance RegFileOps RegArrF where -- On the symbolic path; see 'zeroRA'. initRFg = RegArrF zeroRA - --- Shifts as SMT bitvector shifts ---------------------------------------------- --- --- Embeddings for 'Core.Alu.sllWord', 'Core.Alu.srlWord' and --- 'Core.Alu.sraWord'. See the note on those functions for why they exist: --- without them each shift site converts its five-bit amount through 'Integer', --- and the resulting --- @ubv_to_int@ / @int_to_bv@ pair makes every query unreadable to the --- bitvector-only solvers. --- --- The amount is zero-extended to the word width because SMT's shifts require --- both operands to have the same sort. That is exact rather than a choice: the --- amount is five bits, so it is always less than 32 and no shift saturates. - --- | @shiftL@ on a 'Word' as @bvshl@. -sllWordE :: - forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). - (Coercible Clash.BitVec bvX) => - (Coercible Clash.BitVec bvN) => - bvX 32 -> - bvN 5 -> - bvX 32 -sllWordE = coerce go - where - go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 - go (Clash.BitVecP x) (Clash.BitVecP n) = - Clash.BitVecP (P.bvshl x (P.bvzext n)) - --- | @shiftR@ on a 'Word' as @bvlshr@. -srlWordE :: - forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). - (Coercible Clash.BitVec bvX) => - (Coercible Clash.BitVec bvN) => - bvX 32 -> - bvN 5 -> - bvX 32 -srlWordE = coerce go - where - go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 - go (Clash.BitVecP x) (Clash.BitVecP n) = - Clash.BitVecP (P.bvlshr x (P.bvzext n)) - --- | Arithmetic @shiftR@ on a 'Word' as @bvashr@. -sraWordE :: - forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). - (Coercible Clash.BitVec bvX) => - (Coercible Clash.BitVec bvN) => - bvX 32 -> - bvN 5 -> - bvX 32 -sraWordE = coerce go - where - go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 - go (Clash.BitVecP x) (Clash.BitVecP n) = - Clash.BitVecP (P.bvashr x (P.bvzext n)) diff --git a/proof/Proof/Core/SMT/Axioms.hs b/proof/Proof/Core/SMT/Axioms.hs index 4804451..3418b39 100644 --- a/proof/Proof/Core/SMT/Axioms.hs +++ b/proof/Proof/Core/SMT/Axioms.hs @@ -1,48 +1,27 @@ --- | The axioms for the properties about the core: those every proof builds on --- ("Proof.SMT.Axioms"), plus the core's shift wrappers and its register file as --- an SMT array ("Proof.Core.SMT.Array"). +-- | The embeddings for the properties about the core: those every proof builds +-- on ("Proof.SMT.Axioms"), plus the core's register file as an SMT array +-- ("Proof.Core.SMT.Array"). -- -- This lives in its own module because GHC's stage restriction requires a value -- mentioned in an @ANN@ pragma to be imported rather than defined locally. -module Proof.Core.SMT.Axioms (arrayAxioms) where +module Proof.Core.SMT.Axioms (arrayEmbeddings) where -import Core.Alu (sllWord, sraWord, srlWord) -import qualified Data.Map as Map -import Pantomime (PluginAxioms (..)) import Proof.Core.SMT.Array -import Proof.SMT.Axioms (memAxioms) +import Proof.SMT.Axioms (memEmbeddings) +import SymFC (Embeddings (..)) --- | The ALU shifts, mapped to the SMT bitvector shifts. --- --- They are part of the core's semantics, not of the container encoding: any --- property that runs the ALU needs them. Without them 'Core.Alu.sllWord' and --- friends are OPAQUE names with no unfolding, and symbolic execution stops --- with \"Unbound variable in symbolise\". See 'Core.Alu.sllWord' for why the --- wrappers exist: they keep the shift amount a bitvector, so a query stays in --- the bitvector-and-array fragment that Bitwuzla and Yices can read. -shiftAxioms :: PluginAxioms -shiftAxioms = - PluginAxioms - { typeAxioms = Map.empty, - termAxioms = - [ ('sllWord, 'sllWordE), - ('srlWord, 'srlWordE), - ('sraWord, 'sraWordE) - ] - } - --- | The register-file-as-SMT-array embedding and the shifts, on top of memory --- and the base set. +-- | The register-file-as-SMT-array embedding, on top of memory and the base +-- set. -- -- Monomorphic by necessity: an array needs concrete index and element sorts. -arrayAxioms :: PluginAxioms -arrayAxioms = - memAxioms - <> shiftAxioms - <> PluginAxioms - { typeAxioms = Map.fromList [(''RegArr, ''RegArrSMT)], - termAxioms = - [ ('loadRA, 'loadRAE), +arrayEmbeddings :: Embeddings +arrayEmbeddings = + memEmbeddings + <> Embeddings + { typeEmbeddings = [(''RegArr, ''RegArrSMT)], + termEmbeddings = + [ ('freshRA, 'freshRAE), + ('loadRA, 'loadRAE), ('zeroRA, 'zeroRAE), ('storeRA, 'storeRAE), ('eqRA, 'eqRAE) diff --git a/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs index ab6fc09..63a1c87 100644 --- a/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs @@ -13,7 +13,7 @@ -- twice 'penalty' (no, one or two lines missed; -- 'Proof.Memory.Cache4K.CachedCore.Functional.Driver.cachedDriverValues'), so -- there is one step per hop length, named after it for @'penalty' = 4@. Split --- by length because Pantomime unrolls recursion only when its count is +-- by length because SymFC unrolls recursion only when its count is -- concrete. -- -- == Why they hold diff --git a/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs index 8a4493b..b2a0ef8 100644 --- a/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs @@ -32,17 +32,14 @@ module Proof.Memory.Cache4K.CachedCore.Functional.Solver indStep0P, indStep4P, indStep8P, - results, ) where -import qualified Core.Pipeline as Core import Memory.Cache4K -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime -import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) -import Proof.Memory.Cache4K.SMT.Raw (RawData) +import Memory.Cache4KServer (CacheSrv (..)) +import Proof.Core.Functional.Machine (SysG (..)) +import Proof.Core.Functional.System (freshSys) +import Proof.Core.SMT.Array (RegArrF (..), freshRA) import Proof.Memory.Cache4K.CachedCore.Functional.Driver ( cachedDriverMatchesSpec, cachedDriverValues, @@ -50,130 +47,115 @@ import Proof.Memory.Cache4K.CachedCore.Functional.Driver import Proof.Memory.Cache4K.CachedCore.Functional.Invariant (cachedInvFunctional) import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..)) import Proof.Memory.Cache4K.CachedCore.Functional.Obligation -import Proof.Core.Functional.Machine (SysG (..)) -import Proof.Core.Functional.System (KState, sysOf) -import Proof.Core.SMT.Array (RegArr, RegArrF (..)) -import Proof.SMT.Array (MemArr) -import Proof.SMT.Logged (pantomime) +import Proof.Memory.Cache4K.SMT.Array (freshData, freshRaw, freshTag) +import Proof.Memory.Cache4K.SMT.Axioms (cacheEmbeddings, coherentEmbeddings) +import Proof.Memory.Cache4K.SMT.Raw (RawData) +import Proof.SMT.Array (MemArr, freshMA) +import Proof.SMT.Symbolic (expectValid) +import SymFC (SymFC (..)) +import qualified SymFC.BuiltIn as SymFC import Types -- The driver ------------------------------------------------------------------- -- --- The cached system has the ideal system's core and input, and a cache with +-- The cached system has a symbolic system's core and input, and a cache with -- arbitrary tags, data, memory and state. +-- | A cached system: the core and input of a fresh system, behind a cache with +-- arbitrary tags, data, memory and state. +freshCachedSys :: SymFC.Sym (CachedSysG RegArrF MemArr) +freshCachedSys = do + sys <- freshSys + tags <- freshTag + dat <- freshData + cma <- freshMA + st <- SymFC.fresh + pure $ + CachedSys (sysCore sys) (sysInput sys) (CacheSrv (Cache4K tags dat) cma st) + -- | On systems the invariant relates to an ideal system, the driver agrees with -- its operational reading. -{-# ANN cachedDriverMatchesSpecP (Theory cacheAxioms) #-} -cachedDriverMatchesSpecP :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> - Pantomime.Bool -cachedDriverMatchesSpecP wa wsi wwi ss i ra ma tags dat cma st = - Pantomime.boolean $ cachedDriverMatchesSpec wa wsi wwi sys csys - where - sys = sysOf ss i ra ma - csys = - CachedSys - (sysCore sys) - (sysInput sys) - (CacheSrv (Cache4K tags dat) cma st) +{-# ANN cachedDriverMatchesSpecP (SymFC ['cacheEmbeddings]) #-} +cachedDriverMatchesSpecP :: SymFC.Sym () +cachedDriverMatchesSpecP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + sys <- freshSys + tags <- freshTag + dat <- freshData + cma <- freshMA + st <- SymFC.fresh + let csys = + CachedSys (sysCore sys) (sysInput sys) (CacheSrv (Cache4K tags dat) cma st) + expectValid $ cachedDriverMatchesSpec wa wsi wwi sys csys -- | The driver is 0, 'penalty' or twice 'penalty', on any system. -{-# ANN cachedDriverValuesP (Theory cacheAxioms) #-} -cachedDriverValuesP :: - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> - Pantomime.Bool -cachedDriverValuesP ss i ra ma tags dat cma st = - Pantomime.boolean $ cachedDriverValues csys - where - sys = sysOf ss i ra ma - csys = - CachedSys - (sysCore sys) - (sysInput sys) - (CacheSrv (Cache4K tags dat) cma st) +{-# ANN cachedDriverValuesP (SymFC ['cacheEmbeddings]) #-} +cachedDriverValuesP :: SymFC.Sym () +cachedDriverValuesP = expectValid . cachedDriverValues =<< freshCachedSys -- The invariant ---------------------------------------------------------------- -- | The invariant is functional: two ideal systems related to the same cached -- system are equal. The cached system's core and input come from a third -- symbolic system; its cache is arbitrary. -{-# ANN cachedInvFunctionalP (Theory cacheAxioms) #-} -cachedInvFunctionalP :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> MemArr -> - KState -> Core.Input -> RegArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> - Pantomime.Bool -cachedInvFunctionalP - wa wsi wwi ss1 i1 ra1 ma1 ss2 i2 ra2 ma2 ss i ra tags dat cma st = - Pantomime.boolean $ cachedInvFunctional wa wsi wwi sys1 sys2 csys - where - sys1 = sysOf ss1 i1 ra1 ma1 - sys2 = sysOf ss2 i2 ra2 ma2 - csys0 = sysOf ss i ra cma - csys = - CachedSys - (sysCore csys0) - (sysInput csys0) - (CacheSrv (Cache4K tags dat) cma st) +{-# ANN cachedInvFunctionalP (SymFC ['cacheEmbeddings]) #-} +cachedInvFunctionalP :: SymFC.Sym () +cachedInvFunctionalP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + sys1 <- freshSys + sys2 <- freshSys + csys <- freshCachedSys + expectValid $ cachedInvFunctional wa wsi wwi sys1 sys2 csys -- The base case ---------------------------------------------------------------- --- | Under 'cacheAxioms': the initial cache is the empty one +-- | Under 'cacheEmbeddings': the initial cache is the empty one -- ('Memory.Cache4K.dataZero'), not a constructed one. -{-# ANN baseCaseP (Theory cacheAxioms) #-} -baseCaseP :: - Address -> SetIdx -> WordIdx -> Address -> RegArr -> MemArr -> Pantomime.Bool -baseCaseP wa wsi wwi pc ra ma = - Pantomime.boolean $ baseCase wa wsi wwi pc (RegArrF ra) ma +{-# ANN baseCaseP (SymFC ['cacheEmbeddings]) #-} +baseCaseP :: SymFC.Sym () +baseCaseP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + pc <- SymFC.fresh + ra <- freshRA + ma <- freshMA + expectValid $ baseCase wa wsi wwi pc (RegArrF ra) ma -- The inductive steps ---------------------------------------------------------- -- --- The ideal system is built from symbolic parts as in the core's proof --- ('Proof.Core.Functional.System.sysOf'); the cache adds its tags and the +-- The ideal system is a fresh system as in the core's proof +-- ('Proof.Core.Functional.System.freshSys'); the cache adds its tags and the -- contents of its invalid lines. +type HopObligation = + Address -> SetIdx -> WordIdx -> SysG RegArrF MemArr -> TagArr -> RawData -> Bool + +holdsOnEveryHop :: HopObligation -> SymFC.Sym () +holdsOnEveryHop obligation = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + sys <- freshSys + tags <- freshTag + raw <- freshRaw + expectValid $ obligation wa wsi wwi sys tags raw + -- | The one-cycle hop: a request the cache answers at once. -{-# ANN indStep0P (Theory coherentAxioms) #-} -indStep0P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStep0P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStep0 wa wsi wwi (sysOf ss i ra ma) tags raw +{-# ANN indStep0P (SymFC ['coherentEmbeddings]) #-} +indStep0P :: SymFC.Sym () +indStep0P = holdsOnEveryHop indStep0 -- | The hop of a read that misses one line. -{-# ANN indStep4P (Theory coherentAxioms) #-} -indStep4P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStep4P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStep4 wa wsi wwi (sysOf ss i ra ma) tags raw +{-# ANN indStep4P (SymFC ['coherentEmbeddings]) #-} +indStep4P :: SymFC.Sym () +indStep4P = holdsOnEveryHop indStep4 -- | The hop of a read that misses both its lines. -{-# ANN indStep8P (Theory coherentAxioms) #-} -indStep8P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStep8P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStep8 wa wsi wwi (sysOf ss i ra ma) tags raw - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("cachedDriverMatchesSpecP", $(pantomime 'cachedDriverMatchesSpecP)), - ("cachedDriverValuesP", $(pantomime 'cachedDriverValuesP)), - ("cachedInvFunctionalP", $(pantomime 'cachedInvFunctionalP)), - ("baseCaseP", $(pantomime 'baseCaseP)), - ("indStep0P", $(pantomime 'indStep0P)), - ("indStep4P", $(pantomime 'indStep4P)), - ("indStep8P", $(pantomime 'indStep8P)) - ] +{-# ANN indStep8P (SymFC ['coherentEmbeddings]) #-} +indStep8P :: SymFC.Sym () +indStep8P = holdsOnEveryHop indStep8 diff --git a/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs index 93ea744..41176be 100644 --- a/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs @@ -24,115 +24,106 @@ module Proof.Memory.Cache4K.CachedCore.Leakage.Solver indStepLeak0P, indStepLeak4P, indStepLeak8P, - results, ) where -import qualified Core.Pipeline as Core import Memory.Cache4K -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime +import Memory.Cache4KServer (CacheSrv (..)) import Proof.Core.Functional.Machine (SysG (..)) +import Proof.Core.Functional.System (freshSys) +import Proof.Core.SMT.Array (RegArrF (..), freshRA) import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..)) import Proof.Memory.Cache4K.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) import Proof.Memory.Cache4K.CachedCore.Leakage.Invariant (cachedSimInvFunctional) -import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator (SimCachedSys (..)) -import Proof.Core.Leakage.Model (Obs) -import Proof.Memory.Cache4K.Server.Leakage.Simulator - ( SimCacheSrv (..), - SimCacheSrvState, - ) import Proof.Memory.Cache4K.CachedCore.Leakage.Obligation -import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator (SimCachedSys (..)) +import Proof.Memory.Cache4K.SMT.Array (freshData, freshRaw, freshTag) +import Proof.Memory.Cache4K.SMT.Axioms (cacheEmbeddings, coherentEmbeddings) import Proof.Memory.Cache4K.SMT.Raw (RawData) -import Proof.Core.Functional.System (KState, sysOf) -import Proof.Core.SMT.Array (RegArr, RegArrF (..)) -import Proof.SMT.Array (MemArr) -import Proof.SMT.Logged (pantomime) +import Proof.Memory.Cache4K.Server.Leakage.Simulator (SimCacheSrv (..)) +import Proof.SMT.Array (MemArr, freshMA) +import Proof.SMT.Symbolic (expectValid) +import SymFC (SymFC (..)) +import qualified SymFC.BuiltIn as SymFC import Types +-- | A simulator with arbitrary tags, state and answer flag. +freshSimCachedSys :: SymFC.Sym SimCachedSys +freshSimCachedSys = + SimCachedSys <$> (SimCacheSrv <$> freshTag <*> SymFC.fresh) <*> SymFC.fresh + -- The driver ------------------------------------------------------------------- -- | From a ready simulator, its driver agrees with its operational reading, for -- the observation of any request. -{-# ANN simCachedDriverMatchesSpecP (Theory cacheAxioms) #-} -simCachedDriverMatchesSpecP :: - TagArr -> SimCacheSrvState -> Bool -> Obs -> Pantomime.Bool -simCachedDriverMatchesSpecP tags sst answered obs = - Pantomime.boolean $ simCachedDriverMatchesSpec sim obs - where - sim = SimCachedSys (SimCacheSrv tags sst) answered +{-# ANN simCachedDriverMatchesSpecP (SymFC ['cacheEmbeddings]) #-} +simCachedDriverMatchesSpecP :: SymFC.Sym () +simCachedDriverMatchesSpecP = do + sim <- freshSimCachedSys + obs <- SymFC.fresh + expectValid $ simCachedDriverMatchesSpec sim obs -- The invariant ---------------------------------------------------------------- -- | The invariant is functional: two simulators it relates to the same cached -- system agree at the witness set. The cached system is a symbolic system -- behind an arbitrary cache. -{-# ANN cachedSimInvFunctionalP (Theory cacheAxioms) #-} -cachedSimInvFunctionalP :: - SetIdx -> - TagArr -> SimCacheSrvState -> Bool -> - TagArr -> SimCacheSrvState -> Bool -> - KState -> Core.Input -> RegArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> - Pantomime.Bool -cachedSimInvFunctionalP - wsi tags1 sst1 answered1 tags2 sst2 answered2 ss i ra tags dat ma st = - Pantomime.boolean $ cachedSimInvFunctional wsi sim1 sim2 csys - where - sim1 = SimCachedSys (SimCacheSrv tags1 sst1) answered1 - sim2 = SimCachedSys (SimCacheSrv tags2 sst2) answered2 - sys = sysOf ss i ra ma - csys = - CachedSys (sysCore sys) (sysInput sys) (CacheSrv (Cache4K tags dat) ma st) +{-# ANN cachedSimInvFunctionalP (SymFC ['cacheEmbeddings]) #-} +cachedSimInvFunctionalP :: SymFC.Sym () +cachedSimInvFunctionalP = do + wsi <- SymFC.fresh + sim1 <- freshSimCachedSys + sim2 <- freshSimCachedSys + sys <- freshSys + tags <- freshTag + dat <- freshData + st <- SymFC.fresh + let csys = + CachedSys + (sysCore sys) + (sysInput sys) + (CacheSrv (Cache4K tags dat) (sysMem sys) st) + expectValid $ cachedSimInvFunctional wsi sim1 sim2 csys -- The base case ---------------------------------------------------------------- -- | The simulator at start agrees with the system at start, for any start -- PC, register file and memory. -{-# ANN baseCaseLeakP (Theory cacheAxioms) #-} -baseCaseLeakP :: SetIdx -> Address -> RegArr -> MemArr -> Pantomime.Bool -baseCaseLeakP wsi pc ra ma = - Pantomime.boolean $ baseCaseLeak wsi pc (RegArrF ra) ma +{-# ANN baseCaseLeakP (SymFC ['cacheEmbeddings]) #-} +baseCaseLeakP :: SymFC.Sym () +baseCaseLeakP = do + wsi <- SymFC.fresh + pc <- SymFC.fresh + ra <- freshRA + ma <- freshMA + expectValid $ baseCaseLeak wsi pc (RegArrF ra) ma -- The inductive steps ---------------------------------------------------------- +type HopLeakObligation = + Address -> SetIdx -> WordIdx -> SysG RegArrF MemArr -> TagArr -> RawData -> Bool + +holdsOnEveryHop :: HopLeakObligation -> SymFC.Sym () +holdsOnEveryHop obligation = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + sys <- freshSys + tags <- freshTag + raw <- freshRaw + expectValid $ obligation wa wsi wwi sys tags raw + -- | The one-cycle hop: a request the cache answers at once. -{-# ANN indStepLeak0P (Theory coherentAxioms) #-} -indStepLeak0P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStepLeak0P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStepLeak0 wa wsi wwi (sysOf ss i ra ma) tags raw +{-# ANN indStepLeak0P (SymFC ['coherentEmbeddings]) #-} +indStepLeak0P :: SymFC.Sym () +indStepLeak0P = holdsOnEveryHop indStepLeak0 -- | The hop of a read that misses one line. -{-# ANN indStepLeak4P (Theory coherentAxioms) #-} -indStepLeak4P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStepLeak4P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStepLeak4 wa wsi wwi (sysOf ss i ra ma) tags raw +{-# ANN indStepLeak4P (SymFC ['coherentEmbeddings]) #-} +indStepLeak4P :: SymFC.Sym () +indStepLeak4P = holdsOnEveryHop indStepLeak4 -- | The hop of a read that misses both its lines. -{-# ANN indStepLeak8P (Theory coherentAxioms) #-} -indStepLeak8P :: - Address -> SetIdx -> WordIdx -> - KState -> Core.Input -> RegArr -> MemArr -> - TagArr -> RawData -> Pantomime.Bool -indStepLeak8P wa wsi wwi ss i ra ma tags raw = - Pantomime.boolean $ indStepLeak8 wa wsi wwi (sysOf ss i ra ma) tags raw - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("simCachedDriverMatchesSpecP", $(pantomime 'simCachedDriverMatchesSpecP)), - ("cachedSimInvFunctionalP", $(pantomime 'cachedSimInvFunctionalP)), - ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), - ("indStepLeak0P", $(pantomime 'indStepLeak0P)), - ("indStepLeak4P", $(pantomime 'indStepLeak4P)), - ("indStepLeak8P", $(pantomime 'indStepLeak8P)) - ] +{-# ANN indStepLeak8P (SymFC ['coherentEmbeddings]) #-} +indStepLeak8P :: SymFC.Sym () +indStepLeak8P = holdsOnEveryHop indStepLeak8 diff --git a/proof/Proof/Memory/Cache4K/SMT/Array.hs b/proof/Proof/Memory/Cache4K/SMT/Array.hs index 911a605..45b5d15 100644 --- a/proof/Proof/Memory/Cache4K/SMT/Array.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Array.hs @@ -6,11 +6,16 @@ -- "Proof.Memory.Cache4K.SMT.Axioms" put in place of the wrapper. module Proof.Memory.Cache4K.SMT.Array ( TagArrSMT (..), + freshTag, + freshTagE, tagReadE, tagWriteE, tagEmptyE, tagEqE, DataArrSMT (..), + freshData, + freshRaw, + freshDataE, dataReadE, dataWriteE, dataZeroE, @@ -19,47 +24,65 @@ module Proof.Memory.Cache4K.SMT.Array where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Data.Coerce (Coercible, coerce) -import qualified Pantomime.BuiltIn as P -import qualified Pantomime.Clash as Clash +import Data.Coerce (coerce) +import Memory.Cache4K (DataArr, TagArr) +import Proof.Memory.Cache4K.SMT.Raw (RawData) +import qualified SymFC.BuiltIn as P +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import qualified SymFC.Clash as Clash import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -- | 'Memory.Cache4K.TagArr' on the SMT side. newtype TagArrSMT = TagArrSMT (P.Array (P.BitVec 8) (P.BitVec 21)) +-- | A fresh tag array. Like 'Proof.SMT.Array.freshRA' it has no Haskell +-- meaning: it halts unless 'freshTagE' replaces it. +{-# OPAQUE freshTag #-} +freshTag :: P.Sym TagArr +freshTag = P.halt + +freshTagE :: forall arr. Embeddable arr TagArrSMT => P.Sym arr +freshTagE | Embedding <- embedding @arr = coerce . TagArrSMT <$> P.fresh + tagReadE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible TagArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr TagArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => bvI 8 -> arr -> bvV 21 -tagReadE = coerce go +tagReadE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: Clash.BitVec 8 -> TagArrSMT -> Clash.BitVec 21 go (Clash.BitVecP k) (TagArrSMT arr) = Clash.BitVecP (P.aselect arr k) tagWriteE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible TagArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr TagArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => bvI 8 -> bvV 21 -> arr -> arr -tagWriteE = coerce go +tagWriteE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: Clash.BitVec 8 -> Clash.BitVec 21 -> TagArrSMT -> TagArrSMT go (Clash.BitVecP k) (Clash.BitVecP v) (TagArrSMT arr) = TagArrSMT (P.astore arr k v) -tagEmptyE :: forall arr. (Coercible TagArrSMT arr) => arr -tagEmptyE = coerce (TagArrSMT (P.aconst 0)) +tagEmptyE :: forall arr. Embeddable arr TagArrSMT => arr +tagEmptyE | Embedding <- embedding @arr = coerce (TagArrSMT (P.aconst 0)) -tagEqE :: forall arr. (Coercible TagArrSMT arr) => arr -> arr -> Bool -tagEqE = coerce go +tagEqE :: forall arr. Embeddable arr TagArrSMT => arr -> arr -> Bool +tagEqE | Embedding <- embedding @arr = coerce go where go :: TagArrSMT -> TagArrSMT -> Bool go (TagArrSMT a) (TagArrSMT b) = a == b @@ -67,39 +90,58 @@ tagEqE = coerce go -- | 'Memory.Cache4K.DataArr' on the SMT side. newtype DataArrSMT = DataArrSMT (P.Array (P.BitVec 10) (P.BitVec 32)) +-- | A fresh data array, which halts unless an embedding replaces it. +{-# OPAQUE freshData #-} +freshData :: P.Sym DataArr +freshData = P.halt + +-- | A fresh raw array, which halts unless 'freshDataE' replaces it. +{-# OPAQUE freshRaw #-} +freshRaw :: P.Sym RawData +freshRaw = P.halt + +freshDataE :: forall arr. Embeddable arr DataArrSMT => P.Sym arr +freshDataE | Embedding <- embedding @arr = coerce . DataArrSMT <$> P.fresh + dataReadE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible DataArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr DataArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => bvI 10 -> arr -> bvV 32 -dataReadE = coerce go +dataReadE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: Clash.BitVec 10 -> DataArrSMT -> Clash.BitVec 32 go (Clash.BitVecP k) (DataArrSMT arr) = Clash.BitVecP (P.aselect arr k) dataWriteE :: forall arr (bvI :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible DataArrSMT arr) => - (Coercible Clash.BitVec bvI) => - (Coercible Clash.BitVec bvV) => + Embeddable arr DataArrSMT => + Embeddable bvI Clash.BitVec => + Embeddable bvV Clash.BitVec => bvI 10 -> bvV 32 -> arr -> arr -dataWriteE = coerce go +dataWriteE + | Embedding <- embedding @arr + , Embedding <- embedding @bvI + , Embedding <- embedding @bvV = coerce go where go :: Clash.BitVec 10 -> Clash.BitVec 32 -> DataArrSMT -> DataArrSMT go (Clash.BitVecP k) (Clash.BitVecP v) (DataArrSMT arr) = DataArrSMT (P.astore arr k v) -dataZeroE :: forall arr. (Coercible DataArrSMT arr) => arr -dataZeroE = coerce (DataArrSMT (P.aconst 0)) +dataZeroE :: forall arr. Embeddable arr DataArrSMT => arr +dataZeroE | Embedding <- embedding @arr = coerce (DataArrSMT (P.aconst 0)) -dataEqE :: forall arr. (Coercible DataArrSMT arr) => arr -> arr -> Bool -dataEqE = coerce go +dataEqE :: forall arr. Embeddable arr DataArrSMT => arr -> arr -> Bool +dataEqE | Embedding <- embedding @arr = coerce go where go :: DataArrSMT -> DataArrSMT -> Bool go (DataArrSMT a) (DataArrSMT b) = a == b diff --git a/proof/Proof/Memory/Cache4K/SMT/Axioms.hs b/proof/Proof/Memory/Cache4K/SMT/Axioms.hs index e116f9f..61d97fa 100644 --- a/proof/Proof/Memory/Cache4K/SMT/Axioms.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Axioms.hs @@ -1,9 +1,8 @@ --- | The axioms for the properties about "Memory.Cache4K": those of the register --- file and memory, and the two cache arrays. In its own module for the same --- reason as "Proof.SMT.Axioms". -module Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) where +-- | The embeddings for the properties about "Memory.Cache4K": those of the +-- register file and memory, and the two cache arrays. In its own module for the +-- same reason as "Proof.SMT.Axioms". +module Proof.Memory.Cache4K.SMT.Axioms (cacheEmbeddings, coherentEmbeddings) where -import qualified Data.Map as Map import Memory.Cache4K ( DataArr, TagArr, @@ -16,24 +15,25 @@ import Memory.Cache4K tagRead, tagWrite, ) -import Pantomime (PluginAxioms (..)) -import Proof.Core.SMT.Axioms (arrayAxioms) +import Proof.Core.SMT.Axioms (arrayEmbeddings) import Proof.Memory.Cache4K.SMT.Array import Proof.Memory.Cache4K.Server.Functional.Obligation (mkDataMem) import Proof.Memory.Cache4K.SMT.Coherent import Proof.Memory.Cache4K.SMT.Raw +import SymFC (Embeddings (..)) -cacheAxioms :: PluginAxioms -cacheAxioms = - arrayAxioms - <> PluginAxioms - { typeAxioms = - Map.fromList - [ (''TagArr, ''TagArrSMT), - (''DataArr, ''DataArrSMT) - ], - termAxioms = - [ ('tagRead, 'tagReadE), +cacheEmbeddings :: Embeddings +cacheEmbeddings = + arrayEmbeddings + <> Embeddings + { typeEmbeddings = + [ (''TagArr, ''TagArrSMT), + (''DataArr, ''DataArrSMT) + ], + termEmbeddings = + [ ('freshTag, 'freshTagE), + ('freshData, 'freshDataE), + ('tagRead, 'tagReadE), ('tagWrite, 'tagWriteE), ('tagEmpty, 'tagEmptyE), ('tagEq, 'tagEqE), @@ -44,31 +44,32 @@ cacheAxioms = ] } --- | The axioms for the cache's proof: as 'cacheAxioms', but the data array is --- embedded as 'Proof.Memory.Cache4K.SMT.Coherent.DataC', so that --- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkData' builds a cache --- coherent by construction (through its 'MemArr' instance, --- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem'). The raw-array --- and tag axioms come first: an embedding that calls another wrapper --- ('dataReadC' calls 'rawRead' and 'tagRead') only sees the axioms listed --- before its own. -coherentAxioms :: PluginAxioms -coherentAxioms = - arrayAxioms - <> PluginAxioms - { typeAxioms = - Map.fromList - [ (''TagArr, ''TagArrSMT), - (''DataArr, ''DataC), - (''RawData, ''DataArrSMT) - ], - termAxioms = - [ ('rawRead, 'dataReadE), +-- | The embeddings for the cache's proof: as 'cacheEmbeddings', but the data +-- array is embedded as 'Proof.Memory.Cache4K.SMT.Coherent.DataC', so that +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkData' builds a cache coherent by +-- construction (through its 'MemArr' instance, +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem'). The raw-array and tag +-- embeddings come first: an embedding that calls another wrapper ('dataReadC' +-- calls 'rawRead' and 'tagRead') only sees the embeddings listed before its own. +coherentEmbeddings :: Embeddings +coherentEmbeddings = + arrayEmbeddings + <> Embeddings + { typeEmbeddings = + [ (''TagArr, ''TagArrSMT), + (''DataArr, ''DataC), + (''RawData, ''DataArrSMT) + ], + termEmbeddings = + [ ('freshRaw, 'freshDataE), + ('rawRead, 'dataReadE), ('rawWrite, 'dataWriteE), ('rawZero, 'dataZeroE), + ('freshTag, 'freshTagE), ('tagRead, 'tagReadE), ('tagWrite, 'tagWriteE), ('tagEmpty, 'tagEmptyE), + ('freshData, 'freshDataC), ('dataRead, 'dataReadC), ('dataWrite, 'dataWriteC), ('mkDataMem, 'mkDataC) diff --git a/proof/Proof/Memory/Cache4K/SMT/Coherent.hs b/proof/Proof/Memory/Cache4K/SMT/Coherent.hs index a89e244..f49aad2 100644 --- a/proof/Proof/Memory/Cache4K/SMT/Coherent.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Coherent.hs @@ -13,6 +13,7 @@ -- the longest hop exhaust memory before the query is even built. module Proof.Memory.Cache4K.SMT.Coherent ( DataC (..), + freshDataC, dataReadC, dataWriteC, mkDataC, @@ -20,11 +21,14 @@ module Proof.Memory.Cache4K.SMT.Coherent where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Data.Coerce (Coercible, coerce) +import Data.Coerce (coerce) import Memory.Cache4K import Memory.Types (MemOps (..)) +import Proof.Memory.Cache4K.SMT.Array (freshRaw, freshTag) import Proof.Memory.Cache4K.SMT.Raw -import Proof.SMT.Array (MemArr) +import Proof.SMT.Array (MemArr, freshMA) +import qualified SymFC.BuiltIn as P +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) import Types (Word) import Prelude hiding (Ordering (..), Word, init, log, not, repeat, undefined, (!!), (&&), (++), (||)) @@ -36,27 +40,35 @@ import Prelude hiding (Ordering (..), Word, init, log, not, repeat, undefined, ( data DataC = DataC RawData RawData MemArr TagArr RawData -- | The embedding of 'Memory.Cache4K.dataRead'. -dataReadC :: forall arr. (Coercible DataC arr) => BitVector 10 -> arr -> Word +dataReadC :: forall arr. Embeddable arr DataC => BitVector 10 -> arr -> Word dataReadC i a - | rawRead i written /= 0 = rawRead i ws - | entryValid e = memReadWord (wordAddr (entryTag e) si (slice d1 d0 i) 0) mem - | otherwise = rawRead i raw + | Embedding <- embedding @arr = readC (coerce a) where - DataC ws written mem tags raw = coerce a + readC (DataC ws written mem tags raw) + | rawRead i written /= 0 = rawRead i ws + | entryValid e = memReadWord (wordAddr (entryTag e) si (slice d1 d0 i) 0) mem + | otherwise = rawRead i raw + where + e = tagRead si tags si = slice d9 d2 i - e = tagRead si tags -- | The embedding of 'Memory.Cache4K.dataWrite'. -dataWriteC :: - forall arr. (Coercible DataC arr) => BitVector 10 -> Word -> arr -> arr -dataWriteC i v a = - coerce (DataC (rawWrite i v ws) (rawWrite i 1 written) mem tags raw) +dataWriteC :: forall arr. Embeddable arr DataC => BitVector 10 -> Word -> arr -> arr +dataWriteC i v a + | Embedding <- embedding @arr = coerce (writeC (coerce a)) where - DataC ws written mem tags raw = coerce a + writeC (DataC ws written mem tags raw) = DataC (rawWrite i v ws) (rawWrite i 1 written) mem tags raw -- | The embedding of -- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem': nothing -- written yet. -mkDataC :: - forall arr. (Coercible DataC arr) => MemArr -> TagArr -> RawData -> arr -mkDataC mem t raw = coerce (DataC rawZero rawZero mem t raw) +mkDataC :: forall arr. Embeddable arr DataC => MemArr -> TagArr -> RawData -> arr +mkDataC mem t raw + | Embedding <- embedding @arr = coerce (DataC rawZero rawZero mem t raw) + +-- | The embedding of 'Proof.Memory.Cache4K.SMT.Array.freshData': any coherent-cache +-- data array, writes included. +freshDataC :: forall arr. Embeddable arr DataC => P.Sym arr +freshDataC + | Embedding <- embedding @arr = + coerce <$> (DataC <$> freshRaw <*> freshRaw <*> freshMA <*> freshTag <*> freshRaw) diff --git a/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs index 4b2cb37..b112d62 100644 --- a/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs @@ -95,7 +95,7 @@ srvDriverSpec fuel srv0 req = -- ('Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver') agrees with its -- operational reading ('srvDriverSpec'). -- Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two missed --- lines, and no more, since Pantomime unrolls all of them. Readiness suffices, +-- lines, and no more, since SymFC unrolls all of them. Readiness suffices, -- unlike for the core ('Proof.Core.Functional.Driver.driverMatchesSpec'): the -- driver only asks which lines hit, so every ready server is a valid start, -- and the invariant, which implies readiness, would only narrow the statement. diff --git a/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs index e61c213..004f3d5 100644 --- a/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs @@ -18,7 +18,7 @@ -- From a server that satisfies the invariant the driver is 0, 'penalty' or -- twice 'penalty' (no, one or two lines missed), so there is one step -- obligation per hop length, named after it for @'penalty' = 4@. Split by --- length because Pantomime unrolls recursion only when its count is concrete. +-- length because SymFC unrolls recursion only when its count is concrete. -- A step states only the last answer and the invariant after the hop; that the -- answers before the last are 'Nothing' is stated apart, as a sanity check -- ('indStepWaits4', 'indStepWaits8'), since it follows from the driver's diff --git a/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs index fe204d4..5524aa9 100644 --- a/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs @@ -38,19 +38,19 @@ module Proof.Memory.Cache4K.Server.Functional.Solver srvReadyIffAnsweredP, srvReadyUnderInvP, corePatientP, - results, ) where import Clash.Prelude (BitVector, d0, d1, d2, d9, not, slice, (++#), (||)) import Core.Pipeline as Core (Request) -import qualified Core.Pipeline as Core -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) +import Memory.Cache4KServer (CacheSrv (..)) import Memory.Cache4K import Memory.Types (MemOps (..)) -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime -import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Core.Functional.Machine (SysG (..)) +import Proof.Core.Functional.System (freshSys) +import Proof.Core.SMT.Axioms (arrayEmbeddings) +import Proof.Memory.Cache4K.SMT.Array (freshData, freshRaw, freshTag) +import Proof.Memory.Cache4K.SMT.Axioms (cacheEmbeddings, coherentEmbeddings) import Proof.Memory.Cache4K.SMT.Raw (RawData, rawRead) import Proof.Memory.Cache4K.Server.Functional.Contract ( srvReadyIffAnswered, @@ -61,12 +61,10 @@ import Proof.Memory.Cache4K.Server.Functional.Contract import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriverValues) import Proof.Memory.Cache4K.Server.Functional.Invariant (srvInvFunctional) import Proof.Memory.Cache4K.Server.Functional.Obligation -import Proof.Core.Functional.Machine (SysG (..)) -import Proof.Core.Functional.System (KState, sysOf) -import Proof.Core.SMT.Array (RegArr) -import Proof.SMT.Array (MemArr) -import Proof.Core.SMT.Axioms (arrayAxioms) -import Proof.SMT.Logged (pantomime) +import Proof.SMT.Array (MemArr, freshMA) +import Proof.SMT.Symbolic (expectValid) +import SymFC (SymFC (..)) +import qualified SymFC.BuiltIn as SymFC import Types import Prelude hiding (Word, not, (||)) @@ -74,12 +72,16 @@ import Prelude hiding (Word, not, (||)) -- | The tag and data array embeddings, which are trusted, against facts a -- broken one would get wrong. -{-# ANN cacheArraysP (Theory cacheAxioms) #-} -cacheArraysP :: - TagArr -> DataArr -> SetIdx -> BitVector 21 -> BitVector 10 -> Word -> - Pantomime.Bool -cacheArraysP tags dat s e i w = - Pantomime.boolean $ +{-# ANN cacheArraysP (SymFC ['cacheEmbeddings]) #-} +cacheArraysP :: SymFC.Sym () +cacheArraysP = do + tags <- freshTag + dat <- freshData + s <- SymFC.fresh @SetIdx + e <- SymFC.fresh @(BitVector 21) + i <- SymFC.fresh @(BitVector 10) + w <- SymFC.fresh @Word + expectValid $ tagRead s (tagWrite s e tags) == e && dataRead i (dataWrite i w dat) == w && tagRead s tagEmpty == 0 @@ -89,175 +91,178 @@ cacheArraysP tags dat s e i w = -- 'Proof.Memory.Cache4K.SMT.Coherent.DataC'), which is trusted, against what -- 'mkData' defines: a read of the constructed array is memory's word if the -- line is valid, else the raw word. Writes are checked by 'coherentWriteP'. -{-# ANN coherentDataP (Theory coherentAxioms) #-} -coherentDataP :: MemArr -> TagArr -> RawData -> BitVector 10 -> Pantomime.Bool -coherentDataP ma tags raw i = - Pantomime.boolean $ dataRead i (mkData ma tags raw) == constructed i - where - constructed k - | entryValid e = - memReadWord (wordAddr (entryTag e) si (slice d1 d0 k) 0) ma - | otherwise = rawRead k raw - where - si = slice d9 d2 k - e = tagRead si tags +{-# ANN coherentDataP (SymFC ['coherentEmbeddings]) #-} +coherentDataP :: SymFC.Sym () +coherentDataP = do + ma <- freshMA + tags <- freshTag + raw <- freshRaw + i <- SymFC.fresh @(BitVector 10) + let si = slice d9 d2 i + e = tagRead si tags + constructed + | entryValid e = + memReadWord (wordAddr (entryTag e) si (slice d1 d0 i) 0) ma + | otherwise = rawRead i raw + expectValid $ dataRead i (mkData ma tags raw) == constructed -- | A write on any data array of the coherent cache's embedding, including one -- that already holds writes: a read after it gives the written word at its -- index and leaves the other slots as they were. Since it holds for every -- array, it covers any sequence of writes. -{-# ANN coherentWriteP (Theory coherentAxioms) #-} -coherentWriteP :: - DataArr -> BitVector 10 -> BitVector 10 -> Word -> Pantomime.Bool -coherentWriteP dat i j w = - Pantomime.boolean $ +{-# ANN coherentWriteP (SymFC ['coherentEmbeddings]) #-} +coherentWriteP :: SymFC.Sym () +coherentWriteP = do + dat <- freshData + i <- SymFC.fresh @(BitVector 10) + j <- SymFC.fresh @(BitVector 10) + w <- SymFC.fresh @Word + expectValid $ dataRead i (dataWrite i w dat) == w && (i == j || dataRead j (dataWrite i w dat) == dataRead j dat) -- | The coherent cache's index layout agrees with the cache's addressing: at -- any address whose line is valid and holds its block, the cache's word (index -- set, then word, as 'Memory.Cache4K' composes it) is memory's word there. -{-# ANN coherentLayoutP (Theory coherentAxioms) #-} -coherentLayoutP :: MemArr -> TagArr -> RawData -> Address -> Pantomime.Bool -coherentLayoutP ma tags raw a = - Pantomime.boolean $ +{-# ANN coherentLayoutP (SymFC ['coherentEmbeddings]) #-} +coherentLayoutP :: SymFC.Sym () +coherentLayoutP = do + ma <- freshMA + tags <- freshTag + raw <- freshRaw + a <- SymFC.fresh @Address + let e = tagRead (setOf a) tags + expectValid $ not (entryValid e && entryTag e == tagOf a) || dataRead (setOf a ++# wordOf a) (mkData ma tags raw) == memReadWord (wordAddr (tagOf a) (setOf a) (wordOf a) 0) ma - where - e = tagRead (setOf a) tags + +-- Servers ----------------------------------------------------------------------- + +-- | A server with arbitrary tags, data, memory and state. +freshServer :: SymFC.Sym (CacheSrv MemArr) +freshServer = do + tags <- freshTag + dat <- freshData + ma <- freshMA + st <- SymFC.fresh + pure (CacheSrv (Cache4K tags dat) ma st) + +type ServerObligation = CacheSrv MemArr -> Request -> Bool + +holdsOnEveryRequest :: ServerObligation -> SymFC.Sym () +holdsOnEveryRequest obligation = do + srv <- freshServer + req <- SymFC.fresh + expectValid $ obligation srv req -- The driver ------------------------------------------------------------------- -- | The driver is 0, 'penalty' or twice 'penalty', on any server. -{-# ANN srvDriverValuesP (Theory cacheAxioms) #-} -srvDriverValuesP :: - TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool -srvDriverValuesP tags dat ma st req = - Pantomime.boolean $ srvDriverValues (CacheSrv (Cache4K tags dat) ma st) req +{-# ANN srvDriverValuesP (SymFC ['cacheEmbeddings]) #-} +srvDriverValuesP :: SymFC.Sym () +srvDriverValuesP = holdsOnEveryRequest srvDriverValues -- | From a ready server, the driver agrees with its operational reading. -{-# ANN srvDriverMatchesSpecP (Theory cacheAxioms) #-} -srvDriverMatchesSpecP :: - TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool -srvDriverMatchesSpecP tags dat ma st req = - Pantomime.boolean $ - srvDriverMatchesSpec (CacheSrv (Cache4K tags dat) ma st) req +{-# ANN srvDriverMatchesSpecP (SymFC ['cacheEmbeddings]) #-} +srvDriverMatchesSpecP :: SymFC.Sym () +srvDriverMatchesSpecP = holdsOnEveryRequest srvDriverMatchesSpec -- The invariant ---------------------------------------------------------------- -- | The invariant is functional: two ideal memories related to the same server -- are equal. -{-# ANN srvInvFunctionalP (Theory cacheAxioms) #-} -srvInvFunctionalP :: - Address -> SetIdx -> WordIdx -> MemArr -> MemArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool -srvInvFunctionalP wa wsi wwi ideal1 ideal2 tags dat ma st = - Pantomime.boolean $ - srvInvFunctional wa wsi wwi ideal1 ideal2 srv - where - srv = CacheSrv (Cache4K tags dat) ma st +{-# ANN srvInvFunctionalP (SymFC ['cacheEmbeddings]) #-} +srvInvFunctionalP :: SymFC.Sym () +srvInvFunctionalP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + ideal1 <- freshMA + ideal2 <- freshMA + srv <- freshServer + expectValid $ srvInvFunctional wa wsi wwi ideal1 ideal2 srv -- The base case ---------------------------------------------------------------- --- | Under 'cacheAxioms': the initial cache is the empty one +-- | Under 'cacheEmbeddings': the initial cache is the empty one -- ('Memory.Cache4K.dataZero'), not a constructed one. -{-# ANN baseCaseP (Theory cacheAxioms) #-} -baseCaseP :: - Address -> SetIdx -> WordIdx -> MemArr -> Pantomime.Bool -baseCaseP wa wsi wwi ma = - Pantomime.boolean $ baseCase wa wsi wwi ma +{-# ANN baseCaseP (SymFC ['cacheEmbeddings]) #-} +baseCaseP :: SymFC.Sym () +baseCaseP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + ma <- freshMA + expectValid $ baseCase wa wsi wwi ma -- The inductive steps ---------------------------------------------------------- +type HopObligation = + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> Bool + +holdsOnEveryHop :: HopObligation -> SymFC.Sym () +holdsOnEveryHop obligation = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + ma <- freshMA + tags <- freshTag + raw <- freshRaw + req <- SymFC.fresh + expectValid $ obligation wa wsi wwi ma tags raw req + -- | The one-cycle hop: a request the cache answers at once. -{-# ANN indStep0P (Theory coherentAxioms) #-} -indStep0P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> - Pantomime.Bool -indStep0P wa wsi wwi ma tags raw req = - Pantomime.boolean $ indStep0 wa wsi wwi ma tags raw req +{-# ANN indStep0P (SymFC ['coherentEmbeddings]) #-} +indStep0P :: SymFC.Sym () +indStep0P = holdsOnEveryHop indStep0 -- | The hop of a read that misses one line: 'penalty' + 1 cycles. -{-# ANN indStep4P (Theory coherentAxioms) #-} -indStep4P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> - Pantomime.Bool -indStep4P wa wsi wwi ma tags raw req = - Pantomime.boolean $ indStep4 wa wsi wwi ma tags raw req +{-# ANN indStep4P (SymFC ['coherentEmbeddings]) #-} +indStep4P :: SymFC.Sym () +indStep4P = holdsOnEveryHop indStep4 -- | Sanity check: during that hop, the answers before the last are 'Nothing'. -{-# ANN indStepWaits4P (Theory coherentAxioms) #-} -indStepWaits4P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> - Pantomime.Bool -indStepWaits4P wa wsi wwi ma tags raw req = - Pantomime.boolean $ indStepWaits4 wa wsi wwi ma tags raw req +{-# ANN indStepWaits4P (SymFC ['coherentEmbeddings]) #-} +indStepWaits4P :: SymFC.Sym () +indStepWaits4P = holdsOnEveryHop indStepWaits4 -- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycles. -{-# ANN indStep8P (Theory coherentAxioms) #-} -indStep8P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> - Pantomime.Bool -indStep8P wa wsi wwi ma tags raw req = - Pantomime.boolean $ indStep8 wa wsi wwi ma tags raw req +{-# ANN indStep8P (SymFC ['coherentEmbeddings]) #-} +indStep8P :: SymFC.Sym () +indStep8P = holdsOnEveryHop indStep8 -- | Sanity check: during that hop, the answers before the last are 'Nothing'. -{-# ANN indStepWaits8P (Theory coherentAxioms) #-} -indStepWaits8P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> - Pantomime.Bool -indStepWaits8P wa wsi wwi ma tags raw req = - Pantomime.boolean $ indStepWaits8 wa wsi wwi ma tags raw req +{-# ANN indStepWaits8P (SymFC ['coherentEmbeddings]) #-} +indStepWaits8P :: SymFC.Sym () +indStepWaits8P = holdsOnEveryHop indStepWaits8 -- The contract ----------------------------------------------------------------- -- -- The properties of "Proof.Memory.Cache4K.Server.Functional.Contract": the -- cache's over a server with arbitrary tags, data, memory and state, the core's --- over a core state built from symbolic parts as in the core's proof --- ('Proof.Core.Functional.System.sysOf'). +-- over a fresh system state as in the core's proof +-- ('Proof.Core.Functional.System.freshSys'). -- | After a step, the server is ready exactly when it has answered. -{-# ANN srvReadyIffAnsweredP (Theory cacheAxioms) #-} -srvReadyIffAnsweredP :: - TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool -srvReadyIffAnsweredP tags dat ma st req = - Pantomime.boolean $ - srvReadyIffAnswered (CacheSrv (Cache4K tags dat) ma st) req +{-# ANN srvReadyIffAnsweredP (SymFC ['cacheEmbeddings]) #-} +srvReadyIffAnsweredP :: SymFC.Sym () +srvReadyIffAnsweredP = holdsOnEveryRequest srvReadyIffAnswered -- | A server related to ideal memory by the invariant is ready. -{-# ANN srvReadyUnderInvP (Theory cacheAxioms) #-} -srvReadyUnderInvP :: - Address -> SetIdx -> WordIdx -> MemArr -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool -srvReadyUnderInvP wa wsi wwi ideal tags dat ma st = - Pantomime.boolean $ - srvReadyUnderInv wa wsi wwi ideal (CacheSrv (Cache4K tags dat) ma st) +{-# ANN srvReadyUnderInvP (SymFC ['cacheEmbeddings]) #-} +srvReadyUnderInvP :: SymFC.Sym () +srvReadyUnderInvP = do + wa <- SymFC.fresh + wsi <- SymFC.fresh + wwi <- SymFC.fresh + ideal <- freshMA + srv <- freshServer + expectValid $ srvReadyUnderInv wa wsi wwi ideal srv -- | The core waits for what it asked for. -{-# ANN corePatientP (Theory arrayAxioms) #-} -corePatientP :: KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -corePatientP ss i ra ma = - Pantomime.boolean $ corePatient (sysCore (sysOf ss i ra ma)) i - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("cacheArraysP", $(pantomime 'cacheArraysP)), - ("coherentDataP", $(pantomime 'coherentDataP)), - ("coherentWriteP", $(pantomime 'coherentWriteP)), - ("coherentLayoutP", $(pantomime 'coherentLayoutP)), - ("srvDriverMatchesSpecP", $(pantomime 'srvDriverMatchesSpecP)), - ("srvDriverValuesP", $(pantomime 'srvDriverValuesP)), - ("srvInvFunctionalP", $(pantomime 'srvInvFunctionalP)), - ("baseCaseP", $(pantomime 'baseCaseP)), - ("indStep0P", $(pantomime 'indStep0P)), - ("indStep4P", $(pantomime 'indStep4P)), - ("indStepWaits4P", $(pantomime 'indStepWaits4P)), - ("indStep8P", $(pantomime 'indStep8P)), - ("indStepWaits8P", $(pantomime 'indStepWaits8P)), - ("srvReadyIffAnsweredP", $(pantomime 'srvReadyIffAnsweredP)), - ("srvReadyUnderInvP", $(pantomime 'srvReadyUnderInvP)), - ("corePatientP", $(pantomime 'corePatientP)) - ] +{-# ANN corePatientP (SymFC ['arrayEmbeddings]) #-} +corePatientP :: SymFC.Sym () +corePatientP = do + sys <- freshSys + expectValid $ corePatient (sysCore sys) (sysInput sys) diff --git a/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs index 396c1c9..f922508 100644 --- a/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs @@ -17,76 +17,79 @@ module Proof.Memory.Cache4K.Server.Leakage.Solver srvSimInvFunctionalP, baseCaseLeakP, indStepLeakP, - results, ) where -import Core.Pipeline (Request) import Memory.Cache4K -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) +import Memory.Cache4KServer (CacheSrv (..)) +import Proof.Memory.Cache4K.SMT.Array (freshData, freshTag) +import Proof.Memory.Cache4K.SMT.Axioms (cacheEmbeddings) +import Proof.Memory.Cache4K.Server.Leakage.Driver (simSrvDriverMatchesSpec) +import Proof.Memory.Cache4K.Server.Leakage.Invariant (srvSimInvFunctional) +import Proof.Memory.Cache4K.Server.Leakage.Obligation import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv (..), - SimCacheSrvState (..), simSrvReadyIffAnswered, ) -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime -import Proof.Memory.Cache4K.Server.Leakage.Driver (simSrvDriverMatchesSpec) -import Proof.Memory.Cache4K.Server.Leakage.Invariant (srvSimInvFunctional) -import Proof.Memory.Cache4K.Server.Leakage.Obligation -import Proof.Memory.Cache4K.Server.Leakage.Model (Obs) -import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms) -import Proof.SMT.Array (MemArr) -import Proof.SMT.Logged (pantomime) +import Proof.SMT.Array (MemArr, freshMA) +import Proof.SMT.Symbolic (expectValid) +import SymFC (SymFC (..)) +import qualified SymFC.BuiltIn as SymFC + +-- | A simulator with arbitrary tags and state. +freshSimServer :: SymFC.Sym SimCacheSrv +freshSimServer = SimCacheSrv <$> freshTag <*> SymFC.fresh + +-- | A server with arbitrary tags, data, memory and state. +freshServer :: SymFC.Sym (CacheSrv MemArr) +freshServer = do + tags <- freshTag + dat <- freshData + ma <- freshMA + st <- SymFC.fresh + pure (CacheSrv (Cache4K tags dat) ma st) -- | After a step, the simulator is ready exactly when it has answered. -{-# ANN simSrvReadyIffAnsweredP (Theory cacheAxioms) #-} -simSrvReadyIffAnsweredP :: - TagArr -> SimCacheSrvState -> Obs -> Pantomime.Bool -simSrvReadyIffAnsweredP tags sst obs = - Pantomime.boolean $ simSrvReadyIffAnswered (SimCacheSrv tags sst) obs +{-# ANN simSrvReadyIffAnsweredP (SymFC ['cacheEmbeddings]) #-} +simSrvReadyIffAnsweredP :: SymFC.Sym () +simSrvReadyIffAnsweredP = do + sim <- freshSimServer + obs <- SymFC.fresh + expectValid $ simSrvReadyIffAnswered sim obs -- | From a ready simulator, its driver agrees with its operational reading. -{-# ANN simSrvDriverMatchesSpecP (Theory cacheAxioms) #-} -simSrvDriverMatchesSpecP :: - TagArr -> SimCacheSrvState -> Obs -> Pantomime.Bool -simSrvDriverMatchesSpecP tags sst obs = - Pantomime.boolean $ simSrvDriverMatchesSpec (SimCacheSrv tags sst) obs +{-# ANN simSrvDriverMatchesSpecP (SymFC ['cacheEmbeddings]) #-} +simSrvDriverMatchesSpecP :: SymFC.Sym () +simSrvDriverMatchesSpecP = do + sim <- freshSimServer + obs <- SymFC.fresh + expectValid $ simSrvDriverMatchesSpec sim obs -- | The invariant is functional: two simulators it relates to the same server -- agree at the witness set. -{-# ANN srvSimInvFunctionalP (Theory cacheAxioms) #-} -srvSimInvFunctionalP :: - SetIdx -> TagArr -> SimCacheSrvState -> TagArr -> SimCacheSrvState -> - TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool -srvSimInvFunctionalP wsi tags1 sst1 tags2 sst2 tags dat ma st = - Pantomime.boolean $ srvSimInvFunctional wsi sim1 sim2 srv - where - sim1 = SimCacheSrv tags1 sst1 - sim2 = SimCacheSrv tags2 sst2 - srv = CacheSrv (Cache4K tags dat) ma st +{-# ANN srvSimInvFunctionalP (SymFC ['cacheEmbeddings]) #-} +srvSimInvFunctionalP :: SymFC.Sym () +srvSimInvFunctionalP = do + wsi <- SymFC.fresh + sim1 <- freshSimServer + sim2 <- freshSimServer + srv <- freshServer + expectValid $ srvSimInvFunctional wsi sim1 sim2 srv -- | The base case: the server and the simulator at start agree. -{-# ANN baseCaseLeakP (Theory cacheAxioms) #-} -baseCaseLeakP :: SetIdx -> MemArr -> Pantomime.Bool -baseCaseLeakP wsi ma = Pantomime.boolean $ baseCaseLeak wsi ma +{-# ANN baseCaseLeakP (SymFC ['cacheEmbeddings]) #-} +baseCaseLeakP :: SymFC.Sym () +baseCaseLeakP = do + wsi <- SymFC.fresh + ma <- freshMA + expectValid $ baseCaseLeak wsi ma -- | The step: in one cycle, the simulator answers exactly when the server does, -- and the two agree afterwards. -{-# ANN indStepLeakP (Theory cacheAxioms) #-} -indStepLeakP :: - SetIdx -> TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> - Pantomime.Bool -indStepLeakP wsi tags dat ma st req = - Pantomime.boolean $ indStepLeak wsi (CacheSrv (Cache4K tags dat) ma st) req - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("simSrvReadyIffAnsweredP", $(pantomime 'simSrvReadyIffAnsweredP)), - ("simSrvDriverMatchesSpecP", $(pantomime 'simSrvDriverMatchesSpecP)), - ("srvSimInvFunctionalP", $(pantomime 'srvSimInvFunctionalP)), - ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), - ("indStepLeakP", $(pantomime 'indStepLeakP)) - ] +{-# ANN indStepLeakP (SymFC ['cacheEmbeddings]) #-} +indStepLeakP :: SymFC.Sym () +indStepLeakP = do + wsi <- SymFC.fresh + srv <- freshServer + req <- SymFC.fresh + expectValid $ indStepLeak wsi srv req diff --git a/proof/Proof/SMT/Array.hs b/proof/Proof/SMT/Array.hs index 571ee8a..8c9f5d8 100644 --- a/proof/Proof/SMT/Array.hs +++ b/proof/Proof/SMT/Array.hs @@ -1,8 +1,9 @@ {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MonoLocalBinds #-} -- | Memory embedded as an SMT array, shared by every proof, and the --- conversion of 'Unsigned' to 'Integer' that pantomime-clash leaves out. The +-- conversion of 'Unsigned' to 'Integer' that symfc-clash leaves out. The -- core's register file is embedded the same way in "Proof.Core.SMT.Array". -- -- The embedding has to be /monomorphic/: an SMT array needs concrete index and @@ -29,14 +30,17 @@ module Proof.SMT.Array storeME, eqM, eqME, + freshMA, + freshMAE, unsignedToIntegerE, ) where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Data.Coerce (Coercible, coerce) -import qualified Pantomime.BuiltIn as P -import qualified Pantomime.Clash as Clash +import Data.Coerce (coerce) +import qualified SymFC.BuiltIn as P +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import qualified SymFC.Clash as Clash import Memory.Types (MEM_SIZE_BYTES, MemOps (..)) import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) @@ -69,27 +73,33 @@ storeM (MemArr v) a b = MemArr (replace a b v) loadME :: forall arr (bvA :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible MemArrSMT arr) => - (Coercible Clash.BitVec bvA) => - (Coercible Clash.BitVec bvV) => + Embeddable arr MemArrSMT => + Embeddable bvA Clash.BitVec => + Embeddable bvV Clash.BitVec => arr -> bvA 32 -> bvV 8 -loadME = coerce go +loadME + | Embedding <- embedding @arr + , Embedding <- embedding @bvA + , Embedding <- embedding @bvV = coerce go where go :: MemArrSMT -> Clash.BitVec 32 -> Clash.BitVec 8 go (MemArrSMT arr) (Clash.BitVecP a) = Clash.BitVecP (P.aselect arr a) storeME :: forall arr (bvA :: Nat -> Type) (bvV :: Nat -> Type). - (Coercible MemArrSMT arr) => - (Coercible Clash.BitVec bvA) => - (Coercible Clash.BitVec bvV) => + Embeddable arr MemArrSMT => + Embeddable bvA Clash.BitVec => + Embeddable bvV Clash.BitVec => arr -> bvA 32 -> bvV 8 -> arr -storeME = coerce go +storeME + | Embedding <- embedding @arr + , Embedding <- embedding @bvA + , Embedding <- embedding @bvV = coerce go where go :: MemArrSMT -> Clash.BitVec 32 -> Clash.BitVec 8 -> MemArrSMT go (MemArrSMT arr) (Clash.BitVecP a) (Clash.BitVecP v) = @@ -105,12 +115,27 @@ instance Eq MemArr where (==) = eqM -- | Embedding of 'eqM' as array equality. -eqME :: forall arr. (Coercible MemArrSMT arr) => arr -> arr -> Bool -eqME = coerce go +eqME :: forall arr. Embeddable arr MemArrSMT => arr -> arr -> Bool +eqME + | Embedding <- embedding @arr = coerce go where go :: MemArrSMT -> MemArrSMT -> Bool go (MemArrSMT a) (MemArrSMT b) = a == b +-- | A fresh symbolic memory. +-- +-- A 'Vec' has no symbolic counterpart, so this has no Haskell meaning: the body +-- halts, and 'freshMAE' replaces it under the term axiom. If the axiom ever +-- stops firing, the property halts and the build fails instead of silently +-- checking a concrete memory. +{-# OPAQUE freshMA #-} +freshMA :: P.Sym MemArr +freshMA = P.halt + +-- | Embedding of 'freshMA' as a fresh SMT array. +freshMAE :: forall arr. Embeddable arr MemArrSMT => P.Sym arr +freshMAE | Embedding <- embedding @arr = coerce . MemArrSMT <$> P.fresh + instance MemOps MemArr where memReadByte a m = loadM m a @@ -132,7 +157,7 @@ instance MemOps MemArr where -- Unsigned to Integer --------------------------------------------------------- -- --- pantomime-clash embeds @toInteger@ on 'BitVector' but not on 'Unsigned', and +-- symfc-clash embeds @toInteger@ on 'BitVector' but not on 'Unsigned', and -- Clash's primitive is @OPAQUE@, so even a literal such as -- 'Memory.Cache4KServer.penalty' converted with 'fromIntegral' stops symbolic -- execution. Both types are embedded as 'Clash.BitVec', so the embedding is @@ -142,10 +167,11 @@ instance MemOps MemArr where -- | @toInteger@ on an 'Unsigned' as @ubv_to_int@. unsignedToIntegerE :: forall (bv :: Nat -> Type) (n :: Nat). - (Coercible Clash.BitVec bv) => + Embeddable bv Clash.BitVec => bv n -> Integer -unsignedToIntegerE = coerce go +unsignedToIntegerE + | Embedding <- embedding @bv = coerce go where go :: Clash.BitVec n -> Integer go Clash.BitVecZ = 0 diff --git a/proof/Proof/SMT/Axioms.hs b/proof/Proof/SMT/Axioms.hs index b4a59b8..6844a7e 100644 --- a/proof/Proof/SMT/Axioms.hs +++ b/proof/Proof/SMT/Axioms.hs @@ -1,44 +1,44 @@ {-# LANGUAGE MagicHash #-} --- | The axiom sets every proof builds on: the embeddings of 'base' and of the --- Clash numeric types, and memory as an SMT array ("Proof.SMT.Array"). The --- core's register file and shifts add theirs in "Proof.Core.SMT.Axioms". +-- | The embedding sets every proof builds on: the embeddings of 'base', of the +-- Clash numeric types and of the ALU shifts, and memory as an SMT array +-- ("Proof.SMT.Array"). The core's register file adds its own in +-- "Proof.Core.SMT.Axioms". -- -- This lives in its own module because GHC's stage restriction requires a value -- mentioned in an @ANN@ pragma to be imported rather than defined locally. -module Proof.SMT.Axioms (axioms, memAxioms) where +module Proof.SMT.Axioms (embeddings, memEmbeddings) where -import Proof.SMT.Array -import qualified Data.Map as Map -import Pantomime (PluginAxioms (..)) -import qualified Pantomime.Base as Base -import qualified Pantomime.Clash as Clash import qualified Clash.Sized.Internal.Unsigned as Unsigned +import Proof.SMT.Array +import Stepper.Concrete (baseEmbeddings) +import SymFC (Embeddings (..)) --- | 'base' embeddings plus the Clash numeric types ('BitVector', 'Unsigned', --- 'Signed', 'Bit'), which is what this core's types are built from. -axioms :: PluginAxioms -axioms = Base.axioms <> Clash.axioms <> unsignedAxioms +-- | The stepper's base set ('base', the Clash numeric types and the ALU +-- shifts), plus the conversion of 'Unsigned' to 'Integer'. +embeddings :: Embeddings +embeddings = baseEmbeddings <> unsignedEmbeddings --- | What pantomime-clash leaves out for 'Unsigned': its conversion to --- 'Integer', which 'fromIntegral' goes through. -unsignedAxioms :: PluginAxioms -unsignedAxioms = - PluginAxioms - { typeAxioms = Map.empty, - termAxioms = [('Unsigned.toInteger#, 'unsignedToIntegerE)] +-- | What symfc-clash leaves out for 'Unsigned': its conversion to 'Integer', +-- which 'fromIntegral' goes through. +unsignedEmbeddings :: Embeddings +unsignedEmbeddings = + Embeddings + { typeEmbeddings = [], + termEmbeddings = [('Unsigned.toInteger#, 'unsignedToIntegerE)] } -- | The memory-as-SMT-array embedding, on top of the base set. -- -- Monomorphic by necessity: an array needs concrete index and element sorts. -memAxioms :: PluginAxioms -memAxioms = - axioms - <> PluginAxioms - { typeAxioms = Map.fromList [(''MemArr, ''MemArrSMT)], - termAxioms = - [ ('loadM, 'loadME), +memEmbeddings :: Embeddings +memEmbeddings = + embeddings + <> Embeddings + { typeEmbeddings = [(''MemArr, ''MemArrSMT)], + termEmbeddings = + [ ('freshMA, 'freshMAE), + ('loadM, 'loadME), ('storeM, 'storeME), ('eqM, 'eqME) ] diff --git a/proof/Proof/SMT/Concrete.hs b/proof/Proof/SMT/Concrete.hs new file mode 100644 index 0000000..62838fb --- /dev/null +++ b/proof/Proof/SMT/Concrete.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Concrete + ( literalAddressIsKnown + , literalAddressWrongValueFails + , literalArithmeticIsKnown + , freshAddressIsUnknown + , mergedAddressIsUnknown + , literalBoolIsKnown + , literalBoolWrongValueFails + , literalComparisonIsKnown + , freshBoolIsUnknown + , mergedBoolIsUnknown + , xorWithSelfIsZero + , closureOverConstantIsKnown + , closureOverConstantWrongValueFails + , closureOverFreshIsUnknown + , closureOverForcedFreshIsUnknown + , closureIgnoringFreshIsKnown + , sectionOverConstantIsKnown + , sectionOverFreshIsUnknown + , branchingClosureIsUnknown + , closureFromConstantBranchIsKnown + , closureOverUnforcedDifferenceIsUnknown + , closureOverForcedXorIsKnown + , recursiveClosureOverConstantIsKnown + , recursiveClosureOverFreshIsUnknown + , justConstantIsKnown + , justConstantWrongValueFails + , justFreshIsUnknown + , pairWithIdentityIsKnown + ) where + +import Data.Bits (xor) +import Data.Maybe (isNothing) +import Stepper.Concrete (concreteAddress, knownBool, stepperEmbeddings) +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address) + +expectKnownAs :: Address -> Address -> SymFC.Sym () +expectKnownAs expected address = do + known <- concreteAddress address + if known == Just expected then pure () else SymFC.halt + +expectNotKnownAs :: Address -> Address -> SymFC.Sym () +expectNotKnownAs expected address = do + known <- concreteAddress address + if known == Just expected then SymFC.halt else pure () + +expectUnknown :: Address -> SymFC.Sym () +expectUnknown address = do + known <- concreteAddress address + if isNothing known then pure () else SymFC.halt + +textBase :: Address +textBase = 0x1000 + +wordSize :: Address +wordSize = 4 + +{-# ANN literalAddressIsKnown (SymFC ['stepperEmbeddings]) #-} +literalAddressIsKnown :: SymFC.Sym () +literalAddressIsKnown = expectKnownAs 0x1000 textBase + +{-# ANN literalAddressWrongValueFails (SymFC ['stepperEmbeddings]) #-} +literalAddressWrongValueFails :: SymFC.Sym () +literalAddressWrongValueFails = expectNotKnownAs 0x1004 textBase + +{-# ANN literalArithmeticIsKnown (SymFC ['stepperEmbeddings]) #-} +literalArithmeticIsKnown :: SymFC.Sym () +literalArithmeticIsKnown = expectKnownAs 0x1004 (textBase + wordSize) + +{-# ANN freshAddressIsUnknown (SymFC ['stepperEmbeddings]) #-} +freshAddressIsUnknown :: SymFC.Sym () +freshAddressIsUnknown = SymFC.fresh @Address >>= expectUnknown + +{-# ANN mergedAddressIsUnknown (SymFC ['stepperEmbeddings]) #-} +mergedAddressIsUnknown :: SymFC.Sym () +mergedAddressIsUnknown = do + b <- SymFC.fresh @Bool + expectUnknown (if b then 1 else 2) + +expectBoolKnownAs :: Bool -> Bool -> SymFC.Sym () +expectBoolKnownAs expected value = do + known <- knownBool value + if known == Just expected then pure () else SymFC.halt + +expectBoolNotKnownAs :: Bool -> Bool -> SymFC.Sym () +expectBoolNotKnownAs expected value = do + known <- knownBool value + if known == Just expected then SymFC.halt else pure () + +expectBoolUnknown :: Bool -> SymFC.Sym () +expectBoolUnknown value = do + known <- knownBool value + if isNothing known then pure () else SymFC.halt + +{-# ANN literalBoolIsKnown (SymFC ['stepperEmbeddings]) #-} +literalBoolIsKnown :: SymFC.Sym () +literalBoolIsKnown = expectBoolKnownAs True True + +{-# ANN literalBoolWrongValueFails (SymFC ['stepperEmbeddings]) #-} +literalBoolWrongValueFails :: SymFC.Sym () +literalBoolWrongValueFails = expectBoolNotKnownAs False True + +{-# ANN literalComparisonIsKnown (SymFC ['stepperEmbeddings]) #-} +literalComparisonIsKnown :: SymFC.Sym () +literalComparisonIsKnown = expectBoolKnownAs True (textBase + wordSize == 0x1004) + +{-# ANN freshBoolIsUnknown (SymFC ['stepperEmbeddings]) #-} +freshBoolIsUnknown :: SymFC.Sym () +freshBoolIsUnknown = SymFC.fresh @Bool >>= expectBoolUnknown + +{-# ANN mergedBoolIsUnknown (SymFC ['stepperEmbeddings]) #-} +mergedBoolIsUnknown :: SymFC.Sym () +mergedBoolIsUnknown = do + b <- SymFC.fresh @Bool + expectBoolUnknown ((if b then 1 else 2 :: Address) == 1) + +{-# ANN xorWithSelfIsZero (SymFC ['stepperEmbeddings]) #-} +xorWithSelfIsZero :: SymFC.Sym () +xorWithSelfIsZero = do + word <- SymFC.fresh @Address + expectBoolKnownAs True (word `xor` word == 0) + +knownAnd :: (a -> Bool) -> a -> SymFC.Sym Bool +knownAnd property value = do + known <- SymFC.concrete value + pure $ case known of + SymFC.Known value' -> property value' + SymFC.NotKnown -> False + +expectKnownWith :: (a -> Bool) -> a -> SymFC.Sym () +expectKnownWith property value = do + holds <- knownAnd property value + if holds then pure () else SymFC.halt + +refuteKnownWith :: (a -> Bool) -> a -> SymFC.Sym () +refuteKnownWith property value = do + holds <- knownAnd property value + if holds then SymFC.halt else pure () + +expectNotKnown :: a -> SymFC.Sym () +expectNotKnown = refuteKnownWith (const True) + +{-# OPAQUE addTo #-} +addTo :: Word -> Word -> Word +addTo k = \y -> y + k + +{-# OPAQUE pickAdder #-} +pickAdder :: Bool -> Word -> Word +pickAdder b = if b then (+ 1) else (+ 2) + +{-# OPAQUE subtractUntilBelow #-} +subtractUntilBelow :: Word -> Word -> Word +subtractUntilBelow k = go + where + go n = if n < k then n else go (n - k) + +{-# ANN closureOverConstantIsKnown (SymFC ['stepperEmbeddings]) #-} +closureOverConstantIsKnown :: SymFC.Sym () +closureOverConstantIsKnown = expectKnownWith (\f -> f 1 == 6) (addTo 5) + +{-# ANN closureOverConstantWrongValueFails (SymFC ['stepperEmbeddings]) #-} +closureOverConstantWrongValueFails :: SymFC.Sym () +closureOverConstantWrongValueFails = refuteKnownWith (\f -> f 1 == 7) (addTo 5) + +{-# ANN closureOverFreshIsUnknown (SymFC ['stepperEmbeddings]) #-} +closureOverFreshIsUnknown :: SymFC.Sym () +closureOverFreshIsUnknown = do + x <- SymFC.fresh @Word + expectNotKnown (addTo x) + +{-# ANN closureOverForcedFreshIsUnknown (SymFC ['stepperEmbeddings]) #-} +closureOverForcedFreshIsUnknown :: SymFC.Sym () +closureOverForcedFreshIsUnknown = do + x <- SymFC.fresh @Word + x `seq` expectNotKnown (addTo x) + +{-# ANN closureIgnoringFreshIsKnown (SymFC ['stepperEmbeddings]) #-} +closureIgnoringFreshIsKnown :: SymFC.Sym () +closureIgnoringFreshIsKnown = do + x <- SymFC.fresh @Word + let k = 5 :: Word + x `seq` expectKnownWith (\f -> f 1 == 6) (\y -> y + k) + +{-# ANN sectionOverConstantIsKnown (SymFC ['stepperEmbeddings]) #-} +sectionOverConstantIsKnown :: SymFC.Sym () +sectionOverConstantIsKnown = expectKnownWith (\f -> f 1 == 4) (+ (3 :: Word)) + +{-# ANN sectionOverFreshIsUnknown (SymFC ['stepperEmbeddings]) #-} +sectionOverFreshIsUnknown :: SymFC.Sym () +sectionOverFreshIsUnknown = do + x <- SymFC.fresh @Word + x `seq` expectNotKnown (+ x) + +{-# ANN branchingClosureIsUnknown (SymFC ['stepperEmbeddings]) #-} +branchingClosureIsUnknown :: SymFC.Sym () +branchingClosureIsUnknown = do + b <- SymFC.fresh @Bool + expectNotKnown (if b then (+ 1) else (+ (2 :: Word))) + +{-# ANN closureFromConstantBranchIsKnown (SymFC ['stepperEmbeddings]) #-} +closureFromConstantBranchIsKnown :: SymFC.Sym () +closureFromConstantBranchIsKnown = expectKnownWith (\f -> f 1 == 2) (pickAdder True) + +{-# ANN closureOverUnforcedDifferenceIsUnknown (SymFC ['stepperEmbeddings]) #-} +closureOverUnforcedDifferenceIsUnknown :: SymFC.Sym () +closureOverUnforcedDifferenceIsUnknown = do + x <- SymFC.fresh @Word + let z = x - x + x `seq` expectNotKnown (\y -> y + z) + +{-# ANN closureOverForcedXorIsKnown (SymFC ['stepperEmbeddings]) #-} +closureOverForcedXorIsKnown :: SymFC.Sym () +closureOverForcedXorIsKnown = do + x <- SymFC.fresh @Word + let isZero = x `xor` x == 0 + isZero `seq` expectKnownWith (\f -> f 1 == 1) (\y -> if isZero then y else y + 1) + +{-# ANN recursiveClosureOverConstantIsKnown (SymFC ['stepperEmbeddings]) #-} +recursiveClosureOverConstantIsKnown :: SymFC.Sym () +recursiveClosureOverConstantIsKnown = expectKnownWith (\f -> f 12 == 2) (subtractUntilBelow 5) + +{-# ANN recursiveClosureOverFreshIsUnknown (SymFC ['stepperEmbeddings]) #-} +recursiveClosureOverFreshIsUnknown :: SymFC.Sym () +recursiveClosureOverFreshIsUnknown = do + x <- SymFC.fresh @Word + x `seq` expectNotKnown (subtractUntilBelow x) + +{-# ANN justConstantIsKnown (SymFC ['stepperEmbeddings]) #-} +justConstantIsKnown :: SymFC.Sym () +justConstantIsKnown = expectKnownWith (== Just 5) (Just (5 :: Word)) + +{-# ANN justConstantWrongValueFails (SymFC ['stepperEmbeddings]) #-} +justConstantWrongValueFails :: SymFC.Sym () +justConstantWrongValueFails = refuteKnownWith (== Just 6) (Just (5 :: Word)) + +{-# ANN justFreshIsUnknown (SymFC ['stepperEmbeddings]) #-} +justFreshIsUnknown :: SymFC.Sym () +justFreshIsUnknown = do + x <- SymFC.fresh @Word + x `seq` expectNotKnown (Just x) + +{-# ANN pairWithIdentityIsKnown (SymFC ['stepperEmbeddings]) #-} +pairWithIdentityIsKnown :: SymFC.Sym () +pairWithIdentityIsKnown = expectKnownWith (\(n, f) -> f n == 5) (5 :: Word, \y -> y) diff --git a/proof/Proof/SMT/Logged.hs b/proof/Proof/SMT/Logged.hs deleted file mode 100644 index 84a24e1..0000000 --- a/proof/Proof/SMT/Logged.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Small build-time wrapper that makes long proof runs attributable. --- --- Pantomime's solver transcript does not identify the splice that produced a --- query. Printing a marker on either side lets a timeout be mapped back to the --- exact obligation without changing the proposition sent to the solver. -module Proof.SMT.Logged - ( pantomime, - ) -where - -import Language.Haskell.TH.Syntax (Exp, Name, Q, nameBase, runIO) -import qualified Pantomime -import Prelude (String, pure, putStrLn, ($), (++)) - -pantomime :: Name -> Q Exp -pantomime property = do - marker "BEGIN" - result <- Pantomime.pantomime property - marker "END" - pure result - where - marker :: String -> Q () - marker phase = - runIO $ - putStrLn ("PANTOMIME_" ++ phase ++ " " ++ nameBase property) diff --git a/proof/Proof/SMT/Sanity.hs b/proof/Proof/SMT/Sanity.hs index daf5938..5924f1b 100644 --- a/proof/Proof/SMT/Sanity.hs +++ b/proof/Proof/SMT/Sanity.hs @@ -1,16 +1,12 @@ --- | Sanity check that the Pantomime plugin is correctly wired into this --- project. The properties below are checked at compile time by the plugin, --- which discharges them via Z3. --- --- IMPORTANT: as of pantomime 1821a71, an annotation on its own does NOT fail --- the build when a property is invalid -- the plugin just logs the --- counterexample and compilation succeeds. To actually observe the result you --- must splice in @$(pantomime 'name)@, which the plugin rewrites to --- @Nothing@ (valid) or @Just counterexample@ (invalid). See 'results'. +{-# LANGUAGE ImportQualifiedPost #-} + +-- | Sanity check that the SymFC plugin is correctly wired into this project. +-- The properties below are checked at compile time by the plugin, which +-- discharges them via Z3, and a property that halts fails the build. -- -- NOTE: this module -- and every other property the plugin checks -- only -- builds at @-O1@ or above. Under @stack build --fast@ (@-O0@) GHC creates no --- unfoldings, so the plugin cannot see through @$@ or @Pantomime.boolean@ and +-- unfoldings, so the plugin cannot see through @$@ or @SymFC.boolean@ and -- stops with @Unbound variable in symbolise@, which fails the build rather -- than reporting a failed proof. Use a plain @stack build@ for anything that -- touches the proof. @@ -18,41 +14,50 @@ module Proof.SMT.Sanity ( deMorgan , doubling , bogus - , results ) where -import Pantomime (Theory (..), pantomime) -import qualified Pantomime.Base as Base -import qualified Pantomime.BuiltIn as Pantomime +import SymFC (SymFC (..)) +import SymFC.Base qualified as Base +import SymFC.BuiltIn (Sym) +import SymFC.BuiltIn qualified as SymFC --- | The example from the Pantomime README: de Morgan over all booleans. +-- | The example from the SymFC README: de Morgan over all booleans. -- --- NOTE: unlike the README, this needs 'Base.axioms'. GHC compiles @(==) \@Bool@ --- down to the @dataToTagSmall#@ primop, which only 'Base.axioms' maps onto a --- Pantomime primitive. -{-# ANN deMorgan (Theory Base.axioms) #-} -deMorgan :: Bool -> Bool -> Pantomime.Bool -deMorgan x y = Pantomime.boolean $ (not x && not y) == not (x || y) - --- | The example from the Pantomime install guide, which additionally exercises --- the 'base' axioms (i.e. the embedding of 'Int' into the theory of --- bitvectors). -{-# ANN doubling (Theory Base.axioms) #-} -doubling :: Int -> Pantomime.Bool -doubling x = Pantomime.boolean $ x + x == 2 * x +-- NOTE: unlike the README, this needs 'Base.embeddings'. GHC compiles @(==) \@Bool@ +-- down to the @dataToTagSmall#@ primop, which only 'Base.embeddings' maps onto a +-- SymFC primitive. +{-# ANN deMorgan (SymFC ['Base.embeddings]) #-} +deMorgan :: Sym () +deMorgan = do + x <- SymFC.fresh + y <- SymFC.fresh + let prop = (not x && not y) == not (x || y) + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt --- | Negative control: this is false (e.g. at @x = -1@). It is kept deliberately --- so that 'results' demonstrates the checker reporting a counterexample rather --- than silently accepting everything. -{-# ANN bogus (Theory Base.axioms) #-} -bogus :: Int -> Pantomime.Bool -bogus x = Pantomime.boolean $ x + x == 3 * x +-- | The example from the SymFC install guide, which additionally exercises +-- the 'base' axioms (i.e. the embedding of 'Int' into the theory of bitvectors). +{-# ANN doubling (SymFC ['Base.embeddings]) #-} +doubling :: Sym () +doubling = do + x <- SymFC.fresh @Int + let prop = x + x == 2 * x + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt --- | Verification verdicts, filled in by the plugin at compile time. --- 'Nothing' means valid; 'Just' carries the counterexample. -results :: [(String, Maybe String)] -results = - [ ("deMorgan", $(pantomime 'deMorgan)) - , ("doubling", $(pantomime 'doubling)) - , ("bogus" , $(pantomime 'bogus)) - ] +-- | Negative control: this is false (e.g. at @x = -1@), so the build passes +-- only if the checker finds a counterexample rather than silently accepting +-- everything. +{-# ANN bogus (SymFC ['Base.embeddings]) #-} +bogus :: Sym () +bogus = do + x <- SymFC.fresh @Int + let prop = x + x == 3 * x + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.Instance -> pure () + _ -> SymFC.halt diff --git a/proof/Proof/SMT/Stepper.hs b/proof/Proof/SMT/Stepper.hs new file mode 100644 index 0000000..ac05727 --- /dev/null +++ b/proof/Proof/SMT/Stepper.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper + ( stepChangesState + , addiSetsX1 + , addiWrongValueFails + , chainUnrolled + , chainUnrolledWrongValueFails + , chainFuel + , chainFuelWrongValueFails + , chainIntFuel + , chainIntFuelWrongValueFails + ) where + +import Core.ISA (IsaStateG (..), StepG (..), isaStep) +import Memory.Types (MemOps (..)) +import Core.RegFile (RegFileOps (..)) +import Stepper (Fuel (..), IsaSys, IsaSysStep) +import Stepper.Concrete (baseEmbeddings) +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Size (..), Word) +import Prelude hiding (Word) + +expectValid :: Bool -> SymFC.Sym () +expectValid prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt + +expectCounterexample :: Bool -> SymFC.Sym () +expectCounterexample prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.Instance -> pure () + _ -> SymFC.halt + +{-# ANN stepChangesState (SymFC ['baseEmbeddings]) #-} +stepChangesState :: SymFC.Sym () +stepChangesState = do + isa0 <- SymFC.fresh @IsaSys + expectCounterexample $ Next isa0 == isaStep isa0 + + +addiX1X0Imm5 :: Word +addiX1X0Imm5 = 0x00500093 + +addiAtZero :: IsaSys -> IsaSys +addiAtZero isa = isa {isaPc = 0, isaMem = memWrite 0 Word addiX1X0Imm5 (isaMem isa)} + +stepSetsX1To :: Word -> IsaSys -> Bool +stepSetsX1To value isa = + isaStep isa == Next isa {isaPc = 4, isaRegFile = modifyRFg 1 value (isaRegFile isa)} + +{-# ANN addiSetsX1 (SymFC ['baseEmbeddings]) #-} +addiSetsX1 :: SymFC.Sym () +addiSetsX1 = do + isa <- addiAtZero <$> SymFC.fresh @IsaSys + expectValid $ stepSetsX1To 5 isa + +{-# ANN addiWrongValueFails (SymFC ['baseEmbeddings]) #-} +addiWrongValueFails :: SymFC.Sym () +addiWrongValueFails = do + isa <- addiAtZero <$> SymFC.fresh @IsaSys + expectCounterexample $ stepSetsX1To 6 isa + + +addiX2X1Imm3 :: Word +addiX2X1Imm3 = 0x00308113 + +addX3X1X2 :: Word +addX3X1X2 = 0x002081B3 + +chainEnd :: Address +chainEnd = 12 + +chainAtZero :: IsaSys -> IsaSys +chainAtZero isa = isa {isaPc = 0, isaMem = program} + where + program = + memWrite 8 Word addX3X1X2 $ + memWrite 4 Word addiX2X1Imm3 $ + memWrite 0 Word addiX1X0Imm5 (isaMem isa) + +chainSetsX3To :: Word -> IsaSys -> IsaSysStep +chainSetsX3To x3 isa = Next isa {isaPc = chainEnd, isaRegFile = registers} + where + registers = + modifyRFg 3 x3 $ + modifyRFg 2 8 $ + modifyRFg 1 5 (isaRegFile isa) + +andThenStep :: IsaSysStep -> IsaSysStep +andThenStep = \case + Next isa -> isaStep isa + IsaHalted -> IsaHalted + +threeStepsUnrolled :: IsaSys -> IsaSysStep +threeStepsUnrolled = andThenStep . andThenStep . isaStep + +{-# ANN chainUnrolled (SymFC ['baseEmbeddings]) #-} +chainUnrolled :: SymFC.Sym () +chainUnrolled = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectValid $ threeStepsUnrolled isa == chainSetsX3To 13 isa + +{-# ANN chainUnrolledWrongValueFails (SymFC ['baseEmbeddings]) #-} +chainUnrolledWrongValueFails :: SymFC.Sym () +chainUnrolledWrongValueFails = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectCounterexample $ threeStepsUnrolled isa == chainSetsX3To 14 isa + +threeSteps :: Fuel +threeSteps = More (More (More Done)) + +stepWithFuel :: Fuel -> IsaSys -> IsaSysStep +stepWithFuel Done isa = Next isa +stepWithFuel (More fuel) isa = case isaStep isa of + Next isa' -> stepWithFuel fuel isa' + IsaHalted -> IsaHalted + +{-# ANN chainFuel (SymFC ['baseEmbeddings]) #-} +chainFuel :: SymFC.Sym () +chainFuel = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectValid $ stepWithFuel threeSteps isa == chainSetsX3To 13 isa + +{-# ANN chainFuelWrongValueFails (SymFC ['baseEmbeddings]) #-} +chainFuelWrongValueFails :: SymFC.Sym () +chainFuelWrongValueFails = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectCounterexample $ stepWithFuel threeSteps isa == chainSetsX3To 14 isa + +stepTimes :: Int -> IsaSys -> IsaSysStep +stepTimes n isa + | n <= 0 = Next isa + | otherwise = case isaStep isa of + Next isa' -> stepTimes (n - 1) isa' + IsaHalted -> IsaHalted + +{-# ANN chainIntFuel (SymFC ['baseEmbeddings]) #-} +chainIntFuel :: SymFC.Sym () +chainIntFuel = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectValid $ stepTimes 3 isa == chainSetsX3To 13 isa + +{-# ANN chainIntFuelWrongValueFails (SymFC ['baseEmbeddings]) #-} +chainIntFuelWrongValueFails :: SymFC.Sym () +chainIntFuelWrongValueFails = do + isa <- chainAtZero <$> SymFC.fresh @IsaSys + expectCounterexample $ stepTimes 3 isa == chainSetsX3To 14 isa diff --git a/proof/Proof/SMT/Stepper/Blake2b.hs b/proof/Proof/SMT/Stepper/Blake2b.hs new file mode 100644 index 0000000..c93001d --- /dev/null +++ b/proof/Proof/SMT/Stepper/Blake2b.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.Blake2b + ( blake2bSecretBlockNoLeak + , blake2bSecretBlockOneStepShortOutOfFuel + , blake2bSecretChainingValueNoLeak + , blake2bSecretBlockPointerLeaks + , blake2bDecodeAgrees + , blake2bFetchesByAddress + , blake2bDecodeRejectsWrongInstruction + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_blake2b" + [ ("blake2bCompress", ["blake2b_compress_ref", "memcpy"]) + ]) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +plusFuel :: Fuel -> Fuel -> Fuel +plusFuel Done later = later +plusFuel (More fuel) later = More (plusFuel fuel later) + +tenfold :: Fuel -> Fuel +tenfold fuel = plusFuel eightfold twofold + where + twofold = plusFuel fuel fuel + fourfold = plusFuel twofold twofold + eightfold = plusFuel fourfold fourfold + +decimalSteps :: [Int] -> Fuel +decimalSteps = digitsAfter Done + where + digitsAfter sofar [] = sofar + digitsAfter sofar (digit : rest) = digitsAfter (plusFuel (steps digit) (tenfold sofar)) rest + +exactSteps :: Fuel +exactSteps = decimalSteps [7, 4, 5, 0] + +oneStepShort :: Fuel +oneStepShort = decimalSteps [7, 4, 4, 9] + +stateAddr, countersAddr, blockAddr, stackTop, returnOutsideCode :: Address +stateAddr = 0x1000 +countersAddr = 0x1040 +blockAddr = 0x2000 +stackTop = 0x8000 +returnOutsideCode = 0 + +otherBlockAddr :: Address +otherBlockAddr = 0x5000 + +chainingValueWords, counterWords, blockWords :: Int +counterWords = 8 +chainingValueWords = 16 +blockWords = 32 + +wordBytes :: Address +wordBytes = 4 + +ra, sp, a0, a1 :: RegIdx +ra = 1 +sp = 2 +a0 = 10 +a1 = 11 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +withArguments :: Rel Word -> RelState -> SymFC.Sym RelState +withArguments blockPointer st = do + regs <- + writeReg a0 (pointer stateAddr) + =<< writeReg a1 blockPointer + =<< writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) (relRegs st) + pure st {relRegs = regs} + +withSecretWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withSecretWords _ 0 st = pure st +withSecretWords base count st = do + wordA <- SymFC.fresh @Word + wordB <- SymFC.fresh @Word + next <- withSecretWord base wordA wordB st + withSecretWords (base + wordBytes) (count - 1) next + +withPublicWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withPublicWords _ 0 st = pure st +withPublicWords base count st = do + value <- SymFC.fresh @Word + mem <- writeMem (relPath st) Word base (Same value) (relMem st) + withPublicWords (base + wordBytes) (count - 1) st {relMem = mem} + +compressCall :: Fuel -> Rel Word -> Bool -> SymFC.Sym Verdict +compressCall fuel blockPointer secretChainingValue = do + isa <- SymFC.fresh @IsaSys + let start = (sameState blake2bCompressCode isa) {relPc = blake2bCompressEntry} + withBlock <- withSecretWords blockAddr blockWords =<< withArguments blockPointer start + withCounters <- withPublicWords countersAddr counterWords withBlock + withChainingValue <- + if secretChainingValue + then withSecretWords stateAddr chainingValueWords withCounters + else withPublicWords stateAddr chainingValueWords withCounters + relRun fuel withChainingValue + +secretBlockPublicChainingValue :: Fuel -> SymFC.Sym Verdict +secretBlockPublicChainingValue fuel = compressCall fuel (pointer blockAddr) False + +secretBlockSecretChainingValue :: Fuel -> SymFC.Sym Verdict +secretBlockSecretChainingValue fuel = compressCall fuel (pointer blockAddr) True + +secretBlockPointer :: SymFC.Sym Verdict +secretBlockPointer = compressCall exactSteps (Pair (bitCoerce blockAddr) (bitCoerce otherBlockAddr)) False + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt + +firstBlockByteLoad :: Address +firstBlockByteLoad = 0x19c28 + +{-# ANN blake2bSecretBlockNoLeak (SymFC ['stepperEmbeddings]) #-} +blake2bSecretBlockNoLeak :: SymFC.Sym () +blake2bSecretBlockNoLeak = expectNoLeak $ secretBlockPublicChainingValue exactSteps + +{-# ANN blake2bSecretBlockOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +blake2bSecretBlockOneStepShortOutOfFuel :: SymFC.Sym () +blake2bSecretBlockOneStepShortOutOfFuel = expectOutOfFuel $ secretBlockPublicChainingValue oneStepShort + +{-# ANN blake2bSecretChainingValueNoLeak (SymFC ['stepperEmbeddings]) #-} +blake2bSecretChainingValueNoLeak :: SymFC.Sym () +blake2bSecretChainingValueNoLeak = expectNoLeak $ secretBlockSecretChainingValue exactSteps + +{-# ANN blake2bSecretBlockPointerLeaks (SymFC ['stepperEmbeddings]) #-} +blake2bSecretBlockPointerLeaks :: SymFC.Sym () +blake2bSecretBlockPointerLeaks = expectLeakAt firstBlockByteLoad secretBlockPointer + +{-# ANN blake2bDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +blake2bDecodeAgrees :: SymFC.Sym () +blake2bDecodeAgrees = expectDecodeAgreement [blake2bCompressDecoded] + +{-# ANN blake2bFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +blake2bFetchesByAddress :: SymFC.Sym () +blake2bFetchesByAddress = expectFetchByAddress [blake2bCompressCode] + +{-# ANN blake2bDecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +blake2bDecodeRejectsWrongInstruction :: SymFC.Sym () +blake2bDecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction blake2bCompressDecoded] diff --git a/proof/Proof/SMT/Stepper/Chacha.hs b/proof/Proof/SMT/Stepper/Chacha.hs new file mode 100644 index 0000000..68e6fd6 --- /dev/null +++ b/proof/Proof/SMT/Stepper/Chacha.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.Chacha + ( chachaBlockNoLeak + , chachaShortRunOutOfFuel + , chachaOneStepShortOutOfFuel + , chachaSecretLengthLeaks + , chachaDecodeAgrees + , chachaFetchesByAddress + , chachaDecodeRejectsWrongInstruction + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_chacha20" + [ ("chachaEncrypt", ["chacha20_encrypt_bytes.part.0", "memset"]) + ]) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +plusFuel :: Fuel -> Fuel -> Fuel +plusFuel Done later = later +plusFuel (More fuel) later = More (plusFuel fuel later) + +tenfold :: Fuel -> Fuel +tenfold fuel = plusFuel eightfold twofold + where + twofold = plusFuel fuel fuel + fourfold = plusFuel twofold twofold + eightfold = plusFuel fourfold fourfold + +decimalSteps :: [Int] -> Fuel +decimalSteps = digitsAfter Done + where + digitsAfter sofar [] = sofar + digitsAfter sofar (digit : rest) = digitsAfter (plusFuel (steps digit) (tenfold sofar)) rest + +oneBlockSteps :: Fuel +oneBlockSteps = decimalSteps [2, 0, 6, 3] + +oneStepShort :: Fuel +oneStepShort = decimalSteps [2, 0, 6, 2] + +tooFewSteps :: Fuel +tooFewSteps = decimalSteps [2, 0, 0] + +contextAddr, inputBuf, outputBuf, stackTop, returnOutsideCode :: Address +contextAddr = 0x1000 +inputBuf = 0x2000 +outputBuf = 0x3000 +stackTop = 0x8000 +returnOutsideCode = 0 + +stackGuardSlot, stackGuard :: Address +stackGuardSlot = 0x50020 +stackGuard = 0x50ba0 + +blockBytes :: Word +blockBytes = 64 + +ra, sp, a0, a1, a2, a3, a4 :: RegIdx +ra = 1 +sp = 2 +a0 = 10 +a1 = 11 +a2 = 12 +a3 = 13 +a4 = 14 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +withArguments :: Rel Word -> RelState -> SymFC.Sym RelState +withArguments lengthLow st = do + regs <- + writeReg a0 (pointer contextAddr) + =<< writeReg a1 (pointer inputBuf) + =<< writeReg a2 (pointer outputBuf) + =<< writeReg a3 lengthLow + =<< writeReg a4 (Same 0) + =<< writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) (relRegs st) + pure st {relRegs = regs} + +withPublicWord :: Address -> Word -> RelState -> SymFC.Sym RelState +withPublicWord addr value st = do + mem <- writeMem (relPath st) Word addr (Same value) (relMem st) + pure st {relMem = mem} + +withStackGuardPointer :: RelState -> SymFC.Sym RelState +withStackGuardPointer = withPublicWord stackGuardSlot (bitCoerce stackGuard) + +contextWord :: Address -> Address +contextWord index = contextAddr + 4 * index + +expandConstant :: Int -> Word +expandConstant 0 = 0x61707865 +expandConstant 1 = 0x3320646e +expandConstant 2 = 0x79622d32 +expandConstant _ = 0x6b206574 + +withConstants :: RelState -> SymFC.Sym RelState +withConstants st = + withPublicWord (contextWord 0) (expandConstant 0) st + >>= withPublicWord (contextWord 1) (expandConstant 1) + >>= withPublicWord (contextWord 2) (expandConstant 2) + >>= withPublicWord (contextWord 3) (expandConstant 3) + +data SecretKey = SecretKey Word Word Word Word Word Word Word Word + +freshSecretKey :: SymFC.Sym SecretKey +freshSecretKey = + SecretKey + <$> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + +withSecretKeys :: SecretKey -> SecretKey -> RelState -> SymFC.Sym RelState +withSecretKeys (SecretKey ka0 ka1 ka2 ka3 ka4 ka5 ka6 ka7) (SecretKey kb0 kb1 kb2 kb3 kb4 kb5 kb6 kb7) st = + withSecretWord (contextWord 4) ka0 kb0 st + >>= withSecretWord (contextWord 5) ka1 kb1 + >>= withSecretWord (contextWord 6) ka2 kb2 + >>= withSecretWord (contextWord 7) ka3 kb3 + >>= withSecretWord (contextWord 8) ka4 kb4 + >>= withSecretWord (contextWord 9) ka5 kb5 + >>= withSecretWord (contextWord 10) ka6 kb6 + >>= withSecretWord (contextWord 11) ka7 kb7 + +encryptCall :: Fuel -> Rel Word -> SymFC.Sym Verdict +encryptCall fuel lengthLow = do + isa <- SymFC.fresh @IsaSys + keyA <- freshSecretKey + keyB <- freshSecretKey + let start = (sameState chachaEncryptCode isa) {relPc = chachaEncryptEntry} + ready <- + withArguments lengthLow start + >>= withConstants + >>= withSecretKeys keyA keyB + >>= withStackGuardPointer + relRun fuel ready + +encryptBlock :: Fuel -> SymFC.Sym Verdict +encryptBlock fuel = encryptCall fuel (Same blockBytes) + +encryptSecretLength :: SymFC.Sym Verdict +encryptSecretLength = do + lengthA <- SymFC.fresh @Word + lengthB <- SymFC.fresh @Word + encryptCall oneBlockSteps (Pair lengthA lengthB) + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt + +shortTailCheck :: Address +shortTailCheck = 0x111d0 + +{-# ANN chachaBlockNoLeak (SymFC ['stepperEmbeddings]) #-} +chachaBlockNoLeak :: SymFC.Sym () +chachaBlockNoLeak = expectNoLeak $ encryptBlock oneBlockSteps + +{-# ANN chachaShortRunOutOfFuel (SymFC ['stepperEmbeddings]) #-} +chachaShortRunOutOfFuel :: SymFC.Sym () +chachaShortRunOutOfFuel = expectOutOfFuel $ encryptBlock tooFewSteps + +{-# ANN chachaOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +chachaOneStepShortOutOfFuel :: SymFC.Sym () +chachaOneStepShortOutOfFuel = expectOutOfFuel $ encryptBlock oneStepShort + +{-# ANN chachaSecretLengthLeaks (SymFC ['stepperEmbeddings]) #-} +chachaSecretLengthLeaks :: SymFC.Sym () +chachaSecretLengthLeaks = expectLeakAt shortTailCheck encryptSecretLength + +{-# ANN chachaDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +chachaDecodeAgrees :: SymFC.Sym () +chachaDecodeAgrees = expectDecodeAgreement [chachaEncryptDecoded] + +{-# ANN chachaFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +chachaFetchesByAddress :: SymFC.Sym () +chachaFetchesByAddress = expectFetchByAddress [chachaEncryptCode] + +{-# ANN chachaDecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +chachaDecodeRejectsWrongInstruction :: SymFC.Sym () +chachaDecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction chachaEncryptDecoded] diff --git a/proof/Proof/SMT/Stepper/Invariant.hs b/proof/Proof/SMT/Stepper/Invariant.hs new file mode 100644 index 0000000..f3eeff5 --- /dev/null +++ b/proof/Proof/SMT/Stepper/Invariant.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} + +module Proof.SMT.Stepper.Invariant + ( relStepKeepsInvariant + , relStepKeepsInvariantAtLastWord + , relStepKeepsInvariantWithoutHint + , relStepWrongHintFails + , relStepSwappedRunsFails + ) where + +import Core.ISA (IsaStateG (..), PC, StepG (..), isaStep) +import Memory.Types (MemOps (..)) +import Proof.SMT.Stepper.Relational +import Core.RegFile (RegFileOps (..)) +import Stepper (IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.Memory (Memory) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) +import Proof.Core.Leakage.Model (Leak (..), leakOf) + +codeAddrs :: [Address] +codeAddrs = [0, 4, 8] + +-- | A fold over a literal list becomes 'elem', which SymFC cannot unfold. +everyCodeAddr :: (Address -> Bool) -> Bool +everyCodeAddr holds = holds 0 && holds 4 && holds 8 + +middlePc :: PC +middlePc = 4 + +lastPc :: PC +lastPc = 8 + +-- | Where a reached state stands and how it fetches: through a hint, as after +-- a fall-through, or through the code table, as after a jump. +data Start = Start + { startPc :: PC + , startHint :: Code -> Maybe Fetched + } + +hintedAt :: PC -> Start +hintedAt pc = Start pc (`codeFetch` pc) + +unhintedAt :: PC -> Start +unhintedAt pc = Start pc (const Nothing) + +storedWordAddr :: Address +storedWordAddr = 0x100 + +storedByteAddr :: Address +storedByteAddr = 0x105 + +fetchFrom :: Memory 32 8 -> Address -> Maybe Fetched -> Fetched +fetchFrom mem addr following = (fetchedFromMemory addr (memReadWord addr mem)) {fetchedFollowing = following} + +linkedCode :: Memory 32 8 -> Code +linkedCode mem = + Code + { codeFetch = \pc -> if pc == 0 then Just atZero else if pc == 4 then Just atFour else if pc == 8 then Just atEight else Nothing + , codeAddresses = KnownAddresses codeAddrs + , codeSpan = Just (0, 12) + } + where + atEight = fetchFrom mem 8 Nothing + atFour = fetchFrom mem 4 (Just atEight) + atZero = fetchFrom mem 0 (Just atFour) + +-- | Two ISA states and a 'RelState' that stands for them, in the shape a +-- state has after some steps: a fetch hint, a register written through an +-- unknown index, pending whole-word and byte writes, and a path condition. +data Reached = Reached + { reachedFirst :: IsaSys + , reachedSecond :: IsaSys + , reachedState :: RelState + } + +data History = History + { historyReg :: RegIdx + , historyRegValues :: Rel Word + , historyWords :: Rel Word + , historyBytes :: Rel Word + } + +freshHistory :: SymFC.Sym History +freshHistory = do + reg <- SymFC.fresh @RegIdx + regValues <- Pair <$> SymFC.fresh @Word <*> SymFC.fresh @Word + storedWords <- Pair <$> SymFC.fresh @Word <*> SymFC.fresh @Word + bytes <- Pair <$> SymFC.fresh @Word <*> SymFC.fresh @Word + pure (History reg regValues storedWords bytes) + +replayOn :: PC -> Run -> History -> IsaSys -> IsaSys +replayOn pc run history isa = + isa + { isaPc = pc + , isaRegFile = modifyRFg (historyReg history) (valueIn run (historyRegValues history)) (isaRegFile isa) + , isaMem = + memWrite storedByteAddr Byte (valueIn run (historyBytes history)) $ + memWrite storedWordAddr Word (valueIn run (historyWords history)) (isaMem isa) + } + +replayOnState :: History -> RelState -> SymFC.Sym RelState +replayOnState history st = do + slot <- slotFor (historyReg history) + mem <- + writeMem (relPath st) Word storedWordAddr (historyWords history) (relMem st) + >>= writeMem (relPath st) Byte storedByteAddr (historyBytes history) + pure st {relRegs = writeSlot slot (historyRegValues history) (relRegs st), relMem = mem} + +freshReached :: Start -> SymFC.Sym Reached +freshReached (Start pc hintFrom) = do + first0 <- SymFC.fresh @IsaSys + second0 <- SymFC.fresh @IsaSys + path <- SymFC.fresh @Bool + history <- freshHistory + let first = replayOn pc FirstRun history first0 + second = replayOn pc SecondRun history second0 + code = linkedCode (isaMem first) + start = (pairState code first0 second0) {relPath = path && checkable code first second, relPc = pc, relFetchHint = hintFrom code} + st <- replayOnState history start + pure (Reached first second st) + +storesIntoCode :: Code -> IsaSys -> Bool +storesIntoCode code isa = case leakOf isa of + LStore size addr -> writesCode code size addr + _ -> False + +-- | The steps the checker must follow rather than stop at: both runs hold the +-- same code and leak the same, and the step leaves the code alone. +checkable :: Code -> IsaSys -> IsaSys -> Bool +checkable code first second = + everyCodeAddr (sameWordAt first second) + && leakOf first == leakOf second + && not (storesIntoCode code first) + +codeIntact :: Run -> Code -> RelState -> Bool +codeIntact run code st = everyCodeAddr \addr -> maybe True (fetchIntact mem addr) (codeFetch code addr) + where + mem = memoryIn run (relMem st) + +fetchIntact :: Memory 32 8 -> Address -> Fetched -> Bool +fetchIntact mem pc f = fetchedAddress f == pc && fetchedWord f == memReadWord pc mem + +hintIntact :: Run -> RelState -> Bool +hintIntact run st = case relFetchHint st of + Nothing -> True + Just hint -> fetchIntact mem pc hint && maybe True (fetchIntact mem (pc + 4)) (fetchedFollowing hint) + where + mem = memoryIn run (relMem st) + pc = relPc st + +keepsInvariant :: Run -> Probe -> Code -> RelState -> IsaSys -> Bool +keepsInvariant run probe code st isa = + matchesState run probe st isa && codeIntact run code st && hintIntact run st + +outsideCode :: PC -> Bool +outsideCode pc = everyCodeAddr (pc /=) + +anyBranch :: (RelOutcome -> Bool) -> [RelOutcome] -> Bool +anyBranch _ [] = False +anyBranch holds (branch : rest) = holds branch || anyBranch holds rest + +everyBranch :: (RelOutcome -> Bool) -> [RelOutcome] -> Bool +everyBranch _ [] = True +everyBranch holds (branch : rest) = holds branch && everyBranch holds rest + +followsRun :: Run -> Probe -> IsaSys -> RelOutcome -> Bool +followsRun run probe isa outcome = case outcome of + RelNext st -> relPath st && matchesState run probe st isa + RelFork branches -> anyBranch (followsRun run probe isa) branches + RelOutsideCode -> outsideCode (isaPc isa) + _ -> False + +everyBranchKeeps :: Run -> Probe -> Code -> IsaSys -> RelOutcome -> Bool +everyBranchKeeps run probe code isa outcome = case outcome of + RelNext st -> not (relPath st) || keepsInvariant run probe code st isa + RelFork branches -> everyBranch (everyBranchKeeps run probe code isa) branches + RelOutsideCode -> True + _ -> False + +stepKeepsInvariant :: Run -> Probe -> Code -> IsaSys -> RelOutcome -> Bool +stepKeepsInvariant run probe code isa outcome = case (outcome, isaStep isa) of + (RelHalted, IsaHalted) -> True + (_, Next isa') -> followsRun run probe isa' outcome && everyBranchKeeps run probe code isa' outcome + _ -> False + +bothRunsKeepInvariant :: (Reached -> (IsaSys, IsaSys)) -> Probe -> Reached -> RelOutcome -> Bool +bothRunsKeepInvariant runsOf probe reached outcome = + stepKeepsInvariant FirstRun probe code first outcome + && stepKeepsInvariant SecondRun probe code second outcome + where + code = relCode (reachedState reached) + (first, second) = runsOf reached + +inOrder :: Reached -> (IsaSys, IsaSys) +inOrder reached = (reachedFirst reached, reachedSecond reached) + +swapped :: Reached -> (IsaSys, IsaSys) +swapped reached = (reachedSecond reached, reachedFirst reached) + +checkFromReached :: Start -> SymFC.Sym Bool +checkFromReached = checkRunsFromReached inOrder + +checkRunsFromReached :: (Reached -> (IsaSys, IsaSys)) -> Start -> SymFC.Sym Bool +checkRunsFromReached runsOf start = do + reached <- freshReached start + probe <- freshProbe + outcome <- relStep (reachedState reached) + pure $ not (relPath (reachedState reached)) || bothRunsKeepInvariant runsOf probe reached outcome + +{-# ANN relStepKeepsInvariant (SymFC ['stepperEmbeddings]) #-} +relStepKeepsInvariant :: SymFC.Sym () +relStepKeepsInvariant = expectValid =<< checkFromReached (hintedAt middlePc) + +{-# ANN relStepKeepsInvariantAtLastWord (SymFC ['stepperEmbeddings]) #-} +relStepKeepsInvariantAtLastWord :: SymFC.Sym () +relStepKeepsInvariantAtLastWord = expectValid =<< checkFromReached (hintedAt lastPc) + +{-# ANN relStepKeepsInvariantWithoutHint (SymFC ['stepperEmbeddings]) #-} +relStepKeepsInvariantWithoutHint :: SymFC.Sym () +relStepKeepsInvariantWithoutHint = expectValid =<< checkFromReached (unhintedAt middlePc) + +{-# ANN relStepWrongHintFails (SymFC ['stepperEmbeddings]) #-} +relStepWrongHintFails :: SymFC.Sym () +relStepWrongHintFails = expectCounterexample =<< checkFromReached (Start middlePc wrongHint) + where + wrongHint code = (\atEight -> atEight {fetchedAddress = middlePc}) <$> codeFetch code 8 + +{-# ANN relStepSwappedRunsFails (SymFC ['stepperEmbeddings]) #-} +relStepSwappedRunsFails :: SymFC.Sym () +relStepSwappedRunsFails = expectCounterexample =<< checkRunsFromReached swapped (hintedAt middlePc) diff --git a/proof/Proof/SMT/Stepper/Memcmp.hs b/proof/Proof/SMT/Stepper/Memcmp.hs new file mode 100644 index 0000000..f18b34f --- /dev/null +++ b/proof/Proof/SMT/Stepper/Memcmp.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.Memcmp + ( memcmpLeaks + , sodiumMemcmpNoLeak + , sodiumMemcmpShortRunOutOfFuel + , memcmpFetchesKnownWords + , sodiumMemcmpFetchesKnownWords + , memcmpFetchRejectsWrongWord + , memcmpDecodeAgrees + , memcmpFetchesByAddress + , memcmpDecodeRejectsWrongInstruction + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_vuln_memcmp" + [ ("memcmp", ["memcmp"]) + , ("sodiumMemcmp", ["sodium_memcmp", "_sodium_dummy_symbol_to_prevent_memcmp_lto"]) + ]) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +stepLimit :: Fuel +stepLimit = steps 200 + +tooFewSteps :: Fuel +tooFewSteps = steps 20 + +secretBuf, publicBuf, stackTop, returnOutsideCode :: Address +secretBuf = 0x1000 +publicBuf = 0x2000 +stackTop = 0x8000 +returnOutsideCode = 0 + +bufLen :: Word +bufLen = 8 + +ra, sp, a0, a1, a2 :: RegIdx +ra = 1 +sp = 2 +a0 = 10 +a1 = 11 +a2 = 12 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +withArguments :: RelState -> SymFC.Sym RelState +withArguments st = do + regs <- + writeReg a0 (pointer secretBuf) + =<< writeReg a1 (pointer publicBuf) + =<< writeReg a2 (Same bufLen) + =<< writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) (relRegs st) + pure st {relRegs = regs} + +data SecretBuffer = SecretBuffer Word Word Word Word + +freshSecretBuffer :: SymFC.Sym SecretBuffer +freshSecretBuffer = + SecretBuffer + <$> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + <*> SymFC.fresh @Word + +withSecretBuffer :: SecretBuffer -> RelState -> SymFC.Sym RelState +withSecretBuffer (SecretBuffer lowA lowB highA highB) st = + withSecretWord secretBuf lowA lowB st >>= withSecretWord (secretBuf + 4) highA highB + +callFunction :: Fuel -> Code -> Address -> SymFC.Sym Verdict +callFunction fuel code entry = do + isa <- SymFC.fresh @IsaSys + secret <- freshSecretBuffer + let start = (sameState code isa) {relPc = entry} + relRun fuel =<< withSecretBuffer secret =<< withArguments start + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt + +memcmpWordCompare :: Address +memcmpWordCompare = 0x442f0 + +{-# ANN memcmpLeaks (SymFC ['stepperEmbeddings]) #-} +memcmpLeaks :: SymFC.Sym () +memcmpLeaks = expectLeakAt memcmpWordCompare $ callFunction stepLimit memcmpCode memcmpEntry + +{-# ANN sodiumMemcmpNoLeak (SymFC ['stepperEmbeddings]) #-} +sodiumMemcmpNoLeak :: SymFC.Sym () +sodiumMemcmpNoLeak = expectNoLeak $ callFunction stepLimit sodiumMemcmpCode sodiumMemcmpEntry + +{-# ANN sodiumMemcmpShortRunOutOfFuel (SymFC ['stepperEmbeddings]) #-} +sodiumMemcmpShortRunOutOfFuel :: SymFC.Sym () +sodiumMemcmpShortRunOutOfFuel = expectOutOfFuel $ callFunction tooFewSteps sodiumMemcmpCode sodiumMemcmpEntry + +expectFetch :: Code -> Address -> Word -> SymFC.Sym () +expectFetch code addr expectedWord = case codeFetch code addr of + Just here | fetchedWord here == expectedWord -> pure () + _ -> SymFC.halt + +expectNoFetchOf :: Code -> Address -> Word -> SymFC.Sym () +expectNoFetchOf code addr unexpectedWord = case codeFetch code addr of + Just here | fetchedWord here == unexpectedWord -> SymFC.halt + _ -> pure () + +{-# ANN memcmpFetchesKnownWords (SymFC ['stepperEmbeddings]) #-} +memcmpFetchesKnownWords :: SymFC.Sym () +memcmpFetchesKnownWords = do + expectFetch memcmpCode memcmpEntry 0x00300693 + expectFetch memcmpCode memcmpWordCompare 0x00f71c63 + +{-# ANN sodiumMemcmpFetchesKnownWords (SymFC ['stepperEmbeddings]) #-} +sodiumMemcmpFetchesKnownWords :: SymFC.Sym () +sodiumMemcmpFetchesKnownWords = do + expectFetch sodiumMemcmpCode sodiumMemcmpEntry 0xfd010113 + expectFetch sodiumMemcmpCode (sodiumMemcmpEntry + 4) 0x02812423 + +{-# ANN memcmpFetchRejectsWrongWord (SymFC ['stepperEmbeddings]) #-} +memcmpFetchRejectsWrongWord :: SymFC.Sym () +memcmpFetchRejectsWrongWord = expectNoFetchOf memcmpCode memcmpEntry 0x00300694 + +{-# ANN memcmpDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +memcmpDecodeAgrees :: SymFC.Sym () +memcmpDecodeAgrees = expectDecodeAgreement [memcmpDecoded, sodiumMemcmpDecoded] + +{-# ANN memcmpFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +memcmpFetchesByAddress :: SymFC.Sym () +memcmpFetchesByAddress = expectFetchByAddress [memcmpCode, sodiumMemcmpCode] + +{-# ANN memcmpDecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +memcmpDecodeRejectsWrongInstruction :: SymFC.Sym () +memcmpDecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction memcmpDecoded, sodiumMemcmpDecoded] diff --git a/proof/Proof/SMT/Stepper/P256Call.hs b/proof/Proof/SMT/Stepper/P256Call.hs new file mode 100644 index 0000000..b9e065f --- /dev/null +++ b/proof/Proof/SMT/Stepper/P256Call.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.P256Call + ( decimalSteps + , pointer + , callAt + , withSecretWords + , withPublicWords + , withKnownWords + , expectNoLeak + , expectLeakAt + , expectOutOfFuel + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +plusFuel :: Fuel -> Fuel -> Fuel +plusFuel Done later = later +plusFuel (More fuel) later = More (plusFuel fuel later) + +tenfold :: Fuel -> Fuel +tenfold fuel = plusFuel eightfold twofold + where + twofold = plusFuel fuel fuel + fourfold = plusFuel twofold twofold + eightfold = plusFuel fourfold fourfold + +decimalSteps :: [Int] -> Fuel +decimalSteps = digitsAfter Done + where + digitsAfter sofar [] = sofar + digitsAfter sofar (digit : rest) = digitsAfter (plusFuel (steps digit) (tenfold sofar)) rest + +stackTop, returnOutsideCode, wordBytes :: Address +stackTop = 0x8000 +returnOutsideCode = 0 +wordBytes = 4 + +ra, sp, firstArgument :: RegIdx +ra = 1 +sp = 2 +firstArgument = 10 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +withArgumentsFrom :: RegIdx -> [Rel Word] -> RelRegs -> SymFC.Sym RelRegs +withArgumentsFrom _ [] regs = pure regs +withArgumentsFrom reg (argument : rest) regs = withArgumentsFrom (reg + 1) rest =<< writeReg reg argument regs + +callAt :: Code -> Address -> [Rel Word] -> SymFC.Sym RelState +callAt code entry arguments = do + isa <- SymFC.fresh @IsaSys + let start = (sameState code isa) {relPc = entry} + regs <- + writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) + =<< withArgumentsFrom firstArgument arguments (relRegs start) + pure start {relRegs = regs} + +withSecretWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withSecretWords _ 0 st = pure st +withSecretWords base count st = do + wordA <- SymFC.fresh @Word + wordB <- SymFC.fresh @Word + next <- withSecretWord base wordA wordB st + withSecretWords (base + wordBytes) (count - 1) next + +withPublicWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withPublicWords _ 0 st = pure st +withPublicWords base count st = do + value <- SymFC.fresh @Word + mem <- writeMem (relPath st) Word base (Same value) (relMem st) + withPublicWords (base + wordBytes) (count - 1) st {relMem = mem} + +withKnownWords :: Address -> [Word] -> RelState -> SymFC.Sym RelState +withKnownWords _ [] st = pure st +withKnownWords base (value : rest) st = do + mem <- writeMem (relPath st) Word base (Same value) (relMem st) + withKnownWords (base + wordBytes) rest st {relMem = mem} + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt diff --git a/proof/Proof/SMT/Stepper/P256Field.hs b/proof/Proof/SMT/Stepper/P256Field.hs new file mode 100644 index 0000000..beefa0d --- /dev/null +++ b/proof/Proof/SMT/Stepper/P256Field.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.P256Field + ( p256CompareUnoptimisedNoLeak + , p256CompareUnoptimisedOneStepShortOutOfFuel + , p256CompareOptimisedNoLeak + , p256CompareOptimisedOneStepShortOutOfFuel + , p256CondSubUnoptimisedNoLeak + , p256CondSubUnoptimisedOneStepShortOutOfFuel + , p256CondCopyUnoptimisedNoLeak + , p256CondCopyUnoptimisedOneStepShortOutOfFuel + , p256MontReduceUnoptimisedNoLeak + , p256MontReduceUnoptimisedOneStepShortOutOfFuel + , p256MontReduceOptimisedNoLeak + , p256MontReduceOptimisedOneStepShortOutOfFuel + , p256FieldUnoptimisedDecodeAgrees + , p256FieldUnoptimisedFetchesByAddress + , p256FieldOptimisedDecodeAgrees + , p256FieldOptimisedFetchesByAddress + , p256UnoptimisedDecodeRejectsWrongInstruction + , p256OptimisedDecodeRejectsWrongInstruction + ) where + +import Proof.SMT.Stepper.P256Call +import Stepper (Fuel) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import Stepper.Concrete (stepperEmbeddings) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_ecdsa_sha256_O0" + [ ("compareUnoptimised", ["sp_256_cmp_9"]) + , ("condSubUnoptimised", ["sp_256_cond_sub_9"]) + , ("condCopyUnoptimised", ["sp_256_cond_copy_9"]) + , ("montReduceUnoptimised", ["sp_256_mont_reduce_9"]) + ]) + +$(elfCode "benchmark/bench_ecdsa_sha256_O3" + [ ("compareOptimised", ["sp_256_cmp_9"]) + , ("montReduceOptimised", ["sp_256_mont_reduce_9.constprop.0"]) + ]) + +leftAddr, rightAddr, resultAddr :: Address +leftAddr = 0x1000 +rightAddr = 0x2000 +resultAddr = 0x3000 + +fieldLimbs, productLimbs :: Int +fieldLimbs = 9 +productLimbs = 18 + +unoptimisedModulus :: Address +unoptimisedModulus = 0x45e34 + +montgomeryFactorOfModulus :: Word +montgomeryFactorOfModulus = 1 + +secretWord :: SymFC.Sym (Rel Word) +secretWord = Pair <$> SymFC.fresh @Word <*> SymFC.fresh @Word + +compareCall :: Code -> Address -> Fuel -> SymFC.Sym Verdict +compareCall code entry fuel = do + start <- callAt code entry [pointer leftAddr, pointer rightAddr] + withLeft <- withSecretWords leftAddr fieldLimbs start + withRight <- withSecretWords rightAddr fieldLimbs withLeft + relRun fuel withRight + +condSubCall :: Fuel -> SymFC.Sym Verdict +condSubCall fuel = do + mask <- secretWord + start <- callAt condSubUnoptimisedCode condSubUnoptimisedEntry [pointer resultAddr, pointer leftAddr, pointer rightAddr, mask] + withLeft <- withSecretWords leftAddr fieldLimbs start + withRight <- withSecretWords rightAddr fieldLimbs withLeft + relRun fuel withRight + +condCopyCall :: Fuel -> SymFC.Sym Verdict +condCopyCall fuel = do + mask <- secretWord + start <- callAt condCopyUnoptimisedCode condCopyUnoptimisedEntry [pointer resultAddr, pointer leftAddr, mask] + withSource <- withSecretWords leftAddr fieldLimbs start + withTarget <- withSecretWords resultAddr fieldLimbs withSource + relRun fuel withTarget + +montReduceUnoptimisedCall :: Fuel -> SymFC.Sym Verdict +montReduceUnoptimisedCall fuel = do + start <- + callAt + montReduceUnoptimisedCode + montReduceUnoptimisedEntry + [pointer leftAddr, pointer unoptimisedModulus, Same montgomeryFactorOfModulus] + withProduct <- withSecretWords leftAddr productLimbs start + relRun fuel withProduct + +montReduceOptimisedCall :: Fuel -> SymFC.Sym Verdict +montReduceOptimisedCall fuel = do + start <- callAt montReduceOptimisedCode montReduceOptimisedEntry [pointer leftAddr] + withProduct <- withSecretWords leftAddr productLimbs start + relRun fuel withProduct + +{-# ANN p256CompareUnoptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256CompareUnoptimisedNoLeak :: SymFC.Sym () +p256CompareUnoptimisedNoLeak = + expectNoLeak $ compareCall compareUnoptimisedCode compareUnoptimisedEntry (decimalSteps [1, 4, 2]) + +{-# ANN p256CompareUnoptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256CompareUnoptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256CompareUnoptimisedOneStepShortOutOfFuel = + expectOutOfFuel $ compareCall compareUnoptimisedCode compareUnoptimisedEntry (decimalSteps [1, 4, 1]) + +{-# ANN p256CompareOptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256CompareOptimisedNoLeak :: SymFC.Sym () +p256CompareOptimisedNoLeak = + expectNoLeak $ compareCall compareOptimisedCode compareOptimisedEntry (decimalSteps [6, 9]) + +{-# ANN p256CompareOptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256CompareOptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256CompareOptimisedOneStepShortOutOfFuel = + expectOutOfFuel $ compareCall compareOptimisedCode compareOptimisedEntry (decimalSteps [6, 8]) + +{-# ANN p256CondSubUnoptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256CondSubUnoptimisedNoLeak :: SymFC.Sym () +p256CondSubUnoptimisedNoLeak = expectNoLeak $ condSubCall (decimalSteps [1, 1, 9]) + +{-# ANN p256CondSubUnoptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256CondSubUnoptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256CondSubUnoptimisedOneStepShortOutOfFuel = expectOutOfFuel $ condSubCall (decimalSteps [1, 1, 8]) + +{-# ANN p256CondCopyUnoptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256CondCopyUnoptimisedNoLeak :: SymFC.Sym () +p256CondCopyUnoptimisedNoLeak = expectNoLeak $ condCopyCall (decimalSteps [1, 7, 1]) + +{-# ANN p256CondCopyUnoptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256CondCopyUnoptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256CondCopyUnoptimisedOneStepShortOutOfFuel = expectOutOfFuel $ condCopyCall (decimalSteps [1, 7, 0]) + +{-# ANN p256MontReduceUnoptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256MontReduceUnoptimisedNoLeak :: SymFC.Sym () +p256MontReduceUnoptimisedNoLeak = expectNoLeak $ montReduceUnoptimisedCall (decimalSteps [1, 7, 5, 7]) + +{-# ANN p256MontReduceUnoptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256MontReduceUnoptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256MontReduceUnoptimisedOneStepShortOutOfFuel = + expectOutOfFuel $ montReduceUnoptimisedCall (decimalSteps [1, 7, 5, 6]) + +{-# ANN p256MontReduceOptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256MontReduceOptimisedNoLeak :: SymFC.Sym () +p256MontReduceOptimisedNoLeak = expectNoLeak $ montReduceOptimisedCall (decimalSteps [4, 6, 9]) + +{-# ANN p256MontReduceOptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256MontReduceOptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256MontReduceOptimisedOneStepShortOutOfFuel = + expectOutOfFuel $ montReduceOptimisedCall (decimalSteps [4, 6, 8]) + +{-# ANN p256FieldUnoptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256FieldUnoptimisedDecodeAgrees :: SymFC.Sym () +p256FieldUnoptimisedDecodeAgrees = expectDecodeAgreement [compareUnoptimisedDecoded, condSubUnoptimisedDecoded, condCopyUnoptimisedDecoded, montReduceUnoptimisedDecoded] + +{-# ANN p256FieldUnoptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256FieldUnoptimisedFetchesByAddress :: SymFC.Sym () +p256FieldUnoptimisedFetchesByAddress = expectFetchByAddress [compareUnoptimisedCode, condSubUnoptimisedCode, condCopyUnoptimisedCode, montReduceUnoptimisedCode] + +{-# ANN p256FieldOptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256FieldOptimisedDecodeAgrees :: SymFC.Sym () +p256FieldOptimisedDecodeAgrees = expectDecodeAgreement [compareOptimisedDecoded, montReduceOptimisedDecoded] + +{-# ANN p256FieldOptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256FieldOptimisedFetchesByAddress :: SymFC.Sym () +p256FieldOptimisedFetchesByAddress = expectFetchByAddress [compareOptimisedCode, montReduceOptimisedCode] + +{-# ANN p256UnoptimisedDecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +p256UnoptimisedDecodeRejectsWrongInstruction :: SymFC.Sym () +p256UnoptimisedDecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction compareUnoptimisedDecoded, condSubUnoptimisedDecoded, condCopyUnoptimisedDecoded, montReduceUnoptimisedDecoded] + +{-# ANN p256OptimisedDecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +p256OptimisedDecodeRejectsWrongInstruction :: SymFC.Sym () +p256OptimisedDecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction compareOptimisedDecoded, montReduceOptimisedDecoded] diff --git a/proof/Proof/SMT/Stepper/P256Multiply.hs b/proof/Proof/SMT/Stepper/P256Multiply.hs new file mode 100644 index 0000000..ed9d549 --- /dev/null +++ b/proof/Proof/SMT/Stepper/P256Multiply.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.P256Multiply + ( p256MulUnoptimisedSecretRightLeaks + , p256MulUnoptimisedSecretLeftNoLeak + , p256MulUnoptimisedSecretLeftOneStepShortOutOfFuel + , p256MulOptimisedSecretRightLeaks + , p256MulOptimisedSecretLeftLeaks + , p256SqrUnoptimisedLeaks + , p256SqrOptimisedLeaks + , p256MontReduceOrderUnoptimisedLeaks + , p256MontReduceOrderOptimisedNoLeak + , p256MontReduceOrderOptimisedOneStepShortOutOfFuel + , p256MultiplyUnoptimisedDecodeAgrees + , p256MultiplyUnoptimisedFetchesByAddress + , p256MultiplyOptimisedDecodeAgrees + , p256MultiplyOptimisedFetchesByAddress + ) where + +import Proof.SMT.Stepper.P256Call +import Stepper (Fuel) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_ecdsa_sha256_O0" + [ ("mulUnoptimised", ["sp_256_mul_9", "__muldi3", "memcpy"]) + , ("sqrUnoptimised", ["sp_256_sqr_9", "__muldi3", "memcpy"]) + , ( "montReduceOrderUnoptimised" + , [ "sp_256_mont_reduce_order_9" + , "__mulsi3" + , "sp_256_cond_sub_9" + , "sp_256_mont_shift_9" + , "memset" + , "sp_256_mul_add_9" + , "__muldi3" + , "sp_256_norm_9" + ] + ) + ]) + +$(elfCode "benchmark/bench_ecdsa_sha256_O3" + [ ("mulOptimised", ["sp_256_mul_9", "__muldi3", "memcpy"]) + , ("sqrOptimised", ["sp_256_sqr_9", "__muldi3", "memcpy"]) + , ( "montReduceOrderOptimised" + , [ "sp_256_mont_reduce_order_9.constprop.0" + , "sp_256_mul_add_9.constprop.0" + , "__muldi3" + , "sp_256_norm_9" + ] + ) + ]) + +leftAddr, rightAddr, resultAddr :: Address +leftAddr = 0x1000 +rightAddr = 0x2000 +resultAddr = 0x3000 + +fieldLimbs, productLimbs :: Int +fieldLimbs = 9 +productLimbs = 18 + +curveConstantB :: [Word] +curveConstantB = + [0x7d2604b, 0x1e71e1f1, 0x14ec3d8e, 0x1a0d6198, 0x86bc651, 0x1eaabb4c, 0xf9ecfae, 0x1b154752, 0x5ac635] + +unoptimisedOrder :: Address +unoptimisedOrder = 0x45e7c + +montgomeryFactorOfOrder :: Word +montgomeryFactorOfOrder = 0xe00bc4f + +unoptimisedMulSteps, unoptimisedSqrSteps, unoptimisedReduceOrderSteps :: Fuel +unoptimisedMulSteps = decimalSteps [5, 2, 1, 7, 7] +unoptimisedSqrSteps = decimalSteps [2, 9, 2, 8, 7] +unoptimisedReduceOrderSteps = decimalSteps [5, 8, 3, 0, 3] + +optimisedMulSteps, optimisedSqrSteps, optimisedReduceOrderSteps :: Fuel +optimisedMulSteps = decimalSteps [1, 7, 7, 6, 8] +optimisedSqrSteps = decimalSteps [1, 0, 0, 2, 3] +optimisedReduceOrderSteps = decimalSteps [1, 1, 8, 8, 9] + +unoptimisedMulSecretLeftShort, optimisedReduceOrderShort :: Fuel +unoptimisedMulSecretLeftShort = decimalSteps [5, 2, 1, 7, 6] +optimisedReduceOrderShort = decimalSteps [1, 1, 8, 8, 8] + +firstUnoptimisedTableLoad, firstOptimisedTableLoad :: Address +firstUnoptimisedTableLoad = 0x1b2d4 +firstOptimisedTableLoad = 0x21ca8 + +mulSecretRight :: Code -> Address -> Fuel -> SymFC.Sym Verdict +mulSecretRight code entry fuel = do + start <- callAt code entry [pointer resultAddr, pointer leftAddr, pointer rightAddr] + withLeft <- withPublicWords leftAddr fieldLimbs start + withRight <- withSecretWords rightAddr fieldLimbs withLeft + relRun fuel withRight + +mulSecretLeftByCurveConstant :: Code -> Address -> Fuel -> SymFC.Sym Verdict +mulSecretLeftByCurveConstant code entry fuel = do + start <- callAt code entry [pointer resultAddr, pointer leftAddr, pointer rightAddr] + withLeft <- withSecretWords leftAddr fieldLimbs start + withRight <- withKnownWords rightAddr curveConstantB withLeft + relRun fuel withRight + +sqrSecret :: Code -> Address -> Fuel -> SymFC.Sym Verdict +sqrSecret code entry fuel = do + start <- callAt code entry [pointer resultAddr, pointer leftAddr] + withInput <- withSecretWords leftAddr fieldLimbs start + relRun fuel withInput + +montReduceOrderUnoptimisedCall :: Fuel -> SymFC.Sym Verdict +montReduceOrderUnoptimisedCall fuel = do + start <- + callAt + montReduceOrderUnoptimisedCode + montReduceOrderUnoptimisedEntry + [pointer leftAddr, pointer unoptimisedOrder, Same montgomeryFactorOfOrder] + withProduct <- withSecretWords leftAddr productLimbs start + relRun fuel withProduct + +montReduceOrderOptimisedCall :: Fuel -> SymFC.Sym Verdict +montReduceOrderOptimisedCall fuel = do + start <- callAt montReduceOrderOptimisedCode montReduceOrderOptimisedEntry [pointer leftAddr] + withProduct <- withSecretWords leftAddr productLimbs start + relRun fuel withProduct + +{-# ANN p256MulUnoptimisedSecretRightLeaks (SymFC ['stepperEmbeddings]) #-} +p256MulUnoptimisedSecretRightLeaks :: SymFC.Sym () +p256MulUnoptimisedSecretRightLeaks = + expectLeakAt firstUnoptimisedTableLoad $ + mulSecretRight mulUnoptimisedCode mulUnoptimisedEntry unoptimisedMulSteps + +{-# ANN p256MulUnoptimisedSecretLeftNoLeak (SymFC ['stepperEmbeddings]) #-} +p256MulUnoptimisedSecretLeftNoLeak :: SymFC.Sym () +p256MulUnoptimisedSecretLeftNoLeak = + expectNoLeak $ mulSecretLeftByCurveConstant mulUnoptimisedCode mulUnoptimisedEntry unoptimisedMulSteps + +{-# ANN p256MulUnoptimisedSecretLeftOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256MulUnoptimisedSecretLeftOneStepShortOutOfFuel :: SymFC.Sym () +p256MulUnoptimisedSecretLeftOneStepShortOutOfFuel = + expectOutOfFuel $ mulSecretLeftByCurveConstant mulUnoptimisedCode mulUnoptimisedEntry unoptimisedMulSecretLeftShort + +{-# ANN p256MulOptimisedSecretRightLeaks (SymFC ['stepperEmbeddings]) #-} +p256MulOptimisedSecretRightLeaks :: SymFC.Sym () +p256MulOptimisedSecretRightLeaks = + expectLeakAt firstOptimisedTableLoad $ + mulSecretRight mulOptimisedCode mulOptimisedEntry optimisedMulSteps + +{-# ANN p256MulOptimisedSecretLeftLeaks (SymFC ['stepperEmbeddings]) #-} +p256MulOptimisedSecretLeftLeaks :: SymFC.Sym () +p256MulOptimisedSecretLeftLeaks = + expectLeakAt firstOptimisedTableLoad $ + mulSecretLeftByCurveConstant mulOptimisedCode mulOptimisedEntry optimisedMulSteps + +{-# ANN p256SqrUnoptimisedLeaks (SymFC ['stepperEmbeddings]) #-} +p256SqrUnoptimisedLeaks :: SymFC.Sym () +p256SqrUnoptimisedLeaks = + expectLeakAt firstUnoptimisedTableLoad $ + sqrSecret sqrUnoptimisedCode sqrUnoptimisedEntry unoptimisedSqrSteps + +{-# ANN p256SqrOptimisedLeaks (SymFC ['stepperEmbeddings]) #-} +p256SqrOptimisedLeaks :: SymFC.Sym () +p256SqrOptimisedLeaks = + expectLeakAt firstOptimisedTableLoad $ + sqrSecret sqrOptimisedCode sqrOptimisedEntry optimisedSqrSteps + +{-# ANN p256MontReduceOrderUnoptimisedLeaks (SymFC ['stepperEmbeddings]) #-} +p256MontReduceOrderUnoptimisedLeaks :: SymFC.Sym () +p256MontReduceOrderUnoptimisedLeaks = + expectLeakAt firstUnoptimisedTableLoad $ + montReduceOrderUnoptimisedCall unoptimisedReduceOrderSteps + +{-# ANN p256MontReduceOrderOptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256MontReduceOrderOptimisedNoLeak :: SymFC.Sym () +p256MontReduceOrderOptimisedNoLeak = expectNoLeak $ montReduceOrderOptimisedCall optimisedReduceOrderSteps + +{-# ANN p256MontReduceOrderOptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256MontReduceOrderOptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256MontReduceOrderOptimisedOneStepShortOutOfFuel = + expectOutOfFuel $ montReduceOrderOptimisedCall optimisedReduceOrderShort + +{-# ANN p256MultiplyUnoptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256MultiplyUnoptimisedDecodeAgrees :: SymFC.Sym () +p256MultiplyUnoptimisedDecodeAgrees = expectDecodeAgreement [mulUnoptimisedDecoded, sqrUnoptimisedDecoded, montReduceOrderUnoptimisedDecoded] + +{-# ANN p256MultiplyUnoptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256MultiplyUnoptimisedFetchesByAddress :: SymFC.Sym () +p256MultiplyUnoptimisedFetchesByAddress = expectFetchByAddress [mulUnoptimisedCode, sqrUnoptimisedCode, montReduceOrderUnoptimisedCode] + +{-# ANN p256MultiplyOptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256MultiplyOptimisedDecodeAgrees :: SymFC.Sym () +p256MultiplyOptimisedDecodeAgrees = expectDecodeAgreement [mulOptimisedDecoded, sqrOptimisedDecoded, montReduceOrderOptimisedDecoded] + +{-# ANN p256MultiplyOptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256MultiplyOptimisedFetchesByAddress :: SymFC.Sym () +p256MultiplyOptimisedFetchesByAddress = expectFetchByAddress [mulOptimisedCode, sqrOptimisedCode, montReduceOrderOptimisedCode] diff --git a/proof/Proof/SMT/Stepper/P256Recode.hs b/proof/Proof/SMT/Stepper/P256Recode.hs new file mode 100644 index 0000000..3f6b779 --- /dev/null +++ b/proof/Proof/SMT/Stepper/P256Recode.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.P256Recode + ( p256RecodeUnoptimisedLeaks + , p256RecodeOptimisedLeaks + , p256GetPointUnoptimisedNoLeak + , p256GetPointUnoptimisedOneStepShortOutOfFuel + , p256RecodeUnoptimisedDecodeAgrees + , p256RecodeUnoptimisedFetchesByAddress + , p256RecodeOptimisedDecodeAgrees + , p256RecodeOptimisedFetchesByAddress + ) where + +import Proof.SMT.Stepper.P256Call +import Stepper (Fuel) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_ecdsa_sha256_O0" + [ ("recodeUnoptimised", ["sp_256_ecc_recode_6_9"]) + , ("getPointUnoptimised", ["sp_256_get_point_33_9"]) + ]) + +$(elfCode "benchmark/bench_ecdsa_sha256_O3" + [ ("recodeOptimised", ["sp_256_ecc_recode_6_9"]) + ]) + +scalarAddr, digitsAddr, pointAddr, tableAddr :: Address +scalarAddr = 0x1000 +digitsAddr = 0x2000 +pointAddr = 0x3000 +tableAddr = 0x10000 + +scalarLimbs :: Int +scalarLimbs = 9 + +unoptimisedRecodeSteps, optimisedRecodeSteps :: Fuel +unoptimisedRecodeSteps = decimalSteps [2, 8, 4, 9] +optimisedRecodeSteps = decimalSteps [7, 7, 8] + +getPointSteps, getPointShort :: Fuel +getPointSteps = decimalSteps [1, 6, 0, 4, 2] +getPointShort = decimalSteps [1, 6, 0, 4, 1] + +unoptimisedRecodeIndexLoad, optimisedRecodeIndexLoad :: Address +unoptimisedRecodeIndexLoad = 0x268c8 +optimisedRecodeIndexLoad = 0x18cb4 + +recodeSecretScalar :: Code -> Address -> Fuel -> SymFC.Sym Verdict +recodeSecretScalar code entry fuel = do + start <- callAt code entry [pointer scalarAddr, pointer digitsAddr] + withScalar <- withSecretWords scalarAddr scalarLimbs start + relRun fuel withScalar + +getPointSecretIndex :: Fuel -> SymFC.Sym Verdict +getPointSecretIndex fuel = do + indexA <- SymFC.fresh @Word + indexB <- SymFC.fresh @Word + start <- callAt getPointUnoptimisedCode getPointUnoptimisedEntry [pointer pointAddr, pointer tableAddr, Pair indexA indexB] + relRun fuel start + +{-# ANN p256RecodeUnoptimisedLeaks (SymFC ['stepperEmbeddings]) #-} +p256RecodeUnoptimisedLeaks :: SymFC.Sym () +p256RecodeUnoptimisedLeaks = + expectLeakAt unoptimisedRecodeIndexLoad $ + recodeSecretScalar recodeUnoptimisedCode recodeUnoptimisedEntry unoptimisedRecodeSteps + +{-# ANN p256RecodeOptimisedLeaks (SymFC ['stepperEmbeddings]) #-} +p256RecodeOptimisedLeaks :: SymFC.Sym () +p256RecodeOptimisedLeaks = + expectLeakAt optimisedRecodeIndexLoad $ + recodeSecretScalar recodeOptimisedCode recodeOptimisedEntry optimisedRecodeSteps + +{-# ANN p256GetPointUnoptimisedNoLeak (SymFC ['stepperEmbeddings]) #-} +p256GetPointUnoptimisedNoLeak :: SymFC.Sym () +p256GetPointUnoptimisedNoLeak = expectNoLeak $ getPointSecretIndex getPointSteps + +{-# ANN p256GetPointUnoptimisedOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +p256GetPointUnoptimisedOneStepShortOutOfFuel :: SymFC.Sym () +p256GetPointUnoptimisedOneStepShortOutOfFuel = expectOutOfFuel $ getPointSecretIndex getPointShort + +{-# ANN p256RecodeUnoptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256RecodeUnoptimisedDecodeAgrees :: SymFC.Sym () +p256RecodeUnoptimisedDecodeAgrees = expectDecodeAgreement [recodeUnoptimisedDecoded, getPointUnoptimisedDecoded] + +{-# ANN p256RecodeUnoptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256RecodeUnoptimisedFetchesByAddress :: SymFC.Sym () +p256RecodeUnoptimisedFetchesByAddress = expectFetchByAddress [recodeUnoptimisedCode, getPointUnoptimisedCode] + +{-# ANN p256RecodeOptimisedDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +p256RecodeOptimisedDecodeAgrees :: SymFC.Sym () +p256RecodeOptimisedDecodeAgrees = expectDecodeAgreement [recodeOptimisedDecoded] + +{-# ANN p256RecodeOptimisedFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +p256RecodeOptimisedFetchesByAddress :: SymFC.Sym () +p256RecodeOptimisedFetchesByAddress = expectFetchByAddress [recodeOptimisedCode] diff --git a/proof/Proof/SMT/Stepper/RelMem.hs b/proof/Proof/SMT/Stepper/RelMem.hs new file mode 100644 index 0000000..40b615b --- /dev/null +++ b/proof/Proof/SMT/Stepper/RelMem.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.RelMem + ( layeredMatchesArray + , layeredMissingWriteFails + , layeredPairMatchesArrays + , confinedWriteMatchesArray + , confinedWriteKeepsKnownWords + , aliasingWriteMatchesArray + , aliasingMissingWriteFails + , repeatedKnownLoadXorsToZero + , recordedLoadThenAliasingWriteMatchesArray + , recordedLoadThenConfinedWriteMatchesArray + ) where + +import Clash.Prelude (bitCoerce) +import Control.Monad ((>=>)) +import Data.Bits (xor) +import Memory.Types (MemOps (..)) +import Stepper.Concrete (concreteAddress, stepperEmbeddings) +import Stepper.Memory (Memory) +import Stepper.Memory qualified as Memory +import Stepper.Rel (Rel (..), left, right) +import Stepper.RelMem +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Byte, Size (..), Word) +import Prelude hiding (Word) + +expectValid :: Bool -> SymFC.Sym () +expectValid prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt + +expectCounterexample :: Bool -> SymFC.Sym () +expectCounterexample prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.Instance -> pure () + _ -> SymFC.halt + +firstAddr :: Address +firstAddr = 0x100 + +secondAddr :: Address +secondAddr = 0x104 + +data Writes = Writes + { symbolicAddr :: Address + , firstByte :: Byte + , symbolicByte :: Byte + , secondByte :: Byte + , overwriteByte :: Byte + } + +freshWrites :: SymFC.Sym Writes +freshWrites = + Writes + <$> SymFC.fresh @Address + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + +applyLayered :: Writes -> RelMem -> SymFC.Sym RelMem +applyLayered w = + writeByte True firstAddr (Same (firstByte w)) + >=> writeByte True (symbolicAddr w) (Same (symbolicByte w)) + >=> writeByte True secondAddr (Same (secondByte w)) + >=> writeByte True secondAddr (Same (overwriteByte w)) + +applyPlain :: Writes -> Memory 32 8 -> Memory 32 8 +applyPlain w = + Memory.write secondAddr (overwriteByte w) + . Memory.write secondAddr (secondByte w) + . Memory.write (symbolicAddr w) (symbolicByte w) + . Memory.write firstAddr (firstByte w) + +applyPlainWithoutSymbolic :: Writes -> Memory 32 8 -> Memory 32 8 +applyPlainWithoutSymbolic w = + Memory.write secondAddr (overwriteByte w) + . Memory.write secondAddr (secondByte w) + . Memory.write firstAddr (firstByte w) + +readsAgree :: Address -> RelMem -> Memory 32 8 -> SymFC.Sym Bool +readsAgree probe layered plain = do + atProbe <- readByte probe layered + atFirst <- readByte firstAddr layered + atSecond <- readByte secondAddr layered + pure $ + left atProbe == Memory.read probe plain + && left atFirst == Memory.read firstAddr plain + && left atSecond == Memory.read secondAddr plain + && leftMem layered == plain + +{-# ANN layeredMatchesArray (SymFC ['stepperEmbeddings]) #-} +layeredMatchesArray :: SymFC.Sym () +layeredMatchesArray = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + w <- freshWrites + layered <- applyLayered w (sameMem base) + expectValid =<< readsAgree probe layered (applyPlain w base) + +{-# ANN layeredMissingWriteFails (SymFC ['stepperEmbeddings]) #-} +layeredMissingWriteFails :: SymFC.Sym () +layeredMissingWriteFails = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + w <- freshWrites + layered <- applyLayered w (sameMem base) + expectCounterexample =<< readsAgree probe layered (applyPlainWithoutSymbolic w base) + +secretAddr :: Address +secretAddr = 0x200 + +{-# ANN layeredPairMatchesArrays (SymFC ['stepperEmbeddings]) #-} +layeredPairMatchesArrays :: SymFC.Sym () +layeredPairMatchesArrays = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + secretA <- SymFC.fresh @Byte + secretB <- SymFC.fresh @Byte + w <- freshWrites + layered <- writeByte True secretAddr (Pair secretA secretB) (sameMem base) >>= applyLayered w + let plainA = applyPlain w (Memory.write secretAddr secretA base) + plainB = applyPlain w (Memory.write secretAddr secretB base) + atProbe <- readByte probe layered + expectValid $ + left atProbe == Memory.read probe plainA + && right atProbe == Memory.read probe plainB + && leftMem layered == plainA + && rightMem layered == plainB + +farAddr :: Address +farAddr = 0x2000 + +confinedBetweenKeys :: Address -> Bool +confinedBetweenKeys addr = 0x1000 <= addr && addr < farAddr + +mayAliasKnownKeys :: Address -> Bool +mayAliasKnownKeys addr = firstAddr <= addr && addr <= secondAddr + +data UnknownWrite = UnknownWrite + { unknownAddr :: Address + , unknownByte :: Byte + , firstKnown :: Byte + , secondKnown :: Byte + , farKnown :: Byte + } + +freshUnknownWrite :: SymFC.Sym UnknownWrite +freshUnknownWrite = + UnknownWrite + <$> SymFC.fresh @Address + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + <*> SymFC.fresh @Byte + +knownThenUnknown :: Bool -> UnknownWrite -> RelMem -> SymFC.Sym RelMem +knownThenUnknown path w = + writeByte path firstAddr (Same (firstKnown w)) + >=> writeByte path secondAddr (Same (secondKnown w)) + >=> writeByte path farAddr (Same (farKnown w)) + >=> writeByte path (unknownAddr w) (Same (unknownByte w)) + +knownWritesOnly :: UnknownWrite -> Memory 32 8 -> Memory 32 8 +knownWritesOnly w = + Memory.write farAddr (farKnown w) + . Memory.write secondAddr (secondKnown w) + . Memory.write firstAddr (firstKnown w) + +knownThenUnknownPlain :: UnknownWrite -> Memory 32 8 -> Memory 32 8 +knownThenUnknownPlain w = Memory.write (unknownAddr w) (unknownByte w) . knownWritesOnly w + +agreesAtKeysAndProbe :: Address -> RelMem -> Memory 32 8 -> SymFC.Sym Bool +agreesAtKeysAndProbe probe layered plain = do + atProbe <- agreesAt probe + atFirst <- agreesAt firstAddr + atSecond <- agreesAt secondAddr + atFar <- agreesAt farAddr + pure $ + atProbe && atFirst && atSecond && atFar + && Memory.read probe (leftMem layered) == Memory.read probe plain + where + agreesAt addr = (\byte -> left byte == Memory.read addr plain) <$> readByte addr layered + +{-# ANN confinedWriteMatchesArray (SymFC ['stepperEmbeddings]) #-} +confinedWriteMatchesArray :: SymFC.Sym () +confinedWriteMatchesArray = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + w <- freshUnknownWrite + let path = confinedBetweenKeys (unknownAddr w) + layered <- knownThenUnknown path w (sameMem base) + expectValid . (not path ||) =<< agreesAtKeysAndProbe probe layered (knownThenUnknownPlain w base) + +savedWord :: Word +savedWord = 0x00042838 + +exactWordAt :: Address -> RelMem -> SymFC.Sym (Maybe Address) +exactWordAt addr mem = do + word <- readMemWord addr mem + concreteAddress (bitCoerce (left word)) + +{-# ANN confinedWriteKeepsKnownWords (SymFC ['stepperEmbeddings]) #-} +confinedWriteKeepsKnownWords :: SymFC.Sym () +confinedWriteKeepsKnownWords = do + base <- SymFC.fresh @(Memory 32 8) + addr <- SymFC.fresh @Address + byte <- SymFC.fresh @Byte + let path = confinedBetweenKeys addr + layered <- + ( writeMem path Word firstAddr (Same savedWord) + >=> writeMem path Word farAddr (Same savedWord) + >=> writeByte path addr (Same byte) + ) + (sameMem base) + firstWord <- exactWordAt firstAddr layered + farWord <- exactWordAt farAddr layered + case (firstWord, farWord) of + (Just first, Just far) -> expectValid $ first == bitCoerce savedWord && far == bitCoerce savedWord + _ -> SymFC.halt + +{-# ANN aliasingWriteMatchesArray (SymFC ['stepperEmbeddings]) #-} +aliasingWriteMatchesArray :: SymFC.Sym () +aliasingWriteMatchesArray = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + w <- freshUnknownWrite + let path = mayAliasKnownKeys (unknownAddr w) + layered <- knownThenUnknown path w (sameMem base) + expectValid . (not path ||) =<< agreesAtKeysAndProbe probe layered (knownThenUnknownPlain w base) + +{-# ANN aliasingMissingWriteFails (SymFC ['stepperEmbeddings]) #-} +aliasingMissingWriteFails :: SymFC.Sym () +aliasingMissingWriteFails = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + w <- freshUnknownWrite + let path = mayAliasKnownKeys (unknownAddr w) + layered <- knownThenUnknown path w (sameMem base) + expectCounterexample . (not path ||) =<< agreesAtKeysAndProbe probe layered (knownWritesOnly w base) + +knownLoad :: Address -> RelMem -> SymFC.Sym (Rel Word, RelMem) +knownLoad addr mem = maybe SymFC.halt pure =<< loadKnownWord addr mem + +{-# ANN repeatedKnownLoadXorsToZero (SymFC ['stepperEmbeddings]) #-} +repeatedKnownLoadXorsToZero :: SymFC.Sym () +repeatedKnownLoadXorsToZero = do + base <- SymFC.fresh @(Memory 32 8) + (first, recorded) <- knownLoad firstAddr (sameMem base) + (second, _) <- knownLoad firstAddr recorded + difference <- concreteAddress (bitCoerce (left first `xor` left second)) + case difference of + Just knownDifference -> expectValid $ knownDifference == 0 && left first == memReadWord firstAddr base + Nothing -> SymFC.halt + +recordedLoadThenWriteMatchesArray :: (Address -> Bool) -> SymFC.Sym () +recordedLoadThenWriteMatchesArray onPath = do + base <- SymFC.fresh @(Memory 32 8) + probe <- SymFC.fresh @Address + addr <- SymFC.fresh @Address + byte <- SymFC.fresh @Byte + (loaded, recorded) <- knownLoad firstAddr (sameMem base) + let path = onPath addr + plain = Memory.write addr byte base + written <- writeByte path addr (Same byte) recorded + writtenWord <- readMemWord firstAddr written + atProbe <- readByte probe written + expectValid $ + not path + || ( left loaded == memReadWord firstAddr base + && left writtenWord == memReadWord firstAddr plain + && left atProbe == Memory.read probe plain + && leftMem written == plain + ) + +{-# ANN recordedLoadThenAliasingWriteMatchesArray (SymFC ['stepperEmbeddings]) #-} +recordedLoadThenAliasingWriteMatchesArray :: SymFC.Sym () +recordedLoadThenAliasingWriteMatchesArray = recordedLoadThenWriteMatchesArray mayAliasKnownKeys + +{-# ANN recordedLoadThenConfinedWriteMatchesArray (SymFC ['stepperEmbeddings]) #-} +recordedLoadThenConfinedWriteMatchesArray :: SymFC.Sym () +recordedLoadThenConfinedWriteMatchesArray = recordedLoadThenWriteMatchesArray confinedBetweenKeys diff --git a/proof/Proof/SMT/Stepper/Relational.hs b/proof/Proof/SMT/Stepper/Relational.hs new file mode 100644 index 0000000..35bfcde --- /dev/null +++ b/proof/Proof/SMT/Stepper/Relational.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.Relational + ( expectValid + , expectCounterexample + , Probe (..) + , freshProbe + , Run (..) + , valueIn + , memoryIn + , matchesState + , sameWordAt + , relStepMatchesIsaStep + , leakOfReadsOnlyLeakOfReads + , relStepMismatchFails + , addOnSecretNoLeak + , branchOnPublicNoLeak + , storeSecretNoLeak + , storeIntoCodeIsReported + , branchOnSecretLeaks + , loadFromSecretLeaks + , secretThroughAddLeaks + , storeToSecretAddressLeaks + , jumpToSecretLeaks + , loadSecretWordNoLeak + , loadPublicWordBesideSecretNoLeak + , branchOnSecretWordLeaks + , publicBranchForksNoLeak + , leakOnOnePathLeaks + , leakOnInfeasiblePathNoLeak + , provenAgreementDoesNotHideLeak + , publicJumpToLeakyTargetLeaks + , publicJumpAvoidingLeakyTargetNoLeak + , unconstrainedPublicJumpLeaks + , confinedJumpInLongCodeNoLeak + ) where + +import Data.Functor.Identity (Identity (..), runIdentity) +import Core.ISA (IsaStateG (..), StepG (..), isaInstrAt, isaStep) +import Memory.Types (MemOps (..)) +import Proof.Core.Leakage.Model (leakOf) +import Core.RegFile (RegFileOps (..)) +import Stepper (Fuel (..), IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.Memory (Memory) +import Stepper.Memory qualified as Memory +import Stepper.Rel (Rel (..), left, right) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Word) +import Prelude hiding (Word) + +expectValid :: Bool -> SymFC.Sym () +expectValid prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt + +expectCounterexample :: Bool -> SymFC.Sym () +expectCounterexample prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.Instance -> pure () + _ -> SymFC.halt + +data Probe = Probe + { probeReg :: RegIdx + , probeSlot :: RegSlot + , probeAddr :: Address + } + +freshProbe :: SymFC.Sym Probe +freshProbe = do + reg <- SymFC.fresh @RegIdx + addr <- SymFC.fresh @Address + slot <- slotFor reg + pure (Probe reg slot addr) + +data Run = FirstRun | SecondRun + +valueIn :: Run -> Rel a -> a +valueIn FirstRun = left +valueIn SecondRun = right + +memoryIn :: Run -> RelMem -> Memory 32 8 +memoryIn FirstRun = leftMem +memoryIn SecondRun = rightMem + +matchesState :: Run -> Probe -> RelState -> IsaSys -> Bool +matchesState run probe st isa = + relPc st == isaPc isa + && valueIn run (readSlot (relRegs st) (probeSlot probe)) == lookupRFg (probeReg probe) (isaRegFile isa) + && Memory.read (probeAddr probe) (memoryIn run (relMem st)) == Memory.read (probeAddr probe) (isaMem isa) + +matchesIsaStep :: Probe -> IsaSys -> RelOutcome -> Bool +matchesIsaStep = matchesIsaStepIn FirstRun + +matchesIsaStepIn :: Run -> Probe -> IsaSys -> RelOutcome -> Bool +matchesIsaStepIn run probe isa outcome = case (outcome, isaStep isa) of + (RelNext st, Next isa') -> matchesState run probe st isa' + (RelFork branches, Next isa') -> + someReachable branches && allReachableMatch run probe isa' branches + (RelHalted, IsaHalted) -> True + _ -> False + +someReachable :: [RelOutcome] -> Bool +someReachable [] = False +someReachable (branch : rest) = reachableNext branch || someReachable rest + +allReachableMatch :: Run -> Probe -> IsaSys -> [RelOutcome] -> Bool +allReachableMatch _ _ _ [] = True +allReachableMatch run probe isa (branch : rest) = + reachableNextMatches run probe isa branch && allReachableMatch run probe isa rest + +reachableNext :: RelOutcome -> Bool +reachableNext (RelNext st) = relPath st +reachableNext _ = False + +reachableNextMatches :: Run -> Probe -> IsaSys -> RelOutcome -> Bool +reachableNextMatches run probe isa (RelNext st) = not (relPath st) || matchesState run probe st isa +reachableNextMatches _ _ _ _ = False + +{-# ANN relStepMatchesIsaStep (SymFC ['stepperEmbeddings]) #-} +relStepMatchesIsaStep :: SymFC.Sym () +relStepMatchesIsaStep = do + isa <- SymFC.fresh @IsaSys + probe <- freshProbe + outcome <- relStep (sameState (codeFromMemory (isaMem isa)) isa) + expectValid $ matchesIsaStep probe isa outcome + +registerOf :: IsaSys -> RegIdx -> Word +registerOf isa reg = lookupRFg reg (isaRegFile isa) + +sameWordAt :: IsaSys -> IsaSys -> Address -> Bool +sameWordAt isaA isaB addr = memReadWord addr (isaMem isaA) == memReadWord addr (isaMem isaB) + +{-# ANN leakOfReadsOnlyLeakOfReads (SymFC ['stepperEmbeddings]) #-} +leakOfReadsOnlyLeakOfReads :: SymFC.Sym () +leakOfReadsOnlyLeakOfReads = do + isaA <- SymFC.fresh @IsaSys + isaB <- SymFC.fresh @IsaSys + let pc = isaPc isaA + sameRegister reg = Identity (registerOf isaA reg == registerOf isaB reg) + sameFollowing = Identity (sameWordAt isaA isaB (pc + 4)) + readsAgree = runIdentity (leakOfReadsAgree sameRegister sameFollowing (isaInstrAt isaA)) + sameInstruction = isaPc isaB == pc && sameWordAt isaA isaB pc + expectValid $ not (sameInstruction && readsAgree) || leakOf isaA == leakOf isaB + +{-# ANN relStepMismatchFails (SymFC ['stepperEmbeddings]) #-} +relStepMismatchFails :: SymFC.Sym () +relStepMismatchFails = do + isa <- SymFC.fresh @IsaSys + probe <- freshProbe + outcome <- relStep (sameState (codeFromMemory (isaMem isa)) isa {isaPc = isaPc isa + 4}) + expectCounterexample $ matchesIsaStep probe isa outcome + +secretReg :: RegIdx +secretReg = 10 + +ebreak :: Word +ebreak = 0x00100073 + +toyFuel :: Fuel +toyFuel = More (More (More Done)) + +program :: Word -> Word -> Code +program first second = + withInstruction 0 first $ + withInstruction 4 second $ + withInstruction 8 ebreak $ + withInstruction 12 ebreak noCode + +secretAddr :: Address +secretAddr = 0 + +type Secret = Word -> Word -> RelState -> SymFC.Sym RelState + +runToy :: Secret -> Word -> Word -> SymFC.Sym Verdict +runToy secret first second = do + isa <- SymFC.fresh @IsaSys + secretA <- SymFC.fresh @Word + secretB <- SymFC.fresh @Word + relRun toyFuel =<< secret secretA secretB (sameState (program first second) isa {isaPc = 0}) + +inSecretReg :: Secret +inSecretReg = withSecretReg secretReg + +inSecretWord :: Secret +inSecretWord = withSecretWord secretAddr + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +addA1A0A0 :: Word +addA1A0A0 = 0x00A505B3 + +addA2A1A1 :: Word +addA2A1A1 = 0x00B58633 + +beqX0X0Plus8 :: Word +beqX0X0Plus8 = 0x00000463 + +beqA0X0Plus8 :: Word +beqA0X0Plus8 = 0x00050463 + +beqA1X0Plus8 :: Word +beqA1X0Plus8 = 0x00058463 + +lwA1FromA0 :: Word +lwA1FromA0 = 0x00052583 + +lwA1FromZero :: Word +lwA1FromZero = 0x00002583 + +lwA1From64 :: Word +lwA1From64 = 0x04002583 + +lwA2FromA1 :: Word +lwA2FromA1 = 0x0005A603 + +swA0ToZero :: Word +swA0ToZero = 0x00A02023 + +swA0To64 :: Word +swA0To64 = 0x04A02023 + +swA1ToA0 :: Word +swA1ToA0 = 0x00B52023 + +jalrToA0 :: Word +jalrToA0 = 0x00050067 + +{-# ANN addOnSecretNoLeak (SymFC ['stepperEmbeddings]) #-} +addOnSecretNoLeak :: SymFC.Sym () +addOnSecretNoLeak = expectNoLeak $ runToy inSecretReg addA1A0A0 ebreak + +{-# ANN branchOnPublicNoLeak (SymFC ['stepperEmbeddings]) #-} +branchOnPublicNoLeak :: SymFC.Sym () +branchOnPublicNoLeak = expectNoLeak $ runToy inSecretReg beqX0X0Plus8 ebreak + +{-# ANN storeSecretNoLeak (SymFC ['stepperEmbeddings]) #-} +storeSecretNoLeak :: SymFC.Sym () +storeSecretNoLeak = expectNoLeak $ runToy inSecretReg swA0To64 ebreak + +{-# ANN storeIntoCodeIsReported (SymFC ['stepperEmbeddings]) #-} +storeIntoCodeIsReported :: SymFC.Sym () +storeIntoCodeIsReported = do + verdict <- runToy inSecretReg swA0ToZero ebreak + case verdict of + WritesCode 0 -> pure () + _ -> SymFC.halt + +{-# ANN branchOnSecretLeaks (SymFC ['stepperEmbeddings]) #-} +branchOnSecretLeaks :: SymFC.Sym () +branchOnSecretLeaks = expectLeakAt 0 $ runToy inSecretReg beqA0X0Plus8 ebreak + +{-# ANN loadFromSecretLeaks (SymFC ['stepperEmbeddings]) #-} +loadFromSecretLeaks :: SymFC.Sym () +loadFromSecretLeaks = expectLeakAt 0 $ runToy inSecretReg lwA1FromA0 ebreak + +{-# ANN secretThroughAddLeaks (SymFC ['stepperEmbeddings]) #-} +secretThroughAddLeaks :: SymFC.Sym () +secretThroughAddLeaks = expectLeakAt 4 $ runToy inSecretReg addA1A0A0 beqA1X0Plus8 + +{-# ANN storeToSecretAddressLeaks (SymFC ['stepperEmbeddings]) #-} +storeToSecretAddressLeaks :: SymFC.Sym () +storeToSecretAddressLeaks = expectLeakAt 0 $ runToy inSecretReg swA1ToA0 ebreak + +{-# ANN jumpToSecretLeaks (SymFC ['stepperEmbeddings]) #-} +jumpToSecretLeaks :: SymFC.Sym () +jumpToSecretLeaks = expectLeakAt 0 $ runToy inSecretReg jalrToA0 ebreak + +{-# ANN loadSecretWordNoLeak (SymFC ['stepperEmbeddings]) #-} +loadSecretWordNoLeak :: SymFC.Sym () +loadSecretWordNoLeak = expectNoLeak $ runToy inSecretWord lwA1FromZero addA2A1A1 + +{-# ANN loadPublicWordBesideSecretNoLeak (SymFC ['stepperEmbeddings]) #-} +loadPublicWordBesideSecretNoLeak :: SymFC.Sym () +loadPublicWordBesideSecretNoLeak = expectNoLeak $ runToy inSecretWord lwA1From64 lwA2FromA1 + +{-# ANN branchOnSecretWordLeaks (SymFC ['stepperEmbeddings]) #-} +branchOnSecretWordLeaks :: SymFC.Sym () +branchOnSecretWordLeaks = expectLeakAt 4 $ runToy inSecretWord lwA1FromZero beqA1X0Plus8 + +bneA1X0Plus8 :: Word +bneA1X0Plus8 = 0x00059463 + +forkFuel :: Fuel +forkFuel = More (More (More (More (More (More Done))))) + +runForkToy :: Secret -> Code -> SymFC.Sym Verdict +runForkToy secret code = do + isa <- SymFC.fresh @IsaSys + secretA <- SymFC.fresh @Word + secretB <- SymFC.fresh @Word + relRun forkFuel =<< secret secretA secretB (sameState code isa {isaPc = 0}) + +publicBranchProgram :: Code +publicBranchProgram = + withInstruction 0 lwA1From64 $ + withInstruction 4 beqA1X0Plus8 $ + withInstruction 8 ebreak $ + withInstruction 12 ebreak noCode + +secretBranchOnFallthroughProgram :: Code +secretBranchOnFallthroughProgram = + withInstruction 0 lwA1From64 $ + withInstruction 4 beqA1X0Plus8 $ + withInstruction 8 beqA0X0Plus8 $ + withInstruction 12 ebreak $ + withInstruction 16 ebreak noCode + +secretBranchBehindInfeasibleProgram :: Code +secretBranchBehindInfeasibleProgram = + withInstruction 0 lwA1From64 $ + withInstruction 4 beqA1X0Plus8 $ + withInstruction 8 ebreak $ + withInstruction 12 bneA1X0Plus8 $ + withInstruction 16 ebreak $ + withInstruction 20 beqA0X0Plus8 $ + withInstruction 24 ebreak $ + withInstruction 28 ebreak noCode + +{-# ANN publicBranchForksNoLeak (SymFC ['stepperEmbeddings]) #-} +publicBranchForksNoLeak :: SymFC.Sym () +publicBranchForksNoLeak = expectNoLeak $ runForkToy inSecretReg publicBranchProgram + +{-# ANN leakOnOnePathLeaks (SymFC ['stepperEmbeddings]) #-} +leakOnOnePathLeaks :: SymFC.Sym () +leakOnOnePathLeaks = expectLeakAt 8 $ runForkToy inSecretReg secretBranchOnFallthroughProgram + +{-# ANN leakOnInfeasiblePathNoLeak (SymFC ['stepperEmbeddings]) #-} +leakOnInfeasiblePathNoLeak :: SymFC.Sym () +leakOnInfeasiblePathNoLeak = expectNoLeak $ runForkToy inSecretReg secretBranchBehindInfeasibleProgram + +lwA3FromZero :: Word +lwA3FromZero = 0x00002683 + +beqA3X0Plus8 :: Word +beqA3X0Plus8 = 0x00068463 + +leakAfterProvenAgreementProgram :: Code +leakAfterProvenAgreementProgram = + withInstruction 0 lwA1From64 $ + withInstruction 4 lwA2FromA1 $ + withInstruction 8 lwA3FromZero $ + withInstruction 12 beqA3X0Plus8 $ + withInstruction 16 ebreak $ + withInstruction 20 ebreak noCode + +{-# ANN provenAgreementDoesNotHideLeak (SymFC ['stepperEmbeddings]) #-} +provenAgreementDoesNotHideLeak :: SymFC.Sym () +provenAgreementDoesNotHideLeak = expectLeakAt 12 $ runForkToy inSecretWord leakAfterProvenAgreementProgram + +jalrToA1 :: Word +jalrToA1 = 0x00058067 + +jumpTargetReg :: RegIdx +jumpTargetReg = 11 + +cleanTarget, leakyTarget, otherCleanTarget :: Word +cleanTarget = 8 +leakyTarget = 12 +otherCleanTarget = 16 + +publicJumpProgram :: Code +publicJumpProgram = + withInstruction 0 jalrToA1 $ + withInstruction 4 ebreak $ + withInstruction 8 ebreak $ + withInstruction 12 beqA0X0Plus8 $ + withInstruction 16 ebreak $ + withInstruction 20 ebreak noCode + +runPublicJumpToy :: (Word -> Bool) -> SymFC.Sym Verdict +runPublicJumpToy = runJumpIn publicJumpProgram + +{-# ANN publicJumpToLeakyTargetLeaks (SymFC ['stepperEmbeddings]) #-} +publicJumpToLeakyTargetLeaks :: SymFC.Sym () +publicJumpToLeakyTargetLeaks = + expectLeakAt 12 $ runPublicJumpToy \target -> target == cleanTarget || target == leakyTarget + +{-# ANN publicJumpAvoidingLeakyTargetNoLeak (SymFC ['stepperEmbeddings]) #-} +publicJumpAvoidingLeakyTargetNoLeak :: SymFC.Sym () +publicJumpAvoidingLeakyTargetNoLeak = + expectNoLeak $ runPublicJumpToy \target -> target == cleanTarget || target == otherCleanTarget + +{-# ANN unconstrainedPublicJumpLeaks (SymFC ['stepperEmbeddings]) #-} +unconstrainedPublicJumpLeaks :: SymFC.Sym () +unconstrainedPublicJumpLeaks = expectLeakAt 12 $ runPublicJumpToy (const True) + +ebreaksFrom :: Address -> Fuel -> Code -> Code +ebreaksFrom _ Done code = code +ebreaksFrom addr (More count) code = withInstruction addr ebreak (ebreaksFrom (addr + 4) count code) + +doubled :: Fuel -> Fuel +doubled Done = Done +doubled (More count) = More (More (doubled count)) + +sixtyFour :: Fuel +sixtyFour = doubled (doubled (doubled (doubled (doubled (doubled (More Done)))))) + +longCodeLeakyAddr :: Address +longCodeLeakyAddr = 260 + +firstLongTarget, secondLongTarget :: Word +firstLongTarget = 176 +secondLongTarget = 180 + +longJumpProgram :: Code +longJumpProgram = + withInstruction 0 jalrToA1 $ + ebreaksFrom 4 sixtyFour $ + withInstruction longCodeLeakyAddr beqA0X0Plus8 $ + ebreaksFrom (longCodeLeakyAddr + 4) sixtyFour noCode + +runJumpIn :: Code -> (Word -> Bool) -> SymFC.Sym Verdict +runJumpIn code allowedTarget = do + isa <- SymFC.fresh @IsaSys + secretA <- SymFC.fresh @Word + secretB <- SymFC.fresh @Word + target <- SymFC.fresh @Word + let start = sameState code isa {isaPc = 0} + regs <- writeReg jumpTargetReg (Same target) (relRegs start) + let withTarget = start {relPath = allowedTarget target, relRegs = regs} + relRun forkFuel =<< inSecretReg secretA secretB withTarget + +{-# ANN confinedJumpInLongCodeNoLeak (SymFC ['stepperEmbeddings]) #-} +confinedJumpInLongCodeNoLeak :: SymFC.Sym () +confinedJumpInLongCodeNoLeak = + expectNoLeak $ runJumpIn longJumpProgram \target -> + target == firstLongTarget || target == secondLongTarget diff --git a/proof/Proof/SMT/Stepper/Sha256.hs b/proof/Proof/SMT/Stepper/Sha256.hs new file mode 100644 index 0000000..3914ab5 --- /dev/null +++ b/proof/Proof/SMT/Stepper/Sha256.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.Sha256 + ( sha256SecretBlockNoLeak + , sha256SecretBlockOneStepShortOutOfFuel + , sha256SecretStateNoLeak + , sha256SecretBlockPointerLeaks + , sha256DecodeAgrees + , sha256FetchesByAddress + , sha256DecodeRejectsWrongInstruction + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_sha256" + [ ("sha256Transform", ["SHA256_Transform", "memcpy"]) + ]) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +plusFuel :: Fuel -> Fuel -> Fuel +plusFuel Done later = later +plusFuel (More fuel) later = More (plusFuel fuel later) + +tenfold :: Fuel -> Fuel +tenfold fuel = plusFuel eightfold twofold + where + twofold = plusFuel fuel fuel + fourfold = plusFuel twofold twofold + eightfold = plusFuel fourfold fourfold + +decimalSteps :: [Int] -> Fuel +decimalSteps = digitsAfter Done + where + digitsAfter sofar [] = sofar + digitsAfter sofar (digit : rest) = digitsAfter (plusFuel (steps digit) (tenfold sofar)) rest + +exactSteps :: Fuel +exactSteps = decimalSteps [4, 2, 9, 1] + +oneStepShort :: Fuel +oneStepShort = decimalSteps [4, 2, 9, 0] + +stateAddr, blockAddr, scheduleAddr, scratchAddr, stackTop, returnOutsideCode :: Address +stateAddr = 0x1000 +blockAddr = 0x2000 +scheduleAddr = 0x3000 +scratchAddr = 0x4000 +stackTop = 0x8000 +returnOutsideCode = 0 + +otherBlockAddr :: Address +otherBlockAddr = 0x5000 + +stateWords, blockWords :: Int +stateWords = 8 +blockWords = 16 + +wordBytes :: Address +wordBytes = 4 + +ra, sp, a0, a1, a2, a3 :: RegIdx +ra = 1 +sp = 2 +a0 = 10 +a1 = 11 +a2 = 12 +a3 = 13 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +withArguments :: Rel Word -> RelState -> SymFC.Sym RelState +withArguments blockPointer st = do + regs <- + writeReg a0 (pointer stateAddr) + =<< writeReg a1 blockPointer + =<< writeReg a2 (pointer scheduleAddr) + =<< writeReg a3 (pointer scratchAddr) + =<< writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) (relRegs st) + pure st {relRegs = regs} + +withSecretWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withSecretWords _ 0 st = pure st +withSecretWords base count st = do + wordA <- SymFC.fresh @Word + wordB <- SymFC.fresh @Word + next <- withSecretWord base wordA wordB st + withSecretWords (base + wordBytes) (count - 1) next + +withPublicWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withPublicWords _ 0 st = pure st +withPublicWords base count st = do + value <- SymFC.fresh @Word + mem <- writeMem (relPath st) Word base (Same value) (relMem st) + withPublicWords (base + wordBytes) (count - 1) st {relMem = mem} + +transformCall :: Fuel -> Rel Word -> Bool -> SymFC.Sym Verdict +transformCall fuel blockPointer secretState = do + isa <- SymFC.fresh @IsaSys + let start = (sameState sha256TransformCode isa) {relPc = sha256TransformEntry} + withBlock <- withSecretWords blockAddr blockWords =<< withArguments blockPointer start + withState <- + if secretState + then withSecretWords stateAddr stateWords withBlock + else withPublicWords stateAddr stateWords withBlock + relRun fuel withState + +secretBlockPublicState :: Fuel -> SymFC.Sym Verdict +secretBlockPublicState fuel = transformCall fuel (pointer blockAddr) False + +secretBlockSecretState :: Fuel -> SymFC.Sym Verdict +secretBlockSecretState fuel = transformCall fuel (pointer blockAddr) True + +secretBlockPointer :: SymFC.Sym Verdict +secretBlockPointer = transformCall exactSteps (Pair (bitCoerce blockAddr) (bitCoerce otherBlockAddr)) False + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt + +firstBlockByteLoad :: Address +firstBlockByteLoad = 0x105c0 + +{-# ANN sha256SecretBlockNoLeak (SymFC ['stepperEmbeddings]) #-} +sha256SecretBlockNoLeak :: SymFC.Sym () +sha256SecretBlockNoLeak = expectNoLeak $ secretBlockPublicState exactSteps + +{-# ANN sha256SecretBlockOneStepShortOutOfFuel (SymFC ['stepperEmbeddings]) #-} +sha256SecretBlockOneStepShortOutOfFuel :: SymFC.Sym () +sha256SecretBlockOneStepShortOutOfFuel = expectOutOfFuel $ secretBlockPublicState oneStepShort + +{-# ANN sha256SecretStateNoLeak (SymFC ['stepperEmbeddings]) #-} +sha256SecretStateNoLeak :: SymFC.Sym () +sha256SecretStateNoLeak = expectNoLeak $ secretBlockSecretState exactSteps + +{-# ANN sha256SecretBlockPointerLeaks (SymFC ['stepperEmbeddings]) #-} +sha256SecretBlockPointerLeaks :: SymFC.Sym () +sha256SecretBlockPointerLeaks = expectLeakAt firstBlockByteLoad secretBlockPointer + +{-# ANN sha256DecodeAgrees (SymFC ['stepperEmbeddings]) #-} +sha256DecodeAgrees :: SymFC.Sym () +sha256DecodeAgrees = expectDecodeAgreement [sha256TransformDecoded] + +{-# ANN sha256FetchesByAddress (SymFC ['stepperEmbeddings]) #-} +sha256FetchesByAddress :: SymFC.Sym () +sha256FetchesByAddress = expectFetchByAddress [sha256TransformCode] + +{-# ANN sha256DecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +sha256DecodeRejectsWrongInstruction :: SymFC.Sym () +sha256DecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction sha256TransformDecoded] diff --git a/proof/Proof/SMT/Stepper/X25519/Call.hs b/proof/Proof/SMT/Stepper/X25519/Call.hs new file mode 100644 index 0000000..6e9c019 --- /dev/null +++ b/proof/Proof/SMT/Stepper/X25519/Call.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.X25519.Call + ( decimalSteps + , pointer + , ra + , sp + , a0 + , a1 + , a2 + , stackTop + , returnOutsideCode + , callFrom + , withPublicWord + , withPublicWords + , withSecretWords + , withStackGuardPointer + , expectNoLeak + , expectOutOfFuel + , expectLeakAt + ) where + +import Clash.Prelude (bitCoerce) +import Stepper (Fuel (..), IsaSys) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +steps :: Int -> Fuel +steps 0 = Done +steps n = More (steps (n - 1)) + +plusFuel :: Fuel -> Fuel -> Fuel +plusFuel Done later = later +plusFuel (More fuel) later = More (plusFuel fuel later) + +tenfold :: Fuel -> Fuel +tenfold fuel = plusFuel eightfold twofold + where + twofold = plusFuel fuel fuel + fourfold = plusFuel twofold twofold + eightfold = plusFuel fourfold fourfold + +decimalSteps :: [Int] -> Fuel +decimalSteps = digitsAfter Done + where + digitsAfter sofar [] = sofar + digitsAfter sofar (digit : rest) = digitsAfter (plusFuel (steps digit) (tenfold sofar)) rest + +ra, sp, a0, a1, a2 :: RegIdx +ra = 1 +sp = 2 +a0 = 10 +a1 = 11 +a2 = 12 + +stackTop, returnOutsideCode :: Address +stackTop = 0x8000 +returnOutsideCode = 0 + +stackGuardSlot, stackGuard :: Address +stackGuardSlot = 0x5e020 +stackGuard = 0x5ec04 + +pointer :: Address -> Rel Word +pointer = Same . bitCoerce + +callFrom :: Code -> Address -> Rel Word -> Rel Word -> Rel Word -> SymFC.Sym RelState +callFrom code entry first second third = do + isa <- SymFC.fresh @IsaSys + let start = (sameState code isa) {relPc = entry} + regs <- + writeReg a0 first + =<< writeReg a1 second + =<< writeReg a2 third + =<< writeReg sp (pointer stackTop) + =<< writeReg ra (pointer returnOutsideCode) (relRegs start) + pure start {relRegs = regs} + +withPublicWord :: Address -> Word -> RelState -> SymFC.Sym RelState +withPublicWord addr value st = do + mem <- writeMem (relPath st) Word addr (Same value) (relMem st) + pure st {relMem = mem} + +withPublicWords :: Address -> [Word] -> RelState -> SymFC.Sym RelState +withPublicWords _ [] st = pure st +withPublicWords addr (value : rest) st = withPublicWord addr value st >>= withPublicWords (addr + 4) rest + +withSecretWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withSecretWords _ 0 st = pure st +withSecretWords addr remaining st = do + secretA <- SymFC.fresh @Word + secretB <- SymFC.fresh @Word + withSecretWord addr secretA secretB st >>= withSecretWords (addr + 4) (remaining - 1) + +withStackGuardPointer :: RelState -> SymFC.Sym RelState +withStackGuardPointer = withPublicWord stackGuardSlot (bitCoerce stackGuard) + +expectNoLeak :: SymFC.Sym Verdict -> SymFC.Sym () +expectNoLeak run = do + verdict <- run + case verdict of + NoLeak -> pure () + _ -> SymFC.halt + +expectLeakAt :: Address -> SymFC.Sym Verdict -> SymFC.Sym () +expectLeakAt expectedPc run = do + verdict <- run + case verdict of + Leaks pc | pc == expectedPc -> pure () + _ -> SymFC.halt + +expectOutOfFuel :: SymFC.Sym Verdict -> SymFC.Sym () +expectOutOfFuel run = do + verdict <- run + case verdict of + OutOfFuel -> pure () + _ -> SymFC.halt diff --git a/proof/Proof/SMT/Stepper/X25519/Cswap.hs b/proof/Proof/SMT/Stepper/X25519/Cswap.hs new file mode 100644 index 0000000..fd21f88 --- /dev/null +++ b/proof/Proof/SMT/Stepper/X25519/Cswap.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.X25519.Cswap + ( x25519CswapPublicBitNoLeak + , x25519CswapPublicBitOneStepShort + , x25519CswapSecretBitLeaks + , x25519CmovSecretBitNoLeak + , x25519CmovSecretBitOneStepShort + , x25519CswapDecodeAgrees + , x25519CswapFetchesByAddress + , x25519DecodeRejectsWrongInstruction + ) where + +import Proof.SMT.Stepper.X25519.Call +import Stepper (Fuel) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress, expectDecodeDisagreement, withWrongFirstInstruction) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_x25519" + [ ("cswap", ["fe25519_cswap"]) + , ("cmov", ["fe25519_cmov"]) + ]) + +limbCount :: Int +limbCount = 10 + +firstElement, secondElement :: Address +firstElement = 0x1000 +secondElement = 0x1100 + +publicElement :: [Word] +publicElement = [0x1234567, 0x1244668, 0x1254769, 0x126486a, 0x127496b, 0x1284a6c, 0x1294b6d, 0x12a4c6e, 0x12b4d6f, 0x12c4e70] + +swapWithBitSteps, swapWithBitOneShort :: Fuel +swapWithBitSteps = decimalSteps [1, 1, 2] +swapWithBitOneShort = decimalSteps [1, 1, 1] + +moveSteps, moveOneShort :: Fuel +moveSteps = decimalSteps [6, 3] +moveOneShort = decimalSteps [6, 2] + +firstSwapBranch :: Address +firstSwapBranch = 0x1e158 + +withSecretElements :: RelState -> SymFC.Sym RelState +withSecretElements st = withSecretWords firstElement limbCount st >>= withSecretWords secondElement limbCount + +withPublicElements :: RelState -> SymFC.Sym RelState +withPublicElements st = withPublicWords firstElement publicElement st >>= withPublicWords secondElement publicElement + +secretBit :: SymFC.Sym (Rel Word) +secretBit = Pair <$> SymFC.fresh @Word <*> SymFC.fresh @Word + +conditionalCall :: Code -> Address -> (RelState -> SymFC.Sym RelState) -> Fuel -> Rel Word -> SymFC.Sym Verdict +conditionalCall code entry withElements fuel bit = do + start <- callFrom code entry (pointer firstElement) (pointer secondElement) bit + relRun fuel =<< withElements start + +swapSecrets :: Fuel -> SymFC.Sym Verdict +swapSecrets fuel = conditionalCall cswapCode cswapEntry withSecretElements fuel (Same 1) + +{-# ANN x25519CswapPublicBitNoLeak (SymFC ['stepperEmbeddings]) #-} +x25519CswapPublicBitNoLeak :: SymFC.Sym () +x25519CswapPublicBitNoLeak = expectNoLeak $ swapSecrets swapWithBitSteps + +{-# ANN x25519CswapPublicBitOneStepShort (SymFC ['stepperEmbeddings]) #-} +x25519CswapPublicBitOneStepShort :: SymFC.Sym () +x25519CswapPublicBitOneStepShort = expectOutOfFuel $ swapSecrets swapWithBitOneShort + +{-# ANN x25519CswapSecretBitLeaks (SymFC ['stepperEmbeddings]) #-} +x25519CswapSecretBitLeaks :: SymFC.Sym () +x25519CswapSecretBitLeaks = + expectLeakAt firstSwapBranch $ + conditionalCall cswapCode cswapEntry withPublicElements swapWithBitSteps =<< secretBit + +moveUnderSecretBit :: Fuel -> SymFC.Sym Verdict +moveUnderSecretBit fuel = conditionalCall cmovCode cmovEntry withSecretElements fuel =<< secretBit + +{-# ANN x25519CmovSecretBitNoLeak (SymFC ['stepperEmbeddings]) #-} +x25519CmovSecretBitNoLeak :: SymFC.Sym () +x25519CmovSecretBitNoLeak = expectNoLeak $ moveUnderSecretBit moveSteps + +{-# ANN x25519CmovSecretBitOneStepShort (SymFC ['stepperEmbeddings]) #-} +x25519CmovSecretBitOneStepShort :: SymFC.Sym () +x25519CmovSecretBitOneStepShort = expectOutOfFuel $ moveUnderSecretBit moveOneShort + +{-# ANN x25519CswapDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +x25519CswapDecodeAgrees :: SymFC.Sym () +x25519CswapDecodeAgrees = expectDecodeAgreement [cswapDecoded, cmovDecoded] + +{-# ANN x25519CswapFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +x25519CswapFetchesByAddress :: SymFC.Sym () +x25519CswapFetchesByAddress = expectFetchByAddress [cswapCode, cmovCode] + +{-# ANN x25519DecodeRejectsWrongInstruction (SymFC ['stepperEmbeddings]) #-} +x25519DecodeRejectsWrongInstruction :: SymFC.Sym () +x25519DecodeRejectsWrongInstruction = expectDecodeDisagreement [withWrongFirstInstruction cswapDecoded, cmovDecoded] diff --git a/proof/Proof/SMT/Stepper/X25519/Ladder.hs b/proof/Proof/SMT/Stepper/X25519/Ladder.hs new file mode 100644 index 0000000..267e65e --- /dev/null +++ b/proof/Proof/SMT/Stepper/X25519/Ladder.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.X25519.Ladder + ( x25519LadderFirstStepOutOfFuel + , x25519LadderSecondStepLeaks + , x25519LadderPublicScalarTwoStepsOutOfFuel + , x25519LadderDecodeAgrees + , x25519LadderFetchesByAddress + ) where + +import Proof.SMT.Stepper.X25519.Call +import Stepper (Fuel) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress) +import Stepper.RelState (RelState) +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_x25519" + [ ( "ladder" + , [ "crypto_scalarmult_curve25519_ref10.part.0" + , "memcpy" + , "fe25519_frombytes" + , "fe25519_cswap" + , "fe25519_mul" + , "fe25519_sq" + , "__muldi3" + , "__mulsi3" + ] + ) + ]) + +sharedPoint, scalarIn, publicPoint :: Address +sharedPoint = 0x1000 +scalarIn = 0x1100 +publicPoint = 0x1200 + +scalarWords :: Int +scalarWords = 8 + +basePointU :: [Word] +basePointU = [9, 0, 0, 0, 0, 0, 0, 0] + +untilSecondStepSwap, throughSecondStepSwap :: Fuel +untilSecondStepSwap = decimalSteps [2, 9, 7, 8, 7] +throughSecondStepSwap = decimalSteps [2, 9, 7, 8, 8] + +publicScalar :: [Word] +publicScalar = [0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a, 0x5a5a5a5a] + +untilThirdStep :: Fuel +untilThirdStep = decimalSteps [8, 3, 6, 7, 0] + +firstSwapBranch :: Address +firstSwapBranch = 0x1e158 + +ladderCall :: Fuel -> SymFC.Sym Verdict +ladderCall = ladderCallWith (withSecretWords scalarIn scalarWords) + +ladderCallWith :: (RelState -> SymFC.Sym RelState) -> Fuel -> SymFC.Sym Verdict +ladderCallWith withScalar fuel = do + start <- callFrom ladderCode ladderEntry (pointer sharedPoint) (pointer scalarIn) (pointer publicPoint) + ready <- + withScalar start + >>= withPublicWords publicPoint basePointU + >>= withStackGuardPointer + relRun fuel ready + +{-# ANN x25519LadderFirstStepOutOfFuel (SymFC ['stepperEmbeddings]) #-} +x25519LadderFirstStepOutOfFuel :: SymFC.Sym () +x25519LadderFirstStepOutOfFuel = expectOutOfFuel $ ladderCall untilSecondStepSwap + +{-# ANN x25519LadderSecondStepLeaks (SymFC ['stepperEmbeddings]) #-} +x25519LadderSecondStepLeaks :: SymFC.Sym () +x25519LadderSecondStepLeaks = expectLeakAt firstSwapBranch $ ladderCall throughSecondStepSwap + +{-# ANN x25519LadderPublicScalarTwoStepsOutOfFuel (SymFC ['stepperEmbeddings]) #-} +x25519LadderPublicScalarTwoStepsOutOfFuel :: SymFC.Sym () +x25519LadderPublicScalarTwoStepsOutOfFuel = + expectOutOfFuel $ ladderCallWith (withPublicWords scalarIn publicScalar) untilThirdStep + +{-# ANN x25519LadderDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +x25519LadderDecodeAgrees :: SymFC.Sym () +x25519LadderDecodeAgrees = expectDecodeAgreement [ladderDecoded] + +{-# ANN x25519LadderFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +x25519LadderFetchesByAddress :: SymFC.Sym () +x25519LadderFetchesByAddress = expectFetchByAddress [ladderCode] diff --git a/proof/Proof/SMT/Stepper/X25519/Mul.hs b/proof/Proof/SMT/Stepper/X25519/Mul.hs new file mode 100644 index 0000000..1524b20 --- /dev/null +++ b/proof/Proof/SMT/Stepper/X25519/Mul.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Proof.SMT.Stepper.X25519.Mul + ( x25519MulPublicNoLeak + , x25519MulPublicOneStepShort + , x25519MulSecretLeaks + , x25519ToBytesSecretNoLeak + , x25519ToBytesSecretOneStepShort + , x25519MulSymbolicThreeBits + , x25519MulSymbolicFiveBits + , x25519MulDecodeAgrees + , x25519MulFetchesByAddress + ) where + +import Proof.SMT.Stepper.X25519.Call +import Stepper (Fuel) +import Stepper.Concrete (stepperEmbeddings) +import Stepper.ElfCode (elfCode, expectDecodeAgreement, expectFetchByAddress) +import Stepper.Rel (Rel (..)) +import Stepper.RelState +import Stepper.Relational +import SymFC (SymFC (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +$(elfCode "benchmark/bench_x25519" + [ ("multiply", ["fe25519_mul", "__muldi3", "__mulsi3"]) + , ("toBytes", ["fe25519_tobytes", "fe25519_reduce"]) + ]) + +limbCount :: Int +limbCount = 10 + +productElement, multiplicand, multiplier :: Address +productElement = 0x1000 +multiplicand = 0x1100 +multiplier = 0x1200 + +publicMultiplicand, publicMultiplier :: [Word] +publicMultiplicand = [0x1234567, 0x1244668, 0x1254769, 0x126486a, 0x127496b, 0x1284a6c, 0x1294b6d, 0x12a4c6e, 0x12b4d6f, 0x12c4e70] +publicMultiplier = [0x0abcdef, 0x0abee0f, 0x0ac0e2f, 0x0ac2e4f, 0x0ac4e6f, 0x0ac6e8f, 0x0ac8eaf, 0x0acaecf, 0x0acceef, 0x0acef0f] + +multiplySteps, multiplyOneShort, pastFirstLimbProduct :: Fuel +multiplySteps = decimalSteps [2, 8, 1, 7, 6] +multiplyOneShort = decimalSteps [2, 8, 1, 7, 5] +pastFirstLimbProduct = decimalSteps [3, 0, 0] + +firstMultiplierBitBranch :: Address +firstMultiplierBitBranch = 0x42680 + +bytesOut, elementIn :: Address +bytesOut = 0x1000 +elementIn = 0x1100 + +toBytesSteps, toBytesOneShort :: Fuel +toBytesSteps = decimalSteps [1, 9, 0] +toBytesOneShort = decimalSteps [1, 8, 9] + +multiplyCall :: (RelState -> SymFC.Sym RelState) -> Fuel -> SymFC.Sym Verdict +multiplyCall withFactors fuel = do + start <- callFrom multiplyCode multiplyEntry (pointer productElement) (pointer multiplicand) (pointer multiplier) + relRun fuel =<< withFactors start + +withPublicFactors :: RelState -> SymFC.Sym RelState +withPublicFactors st = withPublicWords multiplicand publicMultiplicand st >>= withPublicWords multiplier publicMultiplier + +withSecretFactors :: RelState -> SymFC.Sym RelState +withSecretFactors st = withSecretWords multiplicand limbCount st >>= withSecretWords multiplier limbCount + +{-# ANN x25519MulPublicNoLeak (SymFC ['stepperEmbeddings]) #-} +x25519MulPublicNoLeak :: SymFC.Sym () +x25519MulPublicNoLeak = expectNoLeak $ multiplyCall withPublicFactors multiplySteps + +{-# ANN x25519MulPublicOneStepShort (SymFC ['stepperEmbeddings]) #-} +x25519MulPublicOneStepShort :: SymFC.Sym () +x25519MulPublicOneStepShort = expectOutOfFuel $ multiplyCall withPublicFactors multiplyOneShort + +{-# ANN x25519MulSecretLeaks (SymFC ['stepperEmbeddings]) #-} +x25519MulSecretLeaks :: SymFC.Sym () +x25519MulSecretLeaks = expectLeakAt firstMultiplierBitBranch $ multiplyCall withSecretFactors pastFirstLimbProduct + +toBytesCall :: Fuel -> SymFC.Sym Verdict +toBytesCall fuel = do + start <- callFrom toBytesCode toBytesEntry (pointer bytesOut) (pointer elementIn) (Same 0) + relRun fuel =<< withSecretWords elementIn limbCount start + +{-# ANN x25519ToBytesSecretNoLeak (SymFC ['stepperEmbeddings]) #-} +x25519ToBytesSecretNoLeak :: SymFC.Sym () +x25519ToBytesSecretNoLeak = expectNoLeak $ toBytesCall toBytesSteps + +{-# ANN x25519ToBytesSecretOneStepShort (SymFC ['stepperEmbeddings]) #-} +x25519ToBytesSecretOneStepShort :: SymFC.Sym () +x25519ToBytesSecretOneStepShort = expectOutOfFuel $ toBytesCall toBytesOneShort + +withPublicSymbolicWords :: Address -> Int -> RelState -> SymFC.Sym RelState +withPublicSymbolicWords _ 0 st = pure st +withPublicSymbolicWords addr remaining st = do + value <- SymFC.fresh @Word + withPublicWord addr value st >>= withPublicSymbolicWords (addr + 4) (remaining - 1) + +withSymbolicFactors :: RelState -> SymFC.Sym RelState +withSymbolicFactors st = withPublicSymbolicWords multiplicand limbCount st >>= withPublicSymbolicWords multiplier limbCount + +{-# ANN x25519MulSymbolicThreeBits (SymFC ['stepperEmbeddings]) #-} +x25519MulSymbolicThreeBits :: SymFC.Sym () +x25519MulSymbolicThreeBits = expectOutOfFuel $ multiplyCall withSymbolicFactors (decimalSteps [2, 3, 3]) + +{-# ANN x25519MulSymbolicFiveBits (SymFC ['stepperEmbeddings]) #-} +x25519MulSymbolicFiveBits :: SymFC.Sym () +x25519MulSymbolicFiveBits = expectOutOfFuel $ multiplyCall withSymbolicFactors (decimalSteps [2, 5, 7]) + +{-# ANN x25519MulDecodeAgrees (SymFC ['stepperEmbeddings]) #-} +x25519MulDecodeAgrees :: SymFC.Sym () +x25519MulDecodeAgrees = expectDecodeAgreement [multiplyDecoded, toBytesDecoded] + +{-# ANN x25519MulFetchesByAddress (SymFC ['stepperEmbeddings]) #-} +x25519MulFetchesByAddress :: SymFC.Sym () +x25519MulFetchesByAddress = expectFetchByAddress [multiplyCode, toBytesCode] diff --git a/proof/Proof/SMT/Symbolic.hs b/proof/Proof/SMT/Symbolic.hs new file mode 100644 index 0000000..ebd5511 --- /dev/null +++ b/proof/Proof/SMT/Symbolic.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Fresh symbolic values of the pipeline's types, for the induction proofs. +-- +-- Each instance uses the 'Generic' default of 'SymFC.Symbolic'. They live here +-- rather than beside the types so that the synthesisable modules stay free of +-- the plugin. +module Proof.SMT.Symbolic + ( expectValid, + ) +where + +import Clash.Prelude (Generic) +import qualified Core.Pipeline as Core +import Core.Instruction +import Memory.Cache4KServer (CacheSrvState (..)) +import Proof.Core.Leakage.Model (Leak, Obs) +import Proof.Core.Leakage.Simulator (SimControl, SimExInstrType, SimMemAccess, SimState) +import Proof.Memory.Cache4K.Server.Leakage.Simulator (SimCacheSrvState (..)) +import qualified SymFC.Base () +import qualified SymFC.BuiltIn as SymFC +import qualified SymFC.Clash () +import Types (Size) + +instance SymFC.Symbolic Size + +instance SymFC.Symbolic Arith + +instance SymFC.Symbolic Comparison + +instance SymFC.Symbolic Sign + +instance SymFC.Symbolic UBase + +instance SymFC.Symbolic Env + +instance SymFC.Symbolic IOperation + +instance SymFC.Symbolic Reason4Stall + +instance SymFC.Symbolic Instruction + +instance SymFC.Symbolic Core.HaltState + +instance SymFC.Symbolic Core.Control + +instance SymFC.Symbolic Core.Input + +instance SymFC.Symbolic Core.MemAccess + +deriving instance Generic CacheSrvState + +instance SymFC.Symbolic CacheSrvState + +instance SymFC.Symbolic Leak + +instance SymFC.Symbolic Obs + +instance SymFC.Symbolic SimMemAccess + +deriving instance Generic SimCacheSrvState + +instance SymFC.Symbolic SimCacheSrvState + +instance SymFC.Symbolic SimExInstrType + +instance SymFC.Symbolic SimControl + +instance SymFC.Symbolic SimState + +-- | Fail the build unless the property holds for every value of its fresh +-- inputs. +expectValid :: Bool -> SymFC.Sym () +expectValid prop = do + result <- SymFC.valid $ SymFC.boolean prop + case result of + SymFC.None -> pure () + _ -> SymFC.halt diff --git a/proof/README.md b/proof/README.md index 71d3cf0..4d85c20 100644 --- a/proof/README.md +++ b/proof/README.md @@ -1,6 +1,6 @@ # The proofs -Everything here is checked at compile time by Pantomime and Bitwuzla. The +Everything here is checked at compile time by SymFC and Bitwuzla. The statements are ordinary Haskell over the code in `src/`. `proof/` may import `src/`, never the reverse: the ISA (`Core.ISA`) and ideal memory (`Memory.Ideal`), which the proofs are checked against, live in `src/`. @@ -45,10 +45,10 @@ kinds, using the ones it needs: | `Driver` | how many cycles one step of the spec takes, and its operational reading | | `Invariant` | the relation between the implementation and its spec | | `Obligation` | the base case and one inductive step per hop length | -| `Solver` | the properties as Pantomime queries, collected in `results` | +| `Solver` | the properties as SymFC queries; an invalid one fails the build | | `System` | (core) how a system state is passed to the solver: SMT arrays for the register file and memory | Only the `Solver` modules (and the `SMT` axioms they use) run the solver. They -are built only with the `smt-proof` flag, and `test/Spec.hs` checks that every -entry in each `results` list is valid. Load or build them one module at a -time: a single module needs about 2 GB. +are built only with the `smt-proof` flag, and a property that does not hold +fails the build. Load or build them one module at a time: a single module +needs about 2 GB. diff --git a/src/Access.hs b/src/Access.hs new file mode 100644 index 0000000..d1ca8ef --- /dev/null +++ b/src/Access.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} + +module Access (Access, extract) where + +import Control.Comonad (Comonad (extract)) + +type Access f = (Applicative f, Comonad f) diff --git a/src/Core/ISA.hs b/src/Core/ISA.hs index 1b44b82..46dbf82 100644 --- a/src/Core/ISA.hs +++ b/src/Core/ISA.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -5,15 +7,20 @@ -- | The ISA specification: what each instruction means, and how the -- architectural state evolves. -- --- Two halves, both semantics. 'interp' turns an 'Core.Instruction.Instruction' --- into an @'Instr' 'Func'@ -- the effect it denotes -- and 'apply' evaluates --- one of those 'Func's against the two source-register values and the PC. On --- top of that, 'isaStep' says how the @(isaPc, isaRegFile, isaMem)@ triple --- moves. +-- Two halves, both semantics. 'interp' turns an 'Instruction.Instruction' into +-- an @'Instr' 'Func'@ -- the effect it denotes -- and 'apply' evaluates one of +-- those 'Func's against the two source-register values and the PC. On top of +-- that, 'isaStep' says how the @(isaPc, isaRegFile, isaMem)@ triple moves. +-- +-- The step itself is 'isaStepM', written once against 'Machine': the register +-- and memory operations a step performs, in some monad, on values wrapped in +-- some 'Access' functor. 'isaStep' runs it on one architectural state. The +-- relational checker in "Stepper.Relational" runs the same 'isaStepM' on two +-- runs at once, so the two cannot disagree about what an instruction does. -- -- The architectural state is parameterised over the register-file and memory -- representations because the @Vec@-backed ones cannot be symbolically --- executed; see 'Core.RegFile.RegFileOps' and 'Memory.Types.MemOps'. +-- executed; see 'RegFile.RegFileOps' and 'Memory.Types.MemOps'. -- -- This is specification, not proof machinery. The refinement proof is stated -- against it, so it must not depend on anything the proof defines. @@ -31,6 +38,9 @@ module Core.ISA IsaState, StepG (..), Step, + Machine (..), + Flow (..), + isaStepM, isaStep, isaStepDecoded, isaRun, @@ -38,15 +48,18 @@ module Core.ISA ) where -import Clash.Prelude - hiding (Const, Log, Ordering (..), Word, def, init, lift, log) +import Access +import Clash.Prelude hiding (Const, Log, Ordering (..), Word, def, init, lift, log) import Core.Alu (alu, branch) +import Data.Functor.Identity import Core.Instruction (Instruction, Sign, decode', loadExtend) -import qualified Core.Instruction +import qualified Core.Instruction as Instruction import Memory.Types (MemBytes, MemOps (..)) import Core.RegFile import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (||)) +import qualified SymFC.BuiltIn as SymFC +import SymFC.Clash () -- Import for orphan instances. type PC = Address @@ -118,46 +131,46 @@ instance DepReg (Instr Func) where deps Nop = (empty, empty) deps Syscall = (pure 17, empty) -interp :: Core.Instruction.Instruction -> Instr Func +interp :: Instruction.Instruction -> Instr Func interp instr - | Core.Instruction.isBreak instr = Break + | Instruction.isBreak instr = Break | otherwise = case instr of - Core.Instruction.RType op rd r1 r2 -> + Instruction.RType op rd r1 r2 -> Reg rd $ binaryF r1 r2 $ \w1 w2 -> alu op w1 w2 - Core.Instruction.IType iop rd r1 imm -> + Instruction.IType iop rd r1 imm -> let op = case iop of - Core.Instruction.Arith op' -> op' - _ -> Core.Instruction.ADD + Instruction.Arith op' -> op' + _ -> Instruction.ADD alu_res = unaryF r1 $ \w -> alu op w (signExtend imm) in case iop of - Core.Instruction.Arith {} -> + Instruction.Arith {} -> Reg rd alu_res - Core.Instruction.Load size sign -> + Instruction.Load size sign -> Load size sign rd $ bitCoerce <$> alu_res - Core.Instruction.Jump -> + Instruction.Jump -> Jump rd (pcF (bitCoerce . (+ 4))) $ bitCoerce <$> alu_res - Core.Instruction.Env Core.Instruction.Break -> + Instruction.Env Instruction.Break -> Break - Core.Instruction.Env Core.Instruction.Call -> + Instruction.Env Instruction.Call -> Syscall - Core.Instruction.SType size imm r1 r2 -> do + Instruction.SType size imm r1 r2 -> do let addr_comp = unpack <$> unaryF r1 (+ signExtend imm) in Store size addr_comp r2 - Core.Instruction.BType cmp imm r1 r2 -> + Instruction.BType cmp imm r1 r2 -> let branched_comp = binaryF r1 r2 $ \w1 w2 -> branch cmp w1 w2 addr_comp = pcF (+ bitCoerce (signExtend imm)) in Branch branched_comp addr_comp - Core.Instruction.UType Core.Instruction.Zero rd imm -> + Instruction.UType Instruction.Zero rd imm -> let imm' = imm ++# (0 :: BitVector 12) in Reg rd $ constF imm' - Core.Instruction.UType Core.Instruction.PC rd imm -> do + Instruction.UType Instruction.PC rd imm -> do let imm' = imm ++# (0 :: BitVector 12) in Reg rd $ pcF $ \pc -> bitCoerce pc + imm' - Core.Instruction.JType rd imm -> + Instruction.JType rd imm -> Jump rd (pcF (bitCoerce . (+ 4))) $ pcF (+ bitCoerce (signExtend imm)) - Core.Instruction.Nop _ -> Nop + Instruction.Nop _ -> Nop where constF :: a -> Func a constF a = @@ -193,6 +206,9 @@ data IsaStateG r m = IsaState isaRegFile :: r, isaMem :: m } + deriving Generic + +instance (SymFC.Symbolic m, SymFC.Symbolic r) => SymFC.Symbolic (IsaStateG r m) where -- | The concrete architectural state the QuickCheck harness uses. type IsaState = IsaStateG RegFile MemBytes @@ -213,6 +229,80 @@ deriving instance (Show r, Show m) => Show (StepG r m) deriving instance (Eq r, Eq m) => Eq (StepG r m) +-- | The register and memory operations one step performs. +-- +-- @v@ wraps every value the step computes: 'Identity' for one run. Addresses +-- and branch conditions are taken out of it with 'extract', because they +-- decide where the step goes. +class (Monad m, Access v) => Machine v m | m -> v where + readReg :: RegIdx -> m (v Word) + writeReg :: RegIdx -> v Word -> m () + loadWord :: Address -> m (v Word) + storeWord :: Size -> Address -> v Word -> m () + +-- | Where control goes after a step. The caller decides what the PC becomes, +-- which lets a symbolic caller split a branch into two paths. +data Flow + = FallThrough + | Goto PC + | BranchTo Bool PC + | Halt + +-- | One step of an already decoded instruction at @pc@. +isaStepM :: Machine v m => PC -> Instr Func -> m Flow +isaStepM pc instr = case instr of + Reg rd f -> do + writeReg rd =<< ap f + pure FallThrough + Load size sign rd f -> do + addr <- extract <$> ap f + word <- loadWord addr + writeReg rd (loadExtend size sign <$> word) + pure FallThrough + Jump rd link target -> do + target' <- extract <$> ap target + writeReg rd . fmap bitCoerce =<< ap link + pure (Goto target') + Store size addr rs2 -> do + addr' <- extract <$> ap addr + storeWord size addr' =<< reg (Just rs2) + pure FallThrough + Branch cond target -> do + taken <- extract <$> ap cond + BranchTo taken . extract <$> ap target + Nop -> pure FallThrough + Break -> pure Halt + Syscall -> pure Halt + where + reg = maybe (pure (pure 0)) readReg + + -- 'Func' is evaluated against the values of its two dependency + -- registers and the PC, exactly as 'apply' prescribes. + ap f = do + r1 <- reg (getR1 instr) + r2 <- reg (getR2 instr) + pure ((\w1 w2 -> unDone (apply f w1 w2 pc)) <$> r1 <*> r2) + +-- | A step on one architectural state. +newtype IsaM r m a = IsaM {runIsaM :: IsaStateG r m -> (a, IsaStateG r m)} + +instance Functor (IsaM r m) where + fmap f (IsaM run) = IsaM \st -> case run st of (a, st') -> (f a, st') + +instance Applicative (IsaM r m) where + pure a = IsaM \st -> (a, st) + IsaM runF <*> IsaM runA = IsaM \st -> case runF st of + (f, st') -> case runA st' of (a, st'') -> (f a, st'') + +instance Monad (IsaM r m) where + IsaM run >>= k = IsaM \st -> case run st of (a, st') -> runIsaM (k a) st' + +instance (RegFileOps r, MemOps m) => Machine Identity (IsaM r m) where + readReg idx = IsaM \st -> (Identity (lookupRFg idx (isaRegFile st)), st) + writeReg idx value = IsaM \st -> ((), st {isaRegFile = modifyRFg idx (runIdentity value) (isaRegFile st)}) + loadWord addr = IsaM \st -> (Identity (memReadWord addr (isaMem st)), st) + storeWord size addr value = IsaM \st -> ((), st {isaMem = memWrite addr size (runIdentity value) (isaMem st)}) + -- | The instruction the ISA would execute next. isaInstrAt :: (MemOps m) => IsaStateG r m -> Instruction isaInstrAt (IsaState pc _ mem) = decode' (memReadWord pc mem) @@ -232,39 +322,14 @@ isaStepDecoded :: Instruction -> IsaStateG r m -> StepG r m -isaStepDecoded ir st@(IsaState pc rf mem) = - case instr of - Reg rd f -> - Next st {isaPc = pc + 4, isaRegFile = modifyRFg rd (ap f) rf} - Load size sign rd f -> - let val = loadExtend size sign (memReadWord (ap f) mem) - in Next st {isaPc = pc + 4, isaRegFile = modifyRFg rd val rf} - Jump rd link target -> - Next - st - { isaPc = ap target, - isaRegFile = modifyRFg rd (bitCoerce (ap link)) rf - } - Store size addr rs2 -> - Next - st - { isaPc = pc + 4, - isaMem = memWrite (ap addr) size (reg (Just rs2)) mem - } - Branch cond target -> - Next st {isaPc = if ap cond then ap target else pc + 4} - Nop -> Next st {isaPc = pc + 4} - Break -> IsaHalted - Syscall -> IsaHalted +isaStepDecoded ir st = + case runIsaM (isaStepM pc (interp ir)) st of + (FallThrough, st') -> Next st' {isaPc = pc + 4} + (Goto target, st') -> Next st' {isaPc = target} + (BranchTo taken target, st') -> Next st' {isaPc = if taken then target else pc + 4} + (Halt, _) -> IsaHalted where - instr = interp ir - - reg = maybe 0 (\idx -> lookupRFg idx rf) - - -- 'Func' is evaluated against the values of its two dependency - -- registers and the PC, exactly as 'apply' prescribes. - ap :: Func a -> a - ap f = unDone (apply f (reg (getR1 instr)) (reg (getR2 instr)) pc) + pc = isaPc st -- | Run at most @n@ architectural steps, stopping early on halt. Returns the -- states visited, starting with the initial one. diff --git a/src/Core/Instruction.hs b/src/Core/Instruction.hs index 71953aa..f0d0042 100644 --- a/src/Core/Instruction.hs +++ b/src/Core/Instruction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} module Core.Instruction ( Instruction (..), @@ -60,6 +61,7 @@ data Arith | -- | Set Less Than Unsigned SLTU deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) -- | Comparison operations. data Comparison @@ -76,24 +78,28 @@ data Comparison | -- | Greater or Equals than Unsigned GEU deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) -- | Sign extension of a load operation. data Sign = Signed | Unsigned deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) -- | The base for an upper type operation: lui or auipc. data UBase = PC | Zero deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) -- | Environment operation: ecall or ebreak. data Env = Call | Break deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) -- | Types of operations using the immediate encoding. data IOperation @@ -102,6 +108,7 @@ data IOperation | Env Env | Jump deriving (Eq, Show, Generic, NFDataX) + deriving stock (Lift) -- | Reason for replacing an instruction with a nop. Some of these can be -- collapsed if we want to optimize later. @@ -128,6 +135,7 @@ data Reason4Stall | -- | The core has halted. Halted deriving (Eq, Show, Generic, NFDataX, Binary) + deriving stock (Lift) -- | Decoded instructions data Instruction @@ -146,6 +154,7 @@ data Instruction | -- | nop Nop Reason4Stall deriving (Eq, Show, Generic, NFDataX) + deriving stock (Lift) nop :: Instruction nop = RType ADD 0 0 0 diff --git a/src/Stepper.hs b/src/Stepper.hs new file mode 100644 index 0000000..b0e2c0f --- /dev/null +++ b/src/Stepper.hs @@ -0,0 +1,14 @@ +module Stepper + ( IsaSys + , IsaSysStep + , Fuel (..) + ) where + +import Core.ISA (IsaStateG, StepG) +import Stepper.Memory (Memory, RegFile) + +type IsaSys = IsaStateG RegFile (Memory 32 8) + +type IsaSysStep = StepG RegFile (Memory 32 8) + +data Fuel = Done | More Fuel diff --git a/src/Stepper/AddrMap.hs b/src/Stepper/AddrMap.hs new file mode 100644 index 0000000..d041dc4 --- /dev/null +++ b/src/Stepper/AddrMap.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Stepper.AddrMap + ( AddrMap + , empty + , insert + , insertWith + , lookup + , foldrWithKey + , partitionByRange + ) where + +import SymFC.BuiltIn qualified as SymFC +import Types (Address) +import Prelude hiding (lookup) + +data Color = Red | Black + +data AddrMap v + = Tip + | Bin Color Address v (AddrMap v) (AddrMap v) + +empty :: AddrMap v +empty = Tip + +balance :: Color -> Address -> v -> AddrMap v -> AddrMap v -> AddrMap v +balance Black z zv (Bin Red y yv (Bin Red x xv a b) c) d = Bin Red y yv (Bin Black x xv a b) (Bin Black z zv c d) +balance Black z zv (Bin Red x xv a (Bin Red y yv b c)) d = Bin Red y yv (Bin Black x xv a b) (Bin Black z zv c d) +balance Black x xv a (Bin Red z zv (Bin Red y yv b c) d) = Bin Red y yv (Bin Black x xv a b) (Bin Black z zv c d) +balance Black x xv a (Bin Red y yv b (Bin Red z zv c d)) = Bin Red y yv (Bin Black x xv a b) (Bin Black z zv c d) +balance color k v l r = Bin color k v l r + +insertRed :: (Maybe v -> v) -> Address -> AddrMap v -> AddrMap v +insertRed combine k Tip = Bin Red k (combine Nothing) Tip Tip +insertRed combine k (Bin color nk nv l r) + | k < nk = balance color nk nv (insertRed combine k l) r + | k > nk = balance color nk nv l (insertRed combine k r) + | otherwise = Bin color k (combine (Just nv)) l r + +blackRoot :: AddrMap v -> AddrMap v +blackRoot (Bin _ k v l r) = Bin Black k v l r +blackRoot Tip = Tip + +insertWith :: (Maybe v -> v) -> Address -> AddrMap v -> AddrMap v +insertWith combine k tree = blackRoot (insertRed combine k tree) + +insert :: Address -> v -> AddrMap v -> AddrMap v +insert k v = insertWith (const v) k + +lookup :: Address -> AddrMap v -> Maybe v +lookup _ Tip = Nothing +lookup k (Bin _ nk nv l r) + | k < nk = lookup k l + | k > nk = lookup k r + | otherwise = Just nv + +foldrWithKey :: (Address -> v -> b -> b) -> b -> AddrMap v -> b +foldrWithKey _ z Tip = z +foldrWithKey f z (Bin _ k v l r) = foldrWithKey f (f k v (foldrWithKey f z r)) l + +singleton :: Address -> v -> AddrMap v +singleton k v = Bin Black k v Tip Tip + +lowestKey :: Address -> AddrMap v -> Address +lowestKey k Tip = k +lowestKey _ (Bin _ k _ l _) = lowestKey k l + +highestKey :: Address -> AddrMap v -> Address +highestKey k Tip = k +highestKey _ (Bin _ k _ _ r) = highestKey k r + +unionDisjoint :: AddrMap v -> AddrMap v -> AddrMap v +unionDisjoint a b = foldrWithKey insert b a + +partitionByRange + :: (Address -> Address -> SymFC.Sym Bool) + -> AddrMap v + -> SymFC.Sym (AddrMap v, AddrMap v) +partitionByRange _ Tip = pure (Tip, Tip) +partitionByRange rangeIsClear tree@(Bin _ k v l r) = do + clear <- rangeIsClear (lowestKey k l) (highestKey k r) + if clear then pure (Tip, tree) else partitionParts rangeIsClear k v l r + +partitionParts + :: (Address -> Address -> SymFC.Sym Bool) + -> Address + -> v + -> AddrMap v + -> AddrMap v + -> SymFC.Sym (AddrMap v, AddrMap v) +partitionParts _ k v Tip Tip = pure (singleton k v, Tip) +partitionParts rangeIsClear k v l r = do + (hitLeft, clearLeft) <- partitionByRange rangeIsClear l + (hitKey, clearKey) <- partitionByRange rangeIsClear (singleton k v) + (hitRight, clearRight) <- partitionByRange rangeIsClear r + pure + ( unionDisjoint hitLeft (unionDisjoint hitKey hitRight) + , unionDisjoint clearLeft (unionDisjoint clearKey clearRight) + ) diff --git a/src/Stepper/Concrete.hs b/src/Stepper/Concrete.hs new file mode 100644 index 0000000..c50cee2 --- /dev/null +++ b/src/Stepper/Concrete.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} + +module Stepper.Concrete + ( baseEmbeddings + , concreteAddress + , concreteAddressE + , concreteRegIdx + , concreteRegIdxE + , concreteEmbeddings + , knownBool + , knownBoolE + , stepperEmbeddings + ) where + +import Clash.Prelude (Nat, Type) +import Data.Coerce (coerce) +import SymFC (Embeddings (..)) +import SymFC.Base qualified as Base +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import SymFC.BuiltIn qualified as SymFC +import SymFC.Clash qualified as Clash +import Stepper.Shift (shiftEmbeddings) +import Types (Address, RegIdx) + +{-# OPAQUE concreteAddress #-} +concreteAddress :: Address -> SymFC.Sym (Maybe Address) +concreteAddress = pure . Just + +{-# OPAQUE concreteRegIdx #-} +concreteRegIdx :: RegIdx -> SymFC.Sym (Maybe RegIdx) +concreteRegIdx = pure . Just + +{-# OPAQUE knownBool #-} +knownBool :: Bool -> SymFC.Sym (Maybe Bool) +knownBool = pure . Just + +fromKnown :: SymFC.Known a -> Maybe a +fromKnown (SymFC.Known value) = Just value +fromKnown SymFC.NotKnown = Nothing + +concreteAddressE + :: forall (bvA :: Nat -> Type) + . Embeddable bvA Clash.BitVec + => bvA 32 + -> SymFC.Sym (Maybe (bvA 32)) +concreteAddressE + | Embedding <- embedding @bvA = coerce go + where + go :: Clash.BitVec 32 -> SymFC.Sym (Maybe (Clash.BitVec 32)) + go (Clash.BitVecP address) = fmap Clash.BitVecP . fromKnown <$> SymFC.concrete address + +concreteRegIdxE + :: forall (bvA :: Nat -> Type) + . Embeddable bvA Clash.BitVec + => bvA 5 + -> SymFC.Sym (Maybe (bvA 5)) +concreteRegIdxE + | Embedding <- embedding @bvA = coerce go + where + go :: Clash.BitVec 5 -> SymFC.Sym (Maybe (Clash.BitVec 5)) + go (Clash.BitVecP idx) = fmap Clash.BitVecP . fromKnown <$> SymFC.concrete idx + +knownBoolE :: Bool -> SymFC.Sym (Maybe Bool) +knownBoolE value = fromKnown <$> SymFC.concrete value + +concreteEmbeddings :: Embeddings +concreteEmbeddings = + Embeddings + { typeEmbeddings = [] + , termEmbeddings = + [ ('concreteAddress, 'concreteAddressE) + , ('concreteRegIdx, 'concreteRegIdxE) + , ('knownBool, 'knownBoolE) + ] + } + +baseEmbeddings :: Embeddings +baseEmbeddings = Base.embeddings <> Clash.embeddings <> shiftEmbeddings + +stepperEmbeddings :: Embeddings +stepperEmbeddings = baseEmbeddings <> concreteEmbeddings diff --git a/src/Stepper/ElfCode.hs b/src/Stepper/ElfCode.hs new file mode 100644 index 0000000..372d7c7 --- /dev/null +++ b/src/Stepper/ElfCode.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} + +module Stepper.ElfCode + ( elfCode + , DecodedTable + , expectDecodeAgreement + , expectFetchByAddress + , expectDecodeDisagreement + , withWrongFirstInstruction + ) where + +import Control.Monad.Catch (throwM) +import Data.Bits (shiftL, (.|.)) +import qualified Data.ByteString as BS +import Data.Elf +import Data.Elf.Headers +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Elf.ElfLoader (getElfSegments, readElf) +import Control.Monad (unless) +import Core.Instruction (Instruction (..), Reason4Stall (..), decode', nop) +import Language.Haskell.TH +import Memory.Types (MemFn (..), MemOps (..)) +import Language.Haskell.TH.Syntax (addDependentFile, lift) +import Numeric (showHex) +import qualified Stepper.RelState as RelState +import qualified SymFC.BuiltIn as SymFC +import Types (Address, Word) +import Prelude hiding (Word) + +data SymbolRange = SymbolRange + { rangeStart :: Integer + , rangeSize :: Integer + } + +data Image = Image + { imageSymbols :: Map String [SymbolRange] + , imageChunks :: [(Integer, BS.ByteString)] + } + +type FetchTable = [(Integer, Integer)] + +type DecodedTable = [(Word, Instruction)] + +decodeAgrees :: DecodedTable -> Bool +decodeAgrees [] = True +decodeAgrees ((word, decoded) : rest) = decode' word == decoded && decodeAgrees rest + +everyTableAgrees :: [DecodedTable] -> Bool +everyTableAgrees [] = True +everyTableAgrees (table : tables) = decodeAgrees table && everyTableAgrees tables + +expectDecodeAgreement :: [DecodedTable] -> SymFC.Sym () +expectDecodeAgreement tables = if everyTableAgrees tables then pure () else SymFC.halt + +expectDecodeDisagreement :: [DecodedTable] -> SymFC.Sym () +expectDecodeDisagreement tables = if everyTableAgrees tables then SymFC.halt else pure () + +differentInstruction :: Instruction -> Instruction +differentInstruction decoded = if decoded == Nop DecodeFail then nop else Nop DecodeFail + +withWrongFirstInstruction :: DecodedTable -> DecodedTable +withWrongFirstInstruction [] = [] +withWrongFirstInstruction ((word, decoded) : rest) = (word, differentInstruction decoded) : rest + +instructionBytes :: Integer +instructionBytes = 4 + +loadImage :: FilePath -> IO Image +loadImage path = do + elf@(Elf classS elfs) <- readElf path + case classS of + SELFCLASS64 -> throwM (userError "64-bit ELF not supported") + SELFCLASS32 -> do + header <- elfFindHeader elfs + symtab <- elfFindSectionByName elfs ".symtab" + symbols <- parseSymbolTable (ehData header) symtab elfs + pure + Image + { imageSymbols = + Map.fromListWith (++) + [ (steName symbol, [SymbolRange (fromIntegral (steValue symbol)) (fromIntegral (steSize symbol))]) + | symbol <- symbols + ] + , imageChunks = [(fromIntegral addr, bytes) | (addr, bytes) <- getElfSegments elf] + } + +littleEndian :: [Integer] -> Integer +littleEndian = foldr (\byte rest -> (rest `shiftL` 8) .|. byte) 0 + +fetchInstruction :: Image -> Integer -> Either String Integer +fetchInstruction image addr = + case [(base, bytes) | (base, bytes) <- imageChunks image, base <= addr, addr + instructionBytes <= base + toInteger (BS.length bytes)] of + [] -> Left ("no ELF data at address " ++ show addr) + (base, bytes) : _ -> + let offset = fromIntegral (addr - base) + instructionBytesOf = BS.take (fromIntegral instructionBytes) (BS.drop offset bytes) + in Right (littleEndian (map fromIntegral (BS.unpack instructionBytesOf))) + +lookupSymbol :: Image -> String -> Either String [SymbolRange] +lookupSymbol image name = maybe (Left ("symbol not found: " ++ name)) Right (Map.lookup name (imageSymbols image)) + +lowestStart :: [SymbolRange] -> Integer +lowestStart = minimum . map rangeStart + +rangeFetchTable :: Image -> SymbolRange -> Either String FetchTable +rangeFetchTable image SymbolRange {..} = + mapM (\addr -> (,) addr <$> fetchInstruction image addr) addresses + where + addresses = [rangeStart, rangeStart + instructionBytes .. rangeStart + rangeSize - instructionBytes] + +symbolFetchTable :: Image -> String -> Either String FetchTable +symbolFetchTable image name = do + ranges <- lookupSymbol image name + concat <$> mapM (rangeFetchTable image) ranges + +functionFetchTable :: Image -> [String] -> Either String FetchTable +functionFetchTable image symbols = do + tables <- mapM (symbolFetchTable image) symbols + pure (Map.toAscList (Map.fromList (concat tables))) + +entryAddress :: Image -> [String] -> Either String Integer +entryAddress image symbols = case symbols of + [] -> Left "function lists no symbols" + entry : _ -> lowestStart <$> lookupSymbol image entry + +type FetchedTable = [(Integer, Name)] + +searchTree :: Name -> FetchedTable -> Q Exp +searchTree _ [] = [|Nothing|] +searchTree pc [(addr, here)] = + [|if $(varE pc) == $(literal addr) then Just $(varE here) else Nothing|] +searchTree pc table = + case splitAt (length table `div` 2) table of + (lower, upper@((pivot, _) : _)) -> + [|if $(varE pc) < $(literal pivot) then $(searchTree pc lower) else $(searchTree pc upper)|] + (lower, []) -> searchTree pc lower + +literal :: Integer -> Q Exp +literal = litE . integerL + +fetchedName :: String -> Integer -> Name +fetchedName name addr = mkName (name ++ "At" ++ showHex addr "") + +decodedTableName :: String -> Name +decodedTableName name = mkName (name ++ "Decoded") + +instructionName :: String -> Integer -> Name +instructionName name word = mkName (name ++ "Instruction" ++ showHex word "") + +distinctWords :: FetchTable -> [Integer] +distinctWords table = Set.toAscList (Set.fromList (map snd table)) + +instructionDeclarations :: String -> FetchTable -> Q [Dec] +instructionDeclarations name table = concat <$> mapM declare (distinctWords table) + where + declare word = do + body <- lift (decode' (fromInteger word)) + pure + [ SigD (instructionName name word) (ConT ''Instruction) + , ValD (VarP (instructionName name word)) (NormalB body) [] + ] + +decodedTableDeclarations :: String -> FetchTable -> Q [Dec] +decodedTableDeclarations name table = do + body <- listE [[|($(literal word), $(varE (instructionName name word)))|] | word <- distinctWords table] + pure + [ SigD (decodedTableName name) (ConT ''DecodedTable) + , ValD (VarP (decodedTableName name)) (NormalB body) [] + ] + +fetchedDeclarations :: String -> FetchTable -> Q [Dec] +fetchedDeclarations name table = concat <$> mapM declare table + where + addresses = Map.fromList table + following addr + | Map.member (addr + instructionBytes) addresses = [|Just $(varE (fetchedName name (addr + instructionBytes)))|] + | otherwise = [|Nothing|] + declare (addr, word) = do + body <- [|RelState.fetchedDecoded $(literal addr) $(literal word) $(varE (instructionName name word)) $(following addr)|] + pure + [ SigD (fetchedName name addr) (ConT ''RelState.Fetched) + , ValD (VarP (fetchedName name addr)) (NormalB body) [] + ] + +codeExpression :: String -> FetchTable -> Q Exp +codeExpression name table = do + pc <- newName "pc" + let sortedTable = sortOn fst table + fetchedTable = [(addr, fetchedName name addr) | (addr, _) <- sortedTable] + fetch = lamE [varP pc] (searchTree pc fetchedTable) + addresses = listE (map (literal . fst) sortedTable) + codeSpan = case (sortedTable, reverse sortedTable) of + ((first, _) : _, (final, _) : _) -> [|Just ($(literal first), $(literal (final + instructionBytes)))|] + _ -> [|Nothing|] + [|RelState.Code $fetch (RelState.KnownAddresses $addresses) $codeSpan|] + +-- | The memory 'Elf.ElfLoader.loadElf' builds from the same segments: each +-- byte as written, later segments over earlier ones, zero elsewhere. +segmentMemory :: Image -> MemFn +segmentMemory image = MemFn \addr -> foldl (byteFrom (toInteger addr)) 0 (imageChunks image) + where + byteFrom addr byte (base, bytes) + | base <= addr && addr < base + toInteger (BS.length bytes) = fromIntegral (BS.index bytes (fromIntegral (addr - base))) + | otherwise = byte + +-- | Fail the splice unless every word in the table is the word the ISA reads +-- at that address from the loaded ELF. +checkTableAgainstMemory :: Image -> FetchTable -> Q () +checkTableAgainstMemory image table = mapM_ check table + where + memory = segmentMemory image + check (addr, word) = do + let fromMemory = toInteger (memReadWord (fromInteger addr) memory) + unless (fromMemory == word) $ + fail ("code table word " ++ showHex word "" ++ " at " ++ showHex addr "" ++ " differs from memory word " ++ showHex fromMemory "") + +-- | Fail unless 'RelState.codeFetch' finds exactly the listed addresses, each +-- at its own address. +expectFetchByAddress :: [RelState.Code] -> SymFC.Sym () +expectFetchByAddress codes = do + pc <- SymFC.fresh @Address + result <- SymFC.valid $ SymFC.boolean $ all (fetchesAt pc) codes + case result of + SymFC.None -> pure () + _ -> SymFC.halt + where + fetchesAt pc code = case (RelState.codeFetch code pc, RelState.codeAddresses code) of + (Just here, _) -> RelState.fetchedAddress here == pc + (Nothing, RelState.KnownAddresses addrs) -> all (/= pc) addrs + (Nothing, RelState.EveryAddress) -> False + +orFail :: Either String a -> Q a +orFail = either fail pure + +functionDeclarations :: Image -> (String, [String]) -> Q [Dec] +functionDeclarations image (name, symbols) = do + entry <- orFail (entryAddress image symbols) + table <- orFail (functionFetchTable image symbols) + checkTableAgainstMemory image table + let entryName = mkName (name ++ "Entry") + codeName = mkName (name ++ "Code") + code <- codeExpression name table + instructions <- instructionDeclarations name table + fetchedTable <- fetchedDeclarations name table + decodedTable <- decodedTableDeclarations name table + pure $ + instructions + ++ fetchedTable + ++ decodedTable + ++ [ SigD entryName (ConT ''Address) + , ValD (VarP entryName) (NormalB (LitE (IntegerL entry))) [] + , SigD codeName (ConT ''RelState.Code) + , ValD (VarP codeName) (NormalB code) [] + ] + +elfCode :: FilePath -> [(String, [String])] -> Q [Dec] +elfCode path functions = do + addDependentFile path + image <- runIO (loadImage path) + concat <$> mapM (functionDeclarations image) functions diff --git a/src/Stepper/Embedding.hs b/src/Stepper/Embedding.hs new file mode 100644 index 0000000..58ed7cd --- /dev/null +++ b/src/Stepper/Embedding.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoScopedTypeVariables #-} + +module Stepper.Embedding + ( -- embeddings + ) where + +import Prelude hiding (Word, read) +import Stepper.Memory qualified as Stepper (Memory) +import Stepper.Memory qualified as Memory +import SymFC.Base qualified as Base +import SymFC.Clash qualified as Clash +import SymFC (Embeddings (..)) +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import SymFC.BuiltIn qualified as SymFC +import Data.Coerce (coerce) +import GHC.TypeNats (type (<=)) + +embeddings :: Embeddings +embeddings = Base.embeddings <> Clash.embeddings <> embeddings' + +embeddings' :: Embeddings +embeddings' = Embeddings + { typeEmbeddings = + [ (''Stepper.Memory, ''Memory) + ] + , termEmbeddings = + [ ('Memory.empty, 'emptyM) + ] + } + +newtype Memory k v where + Memory :: SymFC.Array (SymFC.BitVec k) (SymFC.BitVec v) -> Memory k v + +emptyM + :: Embeddable memory Memory + => 1 <= k + => 1 <= v + => SymFC.KnownNat k + => SymFC.KnownNat v + => memory k v +emptyM @memory | Embedding <- embedding @memory = coerce $ SymFC.aconst 0 + +readM + :: Embeddable memory (Memory 32 8) + => Embeddable address (Clash.BitVec 32) + => Embeddable byte (Clash.BitVec 8) + => address + -> memory + -> byte +readM @memory @address @byte + | Embedding <- embedding @memory + , Embedding <- embedding @address + , Embedding <- embedding @byte + = coerce \(Clash.BitVecP addr) memory -> do + Clash.BitVecP $ SymFC.aselect memory addr + +writeM + :: Embeddable memory (Memory 32 8) + => Embeddable address (Clash.BitVec 32) + => Embeddable byte (Clash.BitVec 8) + => address + -> byte + -> memory + -> memory +writeM @memory @address @byte + | Embedding <- embedding @memory + , Embedding <- embedding @address + , Embedding <- embedding @byte + = coerce \(Clash.BitVecP addr) (Clash.BitVecP byte) memory -> do + SymFC.astore memory addr byte + +eqM + :: Embeddable memory (Memory 32 8) + => memory + -> memory + -> Bool +eqM @memory + | Embedding <- embedding @memory + = coerce \lhs rhs -> SymFC.ite (SymFC.aeq lhs rhs) True False + +type RegFile = SymFC.Array (SymFC.BitVec 5) (SymFC.BitVec 32) + +emptyR :: Embeddable regfile RegFile => regfile +emptyR @regfile | Embedding <- embedding @regfile = coerce $ SymFC.aconst 0 + +readR + :: Embeddable regfile RegFile + => Embeddable address (Clash.BitVec 5) + => Embeddable byte (Clash.BitVec 32) + => address + -> regfile + -> byte +readR @regfile @address @byte + | Embedding <- embedding @regfile + , Embedding <- embedding @address + , Embedding <- embedding @byte + = coerce \(Clash.BitVecP addr) regfile -> do + Clash.BitVecP $ SymFC.aselect regfile addr + +writeR + :: Embeddable regfile RegFile + => Embeddable address (Clash.BitVec 5) + => Embeddable byte (Clash.BitVec 32) + => address + -> byte + -> regfile + -> regfile +writeR @regfile @address @byte + | Embedding <- embedding @regfile + , Embedding <- embedding @address + , Embedding <- embedding @byte + = coerce \(Clash.BitVecP addr) (Clash.BitVecP byte) regfile -> do + SymFC.astore regfile addr byte + +eqR + :: Embeddable regfile RegFile + => regfile + -> regfile + -> Bool +eqR @regfile + | Embedding <- embedding @regfile + = coerce \lhs rhs -> SymFC.ite (SymFC.aeq lhs rhs) True False diff --git a/src/Stepper/Memory.hs b/src/Stepper/Memory.hs new file mode 100644 index 0000000..3635078 --- /dev/null +++ b/src/Stepper/Memory.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE NoScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE UndecidableInstances #-} + +module Stepper.Memory + ( Memory (..) + , empty + , read + , write + , eq + + , RegFile (..) + ) where + +import Clash.Prelude hiding (Word, empty, read) +import Data.Coerce (coerce) +import Data.Constraint (Dict (Dict)) +import Memory.Types (MemOps (..)) +import Prelude hiding (Word, read) +import Types (Size (..)) +import Core.RegFile (RegFileOps (..)) +import SymFC.BuiltIn qualified as SymFC +import SymFC.Clash (BitVec(..)) + +newtype Memory k v where + Memory :: SymFC.Array (SymFC.BitVec k) (SymFC.BitVec v) -> Memory k v + +instance + ( KnownNat k + , KnownNat v + , 1 <= k + , 1 <= v + ) => SymFC.Symbolic (Memory k v) where + symbolic = Memory <$> SymFC.symbolic + +empty + :: KnownNat k + => KnownNat v + => 1 <= k + => 1 <= v + => Memory k v +empty = Memory $ SymFC.aconst 0 + +eq :: Memory k v -> Memory k v -> Bool +eq @k @v = coerce $ (==) @(SymFC.Array (SymFC.BitVec k) (SymFC.BitVec v)) + +instance Eq (Memory k v) where + (==) = eq + +read + :: forall k v + . Unsigned k + -> Memory k v + -> BitVector v +read @k @v key (Memory arr) + | SymFC.ArrayType SymFC.BitVecType SymFC.BitVecType <- SymFC.atype arr + , Dict <- SymFC.reifyKnownNat @k $ Dict @(KnownNat k) + , Dict <- SymFC.reifyKnownNat @v $ Dict @(KnownNat v) = do + let BitVecP key' = bitCoerce key + let value = SymFC.aselect arr key' + bitCoerce $ BitVecP value + +write + :: forall k v + . Unsigned k + -> BitVector v + -> Memory k v + -> Memory k v +write @k @v key value (Memory arr) + | SymFC.ArrayType SymFC.BitVecType SymFC.BitVecType <- SymFC.atype arr + , Dict <- SymFC.reifyKnownNat @k $ Dict @(KnownNat k) + , Dict <- SymFC.reifyKnownNat @v $ Dict @(KnownNat v) = do + let BitVecP key' = bitCoerce key + let BitVecP value' = bitCoerce value + Memory $ SymFC.astore arr key' value' + +instance MemOps (Memory 32 8) where + memReadByte = read + memReadWord a m = do + memReadByte (a + 3) m + ++# memReadByte (a + 2) m + ++# memReadByte (a + 1) m + ++# memReadByte a m + memWrite a size w m = case size of + Byte -> put a b0 m + Half -> put (a + 1) b1 (put a b0 m) + Word -> put (a + 3) b3 (put (a + 2) b2 (put (a + 1) b1 (put a b0 m))) + where + b0 = slice d7 d0 w + b1 = slice d15 d8 w + b2 = slice d23 d16 w + b3 = slice d31 d24 w + put = write + +-- | Register file for the stepper. +newtype RegFile where + RegFile :: Memory 5 32 -> RegFile + +instance SymFC.Symbolic RegFile where + symbolic = RegFile <$> SymFC.symbolic + +instance Eq RegFile where + RegFile lhs == RegFile rhs = lhs == rhs + +instance RegFileOps RegFile where + lookupRFg idx (RegFile memory) = case idx of + 0 -> 0 + _ -> read idx memory + + modifyRFg idx value rf@(RegFile memory) = case idx of + 0 -> rf + _ -> RegFile $ write idx value memory + + initRFg = RegFile empty diff --git a/src/Stepper/Rel.hs b/src/Stepper/Rel.hs new file mode 100644 index 0000000..d3dca96 --- /dev/null +++ b/src/Stepper/Rel.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module Stepper.Rel + ( Rel (..) + , left + , right + , agree + ) where + +import Control.Comonad (Comonad (..)) +import Stepper.Concrete (knownBool) +import SymFC.BuiltIn qualified as SymFC + +data Rel a + = Same a + | Pair a a + +instance Functor Rel where + fmap f (Same a) = Same (f a) + fmap f (Pair a b) = Pair (f a) (f b) + +instance Applicative Rel where + pure = Same + Same f <*> Same a = Same (f a) + Same f <*> Pair a b = Pair (f a) (f b) + Pair f g <*> Same a = Pair (f a) (g a) + Pair f g <*> Pair a b = Pair (f a) (g b) + +-- | A two-run value read as a function from the run to its value, with the +-- first run in focus. 'extract' gives the first run's value; it stands for +-- the value only where both runs agree. +instance Comonad Rel where + extract = left + duplicate (Same a) = Same (Same a) + duplicate (Pair a b) = Pair (Pair a b) (Same b) + +left :: Rel a -> a +left (Same a) = a +left (Pair a _) = a + +right :: Rel a -> a +right (Same a) = a +right (Pair _ b) = b + +agree :: Eq a => Bool -> Rel a -> SymFC.Sym (Maybe a) +agree _ (Same a) = pure (Just a) +agree path (Pair a b) = do + known <- knownBool (a == b) + case known of + Just True -> pure (Just a) + _ -> do + result <- SymFC.valid $ SymFC.boolean $ not path || a == b + pure case result of + SymFC.None -> Just a + _ -> Nothing diff --git a/src/Stepper/RelMem.hs b/src/Stepper/RelMem.hs new file mode 100644 index 0000000..96771ed --- /dev/null +++ b/src/Stepper/RelMem.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TupleSections #-} + +module Stepper.RelMem + ( RelMem + , sameMem + , pairMem + , readByte + , writeByte + , readMemWord + , loadKnownWord + , loadMemWord + , writeMem + , leftMem + , rightMem + ) where + +import Clash.Prelude (d0, d15, d16, d23, d24, d31, d7, d8, slice, (++#)) +import Data.Bits (complement, (.&.)) +import Data.Maybe (fromMaybe) +import Stepper.AddrMap (AddrMap) +import Stepper.AddrMap qualified as AddrMap +import Stepper.Concrete (concreteAddress) +import Stepper.Memory (Memory) +import Stepper.Memory qualified as Memory +import Stepper.Rel (Rel (..), left, right) +import SymFC.BuiltIn qualified as SymFC +import Types (Address, Byte, Size (..), Word) +import Prelude hiding (Word) + +data Base + = SameBase (Memory 32 8) + | PairBase (Memory 32 8) (Memory 32 8) + +data Lane = Lane0 | Lane1 | Lane2 | Lane3 + +data Cell + = WholeWord (Rel Word) + | Lanes (Maybe (Rel Byte)) (Maybe (Rel Byte)) (Maybe (Rel Byte)) (Maybe (Rel Byte)) + +data RelMem = RelMem + { memBase :: Base + , memWrites :: AddrMap Cell + } + +sameMem :: Memory 32 8 -> RelMem +sameMem mem = RelMem (SameBase mem) AddrMap.empty + +pairMem :: Memory 32 8 -> Memory 32 8 -> RelMem +pairMem first second = RelMem (PairBase first second) AddrMap.empty + +storeByte :: Address -> Rel Byte -> Base -> Base +storeByte addr (Same byte) (SameBase mem) = SameBase (Memory.write addr byte mem) +storeByte addr (Pair byteA byteB) (SameBase mem) = + PairBase (Memory.write addr byteA mem) (Memory.write addr byteB mem) +storeByte addr byte (PairBase memA memB) = + PairBase (Memory.write addr (left byte) memA) (Memory.write addr (right byte) memB) + +storeLane :: Address -> Maybe (Rel Byte) -> Base -> Base +storeLane addr = maybe id (storeByte addr) + +loadByte :: Address -> Base -> Rel Byte +loadByte addr (SameBase mem) = Same (Memory.read addr mem) +loadByte addr (PairBase memA memB) = Pair (Memory.read addr memA) (Memory.read addr memB) + +lowBits :: Address +lowBits = 3 + +wordStart :: Address -> Address +wordStart addr = addr .&. complement lowBits + +isWordStart :: Address -> Bool +isWordStart addr = addr .&. lowBits == 0 + +laneOf :: Address -> Lane +laneOf addr = case addr .&. lowBits of + 0 -> Lane0 + 1 -> Lane1 + 2 -> Lane2 + _ -> Lane3 + +byte0, byte1, byte2, byte3 :: Rel Word -> Rel Byte +byte0 word = slice d7 d0 <$> word +byte1 word = slice d15 d8 <$> word +byte2 word = slice d23 d16 <$> word +byte3 word = slice d31 d24 <$> word + +joinBytes :: Rel Byte -> Rel Byte -> Rel Byte -> Rel Byte -> Rel Word +joinBytes b3 b2 b1 b0 = (\x3 x2 x1 x0 -> x3 ++# x2 ++# x1 ++# x0) <$> b3 <*> b2 <*> b1 <*> b0 + +cellLanes :: Cell -> (Maybe (Rel Byte), Maybe (Rel Byte), Maybe (Rel Byte), Maybe (Rel Byte)) +cellLanes (WholeWord word) = (Just (byte0 word), Just (byte1 word), Just (byte2 word), Just (byte3 word)) +cellLanes (Lanes l0 l1 l2 l3) = (l0, l1, l2, l3) + +laneIn :: Lane -> Cell -> Maybe (Rel Byte) +laneIn lane cell = case (lane, cellLanes cell) of + (Lane0, (l0, _, _, _)) -> l0 + (Lane1, (_, l1, _, _)) -> l1 + (Lane2, (_, _, l2, _)) -> l2 + (Lane3, (_, _, _, l3)) -> l3 + +withLane :: Lane -> Rel Byte -> Maybe Cell -> Cell +withLane lane byte old = case (lane, maybe (Nothing, Nothing, Nothing, Nothing) cellLanes old) of + (Lane0, (_, l1, l2, l3)) -> Lanes (Just byte) l1 l2 l3 + (Lane1, (l0, _, l2, l3)) -> Lanes l0 (Just byte) l2 l3 + (Lane2, (l0, l1, _, l3)) -> Lanes l0 l1 (Just byte) l3 + (Lane3, (l0, l1, l2, _)) -> Lanes l0 l1 l2 (Just byte) + +storeCell :: Address -> Cell -> Base -> Base +storeCell start cell base = + storeLane start l0 (storeLane (start + 1) l1 (storeLane (start + 2) l2 (storeLane (start + 3) l3 base))) + where + (l0, l1, l2, l3) = cellLanes cell + +withWritesStored :: RelMem -> Base +withWritesStored (RelMem base writes) = AddrMap.foldrWithKey storeCell base writes + +readKnownByte :: Address -> RelMem -> Rel Byte +readKnownByte known mem = + fromMaybe (loadByte known (memBase mem)) (AddrMap.lookup (wordStart known) (memWrites mem) >>= laneIn (laneOf known)) + +readByte :: Address -> RelMem -> SymFC.Sym (Rel Byte) +readByte addr mem = do + known <- concreteAddress addr + pure case known of + Just knownAddr -> readKnownByte knownAddr mem + Nothing -> loadByte addr (withWritesStored mem) + +outOfReach :: Bool -> Address -> Address -> Address -> SymFC.Sym Bool +outOfReach path addr lo hi = do + result <- SymFC.valid $ SymFC.boolean $ not path || addr < lo || hi + lowBits < addr + pure case result of + SymFC.None -> True + _ -> False + +writeByte :: Bool -> Address -> Rel Byte -> RelMem -> SymFC.Sym RelMem +writeByte path addr byte mem = do + known <- concreteAddress addr + case known of + Just knownAddr -> + pure mem {memWrites = AddrMap.insertWith (withLane (laneOf knownAddr) byte) (wordStart knownAddr) (memWrites mem)} + Nothing -> do + (mayAlias, untouched) <- AddrMap.partitionByRange (outOfReach path addr) (memWrites mem) + let spilled = AddrMap.foldrWithKey storeCell (memBase mem) mayAlias + pure (RelMem (storeByte addr byte spilled) untouched) + +knownWordStart :: Address -> SymFC.Sym (Maybe Address) +knownWordStart addr = do + known <- concreteAddress addr + pure case known of + Just knownAddr | isWordStart knownAddr -> Just knownAddr + _ -> Nothing + +readWordAt :: Address -> RelMem -> Rel Word +readWordAt start mem = case AddrMap.lookup start (memWrites mem) of + Just (WholeWord word) -> word + cell -> wordOver start cell (memBase mem) + +wordOver :: Address -> Maybe Cell -> Base -> Rel Word +wordOver start cell base = joinBytes (laneOr 3 Lane3) (laneOr 2 Lane2) (laneOr 1 Lane1) (laneOr 0 Lane0) + where + laneOr offset lane = fromMaybe (loadByte (start + offset) base) (cell >>= laneIn lane) + +readBytesOfWord :: Address -> RelMem -> SymFC.Sym (Rel Word) +readBytesOfWord addr mem = + joinBytes <$> readByte (addr + 3) mem <*> readByte (addr + 2) mem <*> readByte (addr + 1) mem <*> readByte addr mem + +readMemWord :: Address -> RelMem -> SymFC.Sym (Rel Word) +readMemWord addr mem = do + start <- knownWordStart addr + case start of + Just knownStart -> pure (readWordAt knownStart mem) + Nothing -> readBytesOfWord addr mem + +loadKnownWord :: Address -> RelMem -> SymFC.Sym (Maybe (Rel Word, RelMem)) +loadKnownWord addr mem = fmap (`loadWordAt` mem) <$> knownWordStart addr + +loadMemWord :: Address -> RelMem -> SymFC.Sym (Rel Word, RelMem) +loadMemWord addr mem = do + start <- knownWordStart addr + case start of + Just knownStart -> pure (loadWordAt knownStart mem) + Nothing -> (,mem) <$> readBytesOfWord addr mem + +loadWordAt :: Address -> RelMem -> (Rel Word, RelMem) +loadWordAt start mem = case AddrMap.lookup start (memWrites mem) of + Nothing -> recordBaseWord start mem + Just _ -> (readWordAt start mem, mem) + +recordBaseWord :: Address -> RelMem -> (Rel Word, RelMem) +recordBaseWord start mem = (word, mem {memWrites = AddrMap.insert start (WholeWord word) (memWrites mem)}) + where + word = wordOver start Nothing (memBase mem) + +writeMem :: Bool -> Size -> Address -> Rel Word -> RelMem -> SymFC.Sym RelMem +writeMem path size addr word mem = case size of + Byte -> put addr (byte0 word) mem + Half -> put addr (byte0 word) mem >>= put (addr + 1) (byte1 word) + Word -> do + start <- knownWordStart addr + case start of + Just knownStart -> pure mem {memWrites = AddrMap.insert knownStart (WholeWord word) (memWrites mem)} + Nothing -> + put addr (byte0 word) mem >>= put (addr + 1) (byte1 word) >>= put (addr + 2) (byte2 word) >>= put (addr + 3) (byte3 word) + where + put = writeByte path + +leftMem :: RelMem -> Memory 32 8 +leftMem mem = case withWritesStored mem of + SameBase base -> base + PairBase base _ -> base + +rightMem :: RelMem -> Memory 32 8 +rightMem mem = case withWritesStored mem of + SameBase base -> base + PairBase _ base -> base diff --git a/src/Stepper/RelRegs.hs b/src/Stepper/RelRegs.hs new file mode 100644 index 0000000..c658c33 --- /dev/null +++ b/src/Stepper/RelRegs.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Stepper.RelRegs + ( RelRegs + , regsFrom + , readReg + , writeReg + , RegSlot (..) + , slotFor + , knownSlot + , sourceSlot + , readSlot + , writeSlot + ) where + +import Stepper.Concrete (concreteRegIdx) +import Stepper.Rel (Rel (..)) +import SymFC.BuiltIn qualified as SymFC +import Types (RegIdx, Word) +import Prelude hiding (Word) + +data RegTree + = RegLeaf (Rel Word) + | RegSplit RegIdx RegTree RegTree + +data RelRegs = RelRegs + { knownIndexRegs :: RegTree + , anyIndexRegs :: RegIdx -> Rel Word + } + +data Turn = Below | Above + +data RegSlot + = NoRegister + | ZeroRegister + | KnownRegister RegIdx [Turn] + | AnyRegister RegIdx + +halvingWidths :: [RegIdx] +halvingWidths = [16, 8, 4, 2, 1] + +regsFrom :: (RegIdx -> Rel Word) -> RelRegs +regsFrom initial = RelRegs (spanning 0 halvingWidths) initial + where + spanning lowest [] = RegLeaf (initial lowest) + spanning lowest (half : halves) = + RegSplit (lowest + half) (spanning lowest halves) (spanning (lowest + half) halves) + +data Pivots + = NoPivot + | Pivot RegIdx Pivots Pivots + +pivots :: Pivots +pivots = spanning 0 halvingWidths + where + spanning _ [] = NoPivot + spanning lowest (half : halves) = + Pivot (lowest + half) (spanning lowest halves) (spanning (lowest + half) halves) + +turnsTo :: RegIdx -> [Turn] +turnsTo idx = turnsWithin pivots + where + turnsWithin NoPivot = [] + turnsWithin (Pivot pivot below above) + | idx < pivot = Below : turnsWithin below + | otherwise = Above : turnsWithin above + +zeroTurns :: [Turn] +zeroTurns = turnsTo 0 + +knownSlot :: RegIdx -> RegSlot +knownSlot 0 = ZeroRegister +knownSlot known = KnownRegister known (turnsTo known) + +slotFor :: RegIdx -> SymFC.Sym RegSlot +slotFor idx = maybe (AnyRegister idx) knownSlot <$> concreteRegIdx idx + +sourceSlot :: Maybe RegIdx -> SymFC.Sym RegSlot +sourceSlot = maybe (pure NoRegister) slotFor + +lookupAlong :: [Turn] -> RegTree -> Rel Word +lookupAlong _ (RegLeaf value) = value +lookupAlong (Above : turns) (RegSplit _ _ above) = lookupAlong turns above +lookupAlong (Below : turns) (RegSplit _ below _) = lookupAlong turns below +lookupAlong [] (RegSplit _ below _) = lookupAlong [] below + +readSlot :: RelRegs -> RegSlot -> Rel Word +readSlot _ NoRegister = Same 0 +readSlot regs ZeroRegister = lookupAlong zeroTurns (knownIndexRegs regs) +readSlot regs (KnownRegister _ turns) = lookupAlong turns (knownIndexRegs regs) +readSlot regs (AnyRegister idx) = anyIndexRegs regs idx + +readReg :: RelRegs -> Maybe RegIdx -> SymFC.Sym (Rel Word) +readReg regs idx = readSlot regs <$> sourceSlot idx + +replaceAlong :: [Turn] -> Rel Word -> RegTree -> RegTree +replaceAlong _ value (RegLeaf _) = RegLeaf value +replaceAlong (Above : turns) value (RegSplit pivot below above) = RegSplit pivot below (replaceAlong turns value above) +replaceAlong (Below : turns) value (RegSplit pivot below above) = RegSplit pivot (replaceAlong turns value below) above +replaceAlong [] value (RegSplit pivot below above) = RegSplit pivot (replaceAlong [] value below) above + +replaceMatchingLeaf :: RegIdx -> Rel Word -> RegIdx -> RegTree -> RegTree +replaceMatchingLeaf rd value lowest (RegLeaf old) = RegLeaf (if lowest == rd then value else old) +replaceMatchingLeaf rd value lowest (RegSplit pivot below above) = + RegSplit pivot (replaceMatchingLeaf rd value lowest below) (replaceMatchingLeaf rd value pivot above) + +withChained :: RegIdx -> Rel Word -> (RegIdx -> Rel Word) -> RegIdx -> Rel Word +withChained rd value chain idx = if idx == rd then value else chain idx + +writeUnknownIndex :: RegIdx -> Rel Word -> RelRegs -> RelRegs +writeUnknownIndex 0 _ regs = regs +writeUnknownIndex rd value (RelRegs tree chain) = + RelRegs (replaceMatchingLeaf rd value 0 tree) (withChained rd value chain) + +writeSlot :: RegSlot -> Rel Word -> RelRegs -> RelRegs +writeSlot NoRegister _ regs = regs +writeSlot ZeroRegister _ regs = regs +writeSlot (KnownRegister rd turns) value (RelRegs tree chain) = + RelRegs (replaceAlong turns value tree) (withChained rd value chain) +writeSlot (AnyRegister rd) value regs = writeUnknownIndex rd value regs + +writeReg :: RegIdx -> Rel Word -> RelRegs -> SymFC.Sym RelRegs +writeReg rd value regs = do + slot <- slotFor rd + pure (writeSlot slot value regs) diff --git a/src/Stepper/RelState.hs b/src/Stepper/RelState.hs new file mode 100644 index 0000000..1f336ce --- /dev/null +++ b/src/Stepper/RelState.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Stepper.RelState + ( RelRegs + , readReg + , writeReg + , RelMem + , sameMem + , pairMem + , readMemWord + , loadKnownWord + , loadMemWord + , writeMem + , leftMem + , rightMem + , RegSlot + , slotFor + , readSlot + , writeSlot + , funcSlots + , knownOperands + , Operands (..) + , Fetched (..) + , fetched + , fetchedDecoded + , fetchedFromMemory + , Code (..) + , writesCode + , CodeAddresses (..) + , noCode + , withInstruction + , codeFromMemory + , RelState (..) + , sameState + , pairState + , withSecretReg + , withSecretWord + ) where + +import Data.Functor.Identity (runIdentity) +import Clash.Prelude (bitCoerce) +import Core.ISA (DepReg (..), Func, Instr (..), IsaStateG (..), PC, interp) +import Core.Instruction (Instruction, decode') +import Memory.Types (MemOps (..)) +import Core.RegFile (RegFileOps (..)) +import Stepper (IsaSys) +import Stepper.Concrete (concreteAddress) +import Stepper.Memory (Memory) +import Stepper.Rel (Rel (..)) +import Stepper.RelMem +import Stepper.RelRegs +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (..), Word) +import Prelude hiding (Word) + +data CodeAddresses + = EveryAddress + | KnownAddresses [Address] + +funcSlots :: Func a -> SymFC.Sym (RegSlot, RegSlot) +funcSlots f = (,) <$> sourceSlot (fst (deps f)) <*> sourceSlot (snd (deps f)) + +knownFuncSlots :: Func a -> (RegSlot, RegSlot) +knownFuncSlots f = (knownSourceSlot (fst (deps f)), knownSourceSlot (snd (deps f))) + where + knownSourceSlot = maybe NoRegister knownSlot + +data Operands = Operands + { sourceSlots :: (RegSlot, RegSlot) + , registerFieldSlot :: RegSlot + } + +knownOperands :: Instr Func -> Operands +knownOperands instr = case instr of + Reg rd f -> Operands (knownFuncSlots f) (knownSlot rd) + Load _ _ rd f -> Operands (knownFuncSlots f) (knownSlot rd) + Jump rd _ target -> Operands (knownFuncSlots target) (knownSlot rd) + Store _ addr rs2 -> Operands (knownFuncSlots addr) (knownSlot rs2) + Branch cond _ -> Operands (knownFuncSlots cond) NoRegister + Nop -> unused + Break -> unused + Syscall -> unused + where + unused = Operands (NoRegister, NoRegister) NoRegister + +data Fetched = Fetched + { fetchedAddress :: Address + , fetchedWord :: Word + , fetchedDecodedWord :: Instruction + , fetchedInstr :: Instr Func + , fetchedOperands :: SymFC.Sym (Maybe Operands) + , fetchedFollowing :: Maybe Fetched + } + +fetched :: Address -> Word -> Maybe Fetched -> Fetched +fetched addr word = fetchedDecoded addr word (decode' word) + +fetchedDecoded :: Address -> Word -> Instruction -> Maybe Fetched -> Fetched +fetchedDecoded addr word decoded following = + Fetched + { fetchedAddress = addr + , fetchedWord = word + , fetchedDecodedWord = decoded + , fetchedInstr = instr + , fetchedOperands = pure (Just (knownOperands instr)) + , fetchedFollowing = following >>= sittingAfter addr + } + where + instr = interp decoded + +sittingAfter :: Address -> Fetched -> Maybe Fetched +sittingAfter addr next = if fetchedAddress next == addr + 4 then Just next else Nothing + +fetchedFromMemory :: Address -> Word -> Fetched +fetchedFromMemory addr word = literal {fetchedOperands = operandsIfKnown} + where + literal = fetched addr word Nothing + operandsIfKnown = (knownOperands (fetchedInstr literal) <$) <$> concreteAddress (bitCoerce word) + +data Code = Code + { codeFetch :: Address -> Maybe Fetched + , codeAddresses :: CodeAddresses + , codeSpan :: Maybe (Address, Address) + } + +noCode :: Code +noCode = Code {codeFetch = const Nothing, codeAddresses = KnownAddresses [], codeSpan = Nothing} + +withInstruction :: Address -> Word -> Code -> Code +withInstruction addr word code = + Code + { codeFetch = \pc -> if pc == addr then Just (fetched addr word Nothing) else codeFetch code pc + , codeAddresses = withAddress (codeAddresses code) + , codeSpan = Just (maybe (addr, end) (\(lo, hi) -> (min lo addr, max hi end)) (codeSpan code)) + } + where + end = addr + 4 + withAddress EveryAddress = EveryAddress + withAddress (KnownAddresses addrs) = KnownAddresses (addr : addrs) + +-- | Code read from the given memory, which later stores do not change. Only +-- the single-step proofs use it, so 'writesCode' does not watch it. +codeFromMemory :: Memory 32 8 -> Code +codeFromMemory mem = + Code + { codeFetch = \pc -> Just (fetchedFromMemory pc (memReadWord pc mem)) + , codeAddresses = EveryAddress + , codeSpan = Nothing + } + +-- | Whether a store of this size at this address can touch an instruction. +-- The span test settles almost every store; the per-word test runs only for +-- a store that overlaps the span. Addresses wrap, so a word stored at +-- @0xfffffffe@ writes bytes 0 and 1. +writesCode :: Code -> Size -> Address -> Bool +writesCode code size addr = case (codeSpan code, codeAddresses code) of + (Just (lo, hi), KnownAddresses addrs) -> storeOverlaps lo (hi - lo) && overlapsSome addrs + _ -> False + where + storeOverlaps start len = start - addr < sizeBytes || addr - start < len + sizeBytes = case size of + Byte -> 1 + Half -> 2 + Word -> 4 + overlapsSome = foldr (\word rest -> storeOverlaps word 4 || rest) False + +data RelState = RelState + { relPath :: Bool + , relCode :: Code + , relPc :: PC + , relFetchHint :: Maybe Fetched + , relRegs :: RelRegs + , relMem :: RelMem + , relWritesCode :: Bool + } + +sameState :: Code -> IsaSys -> RelState +sameState code isa = + RelState + { relPath = True + , relCode = code + , relPc = isaPc isa + , relFetchHint = Nothing + , relRegs = regsFrom (\idx -> Same (lookupRFg idx (isaRegFile isa))) + , relMem = sameMem (isaMem isa) + , relWritesCode = False + } + +pairState :: Code -> IsaSys -> IsaSys -> RelState +pairState code first second = + (sameState code first) + { relRegs = regsFrom (\idx -> Pair (registerOf first idx) (registerOf second idx)) + , relMem = pairMem (isaMem first) (isaMem second) + } + where + registerOf isa idx = lookupRFg idx (isaRegFile isa) + +withSecretReg :: RegIdx -> Word -> Word -> RelState -> SymFC.Sym RelState +withSecretReg idx secretA secretB st = do + regs <- writeReg idx (Pair secretA secretB) (relRegs st) + pure st {relRegs = regs} + +withSecretWord :: Address -> Word -> Word -> RelState -> SymFC.Sym RelState +withSecretWord addr secretA secretB st = do + mem <- writeMem (relPath st) Word addr (Pair secretA secretB) (relMem st) + pure st {relMem = mem} diff --git a/src/Stepper/Relational.hs b/src/Stepper/Relational.hs new file mode 100644 index 0000000..f5df208 --- /dev/null +++ b/src/Stepper/Relational.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} + +module Stepper.Relational + ( RelOutcome (..) + , relStep + , Verdict (..) + , relRun + , leakOfReadsAgree + ) where + +import Data.Maybe (isJust) +import Core.ISA (Flow (..), IsaStateG (..), Machine (..), PC, isaStepM) +import Core.Instruction (Instruction) +import Core.Instruction qualified as I +import Memory.Types (MemOps (..)) +import Proof.Core.Leakage.Model (leakOf) +import Core.RegFile (RegFn (..)) +import Stepper (Fuel (..)) +import Stepper.Concrete (concreteAddress, concreteRegIdx, knownBool) +import Stepper.Memory (Memory) +import Stepper.Memory qualified as Memory +import Stepper.Rel (Rel (..), agree, left, right) +import Stepper.RelRegs (RegSlot (AnyRegister), knownSlot) +import Stepper.RelState +import SymFC.BuiltIn qualified as SymFC +import Types (Address, RegIdx, Size (Word)) +import Prelude hiding (Word) + +data RelOutcome + = RelNext RelState + | RelHalted + | RelOutsideCode + | RelInfeasible + | RelFork [RelOutcome] + | RelLeaks PC + | RelWritesCode PC + +data Candidate = Candidate + { candidateGuard :: Bool + , candidateOutcome :: Bool -> RelOutcome + } + +continueOn :: Bool -> RelState -> Candidate +continueOn guard next = Candidate guard \path' -> RelNext next {relPath = path'} + +type RunState = IsaStateG RegFn (Memory 32 8) + +runStates :: RelState -> Fetched -> Maybe Fetched -> Rel RunState +runStates st here next = Pair (runState left leftMem) (runState right rightMem) + where + runState side sideMem = + IsaState + { isaPc = relPc st + , isaRegFile = RegFn \idx -> side (readSlot (relRegs st) (AnyRegister idx)) + , isaMem = memoryLeakOfReads (sideMem (relMem st)) + } + memoryLeakOfReads sideMem = case maybe (codeFetch (relCode st) (relPc st + 4)) Just next of + Just following -> withCodeWord here (withCodeWord following Memory.empty) + Nothing -> withCodeWord here sideMem + withCodeWord instr = memWrite (fetchedAddress instr) Word (fetchedWord instr) + +leakOfReadsAgree :: Applicative m => (RegIdx -> m Bool) -> m Bool -> Instruction -> m Bool +leakOfReadsAgree agrees followingAgrees ir = case ir of + I.BType _ _ rs1 rs2 -> (&&) <$> agrees rs1 <*> agrees rs2 + I.IType I.Jump _ rs1 _ -> agrees rs1 + I.IType (I.Load _ _) _ rs1 _ -> (&&) <$> agrees rs1 <*> followingAgrees + I.SType _ _ rs1 _ -> agrees rs1 + _ -> pure True + +isSame :: Rel a -> Bool +isSame (Same _) = True +isSame (Pair _ _) = False + +sameRegister :: RelRegs -> RegIdx -> SymFC.Sym Bool +sameRegister regs reg = do + known <- concreteRegIdx reg + pure case known of + Just idx -> isSame (readSlot regs (knownSlot idx)) + Nothing -> False + +-- | One step of 'isaStepM' on both runs at once. +newtype RelM a = RelM {runRelM :: RelState -> SymFC.Sym (a, RelState)} + +instance Functor RelM where + fmap f (RelM run) = RelM \st -> (\(a, st') -> (f a, st')) <$> run st + +instance Applicative RelM where + pure a = RelM \st -> pure (a, st) + RelM runF <*> RelM runA = RelM \st -> do + (f, st') <- runF st + (a, st'') <- runA st' + pure (f a, st'') + +instance Monad RelM where + RelM run >>= k = RelM \st -> do + (a, st') <- run st + runRelM (k a) st' + +instance Machine Rel RelM where + readReg idx = RelM \st -> do + slot <- slotFor idx + pure (readSlot (relRegs st) slot, st) + writeReg idx value = RelM \st -> do + slot <- slotFor idx + pure ((), st {relRegs = writeSlot slot value (relRegs st)}) + loadWord addr = RelM \st -> do + (word, mem') <- loadMemWord addr (relMem st) + pure (word, st {relMem = mem'}) + storeWord size addr value = RelM \st -> do + mem' <- writeMem (relPath st) size addr value (relMem st) + let touchesCode = relWritesCode st || writesCode (relCode st) size addr + pure ((), st {relMem = mem', relWritesCode = touchesCode}) + +relStep :: RelState -> SymFC.Sym RelOutcome +relStep st@RelState {relPath = path, relCode = code, relPc = pc, relRegs = regs} = do + current <- currentFetch st + case current of + Nothing -> pure RelOutsideCode + Just (here, next) -> do + readsAgree <- leakOfReadsAgree (sameRegister regs) (pure (isJust next)) (fetchedDecodedWord here) + sameLeak <- + if readsAgree + then pure True + else isJust <$> agree path (leakOf <$> runStates st here next) + if sameLeak + then checkStores next =<< runRelM (isaStepM pc (fetchedInstr here)) st {relWritesCode = False} + else pure (RelLeaks pc) + where + checkStores next (control, later) = do + known <- knownBool (relWritesCode later) + touchesCode <- case known of + Just touches -> pure touches + Nothing -> isFeasible (path && relWritesCode later) + if touchesCode + then pure (RelWritesCode pc) + else continueAfter next control later + + continueAfter next control later = case control of + FallThrough -> pure (RelNext (fallThrough later)) + Goto target -> jumpTo target (`landAt` later) + BranchTo taken target -> forkOn taken (landAt target later) (fallThrough later) + Halt -> pure RelHalted + where + fallThrough after = case next of + Just following -> after {relPc = fetchedAddress following, relFetchHint = Just following} + Nothing -> after {relPc = pc + 4, relFetchHint = Nothing} + + forkOn :: Bool -> RelState -> RelState -> SymFC.Sym RelOutcome + forkOn cond whenTrue whenFalse = do + known <- knownBool cond + case known of + Just True -> pure (RelNext whenTrue) + Just False -> pure (RelNext whenFalse) + Nothing -> forkAmong [continueOn cond whenTrue, continueOn (not cond) whenFalse] + + jumpTo :: PC -> (PC -> RelState) -> SymFC.Sym RelOutcome + jumpTo target landing = do + known <- concreteAddress target + case (known, codeAddresses code) of + (Nothing, KnownAddresses addrs) -> do + outside <- feasibleOutcomes [leaveCode] + oneOutcome <$> landingsAmong addrs outside + where + leaveCode = Candidate (missesEvery addrs target) (const RelOutsideCode) + + landOn addr = RelNext (landing addr) {relPath = path && target == addr} + + reachable addrs' = isFeasible (path && hitsSome addrs' target) + + landingsAmong addrs' later = do + canLand <- reachable addrs' + if canLand then landingsAmongReachable addrs' later else pure later + + landingsAmongReachable [] later = pure later + landingsAmongReachable [addr] later = pure (landOn addr : later) + landingsAmongReachable addrs' later = case halves addrs' of + (lower, upper) -> do + lowerReachable <- reachable lower + if lowerReachable + then landingsAmongReachable lower =<< landingsAmong upper later + else landingsAmongReachable upper later + _ -> pure (RelNext (landing target)) + + isFeasible :: Bool -> SymFC.Sym Bool + isFeasible guardedPath = do + feasible <- SymFC.satisfiable $ SymFC.boolean guardedPath + pure case feasible of + SymFC.None -> False + _ -> True + + forkAmong :: [Candidate] -> SymFC.Sym RelOutcome + forkAmong candidates = oneOutcome <$> feasibleOutcomes candidates + + feasibleOutcomes :: [Candidate] -> SymFC.Sym [RelOutcome] + feasibleOutcomes [] = pure [] + feasibleOutcomes (Candidate guard outcome : rest) = do + let guardedPath = path && guard + feasible <- isFeasible guardedPath + later <- feasibleOutcomes rest + pure (if feasible then outcome guardedPath : later else later) + +landAt :: PC -> RelState -> RelState +landAt addr st = st {relPc = addr, relFetchHint = Nothing} + +currentFetch :: RelState -> SymFC.Sym (Maybe (Fetched, Maybe Fetched)) +currentFetch st = case relFetchHint st of + Just hint -> pure (Just (hint, fetchedFollowing hint)) + Nothing -> traverse withFollowing (codeFetch (relCode st) (relPc st)) + where + withFollowing here = do + atPc <- knownBool (fetchedAddress here == relPc st) + pure case atPc of + Just True -> (here, fetchedFollowing here) + _ -> (here, Nothing) + +missesEvery :: [Address] -> PC -> Bool +missesEvery addrs target = foldr (\addr rest -> target /= addr && rest) True addrs + +hitsSome :: [Address] -> PC -> Bool +hitsSome addrs target = foldr (\addr rest -> target == addr || rest) False addrs + +halves :: [a] -> ([a], [a]) +halves items = splitBeside items items + where + splitBeside (item : rest) (_ : _ : faster) = case splitBeside rest faster of + (front, back) -> (item : front, back) + splitBeside rest _ = ([], rest) + +oneOutcome :: [RelOutcome] -> RelOutcome +oneOutcome [] = RelInfeasible +oneOutcome [outcome] = outcome +oneOutcome outcomes = RelFork outcomes + +data Verdict + = NoLeak + | OutOfFuel + | Leaks PC + | WritesCode PC + +stopsChecking :: Verdict -> Bool +stopsChecking = \case + Leaks {} -> True + WritesCode {} -> True + _ -> False + +laterPathVerdict :: Verdict -> Verdict -> Verdict +laterPathVerdict _ later | stopsChecking later = later +laterPathVerdict OutOfFuel _ = OutOfFuel +laterPathVerdict _ later = later + +relRun :: Fuel -> RelState -> SymFC.Sym Verdict +relRun Done _ = pure OutOfFuel +relRun (More fuel) st = follow fuel =<< relStep st + +follow :: Fuel -> RelOutcome -> SymFC.Sym Verdict +follow fuel outcome = case outcome of + RelNext st' -> relRun fuel st' + RelHalted -> pure NoLeak + RelOutsideCode -> pure NoLeak + RelInfeasible -> pure NoLeak + RelFork branches -> followAll fuel branches + RelLeaks pc -> pure (Leaks pc) + RelWritesCode pc -> pure (WritesCode pc) + +followAll :: Fuel -> [RelOutcome] -> SymFC.Sym Verdict +followAll _ [] = pure NoLeak +followAll fuel (branch : rest) = do + verdict <- follow fuel branch + if stopsChecking verdict + then pure verdict + else laterPathVerdict verdict <$> followAll fuel rest diff --git a/src/Stepper/Shift.hs b/src/Stepper/Shift.hs new file mode 100644 index 0000000..1c1b249 --- /dev/null +++ b/src/Stepper/Shift.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- | The ALU shifts as SMT bitvector shifts. +-- +-- In @src@ rather than with the other embeddings in "Proof.SMT.Axioms" because +-- the stepper needs them too: the hardware proofs and the stepper then send the +-- same shift terms to the solver. +module Stepper.Shift + ( shiftEmbeddings, + sllWordE, + srlWordE, + sraWordE, + ) +where + +import Clash.Prelude (Nat, Type) +import Core.Alu (sllWord, sraWord, srlWord) +import Data.Coerce (coerce) +import SymFC (Embeddings (..)) +import qualified SymFC.BuiltIn as P +import SymFC.BuiltIn (Embeddable, Embedding (..), embedding) +import qualified SymFC.Clash as Clash + +-- | The ALU shifts, mapped to the SMT bitvector shifts. +-- +-- See 'Core.Alu.sllWord' for why the wrappers exist: they keep the shift amount a +-- bitvector, so a query stays in the bitvector-and-array fragment that Bitwuzla +-- and Yices can read. +shiftEmbeddings :: Embeddings +shiftEmbeddings = + Embeddings + { typeEmbeddings = [], + termEmbeddings = + [ ('sllWord, 'sllWordE), + ('srlWord, 'srlWordE), + ('sraWord, 'sraWordE) + ] + } + +-- Shifts as SMT bitvector shifts ---------------------------------------------- +-- +-- Embeddings for 'Core.Alu.sllWord', 'Core.Alu.srlWord' and 'Core.Alu.sraWord'. See the note +-- on those functions for why they exist: without them each shift site converts +-- its five-bit amount through 'Integer', and the resulting @ubv_to_int@ / +-- @int_to_bv@ pair makes every query unreadable to the bitvector-only solvers. +-- +-- The amount is zero-extended to the word width because SMT's shifts require +-- both operands to have the same sort. That is exact rather than a choice: the +-- amount is five bits, so it is always less than 32 and no shift saturates. + +-- | @shiftL@ on a 'Word' as @bvshl@. +sllWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + Embeddable bvX Clash.BitVec => + Embeddable bvN Clash.BitVec => + bvX 32 -> + bvN 5 -> + bvX 32 +sllWordE + | Embedding <- embedding @bvX + , Embedding <- embedding @bvN = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvshl x (P.bvzext n)) + +-- | @shiftR@ on a 'Word' as @bvlshr@. +srlWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + Embeddable bvX Clash.BitVec => + Embeddable bvN Clash.BitVec => + bvX 32 -> + bvN 5 -> + bvX 32 +srlWordE + | Embedding <- embedding @bvX + , Embedding <- embedding @bvN = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvlshr x (P.bvzext n)) + +-- | Arithmetic @shiftR@ on a 'Word' as @bvashr@. +sraWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + Embeddable bvX Clash.BitVec => + Embeddable bvN Clash.BitVec => + bvX 32 -> + bvN 5 -> + bvX 32 +sraWordE + | Embedding <- embedding @bvX + , Embedding <- embedding @bvN = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvashr x (P.bvzext n)) + diff --git a/src/Types.hs b/src/Types.hs index 33422cc..ccaa45c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveLift #-} + module Types ( RegIdx, Imm, @@ -46,6 +48,7 @@ data Size | Half | Word deriving (Eq, Show, Generic, NFDataX, Enum, Bounded) + deriving stock (Lift) vecWordToByte :: forall f n. diff --git a/stack.yaml b/stack.yaml index 8c42462..662faba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,27 +1,131 @@ -resolver: nightly-2026-05-19 +snapshot: ghc-9.12.2 packages: - . extra-deps: - - blake2-0.3.0.1@sha256:616926a31133e2a94c353b56b50ef3a8cfb97baf1d051d0f65545e967c5107da,2301 - - sbv-13.6@sha256:65099c81504a2e85a49cc94a4f8bacad12c423b9171cf2ef3b6686a6a71d99ec,27240 - - melf-1.3.1@sha256:167dd798237451e8ccca8c7d98ec719ce20ce1752445dda1fee165b389830b4e,4526 - - parallel-3.2.2.0@sha256:3df46ec247e12b5e406a0adb9577294431b24814b30df420551d176fd112a966,2038 - - optparse-applicative-0.18.1.0@sha256:f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82,5289 - # NOTE: the 'pantomime' repo was renamed to 'symfc' upstream. - github: PLSec-VU/symfc - commit: 1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3 - - github: PLSec-VU/pantomime-base - commit: 1a3b9e223f488e5f2c60f1e3a06e41d39c06fced - - github: PLSec-VU/pantomime-clash - commit: 5bb122c9d38bb4a18c80360e0e4aff46cc9e817d + commit: 571c726ac0974ca50fda49706aa7d34e6f41ddbf + - github: PLSec-VU/symfc-base + commit: 4464a413720592cb66718e1bdaf38a2e56fbe939 + - github: PLSec-VU/symfc-clash + commit: af54042d920ea6377b4b0aa58a4a536ee7592eb6 - github: RobinWebbers/grisette commit: ae4d837886efb2e7838f89271f343d6fa8130388 + - blake2-0.3.0.1 + - sbv-13.6 + - clash-prelude-1.8.4 + - QuickCheck-2.18.0.0 + - arrows-0.4.4.2 + - async-2.2.6 + - atomic-primops-0.8.8 + - base16-bytestring-1.0.2.0 + - bytes-0.17.5 + - cereal-0.5.8.3 + - cereal-text-0.1.0.2 + - composition-1.0.2.2 + - constraints-0.14.4 + - cryptohash-sha512-0.11.103.0 + - data-binary-ieee754-0.4.4 + - data-default-class-0.2.0.0 + - effectful-core-2.6.1.0 + - effectful-2.6.1.0 + - entropy-0.4.1.11 + - extra-1.8.1 + - generic-deriving-1.14.7 + - ghc-typelits-extra-0.5.2 + - ghc-typelits-knownnat-0.8.2 + - ghc-typelits-natnormalise-0.9.3 + - half-0.3.3 + - hashable-1.5.1.0 + - haskell-src-exts-1.23.1 + - haskell-src-meta-0.8.15 + - infinite-list-0.1.3 + - lens-5.3.6 + - libBF-0.6.8 + - loch-th-0.2.2 + - melf-1.3.1 + - microlens-0.5.0.0 + - optparse-applicative-0.19.0.0 + - parallel-3.2.2.0 + - prettyprinter-1.7.1 + - primitive-0.9.1.0 + - random-1.3.1 + - recursion-schemes-5.2.3 + - reflection-2.1.9 + - singletons-3.0.4 + - string-interpolate-0.3.4.0 + - syb-0.7.3 + - tagged-0.8.10 + - tasty-1.5.3 + - tasty-hunit-0.10.2 + - tasty-quickcheck-0.11.1 + - th-abstraction-0.7.2.0 + - th-compat-0.1.7 + - th-expand-syns-0.4.12.0 + - th-lift-0.8.7 + - th-lift-instances-0.1.20 + - th-orphans-0.13.17 + - tree-view-0.5.1 + - type-errors-0.2.0.2 + - uniplate-1.6.13 + - unordered-containers-0.2.21 + - vector-0.13.2.0 + - Stream-0.4.7.2 + - ansi-terminal-1.1.5 + - assoc-1.1.1 + - base-orphans-0.9.4 + - bifunctors-5.6.3 + - binary-orphans-1.0.5 + - boring-0.2.2 + - call-stack-0.4.0 + - clock-0.8.4 + - comonad-5.0.10 + - contravariant-1.5.6 + - data-default-0.8.0.2 + - data-fix-0.3.4 + - distributive-0.6.3 + - first-class-families-0.8.2.0 + - free-5.2 + - ghc-tcplugin-api-0.18.2.0 + - happy-2.2 + - indexed-traversable-0.1.4 + - indexed-traversable-instances-0.1.2 + - kan-extensions-5.2.8 + - monad-control-1.0.3.1 + - prettyprinter-ansi-terminal-1.1.3 + - profunctors-5.6.3 + - scientific-0.3.8.1 + - semigroupoids-6.0.2 + - split-0.2.5 + - splitmix-0.1.3.2 + - strict-0.5.1 + - strict-mutable-base-1.1.0.0 + - text-conversions-0.3.1.1 + - th-reify-many-0.1.10 + - these-1.2.1 + - transformers-base-0.4.6 + - transformers-compat-0.8 + - unliftio-core-0.2.1.0 + - utf8-string-1.0.2 + - vector-stream-0.1.0.1 + - OneTuple-0.4.2.1 + - StateVar-1.2.2 + - adjunctions-4.4.4 + - ansi-terminal-types-1.1.3 + - base64-bytestring-1.2.1.0 + - colour-2.3.6 + - happy-lib-2.2 + - integer-logarithms-1.0.5 + - invariant-0.6.5 + - lazysmallcheck-0.6 + - safe-0.3.21 + - unliftio-0.2.25.1 + - safe-exceptions-0.1.7.4 -allow-newer-deps: -- blake2 -- pantomime +# allow-newer-deps: +# - blake2 +# - pantomime allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 84ec0e4..d4abbd8 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,88 +4,818 @@ # https://docs.haskellstack.org/en/stable/topics/lock_files packages: +- completed: + name: sym-fc + pantry-tree: + sha256: f9ddbf18192a6af949ad426fe38ccb036fa7c5b4b7dcec9d9c5755ec067b16a2 + size: 2352 + sha256: bc737b38198c205fc279d1f79dd7575c99f5de8ae31be91ad6cf9b857718c97e + size: 79809 + url: https://github.com/PLSec-VU/symfc/archive/571c726ac0974ca50fda49706aa7d34e6f41ddbf.tar.gz + version: 0.1.0.0 + original: + url: https://github.com/PLSec-VU/symfc/archive/571c726ac0974ca50fda49706aa7d34e6f41ddbf.tar.gz +- completed: + name: sym-fc-base + pantry-tree: + sha256: faa3dfe862e5a8faafba36bb8052333afb9efdfcce8f5e2ba131494edb8e9bcb + size: 523 + sha256: 95950bbb0d8de71e5f6eea5d6dbbcf86d5c9cfbd0a25b4e8959d880b2f7bbedc + size: 21566 + url: https://github.com/PLSec-VU/symfc-base/archive/4464a413720592cb66718e1bdaf38a2e56fbe939.tar.gz + version: 0.1.0.0 + original: + url: https://github.com/PLSec-VU/symfc-base/archive/4464a413720592cb66718e1bdaf38a2e56fbe939.tar.gz +- completed: + name: sym-fc-clash + pantry-tree: + sha256: d97d993158d720bd13caeaa3bc250e27f2d44972596ecf6284904b01971a7e97 + size: 600 + sha256: b8705223c5421ad5356faacb378318f55f8e254093a689d455b9f3fc0594271f + size: 21976 + url: https://github.com/PLSec-VU/symfc-clash/archive/af54042d920ea6377b4b0aa58a4a536ee7592eb6.tar.gz + version: 0.1.0.0 + original: + url: https://github.com/PLSec-VU/symfc-clash/archive/af54042d920ea6377b4b0aa58a4a536ee7592eb6.tar.gz +- completed: + name: grisette + pantry-tree: + sha256: ac978bcc6a35ee65677dbe41373c2799759457dedee85c6888a2cb7b362a2068 + size: 31883 + sha256: 46de15734b258feee28ccc47c60a36a12fd3e975077615e8c31291b9d8ca79ef + size: 555460 + url: https://github.com/RobinWebbers/grisette/archive/ae4d837886efb2e7838f89271f343d6fa8130388.tar.gz + version: 0.13.0.1 + original: + url: https://github.com/RobinWebbers/grisette/archive/ae4d837886efb2e7838f89271f343d6fa8130388.tar.gz - completed: hackage: blake2-0.3.0.1@sha256:616926a31133e2a94c353b56b50ef3a8cfb97baf1d051d0f65545e967c5107da,2301 pantry-tree: sha256: b67d23f207499a8060d195212c3cf6c1486eae7e230d9554fcfb3a42158f5b64 size: 2133 original: - hackage: blake2-0.3.0.1@sha256:616926a31133e2a94c353b56b50ef3a8cfb97baf1d051d0f65545e967c5107da,2301 + hackage: blake2-0.3.0.1 - completed: hackage: sbv-13.6@sha256:65099c81504a2e85a49cc94a4f8bacad12c423b9171cf2ef3b6686a6a71d99ec,27240 pantry-tree: sha256: fdf9578d9a43daff4fc8f8023f8ceac6eb2f4563797a4b03888c06e289952aa5 size: 116009 original: - hackage: sbv-13.6@sha256:65099c81504a2e85a49cc94a4f8bacad12c423b9171cf2ef3b6686a6a71d99ec,27240 + hackage: sbv-13.6 +- completed: + hackage: clash-prelude-1.8.4@sha256:181d9564bca862d3cd19189702634370c98b817abc048fa0cdcbee1cf2fb6c78,18384 + pantry-tree: + sha256: 5dd9e46574ab2e78f5b31a1b9b0db6b347bce98c39f0be326674e62d0d54c7c6 + size: 13730 + original: + hackage: clash-prelude-1.8.4 +- completed: + hackage: QuickCheck-2.18.0.0@sha256:8da924b1009c9f1352ff367ab03345e36795958c7bb6c156aa460e3100753dfd,8678 + pantry-tree: + sha256: 721985f15de505c333b6368ac30ecd5b9caebd5d080eefcf813a91648943c099 + size: 2882 + original: + hackage: QuickCheck-2.18.0.0 +- completed: + hackage: arrows-0.4.4.2@sha256:a260222b766da922657e302aa7c0409451913e1e503798a47a213a61ba382460,1235 + pantry-tree: + sha256: 153eac3a26d5922d3be968368125e5a31cc4347049732ef3a75920c4b9fda417 + size: 1035 + original: + hackage: arrows-0.4.4.2 +- completed: + hackage: async-2.2.6@sha256:45d5587d8a348a7e2b3f04de963fe633db49b49cde10ca1e6f834bef3baecee9,3870 + pantry-tree: + sha256: 33ad31cf67d331926b854f8868366ec7ad0cc0e0fe8c8f0627d156afc1625f3d + size: 722 + original: + hackage: async-2.2.6 +- completed: + hackage: atomic-primops-0.8.8@sha256:b1c7845aaf0b9b5df44d1f25222b50c54c9e7c9a32ad5ccd00580a282bfed014,2414 + pantry-tree: + sha256: 841137c12b808834539037b3c98bf67c5663e02da83b426b62de9da41c342a72 + size: 1302 + original: + hackage: atomic-primops-0.8.8 +- completed: + hackage: base16-bytestring-1.0.2.0@sha256:a694e88f9ec9fc79f0b03f233d3fea592b68f70a34aac2ddb5bcaecb6562e2fd,2630 + pantry-tree: + sha256: cb1cf706d7e993bb333391309017b9ad529a509f275aab191bc85206da7763f5 + size: 595 + original: + hackage: base16-bytestring-1.0.2.0 +- completed: + hackage: bytes-0.17.5@sha256:39cd011319dab4feb63f77e6d90f32c2b8fb06e0bbe95875f0258a8c48113b55,2164 + pantry-tree: + sha256: 5ff13f49267d256103626e59c950f16b20e858261d66b6761c452a901d95d40f + size: 844 + original: + hackage: bytes-0.17.5 +- completed: + hackage: cereal-0.5.8.3@sha256:87a227c7b510217ea059db3dd59d9665edd8f0d1d3d8de39458e371a1d9402fb,2767 + pantry-tree: + sha256: 2d570ae699908d131b63fe176115809982f86ec4589cdbf42848aa2ca79209cb + size: 641 + original: + hackage: cereal-0.5.8.3 +- completed: + hackage: cereal-text-0.1.0.2@sha256:dc10e00d9e5047d16a129682aac42c95da188d22e9f85856add051b9ace539c3,1349 + pantry-tree: + sha256: 6550c7b0a17f1f1c2e0f01d9c179f30475e82983c622a4bc0643d1ce7c53f8e2 + size: 265 + original: + hackage: cereal-text-0.1.0.2 +- completed: + hackage: composition-1.0.2.2@sha256:fab25a9386057cdd83094109ac204c8aa7404e19fdfec6708ad383cd3a2d6fe5,659 + pantry-tree: + sha256: a0de4b50887a4fab62a0974edb487f827768099084b601ac73fb20351e0bc832 + size: 218 + original: + hackage: composition-1.0.2.2 +- completed: + hackage: constraints-0.14.4@sha256:31348c35fd0cc970b1f239cffbe44653c06cf81143227ec6ea0c01324519e0c7,2367 + pantry-tree: + sha256: 85d738f32e30ee03fcef568142c0301ae94b79b5e2768278b621fa11463c3408 + size: 993 + original: + hackage: constraints-0.14.4 +- completed: + hackage: cryptohash-sha512-0.11.103.0@sha256:e80f2a6b6ff06d5aa41da8c421b17d6b744015c0c27e273ada22a1929985b373,5517 + pantry-tree: + sha256: dc94d8fb2d09d406c488de6d618d781ab60ade56454ca96dc2a024cf092c2e67 + size: 863 + original: + hackage: cryptohash-sha512-0.11.103.0 +- completed: + hackage: data-binary-ieee754-0.4.4@sha256:60a56dd516e3710f05d79310cce25a10ed0f361a388df1e24ef96ce540901e1c,948 + pantry-tree: + sha256: 5d96e09b3fdd3944db3ccb5fd7a57de3c9cdd905347c000e20d89264a3a95441 + size: 346 + original: + hackage: data-binary-ieee754-0.4.4 +- completed: + hackage: data-default-class-0.2.0.0@sha256:788dc5c0be3981ca83ad11206e300a77ae8a1c8b9bc4f9630f563d37f540ccbd,728 + pantry-tree: + sha256: 2ddcb2ed7288849c7c46c7b3ae4fd0df016069a125f5803740974ea59700df19 + size: 224 + original: + hackage: data-default-class-0.2.0.0 +- completed: + hackage: effectful-core-2.6.1.0@sha256:1305376587c18202cf517377b22bf24eb76fbbdd37aaf3863cdfd5f401d9cb15,4500 + pantry-tree: + sha256: 5d42fb066d44b8382383f99fa52c1a770804187bb3cba24fe37ac91b98860d09 + size: 2543 + original: + hackage: effectful-core-2.6.1.0 +- completed: + hackage: effectful-2.6.1.0@sha256:d385db82b183dae60880fceae76ec08e1a52a4fc5fec648d2cc7657e02750b57,7732 + pantry-tree: + sha256: 9c637b1adacb65e13b729a7f9a5e2c3cddea6c38eff43c84e1585d81018eec3d + size: 3409 + original: + hackage: effectful-2.6.1.0 +- completed: + hackage: entropy-0.4.1.11@sha256:1b9b1a7282ba6d7671e6d7a9be84cc18c40a3a480cef621927a8e4c66ec47913,2935 + pantry-tree: + sha256: 0314feea2035559273d7e2bedfb199042a86f41ec9b014a852ba0bf134f1c52a + size: 682 + original: + hackage: entropy-0.4.1.11 +- completed: + hackage: extra-1.8.1@sha256:b9c360f2f3fbff5ca04656b7aa0a91b254ac7de7e4b959bae4688a178ffd79d1,2738 + pantry-tree: + sha256: 2306b0cbd1f9e0538eb07d0123f34e660916182081cb4b53e85363a6f7a61998 + size: 1961 + original: + hackage: extra-1.8.1 +- completed: + hackage: generic-deriving-1.14.7@sha256:021fa6b98557921c47d46c4afef5c778f287cc76d2fe9a83b9d2164e637b2b86,6529 + pantry-tree: + sha256: 024e082b91c6a55677f491998f199a4986538627d408e07529740ff9c829eb4e + size: 2203 + original: + hackage: generic-deriving-1.14.7 +- completed: + hackage: ghc-typelits-extra-0.5.2@sha256:0d04483a660be3987213418316d2bd9c1a3dcb4227df0a0f80c32e98b87f76fe,5640 + pantry-tree: + sha256: 35c39550d8a12732e8608c28eb63a73cec0322e6dda66c5670955606a8c7ba20 + size: 762 + original: + hackage: ghc-typelits-extra-0.5.2 +- completed: + hackage: ghc-typelits-knownnat-0.8.2@sha256:6e9ef33bd2cf462e7d66f5b28608c0156007947b3a7a95fd5b90bfa4a0365d1e,5993 + pantry-tree: + sha256: 422aa887829f14d76ae88edafcaad5883bf4ced3b4669f4532387f8bddd5d01d + size: 678 + original: + hackage: ghc-typelits-knownnat-0.8.2 +- completed: + hackage: ghc-typelits-natnormalise-0.9.3@sha256:aa48d0755cd246643155704b0082ce8d0bf421f445bf568289d1a8c791257743,3884 + pantry-tree: + sha256: 3e2e641046f266796f72d31a0d5c8543e5b18f1b0326767eabd72b004c1d66eb + size: 688 + original: + hackage: ghc-typelits-natnormalise-0.9.3 +- completed: + hackage: half-0.3.3@sha256:b39549b7f8cd419ac22d9c49f0837d7abc0670cddf7f42f449b10e576dc1c2cb,2011 + pantry-tree: + sha256: d4d228c703f00f3b649dccd81059fb88420dcbb4e7d1e81433d09efefbb784da + size: 501 + original: + hackage: half-0.3.3 +- completed: + hackage: hashable-1.5.1.0@sha256:140fc5adad166f7b527567cbd26ff481e8da4a66bdfc84be3ddf28dbeb66f275,5787 + pantry-tree: + sha256: e3bf67a89d9227d1e0c9a553ecd08f88d8ea492566ed78b30f8de05cf8699c2e + size: 1578 + original: + hackage: hashable-1.5.1.0 +- completed: + hackage: haskell-src-exts-1.23.1@sha256:339841f4a6710e915a0bac8df18d8a454c11d626131aee4d05b6be150b7f863e,4577 + pantry-tree: + sha256: 572aeb73c927ca9b4df7b9a32345dfdc1ba72b7d4af1c38dc12cd6bc2843d88f + size: 97804 + original: + hackage: haskell-src-exts-1.23.1 +- completed: + hackage: haskell-src-meta-0.8.15@sha256:b0843085524e6f1b9ced53b3f254f88c060e0e6f8e91f6df08a19a15ff40d0c5,2660 + pantry-tree: + sha256: 80a237c10a9299a8ff63d1da732c6fc687c8c93fc7ad07bb05c6b6dd90d6d766 + size: 1120 + original: + hackage: haskell-src-meta-0.8.15 +- completed: + hackage: infinite-list-0.1.3@sha256:b41cd107299a430c2a38dbee688c183158beee544227d940b4124183d6f54657,2530 + pantry-tree: + sha256: 405bd544d8bf32233208ddc5364ed473a4e42a1576792bec404561b862860ed4 + size: 610 + original: + hackage: infinite-list-0.1.3 +- completed: + hackage: lens-5.3.6@sha256:73d1a2cd63d19710ea512d54869ba1a395f59be946bad7f6168154b7c9e79070,14697 + pantry-tree: + sha256: 933282c7186503913fc4f9653cde1017b4290a2616dd0e89822a49fc6631c35e + size: 8405 + original: + hackage: lens-5.3.6 +- completed: + hackage: libBF-0.6.8@sha256:076f8dc0d33299c40afa2d0bfe51e93420c9c3e326ebfcac4f0e856152aa4f87,2503 + pantry-tree: + sha256: b3950685f0ef81018241b8d2a518f440a6148658507341708dc0c81a3e19c1ff + size: 794 + original: + hackage: libBF-0.6.8 +- completed: + hackage: loch-th-0.2.2@sha256:262a1f2190decd5e24c9368008a6fc87d83515f5f3a8488e384bd8acc0a5529c,805 + pantry-tree: + sha256: eb29d168e827411d0fd6c93b9efefc95b02cc252e4c7bb47094e9d52ea955cc9 + size: 216 + original: + hackage: loch-th-0.2.2 - completed: hackage: melf-1.3.1@sha256:167dd798237451e8ccca8c7d98ec719ce20ce1752445dda1fee165b389830b4e,4526 pantry-tree: sha256: 8a4044457278930b6932c6499949564d17fea8db5163b059778c7ed8a26a68d7 size: 3429 original: - hackage: melf-1.3.1@sha256:167dd798237451e8ccca8c7d98ec719ce20ce1752445dda1fee165b389830b4e,4526 + hackage: melf-1.3.1 +- completed: + hackage: microlens-0.5.0.0@sha256:af10ae1d922c543b2ec7cbad0f92ce74572621146404bb341fa0cc016ebb59dc,4762 + pantry-tree: + sha256: d5211ca01e39d39db3031a20a0ca59ae13872e79358f0c3de9dfea3197bce9a6 + size: 526 + original: + hackage: microlens-0.5.0.0 +- completed: + hackage: optparse-applicative-0.19.0.0@sha256:4c1dcbdbf2498f7cdd88826e876403db7f8d81931962060ec4c3a57a186c6cc3,5982 + pantry-tree: + sha256: 5533d2f9b0bbd1a6fc04fb805d27d0d8d809b588811844c1eaf087f4ef98a0ee + size: 4091 + original: + hackage: optparse-applicative-0.19.0.0 - completed: hackage: parallel-3.2.2.0@sha256:3df46ec247e12b5e406a0adb9577294431b24814b30df420551d176fd112a966,2038 pantry-tree: sha256: 53a621c99658b84edf55cdbf8bbd74126d9cec6a2a0e6db3f5bef393cbe653ee size: 392 original: - hackage: parallel-3.2.2.0@sha256:3df46ec247e12b5e406a0adb9577294431b24814b30df420551d176fd112a966,2038 + hackage: parallel-3.2.2.0 - completed: - hackage: optparse-applicative-0.18.1.0@sha256:f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82,5289 + hackage: prettyprinter-1.7.1@sha256:9c43c9d8c3cd9f445596e5a2379574bba87f935a4d1fa41b5407ee3cf4edc743,6987 pantry-tree: - sha256: abb295c7aaf194c4cd9ea7201b63e069168ad97cc965e89ec71e09a7c1262de4 - size: 3124 + sha256: cd6f393bf7cba603a1958a139915fc343efd5488e36fd7b3b5c6956c002d04fa + size: 3460 original: - hackage: optparse-applicative-0.18.1.0@sha256:f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82,5289 + hackage: prettyprinter-1.7.1 - completed: - name: pantomime + hackage: primitive-0.9.1.0@sha256:756b222c715bc6ef5ba81fa69cdbaa20c5c53beb6f16f174b8bacc93a6d239f0,3258 pantry-tree: - sha256: a9b33df0c2993334ad2a8cc4187804155fc7870d91edd32bb5dba0abb1ebf4f4 - size: 2948 - sha256: 2196ca8979249fe8ceb82b197decb91786b612d27392a10dbf92177970467387 - size: 89415 - url: https://github.com/PLSec-VU/symfc/archive/1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3.tar.gz - version: 0.1.0.0 + sha256: f3316dce468a892930234a85193674461341e77426e7c46c82448f363367a528 + size: 1793 original: - url: https://github.com/PLSec-VU/symfc/archive/1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3.tar.gz + hackage: primitive-0.9.1.0 - completed: - name: pantomime-base + hackage: random-1.3.1@sha256:0b4f649c3e78713b2ccad1535251ee34b148237fb2229d7058c2b1d9ccc324b8,6004 pantry-tree: - sha256: d9ca9346ffc7552a38580959952435ea61b64b04f4a686ede7090feb9450a2da + sha256: 9e92209c00b0c00b7d1c503e15a27b67b74ac2e3b48269a9255893b06de6836c + size: 1667 + original: + hackage: random-1.3.1 +- completed: + hackage: recursion-schemes-5.2.3@sha256:d5ac7f926b2e99a40152582f18d57fdb088bf3402504abdca4c1da3daacefe5e,3191 + pantry-tree: + sha256: 382a1e722cda4bfdaec65089070f160ef5900cc254134726b6cfc2b62a92e17b + size: 673 + original: + hackage: recursion-schemes-5.2.3 +- completed: + hackage: reflection-2.1.9@sha256:eaf28dc9884718a306ed1e0c215a24b36c68b8aa3be425617f66d886d43fe1e0,4171 + pantry-tree: + sha256: cf3caee8e681914b6323fc0444ea2d51fb403fac0b77f77c7e866be68e73f16c + size: 1060 + original: + hackage: reflection-2.1.9 +- completed: + hackage: singletons-3.0.4@sha256:4c765cc87d78ecc436cd77231d87e646d119e1dd7d0ed027c0eddaa80e284401,3143 + pantry-tree: + sha256: 59487b48c3a22670fb265e7911133a10754a8fdd5b8240b0af7056b39e9a17f3 + size: 713 + original: + hackage: singletons-3.0.4 +- completed: + hackage: string-interpolate-0.3.4.0@sha256:b58f8d4f2d591878b3e632dc36b210582d41e72f5e6484a2e42a647a57b85a18,4274 + pantry-tree: + sha256: 73130fdccd3de97e38971a0dc002fd303fc83db3019ccebf739fe4bc45735822 + size: 1248 + original: + hackage: string-interpolate-0.3.4.0 +- completed: + hackage: syb-0.7.3@sha256:9975950b1ae7f3de8b226a702d384606099742791b6a5d89228e25d87d5527af,3740 + pantry-tree: + sha256: 4d930fb852a7d3a92994b4d0119567209855c8fb230d50e061d510cec67e6cb2 + size: 3400 + original: + hackage: syb-0.7.3 +- completed: + hackage: tagged-0.8.10@sha256:e9b97c98e9827981d62f37c5febf9e6bbb67acec92b8bd41fd9f7ace5eb31d32,2201 + pantry-tree: + sha256: 5ba1ff7ad9a676b89a2a6ab00ac2100f30a21440ef8e04094614ab5b5f494b3f + size: 438 + original: + hackage: tagged-0.8.10 +- completed: + hackage: tasty-1.5.3@sha256:6b5dda3f16db1274a0b3e6c4073ac57172a1e96b1dca05666c5cbd1183639412,2923 + pantry-tree: + sha256: 55cabcd98ff0f5c671a93fb138b8b8cb1cf223497b0fbf9207e6c519fd54a9e9 + size: 1944 + original: + hackage: tasty-1.5.3 +- completed: + hackage: tasty-hunit-0.10.2@sha256:22bc1122e8256664d7cb1e44c6bcace95676c523179947bf2403db71af43dc6d,1473 + pantry-tree: + sha256: ddfcda3c96bbac5c56f7619b1e84917de767cd5843ed44a855127ed91e9502c5 + size: 399 + original: + hackage: tasty-hunit-0.10.2 +- completed: + hackage: tasty-quickcheck-0.11.1@sha256:12ea6b6fecccc146b69aac3c4810fd5d135564245e9c0708df9b24071a8b0588,1622 + pantry-tree: + sha256: 2a842340977d2af2052a6d4fd6065af43ca02fe97bc68d7896a4b597f8f9e6a0 + size: 333 + original: + hackage: tasty-quickcheck-0.11.1 +- completed: + hackage: th-abstraction-0.7.2.0@sha256:380819d6e14645bf66af99b6ea3d3d4309c523c7d0ee376e0678042622f1c272,2181 + pantry-tree: + sha256: b9fa4efe463e44c8675cb68e70bfd71131666870e6ceaa5367672704bc744754 + size: 671 + original: + hackage: th-abstraction-0.7.2.0 +- completed: + hackage: th-compat-0.1.7@sha256:449be09a4e3f46ea4645700c026624c4b6f066f508187326c284dbdea8884bc9,2920 + pantry-tree: + sha256: ab2deb131cdf0ee3671323f6bfa040078779f3284bd3169ada20dfdee15daa1e size: 530 - sha256: b2770278ac560cdcb8947ce4b6f6c17d2a74748a471f76c79ef0417af566f838 - size: 16958 - url: https://github.com/PLSec-VU/pantomime-base/archive/1a3b9e223f488e5f2c60f1e3a06e41d39c06fced.tar.gz - version: 0.1.0.0 original: - url: https://github.com/PLSec-VU/pantomime-base/archive/1a3b9e223f488e5f2c60f1e3a06e41d39c06fced.tar.gz + hackage: th-compat-0.1.7 - completed: - name: pantomime-clash + hackage: th-expand-syns-0.4.12.0@sha256:d71525fb41ae0ad251b36455bde2de78913fba7ba147f50f2b034eeacf57b026,2117 pantry-tree: - sha256: 5ca3e86e8304432d9816d06c3d9aa004e576ce007a7c60310c6c792b48468e69 - size: 611 - sha256: 9c369683baa755b0e862ec2a38d4b6ad966bca29e9de9cfc9f9dc4f1c7eef58d - size: 19357 - url: https://github.com/PLSec-VU/pantomime-clash/archive/5bb122c9d38bb4a18c80360e0e4aff46cc9e817d.tar.gz - version: 0.1.0.0 + sha256: c5cc5cbd75b8fdd3de38752063d6aab9ab3fdaf90b90c5ab141dc423c5398d23 + size: 460 original: - url: https://github.com/PLSec-VU/pantomime-clash/archive/5bb122c9d38bb4a18c80360e0e4aff46cc9e817d.tar.gz + hackage: th-expand-syns-0.4.12.0 - completed: - name: grisette + hackage: th-lift-0.8.7@sha256:b91da4aabdf753d716bc9a838dcbd12fa8ca53baa34c9ca16472e5af8c2640f6,2545 pantry-tree: - sha256: ac978bcc6a35ee65677dbe41373c2799759457dedee85c6888a2cb7b362a2068 - size: 31883 - sha256: 46de15734b258feee28ccc47c60a36a12fd3e975077615e8c31291b9d8ca79ef - size: 555460 - url: https://github.com/RobinWebbers/grisette/archive/ae4d837886efb2e7838f89271f343d6fa8130388.tar.gz - version: 0.13.0.1 + sha256: b9307fa45844a7d2ef496ca46025bca812ef0303fb704f3ec441f7c851a114e0 + size: 542 original: - url: https://github.com/RobinWebbers/grisette/archive/ae4d837886efb2e7838f89271f343d6fa8130388.tar.gz -snapshots: + hackage: th-lift-0.8.7 +- completed: + hackage: th-lift-instances-0.1.20@sha256:c7886eb39760825b8861c68e48b2b5efb5eff8d2cb76201fdd0fb04bcbeff78e,2608 + pantry-tree: + sha256: 0498495a69ca395d95b12a67b6884adaec4ca9ab76b9a62ca76ba064e35a08ff + size: 526 + original: + hackage: th-lift-instances-0.1.20 - completed: - sha256: 5f0858c115d1cc54e5b183ca74dde0b92db445aa09f1161b15e739ef26da684b - size: 752942 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2026/5/19.yaml - original: nightly-2026-05-19 + hackage: th-orphans-0.13.17@sha256:3d81d2d880a1a414a38ea66e62aacac6c907c9776bca6982e3f814c4ed7ca2ca,2468 + pantry-tree: + sha256: 7888085b7db430f05152287ea9ee499b06354ef0754ef85722de9e4de0514fac + size: 527 + original: + hackage: th-orphans-0.13.17 +- completed: + hackage: tree-view-0.5.1@sha256:a32b16fdbe24ad21cb6679c2a925bcc7715ae5c5db0ae6b633e35e28e2fefd98,1184 + pantry-tree: + sha256: 352f008d14d338bc1addd47a627315d907afcc1267a02e2fa92e00fb8a5190be + size: 215 + original: + hackage: tree-view-0.5.1 +- completed: + hackage: type-errors-0.2.0.2@sha256:afd6b33bb582730a90ea58fd23d5b32a38b5b6c8b2f18e3250936bdc0487dfab,2513 + pantry-tree: + sha256: e526c0aeb8ed6681a3812ed8c99f3fb436723ae417485201a544a897579623fe + size: 368 + original: + hackage: type-errors-0.2.0.2 +- completed: + hackage: uniplate-1.6.13@sha256:c8b715570d0b4baa72512e677552dd3f98372a64bf9de000e779bd4162fd7be7,3320 + pantry-tree: + sha256: 7a3065d48fe43c2b7818500d4c571f5226760b5e96d0239b767bfeb573b3c349 + size: 1936 + original: + hackage: uniplate-1.6.13 +- completed: + hackage: unordered-containers-0.2.21@sha256:c5de1fb3377ed3c5f4cd851a771d1acc5c37d2f6bef0a499295c0e8857da5605,3987 + pantry-tree: + sha256: e60c9f5dcacee1c8230534bc7d29224015341c956b63464fb7884a6de8b3614d + size: 1779 + original: + hackage: unordered-containers-0.2.21 +- completed: + hackage: vector-0.13.2.0@sha256:3ec12de580ee31ceac89b314fd00b5057ed40198c0b3d9e9dafa54c1941e6942,8804 + pantry-tree: + sha256: 12839cef1252eaa894d6a9adafaa2e1cdb449f03c343f765294e033c813261fc + size: 4478 + original: + hackage: vector-0.13.2.0 +- completed: + hackage: Stream-0.4.7.2@sha256:ed78165aa34c4e23dc53c9072f8715d414a585037f2145ea0eb2b38300354c53,1009 + pantry-tree: + sha256: 009fe33c4779bd1705a26f9b036f0996e9fc85df06418aec3dda967554e6ef83 + size: 207 + original: + hackage: Stream-0.4.7.2 +- completed: + hackage: ansi-terminal-1.1.5@sha256:408d9232e5304efead718f96138d6d7eb2da608c6121c5c0dc6a71a833b14320,3327 + pantry-tree: + sha256: 081bff43a1d384922a9d9b7b27c96c1fa0ecadbd4dfe0e801b2931e06ee4b50f + size: 1111 + original: + hackage: ansi-terminal-1.1.5 +- completed: + hackage: assoc-1.1.1@sha256:766b1040eda5255bfcf10e1a9859c06d0ed6ad0e2ac87ed915bb035574d10ae4,1437 + pantry-tree: + sha256: 428d036445217eea9eb59e6fc8377b26841b01aaad8790eef4e761f6bd91df59 + size: 290 + original: + hackage: assoc-1.1.1 +- completed: + hackage: base-orphans-0.9.4@sha256:001f2b3094b7a1b00e9fd5dcc519a62b8b147a1754bf550fa42601ff868e2b65,3241 + pantry-tree: + sha256: 95d208040e82bbbb1cfc7d8f53012809c25956bbb7307e162b74db3a4a662367 + size: 1273 + original: + hackage: base-orphans-0.9.4 +- completed: + hackage: bifunctors-5.6.3@sha256:58f1d66db71ed9dd70648eaca1a0986b29354b3a69b5bfd729ce1a896766466e,3271 + pantry-tree: + sha256: f2d043d4e507947c363e69083572c3e4b86daa93ca4271fcdaa4b453f0528d1b + size: 1466 + original: + hackage: bifunctors-5.6.3 +- completed: + hackage: binary-orphans-1.0.5@sha256:1217df567aae672d09979480c362d27559d226081b9b9bc4107d4af008da1f5f,1997 + pantry-tree: + sha256: 4ff72344fa0592e3da7cc3361383bd64541c3487328e5369adda187f1c999255 + size: 285 + original: + hackage: binary-orphans-1.0.5 +- completed: + hackage: boring-0.2.2@sha256:f6d705c30830a337862210f12c4ce38d5ab4d3660631e0214b504f10815a2e8d,1779 + pantry-tree: + sha256: c5af50382f9ef51f4ac4082464e22a5a665f767009d3884fa32fbd2bf73cbbaa + size: 216 + original: + hackage: boring-0.2.2 +- completed: + hackage: call-stack-0.4.0@sha256:ac44d2c00931dc20b01750da8c92ec443eb63a7231e8550188cb2ac2385f7feb,1200 + pantry-tree: + sha256: 04134fa69cdd824b4e4bb7f77e7173e0705f27deabdbbf99549c549400191e1e + size: 501 + original: + hackage: call-stack-0.4.0 +- completed: + hackage: clock-0.8.4@sha256:b938655b00cf204ce69abfff946021bed111d2609a9f7a9c22e28a1a202e9115,4631 + pantry-tree: + sha256: 0ca511f7ea409e65a9de5539f265bb906a3eec6a4ac1a201731a8a328120cc88 + size: 499 + original: + hackage: clock-0.8.4 +- completed: + hackage: comonad-5.0.10@sha256:e8606e010e306f41019026e94b0676993c175260d1d8908e4518b2b06a40272b,3443 + pantry-tree: + sha256: 98be08915d9fb077804a014d4ec7bfe058af0d0125235fb1c5ad1f49a5f7ff85 + size: 1616 + original: + hackage: comonad-5.0.10 +- completed: + hackage: contravariant-1.5.6@sha256:288f1d3e6fb3adcf9f36f28ffa189673f2f1303812296dfb2523478ad31dd9e2,2182 + pantry-tree: + sha256: 0723fa8376b781f80815d4022dc182070b088a2a33d9e7625d3f1b5a68f7a791 + size: 652 + original: + hackage: contravariant-1.5.6 +- completed: + hackage: data-default-0.8.0.2@sha256:d4a8c9ed574a43315262666c75efe1080e3913a653844d2a9ff36051a6211bee,1110 + pantry-tree: + sha256: 6f42bc6c080c5e1cb7894b03b2d1494a05b9056dcef477965205e9448d8889f8 + size: 382 + original: + hackage: data-default-0.8.0.2 +- completed: + hackage: data-fix-0.3.4@sha256:200360c49cc81cf8b8bbdf49afd4aee03fffd09d3395b080a7e7c65fcf01d313,1421 + pantry-tree: + sha256: f7edf89375cd789203cb8633c166a45b9392dd901aeff7788a13dfbb59c2b849 + size: 262 + original: + hackage: data-fix-0.3.4 +- completed: + hackage: distributive-0.6.3@sha256:9dec7cd4dc49325f551b2f2bf2004cfe2454b211e5882265cc87880d4382b1f8,2342 + pantry-tree: + sha256: c765117bbab05d71c228c55013b1311a2f0481c007c6b1f0ff9f515c16dac2d7 + size: 670 + original: + hackage: distributive-0.6.3 +- completed: + hackage: first-class-families-0.8.2.0@sha256:146f656a446fba803aa44176c03c7e0cbe6daae4fa9db9d67ffb1e1ab08ce779,1675 + pantry-tree: + sha256: d75caabbd9859b5710344aaff70979be8f87626c1f16722b45f62ed21a2a0199 + size: 1368 + original: + hackage: first-class-families-0.8.2.0 +- completed: + hackage: free-5.2@sha256:39ca01645f7c2f08ffd64226891c514bdc924a87da48f815f9fe77c2e0ac1164,4178 + pantry-tree: + sha256: c0e2d18aac282ff3fb4febad1e78dfe1d8b0769ae62c799068e922c3ad55e97f + size: 3130 + original: + hackage: free-5.2 +- completed: + hackage: ghc-tcplugin-api-0.18.2.0@sha256:126b0b16d56b5ecb3b5a3dd74e1581619208604d89db8f09bc1bdba95a08b8f2,5414 + pantry-tree: + sha256: 9586d08480915d452410e921a0821ebc4eba74eec69b7119881d1e398b92d689 + size: 575 + original: + hackage: ghc-tcplugin-api-0.18.2.0 +- completed: + hackage: happy-2.2@sha256:b3a984db884db17d4cbe31cd9cf3f4df5eb9b6224313bdddd49712eb40fb0dfb,5065 + pantry-tree: + sha256: 423090b28b1bab7f95cc71d5dafb7bdd64a81fc936994784ed985d41a73a79ac + size: 6513 + original: + hackage: happy-2.2 +- completed: + hackage: indexed-traversable-0.1.4@sha256:8abac0b92795489039d7312050d1393757a6f67859ff6a4f3622260a1b931bce,2187 + pantry-tree: + sha256: 158d037492562c1681c744e616d1667359487093694f35d1ed5624a5ceae8a15 + size: 625 + original: + hackage: indexed-traversable-0.1.4 +- completed: + hackage: indexed-traversable-instances-0.1.2@sha256:68df0fc8070ae2c15f9e6febf1449fee364c131a6d1e93cac45e7895ba86dd89,2401 + pantry-tree: + sha256: 5d8873d51e28d42eebe7c13e3acb5e8a7ddfc2dd42ad011c96bb47b94b1f6b2e + size: 366 + original: + hackage: indexed-traversable-instances-0.1.2 +- completed: + hackage: kan-extensions-5.2.8@sha256:21c5b363a15426514acba3acceca2bf0d0d63272fddffd6b696010609ef4fa31,2511 + pantry-tree: + sha256: d3b8cb3ffc240ddc401c361c6aece85ea74c6a91c7e2590641d4546030f028d8 + size: 1306 + original: + hackage: kan-extensions-5.2.8 +- completed: + hackage: monad-control-1.0.3.1@sha256:2d657279839e1a760c86a69f00f0c36473ef6972d413ec0f83a40249c70e098e,2365 + pantry-tree: + sha256: f6b2e10b7ad03cbc2bd1df28543c9d514d54bd39833e318b48e5f0998d876df5 + size: 292 + original: + hackage: monad-control-1.0.3.1 +- completed: + hackage: prettyprinter-ansi-terminal-1.1.3@sha256:b00f727b964cf13adff7acf575a71fa7e405f5240aff50b07f10df76ab89f8d3,2574 + pantry-tree: + sha256: b5d276267049502c72fdcd2f1d84c15b3598160d61de0482a2e5bb62c40bd4ea + size: 820 + original: + hackage: prettyprinter-ansi-terminal-1.1.3 +- completed: + hackage: profunctors-5.6.3@sha256:bfdb8c8b8cd4390e30219219edaff6ae7f428516f7338f0b7c39cb16b84bad2c,2408 + pantry-tree: + sha256: e8f5f68ed5500e294baed4d2be9d7b494be316ab5b86016bf7b72d9ed0f79aa7 + size: 1588 + original: + hackage: profunctors-5.6.3 +- completed: + hackage: scientific-0.3.8.1@sha256:11b0c3bcc572f08ddcb13bfad94df85e0323f39915e74cae2d7a205c631b4d30,4390 + pantry-tree: + sha256: 95c2af5d6729b5d4a1c2c46f9103d415324386377f337be01eb70367524eb8a7 + size: 657 + original: + hackage: scientific-0.3.8.1 +- completed: + hackage: semigroupoids-6.0.2@sha256:52c5a346fdf74380618f67ff784989ef9078498dbbdff09e4d8e2fed20202e2c,7216 + pantry-tree: + sha256: 97988befa7a35bd1421f2c221adf7fe2d9238d005254133a5b2063592e610fc2 + size: 2403 + original: + hackage: semigroupoids-6.0.2 +- completed: + hackage: split-0.2.5@sha256:5bc1ae848bfded3087ea3e568908f1b75f56ecde6f02df3fad1a138dd5c783d5,2625 + pantry-tree: + sha256: 5d28c851a2c98e3d8ac0f01adc58303d775afe39dce23ec953be64ae65d11166 + size: 443 + original: + hackage: split-0.2.5 +- completed: + hackage: splitmix-0.1.3.2@sha256:a557cff65eed1f70f3a3b468423cd58e7a9a9564c5cc00c76a13de64dec9bcbd,3608 + pantry-tree: + sha256: 95abfd61d6773801e9f18aa91bd5655cbc72b09d93525b98bafa17058f0351d8 + size: 880 + original: + hackage: splitmix-0.1.3.2 +- completed: + hackage: strict-0.5.1@sha256:58c373b7c7748cbb4a5a6c8c15073f99a1c10a9a9bb6894ac33f43a5cdb901f2,3557 + pantry-tree: + sha256: 58e97bedb76e8678bf9851677362a8fe567b3d8021e8cd1e54af2ca99c23632f + size: 654 + original: + hackage: strict-0.5.1 +- completed: + hackage: strict-mutable-base-1.1.0.0@sha256:b1c039f6b179aedb420a90cbe15d3c3e78fbaaa7146ed02700b84c6018ee734f,1430 + pantry-tree: + sha256: 72f03d9f5f5ad68f71e3405f8060b7a1b0875cd3f6a73ac52b8b2f091ae984d2 + size: 439 + original: + hackage: strict-mutable-base-1.1.0.0 +- completed: + hackage: text-conversions-0.3.1.1@sha256:35dc3ee494275509a3a771d5d27fc02d4af34478a40126cba87cdc6f007d551e,1433 + pantry-tree: + sha256: 0007faf239ccc96b1d5f50d96721f80493993731a95e7683bf462ef83bce332f + size: 455 + original: + hackage: text-conversions-0.3.1.1 +- completed: + hackage: th-reify-many-0.1.10@sha256:1827dcffb0c9f214e9739053fc808683336ea65c3749ff2d6148db189cbbd2a4,1753 + pantry-tree: + sha256: 3aed327bc5dff9c9c22bb7d1ea3e4e437b9f74face6fc682cefffe462913dfd0 + size: 373 + original: + hackage: th-reify-many-0.1.10 +- completed: + hackage: these-1.2.1@sha256:ba1aec9a502eb2b3f90ef254f420468a3c4e5b9b7e8324e3ddc7035143c92640,2384 + pantry-tree: + sha256: c8b5f96fd5c55e5afa236716a673b1634e4b681e724603262b6bd0312cbf971a + size: 351 + original: + hackage: these-1.2.1 +- completed: + hackage: transformers-base-0.4.6@sha256:6f18f320e371c8954c4b6b211e2fdd5d15a6d6310bd605b9d640f47ede408961,1643 + pantry-tree: + sha256: 6c2d24a9678865e2a5f4b6286cb17228673a6987fb546bf07b89ffbd19716ad2 + size: 275 + original: + hackage: transformers-base-0.4.6 +- completed: + hackage: transformers-compat-0.8@sha256:246d2d55c4970592fb68d9d9282d1af719729af1a883c1c5b74fdd49d50866dc,3762 + pantry-tree: + sha256: 5d5c99408af0ab2b0b7bfc0754e37bb19b73d2c3efe7ccd6ae5c1a954422615b + size: 1225 + original: + hackage: transformers-compat-0.8 +- completed: + hackage: unliftio-core-0.2.1.0@sha256:f6a2736f858b5390d9384dca43d3ea4d96e9ca17217791791ca4951ba6e8072a,996 + pantry-tree: + sha256: a585417c216bb1a20be0b53a62b6fed6891ff4e30872ec2d706c144eac81e2ec + size: 327 + original: + hackage: unliftio-core-0.2.1.0 +- completed: + hackage: utf8-string-1.0.2@sha256:79416292186feeaf1f60e49ac5a1ffae9bf1b120e040a74bf0e81ca7f1d31d3f,1538 + pantry-tree: + sha256: 0863c3c9b6ee24dd38873c62e38ac46dd50aff2ea6b362beadf7f9b4a273c75f + size: 601 + original: + hackage: utf8-string-1.0.2 +- completed: + hackage: vector-stream-0.1.0.1@sha256:483be6df13c72169a917640589666f9fece7bea9fa13fcd41d052dab37ea289e,1642 + pantry-tree: + sha256: 8f597e9033aaa83fabc206050fd54b1d702ad0760c20b7f56a781b8d7e614685 + size: 325 + original: + hackage: vector-stream-0.1.0.1 +- completed: + hackage: OneTuple-0.4.2.1@sha256:97ed6715380e1be032cf3a8380921a757b52b8e20038139fddaccd8ccd9b8d1a,1985 + pantry-tree: + sha256: 7bd99258b5debdd34a7517ceba6e0305bdfe09b10e5289cfebc2436bbec0da47 + size: 506 + original: + hackage: OneTuple-0.4.2.1 +- completed: + hackage: StateVar-1.2.2@sha256:3c022c00485fe165e3080d5da6b3ca9c9b02f62c5deebc584d1b3d1309ce673e,1673 + pantry-tree: + sha256: 204cac98219e99334f47b12c565945611748ea03a4d629273dd697d738bcfd7f + size: 314 + original: + hackage: StateVar-1.2.2 +- completed: + hackage: adjunctions-4.4.4@sha256:2d827edceef6ffec0c7c767cfe21672d7d8586aa58549c13515ce23b350a6b1d,3042 + pantry-tree: + sha256: b5f9f6e6d587853fe18f43e32eeebedc9f3b3a3ad72e3672ce58dd1e6eaf02d3 + size: 1391 + original: + hackage: adjunctions-4.4.4 +- completed: + hackage: ansi-terminal-types-1.1.3@sha256:1d6061eceaf35a9ed269b81177dd4c8c60403a499526f7f68fdffa4ec7842e7f,1523 + pantry-tree: + sha256: 99497d3d290b931b8aa15e341f74c14b9da8312f7610987973f634c68f640c69 + size: 365 + original: + hackage: ansi-terminal-types-1.1.3 +- completed: + hackage: base64-bytestring-1.2.1.0@sha256:45305ccf8914c66d385b518721472c7b8c858f1986945377f74f85c1e0d49803,2502 + pantry-tree: + sha256: 9e58b1adc5eb2805118c1539d325363d94043370671fb0f13fbe90aaeea3ff44 + size: 850 + original: + hackage: base64-bytestring-1.2.1.0 +- completed: + hackage: colour-2.3.6@sha256:ebdcbf15023958838a527e381ab3c3b1e99ed12d1b25efeb7feaa4ad8c37664a,2378 + pantry-tree: + sha256: 03f8e22f364deb86098dbfbe0bf83c896437b2355f139abdac0402658fb6ac7e + size: 1183 + original: + hackage: colour-2.3.6 +- completed: + hackage: happy-lib-2.2@sha256:ef829bf7f489402742ea5da093d4549cf9f745a0aa0e6894cf67b5260f90306e,6101 + pantry-tree: + sha256: 58cbb282274e29755e5ffbf5e941e0d7c8c47a2b60871f3de5fd85ab98020239 + size: 2493 + original: + hackage: happy-lib-2.2 +- completed: + hackage: integer-logarithms-1.0.5@sha256:870ce80a2e704f179bcda12ee106389a484100fac1534abfd587aaaa51978e6b,2964 + pantry-tree: + sha256: 5b217bbf96ef5487aad81cf1c61a1d1092f8e044403b554e201d8d8478568499 + size: 865 + original: + hackage: integer-logarithms-1.0.5 +- completed: + hackage: invariant-0.6.5@sha256:96f6eec31b5ebd04d09dcc12e7a4f869bc920da72347b9578b0ecbe126125833,3319 + pantry-tree: + sha256: 54ce82471099ac4ba94c0c74540c2fc2c272ecf2b2bb0b0d9bd863aec9659a94 + size: 650 + original: + hackage: invariant-0.6.5 +- completed: + hackage: lazysmallcheck-0.6@sha256:dac7a1e4877681f1260309e863e896674dd6efc1159897b7945893e693f2a6bc,1696 + pantry-tree: + sha256: aea6b83dd91703fd130d98ecfed88b8f16841b22990c837c8fde89f9f6cca809 + size: 2008 + original: + hackage: lazysmallcheck-0.6 +- completed: + hackage: safe-0.3.21@sha256:b928ea1645876788155b38ce85c7e46d157a1bb41d2b05f5770b13d60bc6a3f7,2400 + pantry-tree: + sha256: ffc22bbfa2397e8b12a5ac0d867e4c93fea452d536f35f6f01f90fa326ee1652 + size: 564 + original: + hackage: safe-0.3.21 +- completed: + hackage: unliftio-0.2.25.1@sha256:813fa756f7b95ac4741cbaecbacde48bec2d2fcbbbef5d32fe5ad02b54cbcaaf,3410 + pantry-tree: + sha256: c027ff17b51118a8b44713afda3df25d6db76a13226d6913edf92c111c92526a + size: 2494 + original: + hackage: unliftio-0.2.25.1 +- completed: + hackage: safe-exceptions-0.1.7.4@sha256:8bb7261bd54bd58acfcb154be6a161fb6d0d31a1852aadc8e927d2ad2d7651d1,1412 + pantry-tree: + sha256: fa4189feca3ca20f024087c209dfed9bbc8a9f799fb966bc3db9e24aef81dd09 + size: 511 + original: + hackage: safe-exceptions-0.1.7.4 +snapshots: [] diff --git a/test/Spec.hs b/test/Spec.hs index af0c9fc..8d1d9c8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,22 +19,11 @@ import Core.RegFile import Simulate import Memory.Types import Memory.Vec -#ifdef SMT_PROOF -import qualified Proof.SMT.Sanity as Sanity -#endif import qualified Prelude -#ifdef SMT_PROOF -import qualified Proof.Memory.Cache4K.Server.Functional.Solver -import qualified Proof.Memory.Cache4K.Server.Leakage.Solver -import qualified Proof.Memory.Cache4K.CachedCore.Functional.Solver -import qualified Proof.Memory.Cache4K.CachedCore.Leakage.Solver -import qualified Proof.Core.Functional.Solver -import qualified Proof.Core.Leakage.Solver -#endif import IsaSpec (isaConformanceTests) import ProofSpec (proofTests) import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck import "aimcore" Types import "aimcore" Util @@ -58,151 +46,12 @@ mkPureTest s (CPUTest prog expected) = in forM_ expected $ \(loc, res) -> readWord (fromIntegral loc) ram @?= res -#ifdef SMT_PROOF --- | The compile-time symbolic checks, read back out. --- --- The first three establish that the Pantomime plugin is wired in and actually --- discharging properties -- since pantomime 1821a71 an invalid property no --- longer fails the build, so the negative control has to be asserted here. --- The rest are the proofs themselves; see "Proof.Core.Functional.Solver" and --- "Proof.Core.Leakage.Solver". -sanityTests :: TestTree -sanityTests = - testGroup - "Symbolic proof results" - [ testCase "plugin sanity: deMorgan is valid" $ verdict "deMorgan" @?= Nothing, - testCase "plugin sanity: doubling is valid" $ verdict "doubling" @?= Nothing, - testCase "plugin sanity: negative control yields a counterexample" $ - assertBool "expected a counterexample for 'bogus'" $ - isJust (verdict "bogus"), - testCase "array embedding round-trips" $ - lookup "arrRoundTripP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "shift embeddings are sane" $ - lookup "shiftsSaneP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "on states in the invariant, the driver agrees with its reading" $ - lookup "driverMatchesSpecP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "on the initial system, the driver agrees with its reading" $ - lookup "driverMatchesSpecInitP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the driver gives only the steps' hop lengths" $ - lookup "driverValuesP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "base case: invariant holds after the reset hop" $ - lookup "baseCaseP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "k = 0 inductive step is valid" $ - lookup "indStep0P" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "k = 1 inductive step is valid" $ - lookup "indStep1P" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "k = 2 inductive step is valid" $ - lookup "indStep2P" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "k = 3 inductive step is valid" $ - lookup "indStep3P" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant implies the ISA's PC is the core's architectural one" $ - lookup "pcUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant implies the ISA's register file is the core's architectural one" $ - lookup "regFileUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant implies the ISA's memory is the core's architectural one" $ - lookup "memUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant is functional: it relates one ISA state to a system" $ - lookup "invFunctionalP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the simulator's driver agrees with its operational reading" $ - lookup "simDriverMatchesSpecP" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "on the initial simulator, its driver agrees with its reading" $ - lookup "simDriverMatchesSpecInitP" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "the simulator invariant is functional: it relates one simulator to a system" $ - lookup "simInvFunctionalP" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "leakage base case: simulator matches the first hop" $ - lookup "baseCaseLeakP" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "k = 0 leakage step is valid" $ - lookup "indStepLeak0P" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "k = 1 leakage step is valid" $ - lookup "indStepLeak1P" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "k = 2 leakage step is valid" $ - lookup "indStepLeak2P" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testCase "k = 3 leakage step is valid" $ - lookup "indStepLeak3P" Proof.Core.Leakage.Solver.results @?= Just Nothing, - testGroup - "the 4 KiB cache answers as ideal memory, with delay" - [ testCase name $ - lookup name Proof.Memory.Cache4K.Server.Functional.Solver.results - @?= Just Nothing - | name <- - [ "cacheArraysP", - "coherentDataP", - "coherentWriteP", - "coherentLayoutP", - "srvDriverMatchesSpecP", - "srvDriverValuesP", - "srvInvFunctionalP", - "baseCaseP", - "indStep0P", - "indStep4P", - "indStepWaits4P", - "indStep8P", - "indStepWaits8P", - "srvReadyIffAnsweredP", - "srvReadyUnderInvP", - "corePatientP" - ] - ], - testGroup - "the 4 KiB cache leaks only its requests' observations" - [ testCase name $ - lookup name Proof.Memory.Cache4K.Server.Leakage.Solver.results - @?= Just Nothing - | name <- - [ "simSrvReadyIffAnsweredP", - "simSrvDriverMatchesSpecP", - "srvSimInvFunctionalP", - "baseCaseLeakP", - "indStepLeakP" - ] - ], - testGroup - "the core behind the cache refines the core behind ideal memory" - [ testCase name $ - lookup name Proof.Memory.Cache4K.CachedCore.Functional.Solver.results - @?= Just Nothing - | name <- - [ "cachedDriverMatchesSpecP", - "cachedDriverValuesP", - "cachedInvFunctionalP", - "baseCaseP", - "indStep0P", - "indStep4P", - "indStep8P" - ] - ], - testGroup - "the core behind the cache leaks only what it leaks behind ideal memory" - [ testCase name $ - lookup name Proof.Memory.Cache4K.CachedCore.Leakage.Solver.results - @?= Just Nothing - | name <- - [ "simCachedDriverMatchesSpecP", - "cachedSimInvFunctionalP", - "baseCaseLeakP", - "indStepLeak0P", - "indStepLeak4P", - "indStepLeak8P" - ] - ] - ] - where - verdict :: String -> Maybe String - verdict name = - case lookup name Sanity.results of - Just v -> v - Nothing -> error "Proof.SMT.Sanity.results is missing an expected entry" -#endif tests :: TestTree tests = testGroup "All Tests" - [ -#ifdef SMT_PROOF - sanityTests, -#endif - proofTests, + [ proofTests, cache4KTests, cacheProofTests, isaConformanceTests,