From 75bfd0c72d52c760f44cd458fc1c0ca0fac44a1e Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 9 Sep 2026 13:28:46 +0200 Subject: [PATCH 01/16] Remove dead code from ISA module apply, Done, getRd, getR1, getR2, and depSet were unused within ISA.hs itself, along with the now-unreferenced Data.Set and Data.Maybe imports they required. Co-Authored-By: Claude Sonnet 5 --- src/ISA.hs | 44 -------------------------------------------- 1 file changed, 44 deletions(-) diff --git a/src/ISA.hs b/src/ISA.hs index 1b572d9..66c3fb6 100644 --- a/src/ISA.hs +++ b/src/ISA.hs @@ -4,17 +4,9 @@ module ISA ( Func, - Done (..), DepReg (..), - apply, Instr (..), PC, - depSet, - getRd, - getR1, - getR2, - isLoad, - loadHazard, interp, interp', ) @@ -24,9 +16,6 @@ import Access import Clash.Prelude hiding (Const, Log, Ordering (..), Word, def, init, lift, log) import Core hiding (Syscall) import Data.Functor.Identity -import Data.Maybe (catMaybes) -import Data.Set (Set) -import qualified Data.Set as S import Instruction (Sign) import qualified Instruction import Types @@ -45,12 +34,6 @@ instance Show (Func a) where instance Functor Func where fmap g (Func f d) = Func (\r1 r2 pc -> g $ f r1 r2 pc) d -newtype Done a = Done {unDone :: a} - deriving (Show, Eq) - -apply :: Func a -> Word -> Word -> PC -> Done a -apply (Func f _) r1 r2 pc = Done $ f r1 r2 pc - data Instr f = Reg RegIdx (f Word) | Load Size Sign RegIdx (f Address) @@ -75,28 +58,6 @@ deriving instance ) => Eq (Instr f) -getRd :: Instr a -> Maybe RegIdx -getRd (Reg rd _) = pure rd -getRd (Load _ _ rd _) = pure rd -getRd (Jump rd _ _) = pure rd -getRd Syscall = pure 10 -getRd _ = empty - -getR1 :: Instr Func -> Maybe RegIdx -getR1 = fst . deps - -getR2 :: Instr Func -> Maybe RegIdx -getR2 = snd . deps - -isLoad :: Instr a -> Bool -isLoad Load {} = True -isLoad _ = False - -loadHazard :: Instr Func -> Instr Func -> Bool -loadHazard de_ir (ISA.Load _ _ rd _) = - elem rd $ S.toList $ depSet de_ir -loadHazard _ _ = False - class DepReg a where deps :: a -> (Maybe RegIdx, Maybe RegIdx) @@ -113,11 +74,6 @@ instance DepReg (Instr Func) where deps Nop = (empty, empty) deps Syscall = (pure 17, empty) -depSet :: (DepReg a) => a -> Set RegIdx -depSet a = - let (mr1, mr2) = deps a - in S.fromList $ catMaybes [mr1, mr2] - interp :: (Access f) => Input f -> Instr Func interp input | not (inputIsInstr input) = Nop From 94b077066a3b1ca4a352e8a3deea2349aea08a7b Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 9 Sep 2026 13:58:43 +0200 Subject: [PATCH 02/16] Regenerate stack.yaml.lock to fix stale GitHub archive hashes GitHub changed its archive tarball generation format, so the sha256 hashes pinned for the PLSec-VU/pantomime, pantomime-base, and pantomime-clash GitHub archives no longer matched what GitHub serves, breaking CI's dependency install step. Co-Authored-By: Claude Sonnet 5 --- stack.yaml.lock | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 4179422..78ec65a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -44,8 +44,8 @@ packages: pantry-tree: sha256: db092592a9914ed1ee72d5916ae4f063667170c0b30a5dc9fd36412582682947 size: 2709 - sha256: 1f8b20c1d38659692f2f9320f75b635483ea1750e560b87c89084cc034b8fb58 - size: 81865 + sha256: 9d41677c16f8dffe9a3d31e4fff00bf53a5d63b88fba5e9a93322031349ea459 + size: 81872 url: https://github.com/PLSec-VU/pantomime/archive/491638b742ce2d9fc92976ab0e2037ba259e5ae9.tar.gz version: 0.1.0.0 original: @@ -55,8 +55,8 @@ packages: pantry-tree: sha256: 6729f953ad15ea5d00e2c3142142682f064c30c14e84771967407b8b638e89ad size: 530 - sha256: a81aeb4ae7e5a7a023bc3507022dc8b90323e293abbd0bdc235354e67fb29b61 - size: 16973 + sha256: 98053f17fdd3476737d139beda0e0e3946772e41368f400658151c51fdb6c1e8 + size: 16975 url: https://github.com/PLSec-VU/pantomime-base/archive/64dab2d4fd3ef4c27ec9eb698bf61092fb08d8a4.tar.gz version: 0.1.0.0 original: @@ -66,8 +66,8 @@ packages: pantry-tree: sha256: 978493e7943f08ff0a4b27b0794f0fa392f1dee60c3a746d1970c3b0731121b9 size: 611 - sha256: 73921a56dd8feed1b075b20986ada7ae32041dcabd33418bc63b48f45c6b17bc - size: 19409 + sha256: 012c081c9df84a8725e1e814c16b12bb04e3cd4149de96011efab65f3e835f9b + size: 19408 url: https://github.com/PLSec-VU/pantomime-clash/archive/1f42057f228cd5e476af4b35541598843a7b74f9.tar.gz version: 0.1.0.0 original: From a4c22842119fef497768ae75d02838fa590f10d7 Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 9 Sep 2026 17:17:21 +0200 Subject: [PATCH 03/16] reorder conditions for stall --- src/Core.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 8067965..373f47f 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -324,14 +324,14 @@ decode = do -- Stall if there was a jump in the previous cycle. | jump_previous_cycle = Nop JumpSecondCycle -- Stall if there is a jump in this cycle. - | jump_current_cycle = Nop JumpFirstCycle - -- Stall if there was a store hazard in the previous cycle. | store_hazard_previous_cycle = Nop StoreHazardSecondCycle -- Stall if there is a store hazard in this cycle. - | store_hazard_current_cycle = Nop StoreHazardFirstCycle - -- Stall if there was a load hazard in the previous cycle. | load_hazard_previous_cycle = Nop LoadHazardSecondCycle -- Stall if there is a load hazard in this cycle. + | jump_current_cycle = Nop JumpFirstCycle + -- Stall if there was a store hazard in the previous cycle. + | store_hazard_current_cycle = Nop StoreHazardFirstCycle + -- Stall if there was a load hazard in the previous cycle. | load_hazard_current_cycle = Nop LoadHazardFirstCycle -- Otherwise we process the decoded instruction. | otherwise = ir From a9373202e7101ab62d1d3aa900f639dce8b23d14 Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 9 Sep 2026 17:50:29 +0200 Subject: [PATCH 04/16] Halting moved from memory to writeback --- src/Core.hs | 29 ++++++++++++----------------- src/Leak/PC/PC.hs | 2 +- src/Leak/PC/Sim.hs | 25 ++++++++++++------------- 3 files changed, 25 insertions(+), 31 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 373f47f..697f993 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -133,8 +133,8 @@ data State f = State stateCtrl :: Control f, -- | CPU halt state. stateHalt :: Maybe HaltState, - -- | Pending halt state (propagating through pipeline to ensure flush). - stateHaltPending :: Maybe HaltState + -- | In case of a halt, the address of the next instruction. + stateHaltNextPc :: Address } deriving instance (Show (f Word)) => Show (State f) @@ -228,7 +228,7 @@ init = stateRegFile = initRF, stateCtrl = initCtrl, stateHalt = Nothing, - stateHaltPending = Nothing + stateHaltNextPc = 0 } -- | Initial control lines. @@ -423,10 +423,10 @@ execute = do modify $ \s -> s {stateMeRes = res} Instruction.IType (Env Call) _ _ _ -> do pc <- gets stateExPc - pendingHalt (Syscall (pc + 4)) + modify $ \s -> s {stateHaltNextPc = pc + 4} Instruction.IType (Env Break) _ _ _ -> do pc <- gets stateExPc - pendingHalt (EBreak (pc + 4)) + modify $ \s -> s {stateHaltNextPc = pc + 4} Instruction.Nop _ -> pure () where getFirstArg :: RegIdx -> CPUM f (f Word) @@ -449,10 +449,6 @@ execute = do runMaybeT $ checkForFwd ctrlMeRegFwd <|> checkForFwd ctrlWbRegFwd - pendingHalt :: HaltState -> CPUM f () - pendingHalt hState = do - modify $ \s -> s {stateHaltPending = Just hState} - alu :: (Access f) => Arith -> f Word -> f Word -> f Word alu op lhs rhs = case op of ADD -> (+) <$> lhs <*> rhs @@ -486,13 +482,6 @@ memory = do ir <- gets stateMeInstr res <- gets stateMeRes addr <- gets stateMeAddr - pending <- gets stateHaltPending - - case pending of - Just hlt -> - modify $ \s -> - s {stateHalt = Just hlt, stateHaltPending = Nothing} - Nothing -> pure () modify $ \s -> s {stateWbInstr = ir, stateWbRes = res} @@ -524,7 +513,7 @@ writeback :: forall f. (Access f) => CPUM f () writeback = do input <- asks inputMem ir <- gets stateWbInstr - res <- gets stateWbRes + res <- gets stateWbRes case ir of Instruction.RType _ rd _ _ -> do @@ -546,6 +535,12 @@ writeback = do Instruction.UType _ rd _ -> do setLines $ \c -> c {ctrlWbRegFwd = Just (rd, res)} writeRF rd res + Instruction.IType (Env Call) _ _ _ -> do + cont <- gets stateHaltNextPc + modify $ \s -> s {stateHalt = Just (Syscall cont), stateHaltNextPc = 0} + Instruction.IType (Env Break) _ _ _ -> do + cont <- gets stateHaltNextPc + modify $ \s -> s {stateHalt = Just (EBreak cont), stateHaltNextPc = 0} _ -> do setLines $ \c -> c {ctrlWbRegFwd = Nothing} where diff --git a/src/Leak/PC/PC.hs b/src/Leak/PC/PC.hs index 4fbc4b7..3ae2d3e 100644 --- a/src/Leak/PC/PC.hs +++ b/src/Leak/PC/PC.hs @@ -105,7 +105,7 @@ proj s = (ts, ss) Sim.stateMemInstr = killJump $ toLeakInstr $ Core.stateMeInstr s, Sim.stateWbInstr = killJump $ toLeakInstr $ Core.stateWbInstr s, Sim.stateHalt = Core.stateHalt s, - Sim.stateHaltPending = Core.stateHaltPending s, + Sim.stateHaltNextPc = Core.stateHaltNextPc s, Sim.stateMeMemInstr = Core.ctrlMeMemInstr $ Core.stateCtrl s, Sim.stateJumpAddr = Core.ctrlExJumpAddr $ Core.stateCtrl s, Sim.stateDeLoadHazard = Core.ctrlDeLoadHazard $ Core.stateCtrl s, diff --git a/src/Leak/PC/Sim.hs b/src/Leak/PC/Sim.hs index 1151400..7309aaf 100644 --- a/src/Leak/PC/Sim.hs +++ b/src/Leak/PC/Sim.hs @@ -28,14 +28,14 @@ data State = State stateJumpAddr :: Maybe Address, stateMeMemInstr :: Bool, stateHalt :: Maybe AimCore.HaltState, - stateHaltPending :: Maybe AimCore.HaltState, + stateHaltNextPc :: Address, stateDeLoadHazard :: Maybe Address, stateDeCall :: Bool, stateFirstCycle :: Bool } deriving (Show, Eq) -init :: State +init ::State init = State { stateFePc = initPc, @@ -45,7 +45,7 @@ init = stateMemInstr = Leak.nop, stateWbInstr = Leak.nop, stateHalt = Nothing, - stateHaltPending = Nothing, + stateHaltNextPc = 0, stateMeMemInstr = False, stateJumpAddr = Nothing, stateDeLoadHazard = Nothing, @@ -70,9 +70,9 @@ fetch = do deCall <- gets stateDeCall meMemInstr <- gets stateMeMemInstr status <- gets stateHalt - pending <- gets stateHaltPending + pending <- gets stateHaltNextPc - let isHalted = isJust status || isJust pending + let isHalted = isJust status || pending /= 0 unless (meMemInstr || isHalted) $ outputPc pc @@ -100,12 +100,12 @@ decode = do mJumpAddr <- gets stateJumpAddr firstCycle <- gets stateFirstCycle status <- gets stateHalt - pending <- gets stateHaltPending + pending <- gets stateHaltNextPc let branch_first_cycle = isNopBranchFirstCycle exInstr let load_hazard_first_cycle = isNopLoadHazardFirstCycle exInstr let call_current_cycle = isCall exInstr - let halt_pending = isJust pending + let halt_pending = pending /= 0 -- In Sim, we don't have the real instruction, but we know if it was stalled. let load_hazard_current_cycle = case instrBase instr of @@ -167,7 +167,7 @@ execute = do modify $ \s -> s { stateJumpAddr = Nothing, - stateHaltPending = Just (AimCore.EBreak (pc + 4)), + stateHaltNextPc = pc + 4, stateMemInstr = killJump instr } _ -> do @@ -191,11 +191,6 @@ memory :: SimM () memory = do instr <- gets stateMemInstr modify $ \s -> s {stateWbInstr = killJump instr} - - pending <- gets stateHaltPending - case pending of - Just hlt -> modify $ \s -> s {stateHalt = Just hlt, stateHaltPending = Nothing} - Nothing -> pure () mMeMemInstr <- getFirst . Leak.outMeMemInstr <$> ask case mMeMemInstr of @@ -212,6 +207,10 @@ writeback = do instr <- gets stateWbInstr halted <- gets stateHalt + pending <- gets stateHaltNextPc + when (pending /= 0) $ + modify $ \s -> s {stateHalt = Just (AimCore.EBreak pending), stateHaltNextPc = 0} + mLeakedHalt <- getFirst . Leak.outHalt <$> ask when (isJust halted || isJust mLeakedHalt) $ outputNothing From 18a359818131152b30dd2373cb9c6f8db1cd79ba Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 9 Sep 2026 20:02:18 +0200 Subject: [PATCH 05/16] Fixed address overlap bug --- src/Core.hs | 33 +++++++++++++++++---------------- src/Instruction.hs | 22 +++++++++++++++++++++- 2 files changed, 38 insertions(+), 17 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 697f993..114a9cd 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -159,14 +159,14 @@ data Control f = Control -- | Stores the jump address if the instruction in the `execute` stage -- results in a jump. ctrlExJumpAddr :: Maybe Address, - -- | Stores the write address if the instruction in the `execute` stage + -- | Stores the write address and size if the instruction in the `execute` stage -- is a store. - ctrlExStoreAddr :: Maybe Address, + ctrlExStoreAddrSize :: Maybe (Address, Size), -- | `True` when the instruction in the `memory` stage is a store or a load. ctrlMeMemInstr :: Bool, - -- | Stores the write address if the instruction in the `memory` stage + -- | Stores the write address and size if the instruction in the `memory` stage -- is a store. - ctrlMeStoreAddr :: Maybe Address, + ctrlMeStoreAddrSize :: Maybe (Address, Size), -- | Forwards the `rd` register from the `memory` stage to the `execute` -- stage. ctrlMeRegFwd :: Maybe (RegIdx, f Word), @@ -239,9 +239,9 @@ initCtrl = ctrlDeStoreHazard = Nothing, ctrlExInstr = Nothing, ctrlExJumpAddr = Nothing, - ctrlExStoreAddr = Nothing, + ctrlExStoreAddrSize = Nothing, ctrlMeMemInstr = False, - ctrlMeStoreAddr = Nothing, + ctrlMeStoreAddrSize = Nothing, ctrlMeRegFwd = Nothing, ctrlWbRegFwd = Nothing } @@ -303,15 +303,16 @@ decode = do let call_current_cycle = maybe False isCall (ctrlExInstr ctrl) let break_current_cycle = maybe False isBreak (ctrlExInstr ctrl) - let jump_current_cycle = isJust (ctrlExJumpAddr ctrl) let jump_previous_cycle = maybe False isNopJumpFirstCycle (ctrlExInstr ctrl) + let store_hazard_previous_cycle = maybe False isNopStoreHazardFirstCycle (ctrlExInstr ctrl) + let load_hazard_previous_cycle = maybe False isNopLoadHazardFirstCycle (ctrlExInstr ctrl) + + let jump_current_cycle = isJust (ctrlExJumpAddr ctrl) let store_hazard_current_cycle = - (ctrlExStoreAddr ctrl == Just pc) || - (ctrlMeStoreAddr ctrl == Just pc) - - let store_hazard_previous_cycle = maybe False isNopStoreHazardFirstCycle (ctrlExInstr ctrl) - let load_hazard_previous_cycle = maybe False isNopLoadHazardFirstCycle (ctrlExInstr ctrl) + maybe False (storeHazard pc) (ctrlExStoreAddrSize ctrl) || + maybe False (storeHazard pc) (ctrlMeStoreAddrSize ctrl) + let load_hazard_current_cycle = maybe False (loadHazard ir) (ctrlExInstr ctrl) let ir' @@ -375,7 +376,7 @@ execute = do let res = alu ADD r1 (pure imm') noSecrets' res () $ \res' -> do modify $ \s -> s {stateMeAddr = unpack res'} - Instruction.SType _ imm rs1 rs2 -> do + Instruction.SType size imm rs1 rs2 -> do r1 <- getFirstArg rs1 r2 <- getSecondArg rs2 let imm' = signExtend imm @@ -383,7 +384,7 @@ execute = do modify $ \s -> s {stateMeRes = r2} noSecrets' res () $ \res' -> do modify $ \s -> s {stateMeAddr = unpack res'} - setLines $ \c -> c {ctrlExStoreAddr = Just $ unpack res'} + setLines $ \c -> c {ctrlExStoreAddrSize = Just (unpack res', size)} Instruction.BType cmp imm rs1 rs2 -> do r1 <- getFirstArg rs1 r2 <- getSecondArg rs2 @@ -477,7 +478,7 @@ branch op lhs rhs = case op of where sign = unpack @(Signed 32) -memory :: (Access f) => CPUM f () +memory :: CPUM f () memory = do ir <- gets stateMeInstr res <- gets stateMeRes @@ -498,7 +499,7 @@ memory = do readRAM addr size Instruction.SType size _ _ _ -> do setLines $ \c -> - c {ctrlMeMemInstr = True, ctrlMeStoreAddr = Just addr} + c {ctrlMeMemInstr = True, ctrlMeStoreAddrSize = Just (addr, size)} writeRAM addr size res Instruction.JType rd _ -> setLines $ \c -> c {ctrlMeRegFwd = Just (rd, res)} diff --git a/src/Instruction.hs b/src/Instruction.hs index ce4269e..adb0a9a 100644 --- a/src/Instruction.hs +++ b/src/Instruction.hs @@ -25,6 +25,7 @@ module Instruction isNopStoreHazardFirstCycle, isNopHalted, break, + storeHazard, loadHazard, isLoad, isStore, @@ -37,7 +38,8 @@ import Control.Monad import Data.Binary (Binary) import Data.Maybe (fromMaybe, isJust) import Types -import Prelude hiding (Ordering (..), Word, break, undefined) +import Prelude hiding (Ordering (..), Word, break, undefined, (&&), (||)) +import Pantomime.Expr (Literal(Bool)) -- | All arithmetic and logic operations. data Arith @@ -467,6 +469,24 @@ isNopHalted _ = False break :: Instruction break = IType (Env Break) 0 0 0 +storeHazard :: Address -> (Address, Size) -> Bool +storeHazard read_pc (write_pc, size) = + let read_size = 4 + write_size = sizeBytes size + in if read_pc <= write_pc + then storeHazardLeq read_pc read_size write_pc write_size + else storeHazardLeq write_pc write_size read_pc read_size + where + sizeBytes :: Size -> Address + sizeBytes Byte = 1 + sizeBytes Half = 2 + sizeBytes Word = 4 + + storeHazardLeq :: Address -> Address -> Address -> Address -> Bool + storeHazardLeq addr1 size1 addr2 size2 = + let diff = addr2 - addr1 in + diff < size1 || - diff < size2 + loadHazard :: Instruction -> Instruction -> Bool loadHazard de_ir ex_ir@(IType Load {} _ _ _) = isJust $ do let mr1 = noZero $ getRs1 de_ir From 2340cdf4d8ddbb86d06472a6803920449ccc77f5 Mon Sep 17 00:00:00 2001 From: Kristina Date: Thu, 10 Sep 2026 16:01:57 +0200 Subject: [PATCH 06/16] Functional correctness --- app/Main.hs | 6 +- package.yaml | 24 +- proof/Proof/Driver.hs | 208 +++ proof/Proof/Functional/Induction.hs | 193 +++ proof/Proof/Functional/Invariant.hs | 432 +++++++ proof/Proof/Functional/Obligation.hs | 187 +++ proof/Proof/Leakage/Induction.hs-disabled | 162 +++ proof/Proof/Leakage/Model.hs | 258 ++++ proof/Proof/Leakage/Obligation.hs | 58 + proof/Proof/Leakage/Simulator.hs | 370 ++++++ proof/Proof/Machine.hs | 128 ++ proof/Proof/SMT/Array.hs | 275 ++++ proof/Proof/SMT/Axioms.hs | 61 + proof/Proof/SMT/Logged.hs | 25 + proof/Proof/SMT/Sanity.hs | 57 + proof/notes/counterexample-k0.txt | 143 +++ proof/notes/driver.txt | 91 ++ proof/notes/invariant.txt | 214 ++++ proof/notes/leakage.txt | 53 + src/Core.hs | 123 +- src/Elf/ElfLoader.hs | 2 +- src/HardwareSim.hs | 4 +- src/ISA.hs | 131 +- src/Memory/Types.hs | 43 + src/RegFile.hs | 32 + stack.yaml | 9 +- stack.yaml.lock | 32 +- test/BenchmarkSpec.hs | 2 +- test/ProofSpec.hs | 1412 +++++++++++++++++++++ test/Spec.hs | 48 +- 30 files changed, 4714 insertions(+), 69 deletions(-) create mode 100644 proof/Proof/Driver.hs create mode 100644 proof/Proof/Functional/Induction.hs create mode 100644 proof/Proof/Functional/Invariant.hs create mode 100644 proof/Proof/Functional/Obligation.hs create mode 100644 proof/Proof/Leakage/Induction.hs-disabled create mode 100644 proof/Proof/Leakage/Model.hs create mode 100644 proof/Proof/Leakage/Obligation.hs create mode 100644 proof/Proof/Leakage/Simulator.hs create mode 100644 proof/Proof/Machine.hs create mode 100644 proof/Proof/SMT/Array.hs create mode 100644 proof/Proof/SMT/Axioms.hs create mode 100644 proof/Proof/SMT/Logged.hs create mode 100644 proof/Proof/SMT/Sanity.hs create mode 100644 proof/notes/counterexample-k0.txt create mode 100644 proof/notes/driver.txt create mode 100644 proof/notes/invariant.txt create mode 100644 proof/notes/leakage.txt create mode 100644 test/ProofSpec.hs diff --git a/app/Main.hs b/app/Main.hs index 0c9a85f..396e5a9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -225,7 +225,7 @@ runNormalMemory Options{..} elf entryOffset leakOutputHandle leakDigest finalSta runIOMemT mem $ loadProgram elf let initialSims = P.map (\_ -> simulator @Identity @(IOMemT IO)) [1..optNumInstances] - let initialStates = P.map (\(sim, mem) -> sim { circuitState = (Core.init @Identity) { Core.stateFePc = fromIntegral entryOffset, Core.stateRegFile = modifyRF 2 (pure $ ioMemInitSP mem) initRF } }) (P.zip initialSims memInstances) + let initialStates = P.map (\(sim, mem) -> sim { circuitState = (Core.init @Identity @RegFile) { Core.stateFePc = fromIntegral entryOffset, Core.stateRegFile = modifyRF 2 (pure $ ioMemInitSP mem) initRF } }) (P.zip initialSims memInstances) go 0 (P.zip memInstances initialStates) where @@ -254,7 +254,7 @@ runNormalMemory Options{..} elf entryOffset leakOutputHandle leakDigest finalSta case mRet of Nothing -> pure (Nothing, True) -- exit Just ret -> do - let s'' = Core.init {Core.stateFePc = resumePc, + let s'' = (Core.init :: Core.State Identity) {Core.stateFePc = resumePc, Core.stateRegFile = modifyRF 10 ret (Core.stateRegFile s')} _ <- next s'' o pure (Just Core.initInput, False) @@ -329,7 +329,7 @@ runExecutable opts@Options{..} = do (secureInstrument optVerbose leakOutputHandle leakDigest finalStateRef) (simulator @PubSec @(SecureIOMemT IO)) { circuitState = - (Core.init @PubSec) + (Core.init @PubSec @RegFile) { Core.stateFePc = fromIntegral entryOffset, Core.stateRegFile = modifyRF 2 (pure $ secureIOMemInitSP secureIOMem) initRF } diff --git a/package.yaml b/package.yaml index da2fe45..7adf243 100644 --- a/package.yaml +++ b/package.yaml @@ -62,6 +62,7 @@ dependencies: - pantomime - pantomime-clash - pantomime-base +- template-haskell ghc-options: - -Wall @@ -78,8 +79,27 @@ ghc-options: - -fplugin Pantomime library: - source-dirs: src + source-dirs: + - src + - proof exposed-modules: + - Proof.Machine + - Proof.Driver + - Proof.Functional.Invariant + - Proof.Functional.Obligation + - Proof.Functional.Induction + - Proof.Leakage.Model + - Proof.Leakage.Simulator + - Proof.Leakage.Obligation + # Proof.Leakage.Induction: temporarily out of the build. Its four properties + # are invalid since the aliasing-store assumption was dropped, and the + # counterexample-extraction path trips a Pantomime/effectful unlifting bug + # ("version (2356) /= storageVersion (0)") that fails the build outright. + # Restore once the leakage model can express the store-hazard stall. + - Proof.SMT.Array + - Proof.SMT.Axioms + - Proof.SMT.Logged + - Proof.SMT.Sanity - Access - Core - Elf.ElfLoader @@ -137,4 +157,4 @@ tests: - melf - bytestring - exceptions - + - QuickCheck diff --git a/proof/Proof/Driver.hs b/proof/Proof/Driver.hs new file mode 100644 index 0000000..5b7117b --- /dev/null +++ b/proof/Proof/Driver.hs @@ -0,0 +1,208 @@ +-- | The driver from @proof/notes/driver.txt@, as code. +-- +-- The driver says how many cycles 'Proof.Machine.stepSys' should advance the core +-- before its state is compared against the ISA again. Its stated invariant is +-- operational -- \"step until the instruction in the execute phase is no longer +-- a no-op\" -- so this module provides both: +-- +-- * 'driver', the case table from @driver.txt@, and +-- * 'driverRef', the operational reading, obtained by actually stepping. +-- +-- Checking these two against each other is the first thing the test suite does. +-- +-- NOTE on signatures: @driver.txt@ writes @isJumpInstr@ and @storeHazard@ as +-- functions of a handful of state fields. They cannot in fact be computed from +-- those fields alone -- both depend on the execute stage's forwarded operand +-- values, which in turn depend on the register file, on the memory-stage and +-- writeback-stage forwarding lines, and (for a load in writeback) on +-- 'inputMem'. So they are given here as functions of the whole system state. +-- The stage ordering below mirrors 'Core.pipe': writeback, then memory, then +-- execute. +module Proof.Driver + ( driver, + driverCaseName, + driverRef, + isMemInstr, + isEnvInstr, + isJumpInstr, + storeHazard, + loadHazardD, + exArg, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Data.Functor.Identity +import Instruction hiding (storeHazard) +import qualified Instruction +import Memory.Types (MemOps (..)) +import Proof.Machine +import RegFile +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | From @invariant.txt@: loads and stores are the memory instructions. +isMemInstr :: Instruction -> Bool +isMemInstr ir = isLoad ir || isStore ir + +-- | @ecall@ / @ebreak@. +isEnvInstr :: Instruction -> Bool +isEnvInstr ir = isCall ir || isBreak ir + +-- | The register file as 'Core.execute' sees it, i.e. after 'Core.writeback' +-- has committed the writeback-stage instruction. +rfAfterWriteback :: (RegFileOps r) => SysG r m -> r Identity +rfAfterWriteback (Sys st inp _) = + case stateWbInstr st of + RType _ rd _ _ -> put rd res + IType (Arith _) rd _ _ -> put rd res + IType (Load size sign) rd _ _ -> put rd (pure (loadExtend size sign (runIdentity (inputMem inp)))) + JType rd _ -> put rd res + IType Jump rd _ _ -> put rd res + UType _ rd _ -> put rd res + _ -> stateRegFile st + where + res = stateWbRes st + put rd v = modifyRFg rd v (stateRegFile st) + +-- | @ctrlMeRegFwd@ as set by 'Core.memory'. Note that a load in the memory +-- stage forwards nothing (its value is not available yet). +meFwd :: SysG r m -> Maybe (RegIdx, Word) +meFwd (Sys st _ _) = + case stateMeInstr st of + RType _ rd _ _ -> Just (rd, res) + IType (Arith _) rd _ _ -> Just (rd, res) + JType rd _ -> Just (rd, res) + IType Jump rd _ _ -> Just (rd, res) + UType _ rd _ -> Just (rd, res) + _ -> Nothing + where + res = runIdentity (stateMeRes st) + +-- | @ctrlWbRegFwd@ as set by 'Core.writeback'. A load forwards the value read +-- from memory on this cycle's 'inputMem', not 'stateWbRes'. +wbFwd :: SysG r m -> Maybe (RegIdx, Word) +wbFwd (Sys st inp _) = + case stateWbInstr st of + RType _ rd _ _ -> Just (rd, res) + IType (Arith _) rd _ _ -> Just (rd, res) + IType (Load size sign) rd _ _ -> Just (rd, loadExtend size sign (runIdentity (inputMem inp))) + JType rd _ -> Just (rd, res) + IType Jump rd _ _ -> Just (rd, res) + UType _ rd _ -> Just (rd, res) + _ -> Nothing + where + res = runIdentity (stateWbRes st) + +-- | The value 'Core.execute' reads for a source register, honouring the +-- memory-then-writeback forwarding priority of 'Core.execute'. +exArg :: (RegFileOps r) => SysG r m -> RegIdx -> Word +exArg sys idx = + case pick (meFwd sys) <|> pick (wbFwd sys) of + Just v -> v + Nothing -> runIdentity (lookupRFg idx (rfAfterWriteback sys)) + where + pick m = do + (fwdIdx, fwdVal) <- m + if fwdIdx == idx && idx /= 0 then Just fwdVal else Nothing + +-- | Does the execute-stage instruction take a jump this cycle? This is +-- @ctrlExJumpAddr@ becoming 'Just'. +isJumpInstr :: (RegFileOps r) => SysG r m -> Bool +isJumpInstr sys = + case exInstr sys of + BType cmp _ rs1 rs2 -> + runIdentity (branch cmp (pure (exArg sys rs1)) (pure (exArg sys rs2))) + JType _ _ -> True + IType Jump _ _ _ -> True + _ -> False + +-- | The store-hazard condition of 'Core.decode': the instruction word at the +-- decode-stage PC overlaps a store either in the execute stage or in the memory +-- stage. +-- +-- The overlap test is 'Instruction.storeHazard', the core's own, which is why +-- the store's size is carried alongside its address: a byte store and a word +-- store at the same address clash with different sets of PCs. 'Core.decode' +-- reads the pair off @ctrlExStoreAddrSize@ / @ctrlMeStoreAddrSize@; here the +-- execute-stage address is recomputed from the forwarded operand, as +-- 'Core.execute' would, and the memory-stage one is already in @stateMeAddr@. +storeHazard :: (RegFileOps r) => SysG r m -> Bool +storeHazard sys@(Sys st _ _) = + maybe False (Instruction.storeHazard dePc) exStore + || maybe False (Instruction.storeHazard dePc) meStore + where + dePc = stateDePc st + exStore = case exInstr sys of + SType size imm rs1 _ -> + Just + ( unpack (runIdentity (alu ADD (pure (exArg sys rs1)) (pure (signExtend imm)))), + size + ) + _ -> Nothing + meStore = case stateMeInstr st of + SType size _ _ _ -> Just (stateMeAddr st, size) + _ -> Nothing + +-- | The load-hazard condition of 'Core.decode', between the instruction +-- arriving on 'inputMem' and the one in the execute stage. +loadHazardD :: SysG r m -> Bool +loadHazardD sys@(Sys _ inp _) = + Instruction.loadHazard deIr (exInstr sys) + where + deIr + | inputIsInstr inp = decode' (runIdentity (inputMem inp)) + | otherwise = Nop MemoryBusBusy + +-- | The case table from @driver.txt@, in order. +driver :: (RegFileOps r) => SysG r m -> Int +driver sys@(Sys st _ _) + | ex == Nop FirstCycle = 1 + -- @driver.txt@ has no case for a halted core; every other case is guarded by + -- @stateHalt == Running@. + | not (running sys) = 0 + | isEnvInstr ex = 2 + | isJumpInstr sys = 2 + | storeHazard sys = if isMemInstr ex then 3 else 2 + | loadHazardD sys = 3 + | not (isMemInstr (stateWbInstr st)) = 0 + | not (isMemInstr (stateMeInstr st)) = 1 + | not (isMemInstr ex) = 2 + | otherwise = 3 + where + ex = exInstr sys + +-- | Which case of the table 'driver' fired. Used to measure how much of the +-- table the tests actually reach. +driverCaseName :: (RegFileOps r) => SysG r m -> String +driverCaseName sys@(Sys st _ _) + | ex == Nop FirstCycle = "firstCycle" + | not (running sys) = "halted" + | isEnvInstr ex = "env" + | isJumpInstr sys = "jump" + | storeHazard sys = if isMemInstr ex then "storeHazard/mem" else "storeHazard/nomem" + | loadHazardD sys = "loadHazard" + | not (isMemInstr (stateWbInstr st)) = "steady/wb-nomem" + | not (isMemInstr (stateMeInstr st)) = "steady/me-nomem" + | not (isMemInstr ex) = "steady/ex-nomem" + | otherwise = "steady/all-mem" + where + ex = exInstr sys + +-- | The operational reading of the driver's stated invariant: step until the +-- execute stage holds something that is not a no-op. Returns the number of +-- 'Proof.Machine.stepSys' steps taken, or 'Nothing' if @fuel@ ran out (which is what +-- happens once the core has halted, since the execute stage then holds +-- @Nop Halted@ forever). +-- +-- \"No longer a no-op\" is read as 'Proof.Machine.isBubble': @Nop DecodeFail@ counts +-- as a real instruction, since it is what an undecodable word in memory +-- decodes to. +driverRef :: (RegFileOps r, MemOps m) => Int -> SysG r m -> Maybe Int +driverRef fuel sys0 = go 1 (stepSys sys0) + where + go n s + | not (isBubble (exInstr s)) = Just n + | n >= fuel = Nothing + | otherwise = go (n + 1) (stepSys s) diff --git a/proof/Proof/Functional/Induction.hs b/proof/Proof/Functional/Induction.hs new file mode 100644 index 0000000..1e5855a --- /dev/null +++ b/proof/Proof/Functional/Induction.hs @@ -0,0 +1,193 @@ +-- | The inductive steps of the refinement proof, checked symbolically. +-- +-- 'baseCase' says the invariant holds at reset. Then one property per driver +-- delay: if the invariant relates @(isa, sys)@ and the driver says the hop takes +-- @k + 1@ cycles, then after those cycles (and one ISA step, where the hop +-- retires an instruction) the invariant relates them again. Base case plus the +-- four steps is the whole refinement theorem. +-- +-- Checking one @k@ at a time keeps the number of unrolled cycles concrete, +-- which sidesteps Pantomime's termination check: @stepSysN (driver sys + 1)@ +-- would recurse on a symbolic count. +-- +-- Each property is checked by the plugin at compile time and spliced into +-- 'results': 'Nothing' when valid, @'Just' counterexample@ when not. The +-- statements themselves live in "Proof.Functional.Obligation", shared with the QuickCheck +-- harness so the two cannot drift. +-- +-- The pipeline state is passed as an ADT of scalars ('KState') plus SMT-array +-- register file and memory: an ADT of scalars can be a fresh symbolic +-- argument, a record containing a function cannot, and the Clash @Vec@ API is +-- opaque to the plugin (see "Proof.SMT.Array"). +module Proof.Functional.Induction + ( arrRoundTrip, + shiftsSane, + baseCase, + indStep0, + indStep1, + indStep2, + indStep3, + results, + ) +where + +import Proof.SMT.Array +import Proof.SMT.Axioms (arrayAxioms) +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import qualified Core +import Data.Functor.Identity +import ISA (IsaStateG (..)) +import Instruction +import Proof.Functional.Invariant (invAtFree) +import Proof.SMT.Logged (pantomime) +import Proof.Machine +import Memory.Types (initPc) +import Proof.Functional.Obligation +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The pipeline registers, as plain scalars. +data KState = KState + { kFePc :: Address, + kDePc :: Address, + kExPc :: Address, + kExIr :: Instruction, + kMeIr :: Instruction, + kMeRes :: Word, + kMeAddr :: Address, + kWbIr :: Instruction, + kWbRes :: Word, + kCtrl :: Core.Control Identity, + kHalt :: Maybe Core.HaltState, + kHaltNextPc :: Address + } + +-- | Assemble a system state from the symbolic pieces. +sysOf :: KState -> Core.Input Identity -> RegArr -> MemArr -> SysG RegArrF MemArr +sysOf ss i ra ma = + Sys + { sysState = + Core.State + { Core.stateFePc = kFePc ss, + Core.stateDePc = kDePc ss, + Core.stateExPc = kExPc ss, + Core.stateExInstr = kExIr ss, + Core.stateMeInstr = kMeIr ss, + Core.stateMeRes = Identity (kMeRes ss), + Core.stateMeAddr = kMeAddr ss, + Core.stateWbInstr = kWbIr ss, + Core.stateWbRes = Identity (kWbRes ss), + Core.stateRegFile = RegArrF ra, + Core.stateCtrl = kCtrl ss, + Core.stateHalt = kHalt ss, + Core.stateHaltNextPc = kHaltNextPc ss + }, + sysInput = i, + sysMem = ma + } + +-- Sanity probes for the trusted embeddings ------------------------------------- +-- +-- The term axioms in "Proof.SMT.Axioms" replace Haskell functions by hand-written SMT +-- counterparts, so they are trusted, not proved. These two probes check each +-- embedding against facts a broken one would get wrong. + +-- | The register-file array embedding: a read after a write at the same index +-- gives the written value. +{-# ANN arrRoundTrip (Theory arrayAxioms) #-} +arrRoundTrip :: RegArr -> RegIdx -> Word -> Pantomime.Bool +arrRoundTrip a i v = Pantomime.boolean $ 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 shiftsSane (Theory arrayAxioms) #-} +shiftsSane :: Word -> Pantomime.Bool +shiftsSane x = + Pantomime.boolean $ + Core.sllWord x 0 == x + && Core.srlWord x 0 == x + && Core.sraWord x 0 == x + && Core.sllWord x 1 == x + x + && Core.srlWord x 31 == (if sign == 1 then 1 else 0) + && Core.sraWord x 31 == (if sign == 1 then 0xFFFFFFFF else 0) + where + sign = slice d31 d31 x + +-- The base case ---------------------------------------------------------------- + +-- | The invariant holds of the pipeline's initial state. +-- +-- Without this the four steps below say only that the invariant is /preserved/, +-- which is vacuous if it never holds anywhere. Together they give the theorem: +-- the invariant relates the core to the ISA at every state the driver lands on, +-- starting from reset. +-- +-- 'Core.init' has nothing in flight and its fetch PC at 'initPc', which is +-- exactly the invariant's startup case, so this holds for any loaded program -- +-- hence the arbitrary memory rather than a particular one. What it therefore +-- checks is the reset state's /shape/: three stages holding @Nop FirstCycle@, +-- nothing on the bus, no halt raised or pending, and @stateFePc@ equal to the +-- address the ISA starts at. +-- +-- Every field except the register file comes from 'Core.init' itself, so the +-- shape cannot drift from the real reset state. The register file has to be +-- substituted because 'RegFileOps.initRFg' builds a Clash 'Vec' with the opaque +-- 'repeat'. +-- +-- Note what that substitution costs: memory and the register file are the same +-- symbolic values on both sides, so the invariant's two container equalities +-- hold by construction here and this property alone would not notice if the +-- core's reset register file and the ISA's ('RegFile.initRF') disagreed. The +-- concrete test in "ProofSpec" closes that gap -- it runs on the real +-- 'Vec'-backed state, where both files are built independently. +{-# ANN baseCase (Theory arrayAxioms) #-} +baseCase :: RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +baseCase ra ma wr wa = + Pantomime.boolean $ invAtFree wr wa isa sys + where + st = (Core.init :: Core.StateG RegArrF Identity) {Core.stateRegFile = RegArrF ra} + sys = Sys st Core.initInput ma + isa = IsaState {isaPc = initPc, isaRegFile = RegArrF ra, isaMem = ma} + +-- The inductive steps ---------------------------------------------------------- + +-- | @k = 0@: the one-cycle hop (steady, writeback non-memory). +{-# ANN indStep0 (Theory arrayAxioms) #-} +indStep0 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +indStep0 ss i ra ma wr wa = + Pantomime.boolean $ indStepObligation wr wa (sysOf ss i ra ma) + +-- | @k = 1@: the two-cycle hop (startup, or a memory instruction in writeback). +{-# ANN indStep1 (Theory arrayAxioms) #-} +indStep1 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +indStep1 ss i ra ma wr wa = + Pantomime.boolean $ indStepObligation1 wr wa (sysOf ss i ra ma) + +-- | @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 only hop on which the ISA can halt. +{-# ANN indStep2 (Theory arrayAxioms) #-} +indStep2 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +indStep2 ss i ra ma wr wa = + Pantomime.boolean $ indStepObligation2 wr wa (sysOf ss i ra ma) + +-- | @k = 3@: the four-cycle hop (store hazard with a memory execute +-- instruction, load hazard, or all three stages holding memory instructions). +{-# ANN indStep3 (Theory arrayAxioms) #-} +indStep3 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +indStep3 ss i ra ma wr wa = + Pantomime.boolean $ indStepObligation3 wr wa (sysOf ss i ra ma) + +results :: [(String, Maybe String)] +results = + [ ("arrRoundTrip", $(pantomime 'arrRoundTrip)), + ("shiftsSane", $(pantomime 'shiftsSane)), + ("baseCase", $(pantomime 'baseCase)), + ("indStep0", $(pantomime 'indStep0)), + ("indStep1", $(pantomime 'indStep1)), + ("indStep2", $(pantomime 'indStep2)), + ("indStep3", $(pantomime 'indStep3)) + ] diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs new file mode 100644 index 0000000..c50cf73 --- /dev/null +++ b/proof/Proof/Functional/Invariant.hs @@ -0,0 +1,432 @@ +-- | The invariant from @proof/notes/invariant.txt@, as code. +-- +-- The invariant relates an architectural state @(isaPc, isaRegFile, isaMem)@ to +-- a system state @((core state), (input), mem)@. It is a disjunction of cases: +-- one for startup, four for the running core, and two for the halted core. +-- +-- Two forms of the same predicate live here: +-- +-- * 'invCases' represents each case as a named list of conjuncts, so a +-- failing QuickCheck run can report which clause broke ('explain'); +-- * 'invAtFree' is the identical predicate built from '&&' and '||' with no +-- lists, because Pantomime's evaluator diverges on recursion it cannot +-- prove terminating -- even over a fully concrete list. Symbolic execution +-- uses this one. +-- +-- The test \"fold-free invariant agrees with the list version\" keeps the two +-- from drifting. +-- +-- == Where this differs from @invariant.txt@ +-- +-- One place, marked again at its definition: NO @stateCtrl == initCtrl@ clause. +-- It is a holdover from an earlier 'Core' that reset the control lines at the +-- /end/ of each clock cycle; 'Core.withCtrlReset' now resets them at the start, +-- so no state reached by stepping the core satisfies it. +-- +-- The note's four running cases are collapsed into one here. They differ only +-- in the fetch conjuncts, and those track the writeback stage alone; the memory +-- stage's classification does no work beyond excluding an environment +-- instruction. See 'invCasesGen'. +module Proof.Functional.Invariant + ( flushWbStage, + flushMeStage, + isArithOrJumpInstr, + Case (..), + inv, + invAt, + invCases, + invCasesAt, + invAtFree, + explain, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Data.Functor.Identity +import Instruction +import Memory.Types +import Proof.Driver (isEnvInstr, isMemInstr) +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Proof.Machine +import RegFile +import Types +import qualified Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) +import qualified Prelude as P + +-- | From @invariant.txt@: everything that is neither a memory instruction nor +-- an environment instruction. +-- +-- Together with 'Proof.Driver.isMemInstr' this is what the note's four running +-- cases split on. The two are complementary apart from @ecall@ and @ebreak@, +-- which neither accepts, so requiring an instruction to satisfy one or the +-- other is exactly requiring that it not be an environment instruction -- which +-- is how the running case states it. +isArithOrJumpInstr :: Instruction -> Bool +isArithOrJumpInstr ir = + case ir of + RType {} -> True + IType (Arith _) _ _ _ -> True + IType (Load _ _) _ _ _ -> False + SType {} -> False + BType {} -> True + JType _ _ -> True + IType Jump _ _ _ -> True + UType {} -> True + IType (Env _) _ _ _ -> False + Nop _ -> True + +-- | Apply the pending effect of the writeback-stage instruction. The load case +-- reads its value off @inputMem@, matching 'Core.writeback'. +flushWbStage :: + (RegFileOps r) => + Instruction -> + Word -> + Word -> + (m, r Identity) -> + (m, r Identity) +flushWbStage ir res inputWord (mem, rf) = + case ir of + RType _ rd _ _ -> (mem, put rd res) + IType (Arith _) rd _ _ -> (mem, put rd res) + IType (Load size sign) rd _ _ -> (mem, put rd (loadExtend size sign inputWord)) + SType {} -> (mem, rf) + BType {} -> (mem, rf) + JType rd _ -> (mem, put rd res) + IType Jump rd _ _ -> (mem, put rd res) + UType _ rd _ -> (mem, put rd res) + IType (Env _) _ _ _ -> (mem, rf) + Nop _ -> (mem, rf) + where + put rd v = modifyRFg rd (pure v) rf + +-- | Apply the pending effect of the memory-stage instruction. +-- +-- The two jump cases write @rd@, matching 'flushWbStage': an instruction in the +-- memory stage this cycle is in the writeback stage the next one, so its pending +-- effect has to be counted the same way in both. +flushMeStage :: + (RegFileOps r, MemOps m) => + Instruction -> + Word -> + Address -> + (m, r Identity) -> + (m, r Identity) +flushMeStage ir res addr (mem, rf) = + case ir of + RType _ rd _ _ -> (mem, put rd res) + IType (Arith _) rd _ _ -> (mem, put rd res) + IType (Load size sign) rd _ _ -> + (mem, put rd (loadExtend size sign (memReadWord addr mem))) + SType size _ _ _ -> (memWriteWord size addr res mem, rf) + BType {} -> (mem, rf) + JType rd _ -> (mem, put rd res) + IType Jump rd _ _ -> (mem, put rd res) + UType _ rd _ -> (mem, put rd res) + IType (Env _) _ _ _ -> (mem, rf) + Nop _ -> (mem, rf) + where + put rd v = modifyRFg rd (pure v) rf + +-- | A named case of the invariant, with its conjuncts. +data Case = Case + { caseName :: String, + caseConjuncts :: [(String, Bool)] + } + +holds :: Case -> Bool +holds = P.all snd . caseConjuncts + +-- | Does any case of the invariant hold? Container form. +inv :: IsaState -> Sys -> Bool +inv isa sys = P.any holds (invCases isa sys) + +-- | The invariant in pointwise form: instead of comparing whole register files +-- and memories, compare them at one witness register @wr@ and one witness byte +-- address @wa@. Quantifying over the witnesses recovers the container form. +-- +-- This is the version symbolic execution can use: function-backed containers +-- have no decidable equality, but they can be read at a symbolic point. +invAt :: (RegFileOps r, MemOps m) => RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +invAt wr wa isa sys = P.any holds (invCasesAt wr wa isa sys) + +-- | Human-readable account of why the invariant failed: for each case, the +-- conjuncts that were false. +explain :: IsaState -> Sys -> String +explain isa sys = + unlines + [ " case " P.++ caseName c P.++ ": failed " P.++ show (P.map fst (P.filter (P.not . snd) (caseConjuncts c))) + | c <- invCases isa sys + ] + +-- | Container-level cases: compare register files and memories directly. +invCases :: IsaState -> Sys -> [Case] +invCases = invCasesGen (==) (==) + +-- | The cases at one witness register and one witness byte address. +invCasesAt :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> [Case] +invCasesAt wr wa = + invCasesGen + (\a b -> runIdentity (lookupRFg wr a) == runIdentity (lookupRFg wr b)) + (\a b -> memReadByte wa a == memReadByte wa b) + +-- | The cases of the invariant, parameterised over how register files and +-- memories are compared. +-- +-- The one deviation from @invariant.txt@ is a silence: the note opens every +-- case with @stateCtrl == initCtrl@, and no case here has it. That clause dates from an +-- earlier 'Core' which reset the control lines at the end of each clock cycle, +-- leaving them at their reset values by the time the next cycle began. +-- 'Core.withCtrlReset' now resets them at the /start/ of the cycle and the +-- stages then set them, so the lines observed in any post-step state are the +-- ones the stages left -- 'Core.execute' alone always sets @ctrlExInstr@ to +-- 'Just'. Only 'Core.init' still satisfies the clause, so keeping it would make +-- the invariant hold of no state the driver lands on and every obligation +-- vacuous. Dropping it is sound because the lines carry no information between +-- cycles: 'Core.withCtrlReset' overwrites them before any stage reads them. +invCasesGen :: + (RegFileOps r, MemOps m) => + (r Identity -> r Identity -> Bool) -> + (m -> m -> Bool) -> + IsaStateG r m -> + SysG r m -> + [Case] +invCasesGen eqRF eqMem (IsaState ipc irf imem) sys@(Sys st inp mem) = + [ runningCase, + Case + "startup" + [ ("running", running sys), + ("wb == Nop FirstCycle", stateWbInstr st == Nop FirstCycle), + ("me == Nop FirstCycle", stateMeInstr st == Nop FirstCycle), + ("ex == Nop FirstCycle", stateExInstr st == Nop FirstCycle), + ("not inputIsInstr", P.not (inputIsInstr inp)), + ("fePc == isaPc", stateFePc st == ipc), + ("isaRegFile == stateRegFile", eqRF irf (stateRegFile st)), + ("isaMem == stateMem", eqMem imem mem) + ], + haltedCase "halted/ebreak" isBreak (EBreak (ipc + 4)), + haltedCase "halted/ecall" isCall (Core.Syscall (ipc + 4)) + ] + where + inputWord = runIdentity (inputMem inp) + + -- Bound once: under symbolic execution a repeated 'decode'' is not shared, + -- and it is a large decision tree. + isaInstr = decode' (memReadWord ipc imem) + + dePcWord = memReadWord (stateDePc st) mem + + -- The note's four running cases, collapsed. + -- + -- They split on @(isArithOrJumpInstr, isMemInstr)@ for the writeback and + -- memory stages, but the only conjuncts that vary across the four -- the + -- fetch triple -- vary with the writeback stage alone: when a memory + -- instruction is in writeback it held the bus last cycle, so nothing was + -- fetched. The memory stage's classification changes no conjunct; its sole + -- effect is to demand the stage hold something the two predicates cover, + -- which is everything but @ecall@ and @ebreak@. Both stages are therefore + -- stated directly as \"not an environment instruction\". + runningCase = + Case "running" $ + [ ("running", running sys), + ("wb is not an env instruction", P.not (isEnvInstr (stateWbInstr st))), + ("me is not an env instruction", P.not (isEnvInstr (stateMeInstr st))), + ("exPc == isaPc", stateExPc st == ipc), + ("ex == decode (mem[isaPc])", stateExInstr st == isaInstr), + ("dePc == exPc + 4", stateDePc st == stateExPc st + 4), + ("no load-use hazard me->ex", P.not (loadHazard (stateExInstr st) (stateMeInstr st))), + ( "(isaMem, isaRegFile) == flush", + let (fm, frf) = + flushMeStage + (stateMeInstr st) + (runIdentity (stateMeRes st)) + (stateMeAddr st) + (flushWbStage (stateWbInstr st) (runIdentity (stateWbRes st)) inputWord (mem, stateRegFile st)) + in eqMem imem fm && eqRF irf frf + ) + ] + P.++ if isMemInstr (stateWbInstr st) + then + [ ("not inputIsInstr", P.not (inputIsInstr inp)), + ("fePc == exPc + 4", stateFePc st == stateExPc st + 4) + ] + else + [ ("inputIsInstr", inputIsInstr inp), + ("inputMem == mem[dePc]", inputWord == dePcWord), + ("fePc == exPc + 8", stateFePc st == stateExPc st + 8) + ] + + -- The halt carries the address the core would resume at, which 'Core.execute' + -- set from the trapping instruction's own PC. Pinning it to @isaPc + 4@ is + -- what fixes @isaPc@ as that instruction's address; "ISA" leaves + -- the architectural state where it was, so the ISA is still \"at\" the trap. + haltedCase name isKind expected = + Case + name + [ ("isa instruction is of this kind", isKind isaInstr), + ("halt state matches", stateHalt st == Just expected), + ("wb == Nop Halted", stateWbInstr st == Nop Halted), + ("me == Nop Halted", stateMeInstr st == Nop Halted), + ("ex == Nop Halted", stateExInstr st == Nop Halted), + ("isaRegFile == stateRegFile", eqRF irf (stateRegFile st)), + ("isaMem == stateMem", eqMem imem mem) + ] + +-- The fold-free form ---------------------------------------------------------- + +-- | The invariant, pointwise, built from '&&' and '||' with no lists and no +-- folds. Semantically identical to @'P.any' holds ('invCasesAt' wr wa)@; see +-- the module header for why both exist. +invAtFree :: + (RegFileOps r, MemOps m) => + RegIdx -> + Address -> + IsaStateG r m -> + SysG r m -> + Bool +invAtFree wr wa isa sys = + runningCaseAt wr wa isa sys + || startupCaseAt wr wa isa sys + || haltedCaseAt HaltBreak wr wa isa sys + || haltedCaseAt HaltCall wr wa isa sys + +-- | Which of the two halted cases: @ebreak@ or @ecall@. +data HaltKind = HaltBreak | HaltCall + +-- | The running case. +runningCaseAt :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +runningCaseAt wr wa (IsaState ipc irf imem) sys@(Sys st inp mem) = + running sys + && not (isEnvInstr (stateWbInstr st)) + && not (isEnvInstr (stateMeInstr st)) + && stateExPc st == ipc + && stateExInstr st == decode' (memReadWord ipc imem) + && stateDePc st == stateExPc st + 4 + && not (loadHazard (stateExInstr st) (stateMeInstr st)) + && ( if isMemInstr (stateWbInstr st) + then not (inputIsInstr inp) && stateFePc st == stateExPc st + 4 + else + inputIsInstr inp + && runIdentity (inputMem inp) == memReadWord (stateDePc st) mem + && stateFePc st == stateExPc st + 8 + ) + && memReadByte wa imem == flushMemByteAt wa sys + && runIdentity (lookupRFg wr irf) == flushRfWordAt wr sys + +-- | The startup case. +startupCaseAt :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +startupCaseAt wr wa (IsaState ipc irf imem) sys@(Sys st inp mem) = + running sys + && stateWbInstr st == Nop FirstCycle + && stateMeInstr st == Nop FirstCycle + && stateExInstr st == Nop FirstCycle + && not (inputIsInstr inp) + && stateFePc st == ipc + && runIdentity (lookupRFg wr irf) == runIdentity (lookupRFg wr (stateRegFile st)) + && memReadByte wa imem == memReadByte wa mem + +-- | One halted case. +haltedCaseAt :: + (RegFileOps r, MemOps m) => + HaltKind -> RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +haltedCaseAt kind wr wa (IsaState ipc irf imem) (Sys st _ mem) = + isKind (decode' (memReadWord ipc imem)) + && stateHalt st == Just expected + && stateWbInstr st == Nop Halted + && stateMeInstr st == Nop Halted + && stateExInstr st == Nop Halted + && memReadByte wa imem == memReadByte wa mem + && runIdentity (lookupRFg wr irf) == runIdentity (lookupRFg wr (stateRegFile st)) + where + isKind = case kind of + HaltBreak -> isBreak + HaltCall -> isCall + expected = case kind of + HaltBreak -> EBreak (ipc + 4) + HaltCall -> Core.Syscall (ipc + 4) + +-- | Read one byte from the memory produced by the invariant's pipeline flush, +-- without constructing that whole memory first. +-- +-- 'flushWbStage' never changes memory; 'flushMeStage' changes it only for a +-- store, by writing up to four consecutive bytes. So this mux is exactly +-- @memReadByte wa@ of the flushed memory, but it sends the solver a pointwise +-- read-over-write formula instead of a @select@ over a nested @store@ chain. +flushMemByteAt :: (MemOps m) => Address -> SysG r m -> Byte +flushMemByteAt wa (Sys st _ mem) = + case stateMeInstr st of + SType size _ _ _ -> + let a = stateMeAddr st + w = runIdentity (stateMeRes st) + b0 = slice d7 d0 w + b1 = slice d15 d8 w + b2 = slice d23 d16 w + b3 = slice d31 d24 w + old = memReadByte wa mem + in case size of + Types.Byte -> + if wa == a then b0 else old + Types.Half -> + if wa == a + then b0 + else if wa == a + 1 then b1 else old + Types.Word -> + if wa == a + then b0 + else + if wa == a + 1 + then b1 + else + if wa == a + 2 + then b2 + else if wa == a + 3 then b3 else old + _ -> memReadByte wa mem + +-- | Read one register from the register file produced by the invariant's +-- pipeline flush, without constructing the two nested updates first. +-- +-- Writeback is applied before memory, so a memory-stage write to the witness +-- register wins. Register zero is immutable. +flushRfWordAt :: + (RegFileOps r, MemOps m) => + RegIdx -> SysG r m -> Word +flushRfWordAt wr (Sys st inp mem) + | wr == 0 = 0 + | otherwise = applyMe (applyWb old) + where + old = runIdentity (lookupRFg wr (stateRegFile st)) + inputWord = runIdentity (inputMem inp) + + put rd value prior = if wr == rd then value else prior + + applyWb prior = + case stateWbInstr st of + RType _ rd _ _ -> put rd (runIdentity (stateWbRes st)) prior + IType (Arith _) rd _ _ -> put rd (runIdentity (stateWbRes st)) prior + IType (Load size sign) rd _ _ -> + put rd (loadExtend size sign inputWord) prior + JType rd _ -> put rd (runIdentity (stateWbRes st)) prior + IType Jump rd _ _ -> put rd (runIdentity (stateWbRes st)) prior + UType _ rd _ -> put rd (runIdentity (stateWbRes st)) prior + _ -> prior + + applyMe prior = + case stateMeInstr st of + RType _ rd _ _ -> put rd (runIdentity (stateMeRes st)) prior + IType (Arith _) rd _ _ -> put rd (runIdentity (stateMeRes st)) prior + IType (Load size sign) rd _ _ -> + put + rd + (loadExtend size sign (memReadWord (stateMeAddr st) mem)) + prior + JType rd _ -> put rd (runIdentity (stateMeRes st)) prior + IType Jump rd _ _ -> put rd (runIdentity (stateMeRes st)) prior + UType _ rd _ -> put rd (runIdentity (stateMeRes st)) prior + _ -> prior diff --git a/proof/Proof/Functional/Obligation.hs b/proof/Proof/Functional/Obligation.hs new file mode 100644 index 0000000..98ad04c --- /dev/null +++ b/proof/Proof/Functional/Obligation.hs @@ -0,0 +1,187 @@ +-- | The proof obligations, in one place. +-- +-- Both the symbolic properties ("Proof.Functional.Induction") and the QuickCheck harness +-- ("ProofSpec") go through these definitions, so the two cannot drift apart. +-- The only thing they are allowed to differ in is how the system state is +-- built: symbolic scalars on one side, a generator on the other. That is the +-- input space, not the property. +module Proof.Functional.Obligation + ( isaOfG, + isaOfHop, + isStartupShape, + indStepObligation, + indStepObligation1, + indStepObligation2, + indStepObligation3, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import qualified Core +import Data.Functor.Identity +import Proof.Driver (driver) +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Instruction +import Proof.Functional.Invariant +import Memory.Types (MemOps (..)) +import Proof.Machine +import RegFile +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The architectural state the invariant claims @sys@ corresponds to. +-- +-- Derived from @sys@ by the flush rather than taken as a further input: the +-- invariant's container equalities then hold by construction, so assuming the +-- invariant at one witness reduces to assuming its scalar conjuncts -- which is +-- the full container invariant, not a weakening of it. +isaOfG :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m +isaOfG (Sys st inp mem) = + IsaState {isaPc = Core.stateExPc st, isaRegFile = frf, isaMem = fm} + where + (fm, frf) = + flushMeStage + (Core.stateMeInstr st) + (runIdentity (Core.stateMeRes st)) + (Core.stateMeAddr st) + ( flushWbStage + (Core.stateWbInstr st) + (runIdentity (Core.stateWbRes st)) + (runIdentity (Core.inputMem inp)) + (mem, Core.stateRegFile st) + ) + +-- | Does the pipeline have the shape the invariant's startup case describes? +-- +-- The distinction matters from @k = 1@ onwards: a startup hop brings the first +-- instruction into the execute stage without executing anything, so the +-- architectural state does not advance across it. Every other hop retires one +-- instruction. +isStartupShape :: SysG r m -> Bool +isStartupShape (Sys st inp _) = + Core.stateWbInstr st == Nop FirstCycle + && Core.stateMeInstr st == Nop FirstCycle + && Core.stateExInstr st == Nop FirstCycle + && not (Core.inputIsInstr inp) + +-- | The architectural state for a hop, startup included. +-- +-- 'isaOfG' reads the architectural PC off the /execute/ stage, which is right +-- for a running state. A startup state has nothing in the pipe yet, and the +-- invariant's startup case correspondingly pins @isaPc@ to the /fetch/ stage; +-- deriving it from @exPc@ there would produce an architectural state that no +-- case of the invariant admits, and the obligation would hold vacuously on +-- every startup state instead of saying anything about it. +-- +-- The register file and memory need no special case: on a startup-shaped state +-- both flushes are the identity, since every stage holds @Nop FirstCycle@. +isaOfHop :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m +isaOfHop sys + | isStartupShape sys = (isaOfG sys) {isaPc = Core.stateFePc (sysState sys)} + | otherwise = isaOfG sys + +-- | The @k = 0@ inductive step: the driver's one-cycle hop. +-- +-- > inv(a, c) /\ driver(c) = 0 ==> inv(isaStep(a), stepSys(c)) +-- +-- There is no side condition about aliasing stores: 'Core.decode' detects a +-- store overlapping the instruction word being decoded and stalls, so a store +-- that rewrites an instruction in flight is handled by the core rather than +-- assumed away here. +-- +-- @driver == 0@ excludes environment instructions, so the ISA cannot halt on +-- this hop and the @IsaHalted@ branch is vacuous. Startup states all have +-- @driver == 1@, so 'isaOfG' (rather than 'isaOfHop') is exact here. +indStepObligation :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStepObligation wr wa sys = + not premises || conclusion + where + isa = isaOfG sys + sys' = stepSys sys + + premises = + invAtFree wr wa isa sys + && driver sys == 0 + + conclusion = + case isaStep isa of + Next isa' -> invAtFree wr wa isa' sys' + IsaHalted -> True + +-- | The @k = 1@ inductive step: the driver's two-cycle hop. +-- +-- One thing differs from @k = 0@ beyond the extra cycle: a startup hop does not +-- retire an instruction, so the architectural state is carried across unchanged. +indStepObligation1 :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStepObligation1 wr wa sys = + not premises || conclusion + where + isa = isaOfHop sys + s1 = stepSys sys + s2 = stepSys s1 + + premises = + invAtFree wr wa isa sys + && driver sys == 1 + + conclusion + | isStartupShape sys = invAtFree wr wa isa s2 + | otherwise = + case isaStep isa of + Next isa' -> invAtFree wr wa isa' s2 + -- driver == 1 excludes environment instructions (they route to a + -- three-cycle hop), so the ISA cannot halt here either. + IsaHalted -> True + +-- | The @k = 2@ inductive step: the driver's three-cycle hop. +-- +-- Unlike the shorter hops, this one can execute an environment instruction. +-- The architectural state then stays at the trapping instruction while the +-- core reaches one of the two halted invariant cases. +indStepObligation2 :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStepObligation2 wr wa sys = + not premises || conclusion + where + isa = isaOfG sys + s1 = stepSys sys + s2 = stepSys s1 + s3 = stepSys s2 + + premises = + invAtFree wr wa isa sys + && driver sys == 2 + + conclusion = + case isaStep isa of + Next isa' -> invAtFree wr wa isa' s3 + IsaHalted -> invAtFree wr wa isa s3 + +-- | The @k = 3@ inductive step: the driver's four-cycle hop, the longest. +-- +-- Stated exactly as 'indStepObligation2', one cycle longer. The @IsaHalted@ +-- alternative is kept even though this hop should not be able to trap -- the +-- driver routes environment instructions to a three-cycle hop -- because +-- covering it costs nothing and assuming it away would be an unchecked side +-- argument. +indStepObligation3 :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStepObligation3 wr wa sys = + not premises || conclusion + where + isa = isaOfG sys + s1 = stepSys sys + s2 = stepSys s1 + s3 = stepSys s2 + s4 = stepSys s3 + + premises = + invAtFree wr wa isa sys + && driver sys == 3 + + conclusion = + case isaStep isa of + Next isa' -> invAtFree wr wa isa' s4 + IsaHalted -> invAtFree wr wa isa s4 diff --git a/proof/Proof/Leakage/Induction.hs-disabled b/proof/Proof/Leakage/Induction.hs-disabled new file mode 100644 index 0000000..3d427b9 --- /dev/null +++ b/proof/Proof/Leakage/Induction.hs-disabled @@ -0,0 +1,162 @@ +-- | The leakage refinement, checked symbolically. +-- +-- One property per driver delay: on a hop of that length, +-- 'Proof.Leakage.Obligation.leakObligation' holds. Split by @k@ because the +-- number of unrolled cycles has to be concrete -- Pantomime cannot recurse on a +-- symbolic count -- and each property pins @driver == k@ so it carries one +-- unrolling rather than four. +-- +-- These four plus 'Proof.Functional.Induction.baseCase' are the leakage +-- theorem: the functional half establishes that the invariant holds wherever +-- the driver lands, which is what each property here assumes. +-- +-- == Running them +-- +-- Under Bitwuzla, not Z3: +-- +-- > SBV_Z3=/opt/homebrew/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build +-- +-- Z3 does not finish these in useful time; under Bitwuzla each solve is seconds +-- and symbolisation dominates. The whole module is well under an hour. +-- +-- Each query runs the pipeline twice over -- once on the real state, once on +-- the censored one -- and compares two states plus two observation traces, so +-- they are larger than the corresponding 'Proof.Functional.Induction' ones. +-- They are stated in the form the QuickCheck harness (@test/LeakageSpec.hs@) +-- checks, so a counterexample to one is a counterexample to the other; when a +-- query comes back @sat@, splitting the premise or the conclusion localises it +-- faster than decoding the model (see @proof/notes/leakage.txt@). +module Proof.Leakage.Induction + ( leakStep0, + leakStep1, + leakStep2, + leakStep3, + leakStep3a, + leakStep3b, + results, + ) +where + +import Proof.SMT.Array +import Proof.SMT.Axioms (arrayAxioms) +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import qualified Core +import Data.Functor.Identity +import Proof.Driver (driver, loadHazardD) +import Instruction +import Proof.Leakage.Obligation (leakObligation) +import Proof.SMT.Logged (pantomime) +import Proof.Machine +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import RegFile (RegFileOps) +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The pipeline registers, as plain scalars. +-- +-- An ADT of scalars can be a fresh symbolic argument; a record containing a +-- function cannot, and the Clash @Vec@ API is opaque to the plugin. Same shape +-- and same reason as 'Proof.Functional.Induction'\'s. +data KState = KState + { kFePc :: Address, + kDePc :: Address, + kExPc :: Address, + kExIr :: Instruction, + kMeIr :: Instruction, + kMeRes :: Word, + kMeAddr :: Address, + kWbIr :: Instruction, + kWbRes :: Word, + kCtrl :: Core.Control Identity, + kHalt :: Maybe Core.HaltState, + kHaltNextPc :: Address + } + +sysOf :: KState -> Core.Input Identity -> RegArr -> MemArr -> SysG RegArrF MemArr +sysOf ss i ra ma = + Sys + { sysState = + Core.State + { Core.stateFePc = kFePc ss, + Core.stateDePc = kDePc ss, + Core.stateExPc = kExPc ss, + Core.stateExInstr = kExIr ss, + Core.stateMeInstr = kMeIr ss, + Core.stateMeRes = Identity (kMeRes ss), + Core.stateMeAddr = kMeAddr ss, + Core.stateWbInstr = kWbIr ss, + Core.stateWbRes = Identity (kWbRes ss), + Core.stateRegFile = RegArrF ra, + Core.stateCtrl = kCtrl ss, + Core.stateHalt = kHalt ss, + Core.stateHaltNextPc = kHaltNextPc ss + }, + sysInput = i, + sysMem = ma + } + +-- | 'Proof.Leakage.Obligation.leakObligation', restricted to hops of length +-- @k + 1@. +leakAt :: + (RegFileOps r, MemOps m) => + Int -> RegIdx -> Address -> SysG r m -> Bool +leakAt k wr wa sys = driver sys /= k || leakObligation wr wa sys + +-- | @k = 0@: the one-cycle hop. +{-# ANN leakStep0 (Theory arrayAxioms) #-} +leakStep0 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep0 ss i ra ma wr wa = + Pantomime.boolean $ leakAt 0 wr wa (sysOf ss i ra ma) + +-- | @k = 1@: the two-cycle hop (startup, or a memory instruction in writeback). +{-# ANN leakStep1 (Theory arrayAxioms) #-} +leakStep1 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep1 ss i ra ma wr wa = + Pantomime.boolean $ leakAt 1 wr wa (sysOf ss i ra ma) + +-- | @k = 2@: the three-cycle hop -- an environment instruction, a taken jump, +-- or a store hazard. The store-hazard route was unreachable while the aliasing +-- assumption stood; it is live now. +{-# ANN leakStep2 (Theory arrayAxioms) #-} +leakStep2 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep2 ss i ra ma wr wa = + Pantomime.boolean $ leakAt 2 wr wa (sysOf ss i ra ma) + +-- | @k = 3@: the four-cycle hop -- a load-use hazard, or memory instructions in +-- all three older stages. +{-# ANN leakStep3 (Theory arrayAxioms) #-} +leakStep3 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep3 ss i ra ma wr wa = + Pantomime.boolean $ leakAt 3 wr wa (sysOf ss i ra ma) + +-- | @k = 3@ restricted to the load-use-hazard route. +-- +-- Kept, with its annotation off, as a worked example of localising a @sat@ +-- result: splitting @leakStep3@ on 'Proof.Driver.loadHazardD' says which of the +-- two shapes that reach a four-cycle hop is at fault, which is quicker than +-- decoding an array-valued model. +-- {-# ANN leakStep3a (Theory arrayAxioms) #-} +leakStep3a :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep3a ss i ra ma wr wa = + Pantomime.boolean $ + let sys = sysOf ss i ra ma + in not (loadHazardD sys) || leakAt 3 wr wa sys + +-- | @k = 3@ restricted to the steady all-memory route. +-- {-# ANN leakStep3b (Theory arrayAxioms) #-} +leakStep3b :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool +leakStep3b ss i ra ma wr wa = + Pantomime.boolean $ + let sys = sysOf ss i ra ma + in loadHazardD sys || leakAt 3 wr wa sys + +-- | Verdicts, spliced in by the plugin at compile time: 'Nothing' when the +-- property is valid, @'Just' counterexample@ when it is not. +results :: [(String, Maybe String)] +results = + [ ("leakStep0", $(pantomime 'leakStep0)), + ("leakStep1", $(pantomime 'leakStep1)), + ("leakStep2", $(pantomime 'leakStep2)), + ("leakStep3", $(pantomime 'leakStep3)) + ] diff --git a/proof/Proof/Leakage/Model.hs b/proof/Proof/Leakage/Model.hs new file mode 100644 index 0000000..6e6f009 --- /dev/null +++ b/proof/Proof/Leakage/Model.hs @@ -0,0 +1,258 @@ +-- | What the core leaks, what an attacker sees, and how to invert one into the +-- other. +-- +-- The leakage proof ("Proof.Leakage.Obligation") establishes that an attacker +-- watching the memory bus learns nothing beyond 'L'. This module defines the +-- three functions that statement is about: +-- +-- * 'obsOf' -- what the attacker sees in one cycle. +-- * 'leakOf' -- what one architectural instruction leaks. A function of the +-- ISA state alone; the pipeline does not appear in it. +-- * 'inv' -- a representative instruction with the same leakage as the real +-- one. The simulator runs the unmodified core on these, so anything 'inv' +-- cannot express is something the proof cannot cover. +module Proof.Leakage.Model + ( -- * Observation + Obs (..), + HopObs (..), + obsOf, + + -- * Leakage + Class (..), + L (..), + leakOf, + mkDeps, + isaClass, + coreClass, + + -- * Inversion + inv, + invWord, + jumpSource, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Data.Functor.Identity +import Data.Maybe (fromMaybe) +import Data.Monoid (getFirst) +import Instruction +import qualified Instruction as I +import Proof.Driver (exArg) +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Memory.Types (MemOps (..)) +import Proof.Machine +import RegFile +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- Observation ----------------------------------------------------------------- + +-- | What the attacker sees on the memory bus in one cycle. +-- +-- An instruction fetch shows its address -- this is the program-counter trace. +-- A data access shows only its kind and width: neither the address nor the +-- value. +-- +-- Data addresses are excluded because the simulator could not reproduce them. +-- A load or store computes its address as @register + immediate@, and 'inv' +-- emits instructions that read a censored register file; a jump target escapes +-- that limit only because 'jumpSource' parks it in a register first, which +-- works for at most one instruction per hop. +data Obs + = NoAccess + | Fetch Address + | DataRead Size + | DataWrite Size + deriving (Eq, Show, Generic, NFDataX) + +-- | The observations of one driver hop, one slot per cycle. +-- +-- A hop is one to four cycles. Four slots rather than a list because Pantomime +-- cannot execute folds; 'Nothing' means the hop was not that long, so hops of +-- different lengths compare unequal. +data HopObs = HopObs (Maybe Obs) (Maybe Obs) (Maybe Obs) (Maybe Obs) + deriving (Eq, Show, Generic, NFDataX) + +-- | The observation a cycle's 'Core.Output' produces. +obsOf :: Output Identity -> Obs +obsOf o = case getFirst (outMem o) of + Nothing -> NoAccess + Just (MemAccess True addr _ _) -> Fetch addr + Just (MemAccess False _ size Nothing) -> DataRead size + Just (MemAccess False _ size (Just _)) -> DataWrite size + +-- Leakage --------------------------------------------------------------------- + +-- | The class of one architectural instruction: what the attacker learns about +-- it beyond its own existence. +-- +-- Each constructor carries what the simulator needs and no more: +-- +-- * 'CBranchTaken' and 'CJal' carry the instruction's own immediate, a field +-- of the instruction word rather than a function of register contents. +-- 'CBranchNotTaken' carries nothing, since an untaken branch's target is +-- not observable. +-- * 'CJalr' carries a computed address. This one is genuinely data +-- dependent -- it is the leak. +-- * 'CLoad' carries its destination register, because a load-use hazard +-- against the next instruction depends on it and that decides how many +-- cycles the next hop takes. It carries no address. +-- * Sizes are carried because 'Obs' shows the access width. +data Class + = CPlain + | CBranchTaken BImm + | CBranchNotTaken + | CJal JImm + | CJalr Address + | CLoad Size RegIdx + | CStore Size + | CCall + | CBreak + deriving (Eq, Show, Generic, NFDataX) + +-- | An instruction's class together with the source registers it may depend on. +-- +-- The dependencies are leaked for every instruction, not only those that use +-- them: 'Core.decode' compares them against the destination register of a load +-- in the execute stage, and that comparison decides the hop length. +data L = L + { lClass :: Class, + lDeps :: (Maybe RegIdx, Maybe RegIdx) + } + deriving (Eq, Show, Generic, NFDataX) + +-- | An instruction's source registers, with @x0@ dropped -- reading @x0@ can +-- never be a hazard. Matches the filter in 'Instruction.loadHazard', which is +-- the consumer that matters. +-- +-- Note this reads the registers through 'Instruction.getRs1' and +-- 'Instruction.getRs2', which do not always answer with the encoded fields: +-- @ecall@ reports @x17@ whatever is encoded, and a @Nop@ reports @x0@. +mkDeps :: Instruction -> (Maybe RegIdx, Maybe RegIdx) +mkDeps ir = (noZero (getRs1 ir), noZero (getRs2 ir)) + where + noZero (Just 0) = Nothing + noZero r = r + +-- | The leakage of the instruction an architectural state is about to process. +leakOf :: (RegFileOps r, MemOps m) => IsaStateG r m -> L +leakOf isa = L (isaClass isa ir) (mkDeps ir) + where + ir = isaInstrAt isa + +-- | Classify an instruction against the architectural state it runs in. +-- +-- Three decisions are data dependent -- whether a branch is taken, and the two +-- computed jump targets -- and are resolved here against the architectural +-- register file. 'coreClass' resolves the same three against forwarded pipeline +-- values, and the proof shows they agree. +isaClass :: (RegFileOps r, MemOps m) => IsaStateG r m -> Instruction -> Class +isaClass (IsaState _ rf _) ir = case ir of + BType cmp imm rs1 rs2 -> + if runIdentity (branch cmp (pure (regv rs1)) (pure (regv rs2))) + then CBranchTaken imm + else CBranchNotTaken + JType _ imm -> CJal imm + IType Jump _ rs1 imm -> CJalr (unpack (regv rs1 + signExtend imm)) + IType (Load size _) rd _ _ -> CLoad size rd + SType size _ _ _ -> CStore size + IType (Env Call) _ _ _ -> CCall + IType (Env Break) _ _ _ -> CBreak + _ -> CPlain + where + regv i = runIdentity (lookupRFg i rf) + +-- | Classify the execute-stage instruction against a core state. +-- +-- The mirror of 'isaClass'. Operands are read through 'Proof.Driver.exArg', +-- which reproduces the forwarding priority 'Core.execute' uses. +coreClass :: (RegFileOps r) => SysG r m -> Instruction -> Class +coreClass sys ir = case ir of + BType cmp imm rs1 rs2 -> + if runIdentity (branch cmp (pure (exArg sys rs1)) (pure (exArg sys rs2))) + then CBranchTaken imm + else CBranchNotTaken + JType _ imm -> CJal imm + IType Jump _ rs1 imm -> CJalr (unpack (exArg sys rs1 + signExtend imm)) + IType (Load size _) rd _ _ -> CLoad size rd + SType size _ _ _ -> CStore size + IType (Env Call) _ _ _ -> CCall + IType (Env Break) _ _ _ -> CBreak + _ -> CPlain + +-- Inversion ------------------------------------------------------------------- + +-- | A representative instruction with the same leakage as the real one. +-- +-- The simulator's register file holds zero everywhere except the one slot +-- 'jumpSource' reserves, so every instruction here is chosen to behave +-- independently of register contents: +-- +-- * @'CBranchTaken' imm@ becomes @beq d1, d2, imm@. Both operands read zero, +-- so it is always taken, and the original immediate takes it to the +-- original target. @'CBranchNotTaken'@ becomes @bne d1, d2, 0@, never taken +-- for the same reason. +-- * @'CJal'@ keeps its immediate, which is PC-relative and needs no register. +-- * @'CJalr'@ addresses @0(src)@ and reads its target out of @src@; see +-- 'jumpSource'. When the real @jalr@ read @x0@ there is no register to use, +-- but then the target is @0 + signExtend imm@ and fits the immediate +-- exactly. +-- * @'CLoad'@ and @'CStore'@ address @0(rs1)@, i.e. address zero. The address +-- is not observable; the width and the fact that it is a memory instruction +-- are, and both survive. +-- +-- Destination registers are @x0@ except for a load, whose destination is +-- leaked because it drives the next hop's hazard. A load into a real register +-- writes @loadExtend size sign 0 == 0@, so the register file stays zero. +-- +-- Source registers are threaded through everywhere so that a load-use hazard +-- against this instruction fires in the simulator exactly when it fires in the +-- core. +inv :: L -> Instruction +inv (L cls (d1, d2)) = case cls of + CPlain -> RType ADD 0 (r d1) (r d2) + CBranchTaken imm -> BType EQ imm (r d1) (r d2) + CBranchNotTaken -> BType NE 0 (r d1) (r d2) + CJal imm -> JType 0 imm + CJalr t -> case d1 of + Just src | src /= 0 -> IType Jump 0 src 0 + _ -> IType Jump 0 0 (slice d11 d0 (pack t)) + CLoad size rd -> IType (Load size I.Signed) rd (r d1) 0 + CStore size -> SType size 0 (r d1) (r d2) + CCall -> IType (Env Call) 0 0 0 + -- The immediate is the opcode rather than a value: 'Instruction.decode' reads + -- @ecall@ off @immI == 0@ and @ebreak@ off @immI == 1@ and re-emits it, so a + -- zero here would not survive 'invWord'. + -- + -- Unlike @ecall@, an @ebreak@ reports its encoded @rs1@ from + -- 'Instruction.getRs1', so that field is a real dependency and has to be + -- threaded through like any other. + CBreak -> IType (Env Break) 0 (r d1) 1 + where + r = fromMaybe 0 + +-- | The word the simulator puts on the bus for 'Core.decode' to read. +-- +-- @'Instruction.decode'' . 'invWord'@ is 'inv': every instruction 'inv' emits +-- survives the round trip. +invWord :: L -> Word +invWord l = case encode' (inv l) of + Just w -> w + Nothing -> 0 + +-- | The register a leaked @jalr@ target has to be parked in, and the target. +-- +-- No RISC-V instruction word can hold a 32-bit jump target: every target the +-- core computes is @PC + immediate@ (13 bits for a branch, 21 for @jal@) or +-- @register + immediate@ (12 bits for @jalr@). The register file is therefore +-- the only place an arbitrary target fits, and @jalr@ is the one instruction +-- that reads it from there. Writing it costs nothing in leakage: the value is +-- the target, which 'L' already carries. +-- +-- 'Nothing' for everything else, including a @jalr@ off @x0@, where the target +-- fits the immediate and nothing needs parking. +jumpSource :: L -> Maybe (RegIdx, Address) +jumpSource (L (CJalr t) (Just src, _)) | src /= 0 = Just (src, t) +jumpSource _ = Nothing diff --git a/proof/Proof/Leakage/Obligation.hs b/proof/Proof/Leakage/Obligation.hs new file mode 100644 index 0000000..26ac8fd --- /dev/null +++ b/proof/Proof/Leakage/Obligation.hs @@ -0,0 +1,58 @@ +-- | The leakage theorem, as a preservation obligation. +-- +-- 'leakObligation' says that 'Proof.Leakage.Simulator.proj' commutes with one +-- driver hop: if it relates an implementation state to an architectural state +-- and a simulator state, then after the hop it relates them again, and the two +-- machines produced the same cycle-by-cycle observations. +-- +-- Together with the invariant holding at reset, that gives the leakage result: +-- an attacker watching the memory bus learns nothing that is not already in +-- 'Proof.Leakage.Model.L'. The simulator reproduces the observation from the +-- leakage alone, including the hop length -- which is the instruction timing. +-- +-- Only the simulator half of the projection is checked here. The architectural +-- half commutes by construction: 'Proof.Leakage.Simulator.archOfLeak' is +-- 'Proof.Functional.Obligation.isaOfHop' composed with +-- 'Proof.Leakage.Simulator.isaNext', and the functional obligations already +-- establish that @isaOfHop@ advances by one 'isaStep' per hop. +-- +-- == What is assumed +-- +-- Nothing beyond the invariant. A store overlapping the instruction word in +-- decode is caught by 'Core.decode' and stalled, so the aliasing-store side +-- condition the earlier proof carried is gone. +-- +-- There is deliberately no assumption on jump targets. Branch and @jal@ targets +-- are reproduced with the original immediates; a @jalr@ target is parked in a +-- register by 'Proof.Leakage.Simulator.installJump' and is exact for any 32-bit +-- address. +module Proof.Leakage.Obligation + ( leakObligation, + leakPremises, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Proof.Functional.Invariant (invAtFree) +import Proof.Functional.Obligation (isaOfHop) +import Proof.Leakage.Model +import Proof.Leakage.Simulator +import Memory.Types (MemOps (..)) +import Proof.Machine +import RegFile +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The premises of 'leakObligation': the functional invariant. +leakPremises :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +leakPremises wr wa sys = invAtFree wr wa (isaOfHop sys) sys + +-- | @proj@ commutes with a driver hop, and the observations agree. +leakObligation :: + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +leakObligation wr wa sys = + not (leakPremises wr wa sys) || (simEq wr (censor sysI) ss' && obsI == obsL) + where + (sysI, obsI) = implHop sys + ((_, ss'), obsL) = leakSimHop (proj sys) diff --git a/proof/Proof/Leakage/Simulator.hs b/proof/Proof/Leakage/Simulator.hs new file mode 100644 index 0000000..ecf3d2e --- /dev/null +++ b/proof/Proof/Leakage/Simulator.hs @@ -0,0 +1,370 @@ +-- | The simulator: a machine that sees only the leakage and still reproduces +-- everything the attacker can see. +-- +-- It is the unmodified 'Core.circuit', run on a censored state and fed +-- instruction words made up from the leakage. Per hop: +-- +-- 1. 'installLeak' puts @'Proof.Leakage.Model.invWord' l@ on the bus. +-- 2. 'Proof.Driver.driver' picks the hop length from the censored state, and +-- the core runs that many cycles, every instruction fetch answered with +-- the same word. +-- 3. 'scrub' normalises the state for the next hop. +-- +-- The hop length is /derived/, not supplied. That is the point: the number of +-- cycles an instruction takes is exactly the timing an attacker sees, so a +-- simulator that were told it would be proving nothing. +-- +-- 'proj' is the refinement relation the proof preserves. Its architectural half +-- is 'archOfLeak' and its simulator half is 'censor'. +module Proof.Leakage.Simulator + ( -- * Simulator states + SimSys, + censor, + censorEx, + censorPast, + exLeak, + installJump, + scrub, + simEq, + + -- * The refinement relation + proj, + archOfLeak, + isaNext, + + -- * The two machines + implHop, + simHop, + leakSimHop, + stepSimOut, + installLeak, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Data.Functor.Identity +import Data.Monoid (getFirst) +import Instruction +import Proof.Driver (driver) +import Proof.Functional.Obligation (isStartupShape, isaOfHop) +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Proof.Leakage.Model +import Memory.Types (MemOps (..)) +import Proof.Machine +import RegFile +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- Censoring -------------------------------------------------------------------- + +-- | The simulator's state: a core state with the secrets removed. +-- +-- The memory slot is @()@ -- the simulator has no memory, and answers +-- instruction fetches from the leakage and data reads with zero. +-- 'Proof.Driver.driver' is polymorphic in the memory type, so it runs on this +-- unchanged. +type SimSys r = SysG r () + +-- | Remove the secrets from a core state. +-- +-- Kept: the three program counters (they are the observable fetch addresses), +-- the halt state, the 'Core.inputIsInstr' flag, and the /class/ of each +-- pipeline instruction. +-- +-- Removed: the register file, both result registers, the memory-stage address, +-- and the instruction word on the bus. The control lines are reset rather than +-- copied, because 'Core.withCtrlReset' rewrites them before any stage reads +-- them and they carry nothing between cycles. +censor :: (RegFileOps r) => SysG r m -> SimSys r +censor sys@(Sys st inp _) = + installJump (jumpSource =<< exLeak sys) $ + Sys + { sysState = + State + { stateFePc = stateFePc st, + stateDePc = stateDePc st, + stateExPc = stateExPc st, + stateExInstr = censorEx sys, + stateMeInstr = censorPast (stateMeInstr st), + stateMeRes = Identity 0, + stateMeAddr = 0, + stateWbInstr = censorPast (stateWbInstr st), + stateWbRes = Identity 0, + stateRegFile = initRFg, + stateCtrl = initCtrl, + stateHalt = stateHalt st, + stateHaltNextPc = stateHaltNextPc st + }, + sysInput = Input (inputIsInstr inp) (Identity 0), + sysMem = () + } + +-- | The leakage of the execute-stage instruction, or 'Nothing' when that stage +-- holds a stall @Nop@. +-- +-- @Nop DecodeFail@ is not a stall: it is what an undecodable memory word +-- decodes to, so it is a real architectural instruction and is classified like +-- any other non-memory one. 'Proof.Machine.isBubble' draws the same line. +exLeak :: (RegFileOps r) => SysG r m -> Maybe L +exLeak sys = case exInstr sys of + Nop DecodeFail -> Just (L CPlain (Nothing, Nothing)) + Nop _ -> Nothing + ir -> Just (L (coreClass sys ir) (mkDeps ir)) + +-- | Censor the execute-stage instruction. +-- +-- This is the only stage whose instruction still has decisions to make, so it +-- is replaced by the representative of its leakage, with the class resolved +-- against the /core/ state -- forwarded operands and all. +-- +-- Stall @Nop@s pass through verbatim: 'Core.decode' reads the reason back off +-- @ctrlExInstr@ to decide the follow-on stall, so it is live here. +censorEx :: (RegFileOps r) => SysG r m -> Instruction +censorEx sys = case exLeak sys of + Nothing -> exInstr sys + Just l -> inv l + +-- | Censor a memory- or writeback-stage instruction. +-- +-- These have no decisions left. 'Core.memory' and 'Core.writeback' consult them +-- only to decide whether to issue a memory access and of what width, which +-- register to forward, and which register to write, so only the memory class +-- and width need survive. +-- +-- The destination register is dropped, unlike in 'censorEx'. No hazard check +-- reads it here -- 'Core.decode', 'Proof.Driver.loadHazardD' and the +-- invariant's @me->ex@ conjunct all look at the execute stage -- and dropping +-- it keeps a censored writeback from clobbering the value 'installJump' parks +-- in the register file. With @rd == 0@ the write is a no-op and +-- 'Core.regWithFwd' ignores the forwarding line. +-- +-- Idempotent on its own image, which is what lets 'scrub' apply it to +-- instructions the simulator produced itself. +censorPast :: Instruction -> Instruction +censorPast ir = case ir of + Nop DecodeFail -> inv (L CPlain (Nothing, Nothing)) + Nop reason -> Nop reason + IType (Load size _) _ _ _ -> inv (L (CLoad size 0) (mkDeps ir)) + SType size _ _ _ -> inv (L (CStore size) (mkDeps ir)) + _ -> inv (L CPlain (mkDeps ir)) + +-- | Park a leaked jump target in the register file, where 'Core.execute' will +-- read it back. +-- +-- The register file is what 'Core.execute' reads, because in a censored state +-- neither forwarding line can fire: 'censorPast' gives every memory- and +-- writeback-stage instruction @rd == 0@, and 'Core.regWithFwd' ignores @x0@. +-- +-- The value lives for exactly one hop -- the next 'censor' or 'scrub' rebuilds +-- the register file -- and during that hop the only register-reading +-- instruction in the execute stage is the @jalr@ that needs it. +installJump :: (RegFileOps r) => Maybe (RegIdx, Address) -> SimSys r -> SimSys r +installJump Nothing ss = ss +installJump (Just (src, target)) (Sys st inp m) = + Sys + st {stateRegFile = modifyRFg src (Identity (pack target)) (stateRegFile st)} + inp + m + +-- | Normalise the simulator's state at a hop boundary. +-- +-- Two jobs. First, discard dead state: the register file, both result +-- registers, the memory-stage address and the parked bus word. Every +-- instruction 'inv' emits reads only registers held at zero, writes either +-- @x0@ or a load result that is zero, and never lets a result value reach an +-- observation, so 'censor' can zero them on the implementation side and the +-- two still agree. +-- +-- Second, re-censor the memory- and writeback-stage instructions. 'censorEx' +-- resolves an execute-stage branch to a taken or untaken representative, and +-- the simulator carries that form down the pipeline; 'censor', looking at the +-- implementation one hop later, sees the same instruction in the memory stage +-- and cannot recover the outcome, so it uses the plain representative. Running +-- 'censorPast' on both sides reconciles them. +scrub :: (RegFileOps r) => L -> SimSys r -> SimSys r +scrub l (Sys st inp _) = + installJump parked $ + Sys + { sysState = + st + { stateMeInstr = censorPast (stateMeInstr st), + stateWbInstr = censorPast (stateWbInstr st), + stateMeRes = Identity 0, + stateWbRes = Identity 0, + stateMeAddr = 0, + stateRegFile = initRFg, + stateCtrl = initCtrl + }, + sysInput = Input (inputIsInstr inp) (Identity 0), + sysMem = () + } + where + -- The instruction that just reached the execute stage is the one this hop + -- injected, so its leakage is @l@ -- unless it was squashed or the core + -- halted, in which case that stage holds a @Nop@ and nothing is parked. + parked + | stateExInstr st == inv l = jumpSource l + | otherwise = Nothing + +-- | Structural equality on simulator states, at one witness register. +-- +-- 'SysG' has an 'Eq' instance, but it needs @'Eq' (r 'Identity')@, which the +-- SMT-array register file does not have; the register file is compared +-- pointwise instead, as 'Proof.Functional.Invariant.invAtFree' does. Quantifying +-- over the witness recovers full equality. +-- +-- The control lines are not compared: 'Core.withCtrlReset' resets them at the +-- start of every cycle, so they carry nothing between hops. +simEq :: (RegFileOps r) => RegIdx -> SimSys r -> SimSys r -> Bool +simEq wr (Sys a ia _) (Sys b ib _) = + stateFePc a == stateFePc b + && stateDePc a == stateDePc b + && stateExPc a == stateExPc b + && stateExInstr a == stateExInstr b + && stateMeInstr a == stateMeInstr b + && stateMeAddr a == stateMeAddr b + && stateWbInstr a == stateWbInstr b + && runIdentity (stateMeRes a) == runIdentity (stateMeRes b) + && runIdentity (stateWbRes a) == runIdentity (stateWbRes b) + && stateHalt a == stateHalt b + && stateHaltNextPc a == stateHaltNextPc b + && inputIsInstr ia == inputIsInstr ib + && runIdentity (lookupRFg wr (stateRegFile a)) == runIdentity (lookupRFg wr (stateRegFile b)) + && runIdentity (inputMem ia) == runIdentity (inputMem ib) + +-- The refinement relation ------------------------------------------------------ + +-- | 'isaStep' made total: a halted ISA stands still. +isaNext :: (RegFileOps r, MemOps m) => IsaStateG r m -> IsaStateG r m +isaNext a = case isaStep a of + Next a' -> a' + IsaHalted -> a + +-- | The architectural state a core state corresponds to, for the leakage proof. +-- +-- Fetch-aligned: the instruction at its PC is the one the pipeline is /taking +-- in/, not the one in the execute stage. 'Proof.Functional.Obligation.isaOfHop' +-- is execute-aligned, one instruction behind, so a single +-- 'isaStep' converts between them. +-- +-- The alignment is forced. The simulator's only channel into the core is the +-- instruction word on the bus, and the invariant pins that word to +-- @mem[dePc] == mem[isaPc + 4]@ -- the instruction after the one in execute. So +-- the leakage a hop consumes must describe that one. +-- +-- At reset nothing is in flight and the PC comes off the fetch stage, exactly as +-- 'Proof.Functional.Obligation.isaOfHop' already does there. +archOfLeak :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m +archOfLeak sys + | isStartupShape sys = isaOfHop sys + | otherwise = isaNext (isaOfHop sys) + +-- | The refinement relation: an architectural state paired with a censored core. +proj :: (RegFileOps r, MemOps m) => SysG r m -> (IsaStateG r m, SimSys r) +proj sys = (archOfLeak sys, censor sys) + +-- The two machines ------------------------------------------------------------- + +-- | One simulator cycle. +-- +-- The shape of 'Proof.Machine.stepSysOut', except that there is no memory to +-- service: an instruction fetch is answered with the leaked word, a data read +-- with zero, and a write with zero exactly as 'Proof.Machine.stepSys' does. +stepSimOut :: (RegFileOps r) => Word -> SimSys r -> (SimSys r, Output Identity) +stepSimOut w (Sys s i _) = + let (s', o) = Core.circuit s i + i' = case getFirst (outMem o) of + Just (MemAccess isInstr _ _ Nothing) -> + Input isInstr (Identity (if isInstr then w else 0)) + Just (MemAccess isInstr _ _ (Just _)) -> Input isInstr (Identity 0) + Nothing -> Input False (Identity 0) + in (Sys s' i' (), o) + +-- | Put the leaked instruction word on the simulator's bus. +-- +-- Only onto an instruction fetch. When 'Core.inputIsInstr' is 'False' the bus +-- carries the data for a load in the writeback stage, and 'Core.writeback' +-- would sign-extend the instruction word into a register. The censored value +-- there is zero and stays zero; the leaked word reaches 'Core.decode' one cycle +-- later through 'stepSimOut'. +installLeak :: Word -> SimSys r -> SimSys r +installLeak word (Sys s i m) + | inputIsInstr i = Sys s (Input True (Identity word)) m + | otherwise = Sys s i m + +-- | The implementation, run for one driver hop, with the observation of each +-- cycle. +-- +-- A four-way case rather than a loop: @driver sys@ is symbolic and Pantomime +-- cannot unroll a symbolic count. +implHop :: (RegFileOps r, MemOps m) => SysG r m -> (SysG r m, HopObs) +implHop sys = case driver sys of + 0 -> + let (s1, o1) = stepSysOut sys + in (s1, HopObs (Just (obsOf o1)) Nothing Nothing Nothing) + 1 -> + let (s1, o1) = stepSysOut sys + (s2, o2) = stepSysOut s1 + in (s2, HopObs (Just (obsOf o1)) (Just (obsOf o2)) Nothing Nothing) + 2 -> + let (s1, o1) = stepSysOut sys + (s2, o2) = stepSysOut s1 + (s3, o3) = stepSysOut s2 + in (s3, HopObs (Just (obsOf o1)) (Just (obsOf o2)) (Just (obsOf o3)) Nothing) + _ -> + let (s1, o1) = stepSysOut sys + (s2, o2) = stepSysOut s1 + (s3, o3) = stepSysOut s2 + (s4, o4) = stepSysOut s3 + in (s4, HopObs (Just (obsOf o1)) (Just (obsOf o2)) (Just (obsOf o3)) (Just (obsOf o4))) + +-- | The simulator, run for one hop. +-- +-- The leaked word goes on the bus before the hop length is asked for, because +-- 'Proof.Driver.driver' reads it: a load-use hazard between the incoming +-- instruction and a load in the execute stage is one of the things that decides +-- how long the hop is. +simHop :: (RegFileOps r) => SimSys r -> L -> (SimSys r, HopObs) +simHop ss l = (scrub l ss', o) + where + w = invWord l + ss0 = installLeak w ss + (ss', o) = case driver ss0 of + 0 -> + let (s1, o1) = stepSimOut w ss0 + in (s1, HopObs (Just (obsOf o1)) Nothing Nothing Nothing) + 1 -> + let (s1, o1) = stepSimOut w ss0 + (s2, o2) = stepSimOut w s1 + in (s2, HopObs (Just (obsOf o1)) (Just (obsOf o2)) Nothing Nothing) + 2 -> + let (s1, o1) = stepSimOut w ss0 + (s2, o2) = stepSimOut w s1 + (s3, o3) = stepSimOut w s2 + in (s3, HopObs (Just (obsOf o1)) (Just (obsOf o2)) (Just (obsOf o3)) Nothing) + _ -> + let (s1, o1) = stepSimOut w ss0 + (s2, o2) = stepSimOut w s1 + (s3, o3) = stepSimOut w s2 + (s4, o4) = stepSimOut w s3 + in (s4, HopObs (Just (obsOf o1)) (Just (obsOf o2)) (Just (obsOf o3)) (Just (obsOf o4))) + +-- | Specification and simulator, composed. +-- +-- The architectural state steps, and the simulator is handed the leakage of the +-- instruction that state is currently processing. Nothing here mentions the +-- pipeline: the leakage is @'leakOf' a@, a function of the architectural state +-- alone. That is the point of the construction -- an attacker model that can be +-- stated without the processor in it. +-- +-- A closed machine, unlike its counterpart in the @highlevel-leakage@ +-- development: AIMCore's ISA reads its instruction out of its own memory, so +-- the architectural state is all the input there is. +leakSimHop :: + (RegFileOps r, MemOps m) => + (IsaStateG r m, SimSys r) -> + ((IsaStateG r m, SimSys r), HopObs) +leakSimHop (a, ss) = ((isaNext a, ss'), o) + where + (ss', o) = simHop ss (leakOf a) diff --git a/proof/Proof/Machine.hs b/proof/Proof/Machine.hs new file mode 100644 index 0000000..66f6242 --- /dev/null +++ b/proof/Proof/Machine.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | The \"system\" that the driver and the invariant talk about. +-- +-- 'Core.circuit' is only the pipeline: memory lives outside it. The core emits +-- a 'MemAccess' on its 'Output' and receives the response on the next +-- 'Input'. So a single system step is one 'Core.circuit' step plus the memory +-- service that 'Simulate.simulator' performs, and the state the proof reasons +-- about is the triple +-- +-- > (Core.State f, Input f, Mem) +-- +-- which is exactly the shape the driver and invariant notes use. +module Proof.Machine + ( SysG (..), + Sys, + stepSys, + stepSysOut, + stepSysN, + initSys, + running, + exInstr, + isNopInstr, + isBubble, + readMemWord, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Data.Functor.Identity +import Data.Maybe (isNothing) +import Data.Monoid (getFirst) +import Instruction +import Memory.Types +import RegFile +import Types +import qualified Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | Core state, the input it is about to consume, and memory. +data SysG r m = Sys + { sysState :: Core.StateG r Identity, + sysInput :: Input Identity, + sysMem :: m + } + +-- | The concrete system the QuickCheck harness runs: @Vec@-backed throughout. +type Sys = SysG RegFile MemBytes + +deriving instance (Show (r Identity), Show m) => Show (SysG r m) + +-- | Structural equality. 'Input' has no 'Eq' instance in "Core" (adding one +-- there clashes with the existing @Eq Out@ in the Leak modules), so we compare +-- its fields directly. +instance (Eq (r Identity), Eq m) => Eq (SysG r m) where + Sys s1 i1 m1 == Sys s2 i2 m2 = + s1 == s2 + && inputIsInstr i1 == inputIsInstr i2 + && runIdentity (inputMem i1) == runIdentity (inputMem i2) + && m1 == m2 + +-- | One system step: run the pipeline for a cycle, then service whatever +-- memory access it emitted. Mirrors 'Simulate.simulator', except that a halted +-- core simply stops changing instead of ending the stream. +stepSys :: (RegFileOps r, MemOps m) => SysG r m -> SysG r m +stepSys = fst . stepSysOut + +-- | 'stepSys', but also returning the pipeline's 'Output' for that cycle. +-- +-- The leakage proof observes the cycle-by-cycle memory traffic, which 'stepSys' +-- discards. Defining both here means what it observes is exactly the traffic +-- the memory service responds to. +stepSysOut :: (RegFileOps r, MemOps m) => SysG r m -> (SysG r m, Output Identity) +stepSysOut (Sys s i m) = + let (s', o) = Core.circuit s i + (i', m') = service (getFirst (outMem o)) m + in (Sys s' i' m', o) + where + service (Just (MemAccess isInstr addr size mval)) mem = + case mval of + -- A read. Note 'Memory.Vec.ramRead' ignores the size and always reads a + -- word; the size-dependent narrowing happens in 'Core.writeback' via + -- 'loadExtend'. We reproduce that here. + Nothing -> (Input isInstr (pure (memReadWord addr mem)), mem) + -- A write. + Just val -> (Input isInstr (pure 0), memWriteWord size addr (runIdentity val) mem) + service Nothing mem = (Input False (pure 0), mem) + +stepSysN :: (RegFileOps r, MemOps m) => Int -> SysG r m -> SysG r m +stepSysN n s + | n <= 0 = s + | otherwise = stepSysN (n - 1) (stepSys s) + +-- | The system as it starts up, with @prog@ loaded at 'initPc'. +initSys :: Vec PROG_SIZE Word -> Sys +initSys prog = + Sys + { sysState = Core.init, + sysInput = initInput, + sysMem = mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog + } + +running :: SysG r m -> Bool +running = isNothing . stateHalt . sysState + +exInstr :: SysG r m -> Instruction +exInstr = stateExInstr . sysState + +isNopInstr :: Instruction -> Bool +isNopInstr (Nop _) = True +isNopInstr _ = False + +-- | Is this a pipeline bubble, as opposed to a real instruction? +-- +-- The driver's stated invariant is \"step until the execute stage is no longer +-- a no-op\", but that is slightly too coarse: @Nop DecodeFail@ is what an +-- undecodable memory word decodes to, so it /is/ the architectural instruction +-- at that PC and the ISA steps over it like any other. Only the stall reasons +-- are genuine bubbles. +isBubble :: Instruction -> Bool +isBubble (Nop DecodeFail) = False +isBubble (Nop _) = True +isBubble _ = False + +readMemWord :: Address -> MemBytes -> Word +readMemWord = readWord diff --git a/proof/Proof/SMT/Array.hs b/proof/Proof/SMT/Array.hs new file mode 100644 index 0000000..5216d7c --- /dev/null +++ b/proof/Proof/SMT/Array.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} + +-- | A register file embedded as an SMT array. +-- +-- The embedding has to be /monomorphic/: an SMT array needs concrete index and +-- element sorts, so there is no way to map @Vec n a@ polymorphically. The +-- pattern is therefore: +-- +-- * a monomorphic newtype ('RegArr') for the Haskell side, +-- * a matching newtype ('RegArrSMT') wrapping the SMT array, +-- * a type axiom relating the two, +-- * monomorphic wrappers ('loadRA', 'storeRA') that the verified code calls +-- instead of Clash's polymorphic @(!!)@ and @replace@, each with a term +-- axiom pointing at an embedding written with 'coerce'. +-- +-- The polymorphic Clash operations must never appear in verified code -- they +-- are @OPAQUE@ and cannot be embedded. They appear here only inside the +-- Haskell implementations, which the axioms replace before symbolic execution +-- ever sees them. +module Proof.SMT.Array + ( RegArr (..), + RegArrF (..), + MemArr (..), + MemArrSMT (..), + loadM, + storeM, + loadME, + storeME, + RegArrSMT (..), + loadRA, + storeRA, + zeroRA, + zeroRAE, + loadRAE, + storeRAE, + sllWordE, + srlWordE, + sraWordE, + ) +where + +import Access +import qualified Clash.Prelude +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Data.Coerce (Coercible, coerce) +import Data.Kind (Type) +import qualified Pantomime.BuiltIn as P +import qualified Pantomime.Clash as Clash +import Memory.Types (MEM_SIZE_BYTES, MemOps (..)) +import RegFile (RegFileOps (..)) +import Types +import qualified Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The Haskell-side register file: 32 entries, so the index is exactly a +-- 'RegIdx' with no offset arithmetic. Slot 0 is present but never used -- +-- @x0@ is handled by the caller, outside the array operations. +newtype RegArr = RegArr (Vec 32 Word) + +-- | The SMT-side counterpart. Same arity (zero), which is what lets the type +-- axiom relate them. +newtype RegArrSMT = RegArrSMT (P.Array (P.BitVec 5) (P.BitVec 32)) + +-- | Read. Replaced by 'loadRAE' under the term axiom. +-- +-- OPAQUE is essential: the axiom is keyed on this /name/, so if GHC inlines +-- the wrapper then only the polymorphic @index_int@ survives into Core and the +-- axiom never fires. +{-# OPAQUE loadRA #-} +loadRA :: RegArr -> RegIdx -> Word +loadRA (RegArr v) i = v !! i + +-- | Write. Replaced by 'storeRAE' under the term axiom. OPAQUE for the same +-- reason as 'loadRA'. +{-# OPAQUE storeRA #-} +storeRA :: RegArr -> RegIdx -> Word -> RegArr +storeRA (RegArr v) i x = RegArr (replace i x v) + +-- | Embedding of 'loadRA' as an array select. +-- +-- Two subtleties. First, the source types are type /variables/ with +-- constructor-level 'Coercible' givens: congruence lifts @Coercible f g@ to +-- @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 +-- 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) => + arr -> + bvI 5 -> + bvV 32 +loadRAE = coerce go + where + go :: RegArrSMT -> Clash.BitVec 5 -> Clash.BitVec 32 + go (RegArrSMT arr) (Clash.BitVecP k) = Clash.BitVecP (P.aselect arr k) + +-- | 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) => + arr -> + bvI 5 -> + bvV 32 -> + arr +storeRAE = coerce go + where + go :: RegArrSMT -> Clash.BitVec 5 -> Clash.BitVec 32 -> RegArrSMT + go (RegArrSMT arr) (Clash.BitVecP k) (Clash.BitVecP v) = + RegArrSMT (P.astore arr k v) + +-- | The all-zero register file. +-- +-- 'Proof.Leakage.Simulator.censor' installs this on every state it builds, so +-- unlike 'Core.init' it is on the symbolic path and has to be embeddable. +-- 'Clash.Prelude.repeat' gives the Haskell semantics; 'zeroRAE' replaces it +-- under the term axiom, which is keyed on this name -- hence OPAQUE, for the +-- same reason as 'loadRA'. +{-# OPAQUE zeroRA #-} +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)) + +-- | The array-backed register file, wrapped so it fits 'RegFileOps'. +-- +-- The @f@ parameter is phantom: the embedding must be monomorphic, so the +-- element type is fixed to 'Word'. This is a verification-only representation +-- and is used at @f ~ Identity@, where 'unAccess' is the identity. +newtype RegArrF (f :: Type -> Type) = RegArrF RegArr + +instance RegFileOps RegArrF where + lookupRFg idx (RegArrF a) = if idx == 0 then pure 0 else pure (loadRA a idx) + modifyRFg idx v rf@(RegArrF a) + | idx == 0 = rf + | otherwise = RegArrF (storeRA a idx (unAccess v)) + + -- On the symbolic path; see 'zeroRA'. + initRFg = RegArrF zeroRA + +-- Shifts as SMT bitvector shifts ---------------------------------------------- +-- +-- Embeddings for 'Core.sllWord', 'Core.srlWord' and 'Core.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)) + +-- Memory as an SMT array ------------------------------------------------------ + +-- | The Haskell-side memory. +-- +-- A 'Vec', mirroring 'RegArr'. The size is irrelevant to verification: the type +-- axiom maps this to an array over the whole 32-bit address space, and the body +-- is never symbolically executed, because 'loadM' and 'storeM' are replaced by +-- their embeddings first. A function would arguably be the more honest Haskell +-- representation, since memory spans 32 bits; whether one would also work here +-- is untested. +newtype MemArr = MemArr (Vec MEM_SIZE_BYTES Byte) + +-- | The SMT-side counterpart: byte-granular, so sub-word stores stay natural. +newtype MemArrSMT = MemArrSMT (P.Array (P.BitVec 32) (P.BitVec 8)) + +-- | Byte read. OPAQUE so the term axiom, which is keyed on this name, still +-- has a name to fire on after optimisation. +{-# OPAQUE loadM #-} +loadM :: MemArr -> Address -> Byte +loadM (MemArr v) a = v !! a + +-- | Byte write. OPAQUE for the same reason. +{-# OPAQUE storeM #-} +storeM :: MemArr -> Address -> Byte -> MemArr +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) => + arr -> + bvA 32 -> + bvV 8 +loadME = 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) => + arr -> + bvA 32 -> + bvV 8 -> + arr +storeME = coerce go + where + go :: MemArrSMT -> Clash.BitVec 32 -> Clash.BitVec 8 -> MemArrSMT + go (MemArrSMT arr) (Clash.BitVecP a) (Clash.BitVecP v) = + MemArrSMT (P.astore arr a v) + +instance MemOps MemArr where + memReadByte a m = loadM m a + + memReadWord a m = + loadM m (a + 3) ++# loadM m (a + 2) ++# loadM m (a + 1) ++# loadM m a + + memWriteWord size a w m = + case size of + Types.Byte -> put a b0 m + Types.Half -> put (a + 1) b1 (put a b0 m) + Types.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 i v mm = storeM mm i v diff --git a/proof/Proof/SMT/Axioms.hs b/proof/Proof/SMT/Axioms.hs new file mode 100644 index 0000000..5b235ae --- /dev/null +++ b/proof/Proof/SMT/Axioms.hs @@ -0,0 +1,61 @@ +-- | The axiom set used by the proof properties. +-- +-- 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, arrayAxioms) where + +import Proof.SMT.Array +import Core (sllWord, sraWord, srlWord) +import qualified Data.Map as Map +import Pantomime (PluginAxioms (..)) +import qualified Pantomime.Base as Base +import qualified Pantomime.Clash as Clash + +-- | 'base' embeddings plus the Clash numeric types ('BitVector', 'Unsigned', +-- 'Signed', 'Bit'), which is what this core's types are built from, plus this +-- core's own shift wrappers. +-- +-- The shift axioms belong here rather than in 'arrayAxioms' because they are +-- part of the core's semantics, not of the container encoding: any property that +-- runs the ALU needs them. Without them 'Core.sllWord' and friends are OPAQUE +-- names with no unfolding, and symbolic execution stops with \"Unbound variable +-- in symbolise\". +axioms :: PluginAxioms +axioms = Base.axioms <> Clash.axioms <> shiftAxioms + +-- | The ALU shifts, mapped to the SMT bitvector shifts. +-- +-- See 'Core.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, on top of the base set. +-- +-- Monomorphic by necessity: an array needs concrete index and element sorts. +arrayAxioms :: PluginAxioms +arrayAxioms = + axioms + <> PluginAxioms + { typeAxioms = + Map.fromList + [ (''RegArr, ''RegArrSMT), + (''MemArr, ''MemArrSMT) + ], + termAxioms = + [ ('loadRA, 'loadRAE), + ('zeroRA, 'zeroRAE), + ('storeRA, 'storeRAE), + ('loadM, 'loadME), + ('storeM, 'storeME) + ] + } diff --git a/proof/Proof/SMT/Logged.hs b/proof/Proof/SMT/Logged.hs new file mode 100644 index 0000000..84a24e1 --- /dev/null +++ b/proof/Proof/SMT/Logged.hs @@ -0,0 +1,25 @@ +-- | 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 new file mode 100644 index 0000000..441ecf3 --- /dev/null +++ b/proof/Proof/SMT/Sanity.hs @@ -0,0 +1,57 @@ +-- | 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'. +-- +-- 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 +-- 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. +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 + +-- | The example from the Pantomime 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 + +-- | 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 + +-- | 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)) + ] diff --git a/proof/notes/counterexample-k0.txt b/proof/notes/counterexample-k0.txt new file mode 100644 index 0000000..3c37c24 --- /dev/null +++ b/proof/notes/counterexample-k0.txt @@ -0,0 +1,143 @@ +Counterexample for indStep0 (k = 0 inductive step), as reported by Z3. +===================================================================== + +SBV cannot parse array-valued variables back out of the model +("Data.SBV.interpretArray: Unable to process solver output"), so the plugin +crashes before printing a counterexample. The model is still recoverable from +the build log in two places: + + 1. The panic message embeds SBV's own s-expression parse of the array value. + 2. The [RECV] lines are Z3's raw `get-value` responses for every variable. + (Filter them back in -- we normally grep them out as noise.) + +Reproduce: uncomment the ANN on 'Verify.indStep0', then + stack build aimcore:lib > /tmp/model.txt 2>&1 + grep "^\[RECV\]" /tmp/model.txt + +DECODED MEMORY (MemArr). Everything not listed is 0. + + addr byte + 0x00000007 0x02 + 0x00000019 0x20 + 0x0000001A 0x40 + 0x7F701B31 0xB3 <-- three consecutive words, 4 bytes apart + 0x7F701B32 0x9B + 0x7F701B33 0x40 + 0x7F701B35 0x70 + 0x7F701B36 0x4F + 0x7F701B37 0xB0 + 0x7F701B39 0x80 + 0x7F701B3A 0x04 + 0x7F701B3B 0x02 + 0x7F701B3C 0x80 + 0xEFFFCFF8 0x02 + +WORDS (little-endian, as readWord assembles them): + + mem[0x7F701B31] = 0x00409BB3 opcode 0x33 -> R-type + mem[0x7F701B35] = 0x00B04F70 opcode 0x70 -> invalid -> Nop DecodeFail + mem[0x7F701B39] = 0x80020480 opcode 0x00 -> invalid -> Nop DecodeFail + +SCALARS identified so far (from [RECV]): + + s106 : Array (BitVec 5) (BitVec 32) the register file + s107 = 0x00006120 + s108 = 0x00B04F70 = mem[dePc], i.e. inputMem + s111 = 0x7F701B39 = fePc = exPc + 8 + +So the three words sit at exPc, dePc = exPc+4 and fePc = exPc+8, and the +invariant's premises (inputMem == mem[dePc], fePc == exPc+8) are satisfied. + +LEAD: the program counter is UNALIGNED -- 0x7F701B31 mod 4 == 1. The core does +not require alignment, so this is reachable in the symbolic state space even +though no realistic program produces it. Worth checking whether the invariant +needs an alignment precondition, or whether something else is at fault. + +NOT YET DONE: mapping the remaining ~141 sN variables to the property's +arguments. They are positional in declaration order, so it is mechanical but +tedious. A better route: re-run this property under the old function-schema +encoding ('Verify.mkRFPts' / 'mkMemPts'), which has no arrays -- SBV can then +decode the model itself and print a named counterexample. + + +===================================================================== +SECOND COUNTEREXAMPLE (after the load-use hazard conjunct was added) +===================================================================== + +k = 0 still comes back sat, but faster: 73s (was 131s), so the first +counterexample class is genuinely closed. + +DECODED MEMORY (all else 0): + + 0x00000001 = 0x02 + 0x04481002 = 0x04 + 0x804007C1 = 0x84 + 0xFED88070 = 0x23 <- the executing instruction starts here + 0xFED88071 = 0x30 + 0xFED88072 = 0x19 + 0xFED88073 = 0x06 + 0xFED88074 = 0x67 + +WORDS: + + mem[0xFED88070] = 0x06193023 opcode 0x23 -> S-TYPE (store), rs1=18, rs2=1 + mem[0xFED88074] = 0x00000067 opcode 0x67 -> JALR, rd=0 rs1=0 imm=0 + +So the execute stage holds a STORE this time, with the next word decoding as +jalr. Stores are the one instruction that writes memory in 'flushMeStage', and +they are also what 'Driver.storeHazard' guards, so both are worth checking: + + - does 'flushMeStage's store case agree with when 'Core.memory' actually + commits the write, the way the load case did not? + - is this another admitted-but-unreachable state, i.e. does the invariant + need a store-hazard precondition the way it now has a load-use one? + +Workflow that worked for the first one: + 1. decode the array from the panic blob (script in this repo's history) + 2. find PC anchors in the [RECV] lines + 3. rebuild concretely with MemFn/RegFn (unbounded, work concretely too) + and search the unmapped fields -- see 'ProofSpec.ceHits' + +===================================================================== +FIFTH COUNTEREXAMPLE: RESOLVED (address wraparound in noStoreAlias) +===================================================================== + +The model had exPc = 0xFFFFFFFC, dePc = 0 (wrapping), fePc = 4, a store in +the execute stage, and 0xFFFFFFFF among its unmapped 32-bit words. The +failing ingredient was the no-self-modifying-store assumption itself: + + clashes p = a < p + 4 && p < a + n -- Unsigned 32, both sums wrap + +With a PC word at the top of the address space (p = 0xFFFFFFFC), a < p + 4 +is a < 0 -- false for EVERY store address -- so a store into that word +passes the assumption unchecked. Dually, memWriteWord wraps its byte +addresses, so a word store at 0xFFFFFFFE writes bytes 0xFFFFFFFE..0x01 and +lands in a low PC word without ever satisfying p < a + n. Either way the +store rewrites an instruction word already latched into the pipeline, and +after the hop 'ex == decode (mem[isaPc])' is gone. + +Why the hand-reconstruction missed it: to satisfy the PRE-state's +'ex == decode (mem[isaPc])' (which reads the flushed memory), the store's +overlapping bytes must preserve the bytes they overwrite -- i.e. meRes must +reproduce mem's contents at the overlap -- and no such word was among the +four positional guesses tried for meRes. + +Why QuickCheck missed it: genArbSys laid out its three instruction words +with the same non-wrapping comparisons (a >= base && a < base + 4), so for +base near the top of the address space the window was empty and the premise +unsatisfiable -- the generator could not represent any state in the region +where the bug lives. + +Fixes, in proof/Invariant.hs and test/ProofSpec.hs: + + * noStoreAlias now checks each written byte with wrapping arithmetic + (byte x is in the word at p iff x - p < 4), fold-free so Pantomime can + still execute it. + * The concrete mechanism is pinned by two tests: "wrap-around aliasing + store breaks the un-guarded inductive step" (the state satisfies the + invariant, driver == 0, and the driven step breaks the invariant) and + "wrap-around aliasing store is excluded by noStoreAlias". + * genArbSys now uses a wrapping memory layout, occasionally sits the + pipeline astride 0xFFFFFFFF -> 0, biases store addresses into the PC + window, and generates branches/loads/stores in the decode slot. + 1e6 arbitrary-state tests pass after the fix. diff --git a/proof/notes/driver.txt b/proof/notes/driver.txt new file mode 100644 index 0000000..ecbf575 --- /dev/null +++ b/proof/notes/driver.txt @@ -0,0 +1,91 @@ +DRIVER: + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateExInstr == Nop FirstCycle + THEN 1 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == True + THEN 2 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == True + THEN 2 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == True AND + isMemInstr stateExInstr == True + THEN 3 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == True AND + isMemInstr stateExInstr == False + THEN 2 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == False AND + loadHazard inputMem stateExInstr == True + THEN 3 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == False AND + loadHazard inputMem stateExInstr == False AND + isMemInstr stateWbInstr == False + THEN 0 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == False AND + loadHazard inputMem stateExInstr == False AND + isMemInstr stateWbInstr == True AND + isMemInstr stateMeInstr == False + THEN 1 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == False AND + loadHazard inputMem stateExInstr == False AND + isMemInstr stateWbInstr == True AND + isMemInstr stateMeInstr == True AND + isMemInstr stateExInstr == False + THEN 2 + +- CASE: + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isEnvInstr stateExInstr == False AND + isJumpInstr stateExInstr stateMeInstr stateMeRes stateWbInstr stateWbRes stateRegFile == False AND + storeHazard stateDePc stateExInstr stateMeInstr stateMeAddr == False AND + loadHazard inputMem stateExInstr == False AND + isMemInstr stateWbInstr == True AND + isMemInstr stateMeInstr == True AND + isMemInstr stateExInstr == True + THEN 3 \ No newline at end of file diff --git a/proof/notes/invariant.txt b/proof/notes/invariant.txt new file mode 100644 index 0000000..542d285 --- /dev/null +++ b/proof/notes/invariant.txt @@ -0,0 +1,214 @@ +NOTE: this file has been reconciled with proof/Proof/Functional/Invariant.hs. +One change against the original: the 'stateCtrl == initCtrl' clause has been +dropped from every case. It is a holdover from an earlier Core that reset the +control lines at the END of each clock cycle, so that they were back at their +reset values by the time the next cycle began. Core.withCtrlReset now resets +them at the START of the cycle and the stages then set them, so the lines seen +in any post-step state are the ones the stages left -- Core.execute alone sets +ctrlExInstr to Just every cycle. Only Core.init still satisfies the clause, so +keeping it would make the invariant hold of no state the driver lands on and +every obligation vacuous. Dropping it is sound because the lines carry no +information between cycles: withCtrlReset overwrites them before any stage +reads them. + +The four running cases are collapsed into one in the Haskell. They differ only +in the fetch conjuncts, and those track the writeback stage alone -- a memory +instruction in writeback held the bus last cycle, so nothing was fetched. The +memory stage's classification changes no conjunct; its only effect is to demand +that the stage hold something isArithOrJumpInstr or isMemInstr covers, which is +everything but ecall and ebreak. Both stages are therefore stated there as "not +an environment instruction". + +Environment instructions in the memory or writeback stage need no case of their +own: those are the intermediate cycles the driver skips, and the hop that starts +with ecall/ebreak in execute lands on the corresponding halted case below. + +See proof/Proof/Functional/Invariant.hs for the executable version, and the +"Driver and invariant" group in the test suite for the checks. + +------------------------------------------------------------------- + +isArithOrJumpInstr :: Instruction -> Bool +isArithOrJumpInstr ir = + case ir of + RType _ _ _ _ -> True + IType (Arith _) _ _ _ -> True + IType (Load _ _) _ _ _ -> False + SType _ _ _ _ -> False + BType _ _ _ _ -> True + JType _ _ -> True + IType Jump _ _ _ -> True + UType _ _ _ -> True + IType (Env Call) _ _ _ -> False + IType (Env Break _) _ _ _ -> False + Nop _ -> True + +isMemInstr :: Instruction -> Bool +isMemInstr ir = + case ir of + RType _ _ _ _ -> False + IType (Arith _) _ _ _ -> False + IType (Load _ _) _ _ _ -> True + SType _ _ _ _ -> True + BType _ _ _ _ -> False + JType _ _ -> False + IType Jump _ _ _ -> False + UType _ _ _ -> False + IType (Env Call) _ _ _ -> False + IType (Env Break _) _ _ _ -> False + Nop _ -> False + +flushWbStage :: Instruction -> Word -> Word -> (RAM, RegFile) -> (RAM, RegFile) +flushWbStage stateWbInstr stateWbRes inputMem (stateMem, stateRegFile) = + case stateWbInstr of + RType _ rd _ _ -> + (stateMem, modifyRF rd stateWbRes stateRegFile) + IType (Arith _) rd _ _ -> + (stateMem, modifyRF rd stateWbRes stateRegFile) + IType (Load size sign) rd _ _ -> + let val = loadExtend size sign inputMem + (stateMem, modifyRF rd val stateRegFile) + SType _ _ _ _ -> + (stateMem, stateRegFile) + BType _ _ _ _ -> + (stateMem, stateRegFile) + JType rd _ -> + (stateMem, modifyRF rd stateWbRes stateRegFile) + IType Jump rd _ _ -> + (stateMem, modifyRF rd stateWbRes stateRegFile) + UType _ rd _ -> + (stateMem, modifyRF rd stateWbRes stateRegFile) + IType (Env Call) _ _ _ -> + (stateMem, stateRegFile) + IType (Env Break _) _ _ _ -> + (stateMem, stateRegFile) + Nop _ -> + (stateMem, stateRegFile) + +flushMeStage :: Instruction -> Word -> Word -> (RAM, RegFile) -> (RAM, RegFile) +flushMeStage stateMeInstr stateMeRes stateMeAddr (stateMem, stateRegFile) = + case stateMeInstr of + RType _ rd _ _ -> + (stateMem, modifyRF rd stateMeRes stateRegFile) + IType (Arith _) rd _ _ -> + (stateMem, modifyRF rd stateMeRes stateRegFile) + IType (Load size sign) rd _ _ -> + let inputMem = ramRead stateMeAddr stateMem + let val = loadExtend size sign inputMem + (stateMem, modifyRF rd val stateRegFile) + SType size _ _ _ -> + (ramWrite stateMeAddr size stateMeRes stateMem, stateRegFile) + BType _ _ _ _ -> + (stateMem, stateRegFile) + JType rd _ -> + (stateMem, modifyRF rd stateMeRes stateRegFile) + IType Jump rd _ _ -> + (stateMem, modifyRF rd stateMeRes stateRegFile) + UType _ rd _ -> + (stateMem, modifyRF rd stateMeRes stateRegFile) + IType (Env Call) _ _ _ -> + (stateMem, stateRegFile) + IType (Env Break _) _ _ _ -> + (stateMem, stateRegFile) + Nop _ -> + (stateMem, stateRegFile) + +INVARIANT: + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + stateWbInstr == Nop FirstCycle AND + stateMeInstr == Nop FirstCycle AND + stateExInstr == Nop FirstCycle AND + inputIsInstr == False AND + fetchPc == isaPc AND + isaRegFile == stateRegFile AND + isaMem == stateMem + +------------------------------------------------------------------- +------------------------------------------------------------------- + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isArithOrJumpInstr stateWbInstr == True AND + isArithOrJumpInstr stateMeInstr == True AND + stateExPc == isaPc AND + stateExInstr == decode (ramRead isaPc isaMem) AND + stateDePc == stateExPc + 4 AND + inputIsInstr == True AND + inputMem == ramRead stateDePc stateMem AND + stateFePc == stateExPc + 8 AND + loadHazard stateExInstr stateMeInstr == False AND + (isaMem, isaRegFile) == flushMemStage stateMeInstr stateMeRes stateMeAddr (flushWbStage stateWbInstr stateWbRes inputMem (stateMem, stateRegFile)) + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isMemInstr stateWbInstr == True AND + isArithOrJumpInstr stateMeInstr == True AND + stateExPc == isaPc AND + stateExInstr == decode (ramRead isaPc isaMem) AND + stateDePc == stateExPc + 4 AND + inputIsInstr == False AND + stateFePc == stateExPc + 4 AND + loadHazard stateExInstr stateMeInstr == False AND + (isaMem, isaRegFile) == flushMemStage stateMeInstr stateMeRes stateMeAddr (flushWbStage stateWbInstr stateWbRes inputMem (stateMem, stateRegFile)) + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isArithOrJumpInstr stateWbInstr == True AND + isMemInstr stateMeInstr == True AND + stateExPc == isaPc AND + stateExInstr == decode (ramRead isaPc isaMem) AND + stateDePc == stateExPc + 4 AND + inputIsInstr == True AND + inputMem == ramRead stateDePc stateMem AND + stateFePc == stateExPc + 8 AND + loadHazard stateExInstr stateMeInstr == False AND + (isaMem, isaRegFile) == flushMemStage stateMeInstr stateMeRes stateMeAddr (flushWbStage stateWbInstr stateWbRes inputMem (stateMem, stateRegFile)) + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF stateHalt == Running AND + isMemInstr stateWbInstr == True AND + isMemInstr stateMeInstr == True AND + stateExPc == isaPc AND + stateExInstr == decode (ramRead isaPc isaMem) AND + stateDePc == stateExPc + 4 AND + inputIsInstr == False AND + stateFePc == stateExPc + 4 AND + loadHazard stateExInstr stateMeInstr == False AND + (isaMem, isaRegFile) == flushMemStage stateMeInstr stateMeRes stateMeAddr (flushWbStage stateWbInstr stateWbRes inputMem (stateMem, stateRegFile)) + +------------------------------------------------------------------- +------------------------------------------------------------------- + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF isBreak (decode (ramRead isaPc isaMem)) == True AND + stateHalt == EBreak (isaPc + 4) AND + stateWbInstr == Nop Halted AND + stateMeInstr == Nop Halted AND + stateExInstr == Nop Halted AND + isaRegFile == stateRegFile AND + isaMem == stateMem + +- CASE: + (isaPc, isaRegFile, isaMem) ~ + ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), + IF isCall (decode (ramRead isaPc isaMem)) == True AND + stateHalt == Syscall (isaPc + 4) AND + stateWbInstr == Nop Halted AND + stateMeInstr == Nop Halted AND + stateExInstr == Nop Halted AND + isaRegFile == stateRegFile AND + isaMem == stateMem diff --git a/proof/notes/leakage.txt b/proof/notes/leakage.txt new file mode 100644 index 0000000..4df3906 --- /dev/null +++ b/proof/notes/leakage.txt @@ -0,0 +1,53 @@ +Leakage proof: how to run it, and how to chase a failure. +========================================================= + +RUNNING +------- +Use Bitwuzla, not Z3. Z3 does not finish these queries in useful time; under +Bitwuzla each solve is seconds and symbolisation dominates. + + SBV_Z3=/opt/homebrew/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" \ + stack build aimcore:lib > /tmp/model.txt 2>&1 + grep "^\[RECV\]" /tmp/model.txt + +Build at -O1 or above. Under `stack build --fast` GHC creates no unfoldings, +the plugin cannot see through cross-module calls, and it aborts with +`Unbound variable in symbolise: ` -- a BUILD failure, easily misread as a +failed proof. + +WHAT IS PROVED +-------------- +Proof.Leakage.Induction holds leakStep0..3, one per driver hop length. All four +are valid. Together with Proof.Functional.Induction.baseCase they give: +an attacker watching the memory bus learns nothing beyond Proof.Leakage.Model.L. + +The only assumption beyond the functional invariant is +Proof.Functional.Invariant.noStoreAlias -- no store writes a word the fetch path +is using -- required at every state of a hop rather than only at its ends. There +is no assumption on jump targets. + +CHASING A `sat` +--------------- +The plugin cannot print counterexamples containing arrays: SBV fails to parse +them back and the build dies with `version (...) /= storageVersion (0)`. The +model is still in the log, as the raw `get-value` responses, in SBV variable +order -- the KState fields, then Core.Input, RegArr, MemArr, then the witness +RegIdx and Address. + +Decoding that by hand is a last resort. Two cheaper moves, in order: + + 1. Split the PREMISE to find which shape fails. leakStep3a / leakStep3b in + Proof.Leakage.Induction do this on `loadHazardD`, separating the two + shapes that reach a four-cycle hop. Their annotations are commented out; + enable them to reproduce. + + 2. Split the CONCLUSION to find which conjunct fails -- the state equality or + one of the four observation slots. Assume the full premises and assert one + piece at a time. + +Then reproduce concretely with test/LeakageSpec.hs, whose arbitrary-state +generators range over the same space the symbolic properties quantify over +(unreachable states included) and give a shrunk, printable counterexample. If +the search cannot find it, the generator is missing a shape: check that the +instruction forms involved are actually generated before concluding the state +is unreachable. diff --git a/src/Core.hs b/src/Core.hs index 114a9cd..6bdf50d 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -13,7 +13,8 @@ module Core circuit, Input (..), Output (..), - State (..), + StateG (..), + State, HaltState (..), fetch, decode, @@ -25,6 +26,9 @@ module Core Control (..), alu, branch, + sllWord, + srlWord, + sraWord, topEntity, ) where @@ -43,13 +47,14 @@ import Types import Prelude hiding (Ordering (..), Word, init, lines, not, undefined, (&&), (||)) topEntity :: + forall f. (Access f, Generic (f Word), NFDataX (f Word)) => Clock System -> Reset System -> Enable System -> Signal System (Input f) -> Signal System (Output f) -topEntity = exposeClockResetEnable $ mealy circuit init +topEntity = exposeClockResetEnable $ mealy (circuit @f @RegFile) (init @f @RegFile) -- | The input to the CPU. data Input f = Input @@ -108,7 +113,11 @@ data HaltState = EBreak Address | Syscall Address | SecurityViolation instance NFDataX HaltState -- | The internal state of the CPU; essentially the pipeline registers. -data State f = State +-- +-- Parameterised over the register-file representation @r@ so that the same +-- pipeline can be run on the synthesisable 'RegFile' or, for symbolic +-- execution, on the function-backed 'RegFn'. See 'RegFileOps'. +data StateG r f = State { -- | Program counter fetch stage. stateFePc :: Address, -- | Program counter decode stage. @@ -128,7 +137,7 @@ data State f = State -- | Computation result writeback stage. stateWbRes :: f Word, -- | Register file. - stateRegFile :: RegFile f, + stateRegFile :: r f, -- | Control/forwarding lines. stateCtrl :: Control f, -- | CPU halt state. @@ -137,13 +146,18 @@ data State f = State stateHaltNextPc :: Address } -deriving instance (Show (f Word)) => Show (State f) +-- | The synthesisable state: the register file is a 'Vec'. +type State = StateG RegFile -deriving instance (Eq (f Word)) => Eq (State f) +deriving instance (Show (f Word), Show (r f)) => Show (StateG r f) -deriving instance Generic (State f) +deriving instance (Eq (f Word), Eq (r f)) => Eq (StateG r f) -deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (State f) +deriving instance Generic (StateG r f) + +deriving anyclass instance + (Generic (f Word), NFDataX (f Word), Generic (r f), NFDataX (r f)) => + NFDataX (StateG r f) -- | Control lines. data Control f = Control @@ -183,22 +197,22 @@ deriving instance Generic (Control f) deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Control f) -type CPUM f = RWS (Input f) (Output f) (State f) +type CPUM r f = RWS (Input f) (Output f) (StateG r f) -setLines :: (MonadState (State f) m) => (Control f -> Control f) -> m () +setLines :: (MonadState (StateG r f) m) => (Control f -> Control f) -> m () setLines f = modify $ \s -> s {stateCtrl = f (stateCtrl s)} -- | No secrets here, buddy: unwrap a word. If it's public, we gucci. If it's -- private, die. -noSecrets' :: (Access f) => f a -> b -> (a -> CPUM f b) -> CPUM f b +noSecrets' :: (Access f) => f a -> b -> (a -> CPUM r f b) -> CPUM r f b noSecrets' w a = noSecrets w (setSecurityViolation >> pure a) -- | Run the CPU for one step. -circuit :: (Access f) => State f -> Input f -> (State f, Output f) +circuit :: forall f r. (Access f, RegFileOps r) => StateG r f -> Input f -> (StateG r f, Output f) circuit = flip $ execRWS pipe -- | The CPU, composed of each stage. -pipe :: (Access f) => CPUM f () +pipe :: (Access f, RegFileOps r) => CPUM r f () pipe = void $ withCtrlReset $ do writeback memory @@ -213,7 +227,7 @@ initInput = inputMem = pure 0 } -init :: (Access f) => State f +init :: forall f r. (Access f, RegFileOps r) => StateG r f init = State { stateFePc = initPc, @@ -225,7 +239,7 @@ init = stateMeAddr = 0, stateWbInstr = Nop FirstCycle, stateWbRes = pure 0, - stateRegFile = initRF, + stateRegFile = initRFg, stateCtrl = initCtrl, stateHalt = Nothing, stateHaltNextPc = 0 @@ -247,19 +261,19 @@ initCtrl = } -- | The control lines need to be reset every tick. -withCtrlReset :: CPUM f () -> CPUM f (Control f) +withCtrlReset :: CPUM r f () -> CPUM r f (Control f) withCtrlReset m = do modify $ \s -> s {stateCtrl = initCtrl} m gets stateCtrl -- | Set security violation flag. -setSecurityViolation :: CPUM f () +setSecurityViolation :: CPUM r f () setSecurityViolation = modify $ \s -> s {stateHalt = Just SecurityViolation} -- | The fetch stage. -fetch :: CPUM f () +fetch :: CPUM r f () fetch = do pc <- gets stateFePc ctrl <- gets stateCtrl @@ -288,7 +302,7 @@ fetch = do } -- | Decode stage. -decode :: (Access f) => CPUM f () +decode :: (Access f) => CPUM r f () decode = do input <- ask pc <- gets stateDePc @@ -324,15 +338,15 @@ decode = do | break_current_cycle = Nop Halted -- Stall if there was a jump in the previous cycle. | jump_previous_cycle = Nop JumpSecondCycle - -- Stall if there is a jump in this cycle. + -- Stall if there was a store hazard in the previous cycle. | store_hazard_previous_cycle = Nop StoreHazardSecondCycle - -- Stall if there is a store hazard in this cycle. + -- Stall if there was a load hazard in the previous cycle. | load_hazard_previous_cycle = Nop LoadHazardSecondCycle - -- Stall if there is a load hazard in this cycle. + -- Stall if there is a jump in this cycle. | jump_current_cycle = Nop JumpFirstCycle - -- Stall if there was a store hazard in the previous cycle. + -- Stall if there is a store hazard in this cycle. | store_hazard_current_cycle = Nop StoreHazardFirstCycle - -- Stall if there was a load hazard in the previous cycle. + -- Stall if there is a load hazard in this cycle. | load_hazard_current_cycle = Nop LoadHazardFirstCycle -- Otherwise we process the decoded instruction. | otherwise = ir @@ -346,7 +360,7 @@ decode = do setLines $ \c -> c {ctrlDeLoadHazard = Just pc} -- | Execute stage. -execute :: forall f. (Access f) => CPUM f () +execute :: forall f r. (Access f, RegFileOps r) => CPUM r f () execute = do ir <- gets stateExInstr @@ -430,17 +444,17 @@ execute = do modify $ \s -> s {stateHaltNextPc = pc + 4} Instruction.Nop _ -> pure () where - getFirstArg :: RegIdx -> CPUM f (f Word) + getFirstArg :: RegIdx -> CPUM r f (f Word) getFirstArg idx = do rf <- gets stateRegFile - regWithFwd idx (lookupRF idx rf) + regWithFwd idx (lookupRFg idx rf) - getSecondArg :: RegIdx -> CPUM f (f Word) + getSecondArg :: RegIdx -> CPUM r f (f Word) getSecondArg idx = do rf <- gets stateRegFile - regWithFwd idx (lookupRF idx rf) + regWithFwd idx (lookupRFg idx rf) - regWithFwd :: RegIdx -> f Word -> CPUM f (f Word) + regWithFwd :: RegIdx -> f Word -> CPUM r f (f Word) regWithFwd idx def = do let checkForFwd line = do (fwdIdx, fwdVal) <- MaybeT $ gets $ line . stateCtrl @@ -457,16 +471,49 @@ alu op lhs rhs = case op of XOR -> (.^.) <$> lhs <*> rhs OR -> (.|.) <$> lhs <*> rhs AND -> (.&.) <$> lhs <*> rhs - SLL -> shiftL <$> lhs <*> (shiftBits <$> rhs) - SRL -> shiftR <$> lhs <*> (shiftBits <$> rhs) - SRA -> pack <$> (shiftR <$> (sign <$> lhs) <*> (shiftBits <$> rhs)) + SLL -> sllWord <$> lhs <*> (shiftBits <$> rhs) + SRL -> srlWord <$> lhs <*> (shiftBits <$> rhs) + SRA -> sraWord <$> lhs <*> (shiftBits <$> rhs) SLT -> set <$> ((<) <$> (sign <$> lhs) <*> (sign <$> rhs)) SLTU -> set <$> ((<) <$> lhs <*> rhs) where - shiftBits s = fromIntegral $ slice d4 d0 s + shiftBits s = slice d4 d0 s sign = unpack @(Signed 32) set b = if b then 1 else 0 +-- | The three RISC-V shifts, with the shift amount kept as a bitvector. +-- +-- RISC-V takes the amount from the low five bits of the second operand, so no +-- amount can reach the word width and these agree with the SMT shifts on the +-- nose. +-- +-- They exist as named 'OPAQUE' functions, rather than 'shiftL' applied inline, +-- for the verifier's sake. 'Data.Bits.shiftL' takes an 'Int', so an inline +-- amount forces @fromIntegral@ on the five-bit slice, and that is modelled +-- through 'Integer': every shift site then emits an integer round trip +-- (@ubv_to_int@ to @int_to_bv@) wrapped in two overflow guards. Those few terms +-- pull integer arithmetic into a query that is otherwise pure bitvectors and +-- arrays, and Bitwuzla and Yices have no integer theory at all -- they reject +-- such a query outright rather than solve it slowly. Keeping the amount a +-- 'BitVector' behind a name lets "Axioms" map each shift to its SMT +-- counterpart; see 'ArrayRF.sllWordE'. +-- +-- OPAQUE is essential, for the same reason as 'ArrayRF.loadRA': the axiom is +-- keyed on the name, so an inlined wrapper would leave nothing to rewrite. +{-# OPAQUE sllWord #-} +sllWord :: Word -> BitVector 5 -> Word +sllWord x n = shiftL x (fromIntegral n) + +-- | Logical right shift; 'BitVector' is unsigned, so 'shiftR' is @bvlshr@. +{-# OPAQUE srlWord #-} +srlWord :: Word -> BitVector 5 -> Word +srlWord x n = shiftR x (fromIntegral n) + +-- | Arithmetic right shift, via 'Signed' as the ISA prescribes. +{-# OPAQUE sraWord #-} +sraWord :: Word -> BitVector 5 -> Word +sraWord x n = pack (shiftR (unpack x :: Signed 32) (fromIntegral n)) + branch :: (Access f) => Comparison -> f Word -> f Word -> f Bool branch op lhs rhs = case op of EQ -> (==) <$> lhs <*> rhs @@ -478,7 +525,7 @@ branch op lhs rhs = case op of where sign = unpack @(Signed 32) -memory :: CPUM f () +memory :: CPUM r f () memory = do ir <- gets stateMeInstr res <- gets stateMeRes @@ -510,7 +557,7 @@ memory = do _ -> pure () -- | Commit computations to the register file. -writeback :: forall f. (Access f) => CPUM f () +writeback :: forall f r. (Access f, RegFileOps r) => CPUM r f () writeback = do input <- asks inputMem ir <- gets stateWbInstr @@ -545,9 +592,9 @@ writeback = do _ -> do setLines $ \c -> c {ctrlWbRegFwd = Nothing} where - writeRF :: RegIdx -> f Word -> CPUM f () + writeRF :: RegIdx -> f Word -> CPUM r f () writeRF idx val = - modify $ \s -> s {stateRegFile = modifyRF idx val (stateRegFile s)} + modify $ \s -> s {stateRegFile = modifyRFg idx val (stateRegFile s)} readPC :: (MonadWriter (Output f) m) => Address -> m () readPC addr = diff --git a/src/Elf/ElfLoader.hs b/src/Elf/ElfLoader.hs index 0effaf3..9c2d5fd 100644 --- a/src/Elf/ElfLoader.hs +++ b/src/Elf/ElfLoader.hs @@ -112,7 +112,7 @@ runElf instr c = go c case mRet of Nothing -> pure () Just ret -> do - let s'' = Core.init {Core.stateFePc = resumePc, + let s'' = (Core.init :: Core.State f) {Core.stateFePc = resumePc, Core.stateRegFile = modifyRF 10 ret (Core.stateRegFile s')} go $ sim {circuitInput = Core.initInput, circuitState = s''} Just (Core.EBreak _) -> pure () diff --git a/src/HardwareSim.hs b/src/HardwareSim.hs index e7d60e4..1adb0ef 100644 --- a/src/HardwareSim.hs +++ b/src/HardwareSim.hs @@ -24,8 +24,8 @@ topEntity :: Signal System (Output Identity) topEntity = exposeClockResetEnable $ system prog3 -cpu :: (Access f, Generic (f Word), NFDataX (f Word), HiddenClockResetEnable dom) => Signal dom (Input f) -> Signal dom (Output f) -cpu = mealy circuit init +cpu :: forall f dom. (Access f, Generic (f Word), NFDataX (f Word), HiddenClockResetEnable dom) => Signal dom (Input f) -> Signal dom (Output f) +cpu = mealy (circuit @f @RegFile) (init @f @RegFile) system :: forall dom. (HiddenClockResetEnable dom) => Vec PROG_SIZE Word -> Signal dom (Output Identity) system prog = cpuOut diff --git a/src/ISA.hs b/src/ISA.hs index 66c3fb6..32caf9e 100644 --- a/src/ISA.hs +++ b/src/ISA.hs @@ -2,13 +2,39 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- | The ISA specification: what each instruction means, and how the +-- architectural state evolves. +-- +-- 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 architectural state is parameterised over the register-file and memory +-- representations because the @Vec@-backed ones cannot be symbolically +-- 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. module ISA ( Func, + Done (..), + apply, DepReg (..), Instr (..), PC, + getR1, + getR2, interp, interp', + IsaStateG (..), + IsaState, + StepG (..), + Step, + isaStep, + isaStepDecoded, + isaRun, + isaInstrAt, ) where @@ -16,8 +42,10 @@ import Access import Clash.Prelude hiding (Const, Log, Ordering (..), Word, def, init, lift, log) import Core hiding (Syscall) import Data.Functor.Identity -import Instruction (Sign) +import Instruction (Instruction, Sign, decode', loadExtend) import qualified Instruction +import Memory.Types (MemBytes, MemOps (..)) +import RegFile import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (||)) @@ -34,6 +62,15 @@ instance Show (Func a) where instance Functor Func where fmap g (Func f d) = Func (\r1 r2 pc -> g $ f r1 r2 pc) d +-- | The result of evaluating a 'Func'. 'isaStepDecoded' is the only consumer: +-- it evaluates each 'Func' against its two dependency registers and the PC to +-- get the architectural transition. +newtype Done a = Done {unDone :: a} + deriving (Show, Eq) + +apply :: Func a -> Word -> Word -> PC -> Done a +apply (Func f _) r1 r2 pc = Done $ f r1 r2 pc + data Instr f = Reg RegIdx (f Word) | Load Size Sign RegIdx (f Address) @@ -58,6 +95,14 @@ deriving instance ) => Eq (Instr f) +-- | The two source registers a decoded instruction depends on. Consumed by +-- 'isaStepDecoded' to supply the operands 'apply' evaluates a 'Func' against. +getR1 :: Instr Func -> Maybe RegIdx +getR1 = fst . deps + +getR2 :: Instr Func -> Maybe RegIdx +getR2 = snd . deps + class DepReg a where deps :: a -> (Maybe RegIdx, Maybe RegIdx) @@ -147,3 +192,87 @@ interp' instr { isaFunc = const $ const f, isaDeps = (empty, empty) } + +-- | Architectural state: the ISA-visible triple. +data IsaStateG r m = IsaState + { isaPc :: PC, + isaRegFile :: r Identity, + isaMem :: m + } + +-- | The concrete architectural state the QuickCheck harness uses. +type IsaState = IsaStateG RegFile MemBytes + +deriving instance (Show (r Identity), Show m) => Show (IsaStateG r m) + +deriving instance (Eq (r Identity), Eq m) => Eq (IsaStateG r m) + +-- | The result of one architectural step. 'IsaHalted' covers @ebreak@ and +-- @ecall@, which is where 'Core' parks in a 'Core.HaltState'. +data StepG r m + = Next (IsaStateG r m) + | IsaHalted + +type Step = StepG RegFile MemBytes + +deriving instance (Show (r Identity), Show m) => Show (StepG r m) + +deriving instance (Eq (r Identity), Eq m) => Eq (StepG r m) + +-- | The instruction the ISA would execute next. +isaInstrAt :: (MemOps m) => IsaStateG r m -> Instruction +isaInstrAt (IsaState pc _ mem) = decode' (memReadWord pc mem) + +isaStep :: (RegFileOps r, MemOps m) => IsaStateG r m -> StepG r m +isaStep st = isaStepDecoded (isaInstrAt st) st + +-- | Step the ISA using an instruction that has already been decoded. +-- +-- This is definitionally the same transition as 'isaStep' when @ir@ is +-- @isaInstrAt st@. Keeping the decoded instruction explicit is useful in the +-- refinement proof: the invariant already states that the core's execute-stage +-- instruction equals @isaInstrAt st@, so the transition can execute that +-- instruction directly instead of nesting one decoder inside another. +isaStepDecoded :: + (RegFileOps r, MemOps m) => + 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 (pure (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 (pure val) rf} + Jump rd link target -> + Next + st + { isaPc = ap target, + isaRegFile = modifyRFg rd (pure (bitCoerce (ap link))) rf + } + Store size addr rs2 -> + Next st {isaPc = pc + 4, isaMem = memWriteWord size (ap addr) (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 + where + instr = interp' ir + + reg = maybe 0 (\idx -> runIdentity (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) + +-- | Run at most @n@ architectural steps, stopping early on halt. Returns the +-- states visited, starting with the initial one. +isaRun :: (RegFileOps r, MemOps m) => Int -> IsaStateG r m -> [IsaStateG r m] +isaRun n st + | n <= 0 = [st] + | otherwise = case isaStep st of + IsaHalted -> [st] + Next st' -> st : isaRun (n - 1) st' diff --git a/src/Memory/Types.hs b/src/Memory/Types.hs index cd950ec..8bcade2 100644 --- a/src/Memory/Types.hs +++ b/src/Memory/Types.hs @@ -2,6 +2,9 @@ module Memory.Types ( MonadMemory (..), + MemOps (..), + MemBytes, + MemFn (..), readWord, write, RAM_SIZE, @@ -31,6 +34,46 @@ class Monad m => MonadMemory m where -- | Check if a memory address is marked as secret isMemorySecret :: Address -> m Bool +-- | The byte-addressed memory the ISA model and the proof harness use. Same +-- size as the one the simulation tests use. +type MemBytes = Vec MEM_SIZE_BYTES Byte + +-- | The operations a memory representation has to provide. +-- +-- Parameterised for the same reason as 'RegFile.RegFileOps': the @Vec@-backed +-- 'MemBytes' cannot be symbolically executed, while the function-backed 'MemFn' +-- can. +class MemOps m where + memReadWord :: Address -> m -> Word + memWriteWord :: Size -> Address -> Word -> m -> m + + -- | Single byte, which is what the pointwise form of the invariant compares. + memReadByte :: Address -> m -> Byte + +instance (KnownNat n) => MemOps (Vec n Byte) where + memReadWord = readWord + memWriteWord = write + memReadByte a m = m !! a + +-- | Verification-only memory: a function rather than a container. +newtype MemFn = MemFn {memByte :: Address -> Byte} + +instance MemOps MemFn where + memReadWord a (MemFn m) = m (a + 3) ++# m (a + 2) ++# m (a + 1) ++# m a + memWriteWord size a 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 i v (MemFn f) = MemFn (\j -> if j == i then v else f j) + + memReadByte a (MemFn m) = m a + readWord :: (KnownNat n) => Address -> Vec n Byte -> Word readWord addr m = (m !! (addr + 3)) ++# (m !! (addr + 2)) ++# (m !! (addr + 1)) ++# (m !! addr) diff --git a/src/RegFile.hs b/src/RegFile.hs index 3bb3f2e..e2e06ab 100644 --- a/src/RegFile.hs +++ b/src/RegFile.hs @@ -8,6 +8,8 @@ module RegFile lookupRF, modifyRF, censorRF, + RegFileOps (..), + RegFn (..), ) where @@ -60,3 +62,33 @@ modifyRF idx val (RegFile rf) = case idx of -- | Censor all registers in the register file. censorRF :: (Access f) => RegFile f -> RegFile f censorRF _ = initRF + +-- | The operations the pipeline needs from a register file. +-- +-- 'Core.StateG' is parameterised over this so that the same pipeline can run on +-- two representations: the synthesisable 'RegFile' (a 'Vec'), and 'RegFn' (a +-- function) which is what symbolic execution can actually handle. See +-- "Induction" for why the 'Vec' one cannot be symbolically executed. +class RegFileOps r where + lookupRFg :: (Access f) => RegIdx -> r f -> f Word + modifyRFg :: (Access f) => RegIdx -> f Word -> r f -> r f + initRFg :: (Access f) => r f + +instance RegFileOps RegFile where + lookupRFg = lookupRF + modifyRFg = modifyRF + initRFg = initRF + +-- | Verification-only register file: a function rather than a container. +-- +-- Not synthesisable -- Clash cannot turn a function into hardware -- so this +-- must never reach 'Core.topEntity'. It exists purely so that reads become +-- applications and writes become lambdas, both of which the symbolic executor +-- handles natively. +newtype RegFn f = RegFn (RegIdx -> f Word) + +instance RegFileOps RegFn where + lookupRFg idx (RegFn g) = if idx == 0 then pure 0 else g idx + modifyRFg idx v rf@(RegFn g) = + if idx == 0 then rf else RegFn (\j -> if j == idx then v else g j) + initRFg = RegFn (const (pure 0)) diff --git a/stack.yaml b/stack.yaml index 370d127..8c42462 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,12 +9,13 @@ extra-deps: - melf-1.3.1@sha256:167dd798237451e8ccca8c7d98ec719ce20ce1752445dda1fee165b389830b4e,4526 - parallel-3.2.2.0@sha256:3df46ec247e12b5e406a0adb9577294431b24814b30df420551d176fd112a966,2038 - optparse-applicative-0.18.1.0@sha256:f30973861ac7e7ebff05ff8c7c3d1e4d283a1f3850e1cc14106b0693ec1b6d82,5289 - - github: PLSec-VU/pantomime - commit: 491638b742ce2d9fc92976ab0e2037ba259e5ae9 + # NOTE: the 'pantomime' repo was renamed to 'symfc' upstream. + - github: PLSec-VU/symfc + commit: 1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3 - github: PLSec-VU/pantomime-base - commit: 64dab2d4fd3ef4c27ec9eb698bf61092fb08d8a4 + commit: 1a3b9e223f488e5f2c60f1e3a06e41d39c06fced - github: PLSec-VU/pantomime-clash - commit: 1f42057f228cd5e476af4b35541598843a7b74f9 + commit: 5bb122c9d38bb4a18c80360e0e4aff46cc9e817d - github: RobinWebbers/grisette commit: ae4d837886efb2e7838f89271f343d6fa8130388 diff --git a/stack.yaml.lock b/stack.yaml.lock index 78ec65a..84ec0e4 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -42,36 +42,36 @@ packages: - completed: name: pantomime pantry-tree: - sha256: db092592a9914ed1ee72d5916ae4f063667170c0b30a5dc9fd36412582682947 - size: 2709 - sha256: 9d41677c16f8dffe9a3d31e4fff00bf53a5d63b88fba5e9a93322031349ea459 - size: 81872 - url: https://github.com/PLSec-VU/pantomime/archive/491638b742ce2d9fc92976ab0e2037ba259e5ae9.tar.gz + sha256: a9b33df0c2993334ad2a8cc4187804155fc7870d91edd32bb5dba0abb1ebf4f4 + size: 2948 + sha256: 2196ca8979249fe8ceb82b197decb91786b612d27392a10dbf92177970467387 + size: 89415 + url: https://github.com/PLSec-VU/symfc/archive/1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3.tar.gz version: 0.1.0.0 original: - url: https://github.com/PLSec-VU/pantomime/archive/491638b742ce2d9fc92976ab0e2037ba259e5ae9.tar.gz + url: https://github.com/PLSec-VU/symfc/archive/1821a716aa06d6fc1d415d7fc758cf3aee9aa0c3.tar.gz - completed: name: pantomime-base pantry-tree: - sha256: 6729f953ad15ea5d00e2c3142142682f064c30c14e84771967407b8b638e89ad + sha256: d9ca9346ffc7552a38580959952435ea61b64b04f4a686ede7090feb9450a2da size: 530 - sha256: 98053f17fdd3476737d139beda0e0e3946772e41368f400658151c51fdb6c1e8 - size: 16975 - url: https://github.com/PLSec-VU/pantomime-base/archive/64dab2d4fd3ef4c27ec9eb698bf61092fb08d8a4.tar.gz + 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/64dab2d4fd3ef4c27ec9eb698bf61092fb08d8a4.tar.gz + url: https://github.com/PLSec-VU/pantomime-base/archive/1a3b9e223f488e5f2c60f1e3a06e41d39c06fced.tar.gz - completed: name: pantomime-clash pantry-tree: - sha256: 978493e7943f08ff0a4b27b0794f0fa392f1dee60c3a746d1970c3b0731121b9 + sha256: 5ca3e86e8304432d9816d06c3d9aa004e576ce007a7c60310c6c792b48468e69 size: 611 - sha256: 012c081c9df84a8725e1e814c16b12bb04e3cd4149de96011efab65f3e835f9b - size: 19408 - url: https://github.com/PLSec-VU/pantomime-clash/archive/1f42057f228cd5e476af4b35541598843a7b74f9.tar.gz + sha256: 9c369683baa755b0e862ec2a38d4b6ad966bca29e9de9cfc9f9dc4f1c7eef58d + size: 19357 + url: https://github.com/PLSec-VU/pantomime-clash/archive/5bb122c9d38bb4a18c80360e0e4aff46cc9e817d.tar.gz version: 0.1.0.0 original: - url: https://github.com/PLSec-VU/pantomime-clash/archive/1f42057f228cd5e476af4b35541598843a7b74f9.tar.gz + url: https://github.com/PLSec-VU/pantomime-clash/archive/5bb122c9d38bb4a18c80360e0e4aff46cc9e817d.tar.gz - completed: name: grisette pantry-tree: diff --git a/test/BenchmarkSpec.hs b/test/BenchmarkSpec.hs index f0e51ea..b77f123 100644 --- a/test/BenchmarkSpec.hs +++ b/test/BenchmarkSpec.hs @@ -82,7 +82,7 @@ mkBenchmarkTest testName _benchmark = (benchmarkInstrument _benchmark) (sim { circuitState = - (Core.init @Identity) + (Core.init @Identity @RegFile) { Core.stateFePc = fromIntegral entryOffset, Core.stateRegFile = modifyRF 2 (pure $ fromIntegral (base + 0x1000000 - 0x1000)) initRF } diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs new file mode 100644 index 0000000..92c708c --- /dev/null +++ b/test/ProofSpec.hs @@ -0,0 +1,1412 @@ +{-# LANGUAGE PackageImports #-} + +module ProofSpec (proofTests, progs, alignedWalk, invTrace, invReport, genProg, genArbSys, genArbSys1, genArbSys2, genArbSys3, genTakenTransfer) where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Clash.Sized.Vector (unsafeFromList) +import Core +import Data.Functor.Identity (Identity (..), runIdentity) +import Proof.Driver +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Instruction +import Proof.Functional.Invariant +import Proof.Machine +import Proof.Functional.Obligation (indStepObligation, indStepObligation1, indStepObligation2, isStartupShape, isaOfG, isaOfHop) +import Memory.Types +import RegFile +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) +import "aimcore" Types +import Prelude hiding (Ordering (..), Word, init, log, map, not, undefined, (!!), (&&), (++), (||)) +import qualified Prelude as P + +-- | A state the driver is meant to be evaluated in: the execute stage holds a +-- real instruction. The startup state (@Nop FirstCycle@) is the one bubble the +-- driver has an explicit case for. Note @Nop DecodeFail@ is /not/ a bubble -- +-- see 'Proof.Machine.isBubble'. +aligned :: Sys -> Bool +aligned s = not (isBubble (exInstr s)) || exInstr s == Nop FirstCycle + +-- | Walk the machine from aligned state to aligned state, taking +-- @driver s + 1@ cycles each hop. +alignedWalk :: Int -> Vec PROG_SIZE Word -> [(Int, Int, Sys)] +alignedWalk k prog = go k 0 (initSys prog) + where + go 0 _ _ = [] + go j i s = + let n = driver s + 1 + s' = stepSysN n s + in (i, n, s') : if running s' then go (j - 1) (i + n) s' else [] + +-- | Hops that do not land on an aligned state. +walkReport :: Int -> Vec PROG_SIZE Word -> String +walkReport k prog = + unlines + [ P.concat + [ " from cycle ", + show i, + " took ", + show n, + " cycles -> ex=", + show (exInstr s'), + " exPc=", + show (stateExPc (sysState s')) + ] + | (i, n, s') <- alignedWalk k prog, + not (aligned s'), + running s' + ] + +-- | The architectural state @prog@ starts in: execution begins at 'initPc', the +-- register file is zeroed, and memory holds the program. The counterpart of +-- 'Proof.Machine.initSys' on the ISA side. +initIsa :: Vec PROG_SIZE Word -> IsaState +initIsa prog = IsaState initPc initRF (mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog) + +-- | The driver and the ISA walked in lockstep. +-- +-- The first hop (out of the startup state) brings the first instruction into +-- the execute stage without the ISA having executed anything, so the ISA state +-- is unchanged across it. Every later hop advances the ISA by one step. +invTrace :: Int -> Vec PROG_SIZE Word -> [(Int, IsaState, Sys)] +invTrace k prog = (0, isa0, sys0) : go k 0 isa0 sys0 True + where + isa0 = initIsa prog + sys0 = initSys prog + + go 0 _ _ _ _ = [] + go j c isa sys firstHop = + let n = driver sys + 1 + c' = c + n + sys' = stepSysN n sys + in if firstHop + then (c', isa, sys') : go (j - 1) c' isa sys' False + else case isaStep isa of + IsaHalted -> [(c', isa, sys')] + Next isa' -> + (c', isa', sys') + : if running sys' then go (j - 1) c' isa' sys' False else [] + +-- | The first point at which the invariant fails, with an explanation. +invReport :: Int -> Vec PROG_SIZE Word -> String +invReport k prog = + case [x | x@(_, isa, sys) <- invTrace k prog, P.not (inv isa sys)] of + [] -> "" + ((c, isa, sys) : _) -> + P.concat + [ "\ninvariant fails at cycle ", + show c, + "\n isaPc=", + show (isaPc isa), + " isaInstr=", + show (isaInstrAt isa), + "\n ex=", + show (exInstr sys), + " exPc=", + show (stateExPc (sysState sys)), + " me=", + show (stateMeInstr (sysState sys)), + " wb=", + show (stateWbInstr (sysState sys)), + "\n halt=", + show (stateHalt (sysState sys)), + "\n", + explain isa sys + ] + +progs :: [(String, Vec PROG_SIZE Word)] +progs = + [ ("prog1 (arith+store)", mkProg prog1), + ("prog2 (load)", mkProg prog2), + ("prog3 (branch)", mkProg prog3), + ("sumTo 10 (loop)", mkProg (sumTo 10)), + ("storeHazardEx (self-modifying)", mkProg storeHazardEx), + ("storeHazardMe (self-modifying)", mkProg storeHazardMe) + ] + +-- | Store hazard raised by the store in the /execute/ stage: it writes to the +-- address currently sitting in decode. Code starts at 'initPc' = 200, so index +-- @k@ lives at @200 + 4k@. Storing @x0@ (always zero) keeps the overwritten +-- word harmless -- it decodes to @Nop DecodeFail@. +storeHazardEx :: Vec 4 Instruction +storeHazardEx = + -- at 200: sw x0, 204(x0) -- targets index 1, which is what decode holds + SType Word 204 0 0 + :> IType (Arith ADD) 1 0 1 + :> IType (Arith ADD) 2 0 2 + :> Instruction.break + :> Nil + +-- | Store hazard raised by the store in the /memory/ stage, one cycle later, +-- while a non-memory instruction is in execute. +storeHazardMe :: Vec 5 Instruction +storeHazardMe = + IType (Arith ADD) 1 0 5 + -- at 204: sw x0, 212(x0) -- targets index 3, reached by decode a cycle later + :> SType Word 212 0 0 + :> IType (Arith ADD) 2 0 2 + :> IType (Arith ADD) 3 0 3 + :> Instruction.break + :> Nil + +-- Random program generation ------------------------------------------------- + +-- | Registers the generated programs use. Kept small so that hazards and +-- forwarding paths are hit often. +genReg :: Gen RegIdx +genReg = chooseBoundedIntegral (0, 7) + +-- | Only encodable instructions that survive a decode round-trip are usable: +-- 'encode' errors otherwise, and the machine executes whatever the memory word +-- decodes to. Anything else is replaced by a harmless @addi x0, x0, 0@. +roundTrips :: Instruction -> Instruction +roundTrips i = + case encode' i of + Just w | decode' w == i -> i + _ -> IType (Arith ADD) 0 0 0 + +-- | A random program of @n@ instructions followed by @ebreak@ padding. +-- +-- Two constraints keep generated programs inside the harness's 400-byte +-- memory: every load and store uses @x0@ as its base with a small immediate, +-- and every branch or jump targets an instruction index inside the program. +genProg :: Gen (Vec PROG_SIZE Word) +genProg = do + n <- choose (1, 12) + body <- P.mapM (genInstr n) [0 .. n - 1] + let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Instruction.break + pure (map encode (unsafeFromList instrs)) + +genInstr :: Int -> Int -> Gen Instruction +genInstr n i = + oneof + [ RType <$> genArith <*> genReg <*> genReg <*> genReg, + IType <$> (Arith <$> genArith) <*> genReg <*> genReg <*> genSmallImm, + -- Loads and stores are pinned to base x0 so addresses stay in the RAM + -- region below the program. + (\size sign rd off -> IType (Load size sign) rd 0 off) + <$> genSize + <*> elements [Signed, Unsigned] + <*> genReg + <*> genDataOff, + (\size off rs2 -> SType size off 0 rs2) <$> genSize <*> genDataOff <*> genReg, + (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] + <*> choose (0, n) + <*> genReg + <*> genReg, + (\rd t -> JType rd (fromIntegral ((t - i) * 4))) <$> genReg <*> choose (0, n), + UType <$> elements [PC, Zero] <*> genReg <*> (fromIntegral <$> choose (0 :: Int, 15)) + ] + where + genArith = elements [ADD, SUB, XOR, OR, AND, SLT, SLTU] + genSize = elements [Byte, Half, Word] + genSmallImm = fromIntegral <$> choose (0 :: Int, 15) + -- Word-aligned offsets well inside the 200-byte RAM region. + genDataOff = (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 40) + +-- | Both checks at once, so a counterexample reports whichever broke. +checkProg :: Int -> Vec PROG_SIZE Word -> String +checkProg k prog = walkReport k prog P.++ invReport k prog + +proofTests :: TestTree +proofTests = + testGroup + "Driver and invariant" + [ -- The base case, on the real 'Vec'-backed reset state. 'Proof.Functional.Induction.baseCase' + -- proves this for an arbitrary memory, but has to substitute the register + -- file (Clash's 'repeat' is opaque to the symbolic executor), so the + -- concrete check is what pins that the state it describes is the one + -- 'Proof.Machine.initSys' actually produces -- including 'Core.init''s reset + -- register file and the loaded program. + testCase "invariant holds at reset" $ + let bad = + [ name + | (name, prog) <- progs, + P.not (inv (initIsa prog) (initSys prog)) + ] + in if P.null bad + then pure () + else assertFailure (P.unlines [n P.++ ":\n" P.++ explain (initIsa prog) (initSys prog) | (n, prog) <- progs, P.elem n bad]), + testProperty "invariant holds at reset for any program" $ + withMaxSuccess 2000 $ + forAll genProg $ \prog -> + counterexample (explain (initIsa prog) (initSys prog)) $ + inv (initIsa prog) (initSys prog), + testGroup + "driver lands on aligned states" + [ testCase name $ + let r = walkReport 40 prog + in if P.null r then pure () else assertFailure ("\n" P.++ r) + | (name, prog) <- progs + ], + testGroup + "invariant holds along the driven walk" + [ testCase name $ + let r = invReport 40 prog + in if P.null r then pure () else assertFailure r + | (name, prog) <- progs + ], + -- The driver's stated invariant, checked directly: from an aligned state, + -- stepping @driver + 1@ cycles is exactly stepping until the execute + -- stage stops being a bubble. + -- + -- @ecall@ / @ebreak@ are excluded because they are terminal: the core + -- halts and the execute stage then holds @Nop Halted@ forever, so there + -- is no next non-bubble for the operational reading to find. + testCase "driver agrees with its operational reading" $ + let bad = + [ (driver sys, ref, exInstr sys) + | prog <- allProgs 500, + (_, _, sys) <- invTrace 40 prog, + running sys, + aligned sys, + P.not (isEnvInstr (exInstr sys)), + let ref = driverRef 12 sys, + ref /= Just (driver sys + 1) + ] + in if P.null bad then pure () else assertFailure (show (P.take 10 bad)), + testProperty "driver and invariant on random programs" $ + withMaxSuccess 2000 $ + forAll genProg $ \prog -> + let r = checkProg 40 prog + in counterexample (show prog P.++ "\n" P.++ r) (P.null r), + testCase "coverage of the checked states" $ + let cov = coverage 2000 + missing = [k | k <- interesting, P.notElem k (P.map P.fst cov)] + in if P.null missing + then pure () + else + assertFailure $ + "\nnever reached: " + P.++ show missing + P.++ "\nreached:\n" + P.++ unlines [" " P.++ k P.++ ": " P.++ show v | (k, v) <- cov], + -- On reachable states, the driven step preserves the invariant. + testCase "inductive on reachable states" $ + let bad = [e | sys <- sampleStates 200, Just e <- [inductiveStep sys]] + in if P.null bad then pure () else assertFailure (P.head bad), + -- A jump spliced into the memory stage. No reachable state has one -- a + -- jump costs three cycles, so it has retired past writeback by the next + -- aligned state -- and nothing else in the invariant rules it out, so this + -- is the only thing constraining the @JType@ / @IType Jump@ clauses of + -- 'Proof.Functional.Invariant.flushMeStage'. It fails if those clauses + -- stop writing @rd@. + testCase "inductive with a jump in the memory stage" $ + let bad = [e | sys <- sampleStates 200, Just e <- [inductiveStep (withJumpInMe sys)]] + in if P.null bad then pure () else assertFailure (P.head bad), + -- The running case is stated as \"neither writeback nor memory holds an + -- environment instruction\", which is the note's four-way split on + -- @isArithOrJumpInstr@ / @isMemInstr@ only because those two predicates + -- partition everything else. If that ever stops being true the collapse is + -- unsound, so check it directly. + testCase "arith-or-jump and mem partition the non-env instructions" $ + let bad = + [ ir + | ir <- allInstrs, + (isArithOrJumpInstr ir || isMemInstr ir) /= P.not (isEnvInstr ir) + ] + in if P.null bad then pure () else assertFailure (show (P.take 5 bad)), + -- The pointwise form is what symbolic execution uses, since function-backed + -- register files and memories have no decidable equality. It must agree + -- with the container form wherever the latter holds, or the witness + -- threading is wrong. + testCase "pointwise invariant agrees with the container form" $ + let bad = + [ (c, wr, wa) + | prog <- allProgs 25, + (c, isa, sys) <- invTrace 40 prog, + inv isa sys, + wr <- [0 .. 31], + wa <- [0, 16 .. 396], + P.not (invAt wr wa isa sys) + ] + in if P.null bad then pure () else assertFailure (show (P.take 5 bad)), + -- The fold-free invariant is what the plugin runs on; it must agree with + -- the named-conjunct version everywhere, or the two paths are checking + -- different things. + testCase "fold-free invariant agrees with the list version" $ + let bad = + [ (c, wr, wa) + | prog <- allProgs 25, + (c, isa, sys) <- invTrace 40 prog, + wr <- [0 .. 31], + wa <- [0, 16 .. 396], + invAt wr wa isa sys /= invAtFree wr wa isa sys + ] + in if P.null bad then pure () else assertFailure (show (P.take 5 bad)), + -- The fifth counterexample of the earlier proof: a store whose byte range + -- sits in (or wraps into) a PC word at the top of the address space. See + -- the comment above 'wrapCESys'. That proof excluded this state by + -- assumption; the core now handles it, so the state must survive its hop + -- on its own. This is the regression test for the address-overlap fix. + testCase "wrap-around aliasing store is handled by the core" $ do + let sys = wrapCESys + wr = 1 + wa = 0xFFFFFFFD + isa = isaFromSys sys + sys' = stepSysN (driver sys P.+ 1) sys + isa' = case isaStep isa of Next x -> x; IsaHalted -> isa + assertBool "state satisfies the invariant" (invAtFree wr wa isa sys) + assertBool + "decode stalls on the store hazard rather than taking a one-cycle hop" + (driver sys P./= 0) + assertBool + "the driven hop preserves the invariant" + (invAtFree wr wa isa' sys'), + testProperty "inductive step on arbitrary pipeline states" $ + -- 1e6 has been run by hand (60s, no counterexample); 20k keeps the + -- suite fast. + -- 1e6 run by hand: 27s, zero discards, no counterexample. + -- 1e6 re-run by hand after the wrap-around fix, with the generator + -- extended to wrapping memory layouts, boundary-straddling PCs, + -- near-PC store addresses, and branches/memory ops in decode: 25s, + -- no counterexample. + withMaxSuccess 20000 $ + forAllShow genArbSys (\_ -> "") $ \(sys, wr, wa) -> + let isa = isaFromSys sys + sys' = stepSys sys + isa' = case isaStep isa of Next x -> x; IsaHalted -> isa + in counterexample + ( "me=" P.++ show (stateMeInstr (sysState sys)) + P.++ "\nwb=" P.++ show (stateWbInstr (sysState sys)) + P.++ "\nex=" P.++ show (exInstr sys) + P.++ "\nexPc=" P.++ show (stateExPc (sysState sys)) + P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa + P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' sys')))) + ) + (indStepObligation wr wa sys), + -- k = 1: the two-cycle hop. Both shapes that reach it are generated; + -- 'coverage1' asserts each is actually sampled, since a premise this + -- specific is easy to miss entirely and still see a green property. + testProperty "k=1 inductive step on arbitrary pipeline states" $ + -- 1e6 run by hand: 23s, no counterexample. 20k keeps the suite fast. + withMaxSuccess 20000 $ + forAllShow genArbSys1 (\_ -> "") $ \(sys, wr, wa) -> + let isa = isaOfHop sys + s2 = stepSysN 2 sys + isa' = case isaStep isa of Next x -> x; IsaHalted -> isa + in counterexample + ( "startupShape=" P.++ show (isStartupShape sys) + P.++ "\nme=" P.++ show (stateMeInstr (sysState sys)) + P.++ "\nwb=" P.++ show (stateWbInstr (sysState sys)) + P.++ "\nex=" P.++ show (exInstr sys) + P.++ "\nexPc=" P.++ show (stateExPc (sysState sys)) + P.++ " fePc=" P.++ show (stateFePc (sysState sys)) + P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa + P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' s2)))) + ) + (indStepObligation1 wr wa sys), + testCase "k=1 generator reaches both hop shapes" $ + let sample = [s | (s, _, _) <- unGen (vectorOf 4000 genArbSys1) (mkQCGen 7) 30] + admitted p = + [ () + | s <- sample, + p s, + driver s P.== 1, + invAtFree 1 0 (isaOfHop s) s + ] + startups = admitted isStartupShape + steadies = admitted (P.not . isStartupShape) + in do + assertBool "no startup state satisfied the k=1 premise" (P.not (P.null startups)) + assertBool "no steady state satisfied the k=1 premise" (P.not (P.null steadies)), + -- Why 'isaOfHop' exists: deriving the architectural PC from the execute + -- stage, as 'isaOfG' does, leaves a startup state satisfying no case of + -- the invariant at all -- so the k=1 obligation would hold vacuously + -- there rather than saying anything. + testCase "startup states need the fetch-stage PC to be admitted" $ + let sample = [s | (s, _, _) <- unGen (vectorOf 2000 genArbSys1) (mkQCGen 11) 30, isStartupShape s] + admits f s = invAtFree 1 0 (f s) s + in do + assertBool "generator produced no startup states" (P.not (P.null sample)) + assertBool + "isaOfHop should admit some startup state" + (P.any (admits isaOfHop) sample) + assertBool + "isaOfG should admit no startup state (that is why isaOfHop exists)" + (P.not (P.any (admits isaOfG) sample)), + -- k = 2: jumps and the all-memory steady shape return to a running + -- invariant case after three core cycles; ecall/ebreak return to one of + -- the two halted cases. + testProperty "k=2 inductive step on arbitrary pipeline states" $ + withMaxSuccess 20000 $ + forAllShow genArbSys2 (\_ -> "") $ \(label, sys, wr, wa) -> + counterexample + ( "case=" P.++ label + P.++ " driverCase=" P.++ driverCaseName sys + P.++ "\nme=" P.++ show (stateMeInstr (sysState sys)) + P.++ "\nwb=" P.++ show (stateWbInstr (sysState sys)) + P.++ "\nex=" P.++ show (exInstr sys) + P.++ "\nexPc=" P.++ show (stateExPc (sysState sys)) + P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa + ) + (indStepObligation2 wr wa sys), + testCase "k=2 generator reaches env, jump, and steady cases" $ + let sample = + [ (label, driverCaseName s) + | (label, s, wr, wa) <- + unGen (vectorOf 4000 genArbSys2) (mkQCGen 29) 30, + driver s P.== 2, + invAtFree wr wa (isaOfG s) s + ] + has label = P.any ((P.== label) . P.fst) sample + in do + assertBool "no env k=2 state satisfied the premise" (has "env") + assertBool "no jump k=2 state satisfied the premise" (has "jump") + assertBool "no steady k=2 state satisfied the premise" (has "steady"), + testCase "jumps never occupy me/wb at a checked state" $ + let bad = + [ (shape (stateMeInstr (sysState sys)), shape (stateWbInstr (sysState sys))) + | prog <- allProgs 2000, + (_, _, sys) <- invTrace 40 prog, + isJumpShape (stateMeInstr (sysState sys)) || isJumpShape (stateWbInstr (sysState sys)) + ] + in if P.null bad then pure () else assertFailure (show (P.take 5 bad)) + ] + +-- Inductiveness probes ------------------------------------------------------- +-- +-- Being *inductive* means: for every (isa, sys) satisfying the invariant, the +-- driven step preserves it. That quantifier ranges over all states the +-- invariant admits, not just those reachable from startup. So a state that +-- cannot actually occur still has to be handled -- and that is where the +-- invariant as written comes apart. + +-- | The architectural state that makes the flush conjunct hold at @sys@ by +-- construction. If @sys@ is an aligned running state, this is the ISA state the +-- invariant claims it corresponds to. +-- Shared with 'Proof.Functional.Induction.indStep0' via "Proof.Functional.Obligation", so the two cannot drift. +isaFromSys :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m +isaFromSys = isaOfG + +-- | Take one driven step and report whether the invariant survived. Returns +-- 'Nothing' when @sys@ does not satisfy the invariant to begin with (such a +-- state is not a counterexample to inductiveness). +inductiveStep :: Sys -> Maybe String +inductiveStep sys + | P.not (P.any holdsCase (invCases isa sys)) = Nothing + | inv' isa' sys' = Nothing + | otherwise = Just (explain isa' sys') + where + isa = isaFromSys sys + sys' = stepSysN (driver sys + 1) sys + isa' = case isaStep isa of + Next i -> i + IsaHalted -> isa + inv' a s = P.any holdsCase (invCases a s) + holdsCase c = P.all P.snd (caseConjuncts c) + +-- | Aligned, running states drawn from the programs under test. +sampleStates :: Int -> [Sys] +sampleStates n = + [ sys + | prog <- allProgs n, + (_, _, sys) <- invTrace 40 prog, + running sys, + aligned sys, + P.not (isEnvInstr (exInstr sys)) + ] + +-- | Put a jump in the memory stage. The invariant permits this -- a jump is not +-- a memory instruction, so @isMemInstr me == False@ is satisfied -- but it can +-- never actually occur, so nothing else in the invariant rules it out. +withJumpInMe :: Sys -> Sys +withJumpInMe s = + s {sysState = (sysState s) {stateMeInstr = JType 5 0, stateMeRes = pure 0x1234}} + +-- | One instruction per constructor shape the invariant's predicates +-- distinguish, so the partition check covers every branch of both. +allInstrs :: [Instruction] +allInstrs = + [ RType ADD 1 2 3, + IType (Arith ADD) 1 2 3, + IType (Load Word Signed) 1 2 3, + SType Word 0 1 2, + BType NE 0 1 2, + JType 1 0, + IType Jump 1 2 3, + UType Zero 1 0, + IType (Env Call) 0 0 0, + IType (Env Break) 0 0 0 + ] + P.++ P.map + Nop + [ JumpFirstCycle, + JumpSecondCycle, + LoadHazardFirstCycle, + LoadHazardSecondCycle, + StoreHazardFirstCycle, + StoreHazardSecondCycle, + MemoryBusBusy, + DecodeFail, + FirstCycle, + Halted + ] + +-- The fifth counterexample, explained: address wraparound --------------------- +-- +-- History, kept because it is what this state tests. The earlier proof excluded +-- aliasing stores by assumption, and that assumption first checked +-- +-- > clashes p = a < p + 4 && p < a + n +-- +-- in 'Unsigned 32' arithmetic. Both @p + 4@ and @a + n@ wrap: with a PC word +-- at the top of the address space (@p = 0xFFFFFFFC@), @a < p + 4@ is @a < 0@, +-- which is false for EVERY store address -- so a store into that word passed +-- the assumption. Likewise a word store at @0xFFFFFFFE@ writes bytes +-- @0xFFFFFFFE..0x00000001@, wrapping into a low PC word without ever +-- satisfying @p < a + n@. +-- +-- There is no assumption now: 'Instruction.storeHazard' is wrap-correct and +-- 'Core.decode' stalls on the overlap, so this state has to survive its hop. +-- +-- This state realises the mechanism concretely: the pipeline sits astride the +-- wrap (exPc = 0xFFFFFFF8, dePc = 0xFFFFFFFC, fePc = 0), and the memory-stage +-- store writes one byte into the middle of the decode-stage instruction word. +-- The invariant holds, the driver picks the one-cycle hop, and after the step +-- @ex == decode (mem[isaPc])@ is gone: the core executes the instruction it +-- latched before the store, while the architectural memory now holds the +-- stored-over word. +wrapExWord, wrapDeWord :: Word +wrapExWord = encode (IType (Arith ADD) 1 0 16) -- addi x1, x0, 16 +wrapDeWord = encode (IType (Arith ADD) 2 0 1) -- addi x2, x0, 1 + +wrapMem :: MemFn +wrapMem = MemFn bytes + where + bytes a + | a - 0xFFFFFFF8 P.< 4 = byteAt wrapExWord (a - 0xFFFFFFF8) + | a - 0xFFFFFFFC P.< 4 = byteAt wrapDeWord (a - 0xFFFFFFFC) + | P.otherwise = 0 + byteAt w k = case k of + 0 -> slice d7 d0 w + 1 -> slice d15 d8 w + 2 -> slice d23 d16 w + _ -> slice d31 d24 w + +wrapCESys :: SysG RegFn MemFn +wrapCESys = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = 0x00000000, + stateDePc = 0xFFFFFFFC, + stateExPc = 0xFFFFFFF8, + stateExInstr = decode' wrapExWord, + -- The store's address and value live in stateMeAddr / stateMeRes; + -- its operand fields are already spent by the time it reaches the + -- memory stage. + stateMeInstr = SType Types.Byte 0 0 0, + stateWbInstr = Nop MemoryBusBusy, + stateMeRes = pure 0, -- the byte written: 0x00, over 0x01 + stateWbRes = pure 0, + stateMeAddr = 0xFFFFFFFD, -- second byte of the decode-stage word + stateRegFile = RegFn (const (pure 0)), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + (Input True (pure wrapDeWord)) + wrapMem + +-- Arbitrary-state search ------------------------------------------------------ +-- +-- The counterexamples symbolic execution finds are all UNREACHABLE states, so +-- walking well-formed programs will never produce them. Generating arbitrary +-- pipeline states directly does, and gives a shrinkable executable example +-- instead of a model to hand-decode. +-- +-- States are built to satisfy the invariant's structural conjuncts by +-- construction (PCs three words apart, ex latched from mem[exPc], inputMem +-- from mem[dePc]) so the premise is not discarded; everything else is random. +-- +-- 'stateCtrl' is left at 'initCtrl' soundly: 'Core.pipe' is wrapped in +-- 'Core.withCtrlReset', which overwrites it before any stage reads it, so the +-- incoming value cannot affect 'Proof.Machine.stepSys'. + +-- | Instruction generators that build in the premise's constraints, rather than +-- generating freely and filtering. Filtering discarded ~6 examples per hit, +-- which wastes work and -- worse -- can bias the sample rather than thin it. + +gr3 :: Gen RegIdx +gr3 = chooseBoundedIntegral (0, 3) + +gi15 :: Gen Imm +gi15 = fromIntegral <$> choose (0 :: Int, 15) + +grAvoiding :: [RegIdx] -> Gen RegIdx +grAvoiding bad = chooseBoundedIntegral (0, 3) `suchThat` (\r -> P.notElem r bad) + +-- | Non-memory instructions: what @driver == 0@ requires of the writeback +-- stage (@isMemInstr wb == False@). +genNonMem :: Gen Instruction +genNonMem = + oneof + [ RType <$> elements [ADD, SUB, XOR, AND, SLT] <*> gr3 <*> gr3 <*> gr3, + (\op rd rs i -> IType (Arith op) rd rs i) <$> elements [ADD, XOR] <*> gr3 <*> gr3 <*> gi15, + UType <$> elements [Zero, PC] <*> gr3 <*> (fromIntegral <$> choose (0 :: Int, 15)), + JType <$> gr3 <*> (fromIntegral <$> choose (0 :: Int, 15)), + (\rd rs i -> IType Jump rd rs i) <$> gr3 <*> gr3 <*> gi15, + P.pure (Nop MemoryBusBusy) + ] + +-- | The decode-stage instruction. Unlike the writeback stage, nothing under +-- @driver == 0@ restricts it, so loads, stores and branches belong in the +-- sample too; a load-use hazard against an execute-stage load is what the +-- caller filters, and anything else the premise discards is a few wasted +-- samples, not a soundness issue. +genDeInstr :: Gen Instruction +genDeInstr = + frequency + [ (3, genNonMem), + ( 1, + (\sz sg rd rs i -> IType (Load sz sg) rd rs i) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> gr3 + <*> gr3 + <*> gi15 + ), + ( 1, + (\sz i r1 r2 -> SType sz i r1 r2) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> gi15 + <*> gr3 + <*> gr3 + ), + ( 1, + (\cmp t r1 r2 -> BType cmp (fromIntegral (2 * t :: Int)) r1 r2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] + <*> choose (0, 7) + <*> gr3 + <*> gr3 + ) + ] + +-- | The execute stage under @driver == 0@: no environment instruction and no +-- jump, both of which the driver routes to a longer hop. Excluding them is +-- exact for k = 0, not a coverage compromise. +genExInstr :: Gen Instruction +genExInstr = + oneof + [ RType <$> elements [ADD, SUB, XOR, AND, SLT] <*> gr3 <*> gr3 <*> gr3, + (\op rd rs i -> IType (Arith op) rd rs i) <$> elements [ADD, XOR] <*> gr3 <*> gr3 <*> gi15, + (\sz sg rd rs i -> IType (Load sz sg) rd rs i) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> elements [Signed, Unsigned] <*> gr3 <*> gr3 <*> gi15, + (\sz i r1 r2 -> SType sz i r1 r2) + <$> elements [Types.Byte, Types.Half, Types.Word] <*> gi15 <*> gr3 <*> gr3, + UType <$> elements [Zero, PC] <*> gr3 <*> (fromIntegral <$> choose (0 :: Int, 15)), + -- Branches are admissible under @driver == 0@ when not taken; taken ones + -- are discarded by the premise, which just costs a few samples. The + -- immediate is kept even so 'roundTrips' preserves the shape. + (\cmp t r1 r2 -> BType cmp (fromIntegral (2 * t :: Int)) r1 r2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] <*> choose (0, 7) <*> gr3 <*> gr3, + P.pure (Nop MemoryBusBusy) + ] + +-- | The memory stage. A load's destination avoids the execute stage's sources, +-- so the load-use hazard the invariant forbids is excluded by construction. +genMeInstr :: Instruction -> Gen Instruction +genMeInstr exI = + oneof + [ genNonMem, + (\sz sg rd rs i -> IType (Load sz sg) rd rs i) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> grAvoiding srcs <*> gr3 <*> gi15, + (\sz i r1 r2 -> SType sz i r1 r2) + <$> elements [Types.Byte, Types.Half, Types.Word] <*> gi15 <*> gr3 <*> gr3 + ] + where + srcs = P.concat [getRs1 exI, getRs2 exI] + +genW :: Gen Word +genW = fromInteger <$> choose (0, 2 P.^ (32 :: Int) - 1) + +genFn :: (P.Eq k) => Gen k -> Gen v -> Gen v -> Gen (k -> v) +genFn gk gv gd = do + n <- choose (0 :: Int, 10) + ps <- vectorOf n ((,) <$> gk <*> gv) + d <- gd + P.pure (\k -> P.maybe d P.id (P.lookup k ps)) + +-- | A pipeline state satisfying the premise of the k = 0 obligation by +-- construction: PCs three words apart, ex latched from mem[exPc], inputMem +-- from mem[dePc], writeback non-memory, execute neither environment nor jump, +-- no load-use hazard, no halt in flight. +-- +-- 'stateCtrl' is left at 'initCtrl' soundly: 'Core.pipe' is wrapped in +-- 'Core.withCtrlReset', which overwrites it before any stage reads it. +genArbSys :: Gen (SysG RegFn MemFn, RegIdx, Address) +genArbSys = do + -- Occasionally sit the pipeline astride the top of the address space: the + -- fifth symbolic counterexample lived there, and the non-wrapping memory + -- layout this generator previously used made the premise unsatisfiable in + -- exactly that region, hiding it from the search. + base <- + frequency + [ (7, unpack <$> genW), + (1, elements [0xFFFFFFF4, 0xFFFFFFF8, 0xFFFFFFFC]) + ] + exI <- genExInstr + meI <- genMeInstr exI + nextI <- case exI of + IType (Load _ _) rd _ _ -> + suchThat genDeInstr (\i -> P.notElem rd (P.concat [getRs1 i, getRs2 i])) + _ -> genDeInstr + wbI <- genNonMem + let w0 = P.maybe 0 P.id (encode' (roundTrips exI)) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + w2 <- genW + extra <- genFn (unpack <$> genW) (fromIntegral <$> choose (0 :: Int, 255)) (P.pure 0) + let byteOf w k = case k of + 0 -> slice d7 d0 w + 1 -> slice d15 d8 w + 2 -> slice d23 d16 w + _ -> slice d31 d24 w + -- Wrapping comparisons: @a - base < 4@ is the wrap-correct form of + -- @base <= a && a < base + 4@, so the three-instruction window stays + -- intact when it straddles 0xFFFFFFFF -> 0. + memf a + | a - base P.< 4 = byteOf w0 (a - base) + | a - base P.< 8 = byteOf w1 (a - base - 4) + | a - base P.< 12 = byteOf w2 (a - base - 8) + | P.otherwise = extra a + rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW + mr <- genW + wbr <- genW + -- Store addresses near the PC window (including partial overlaps and, when + -- the window straddles the wrap, wrapped byte ranges) are where the + -- store-alias corner cases live; a uniform address almost never lands there. + ma <- + frequency + [ (1, unpack <$> genW), + (1, (\d -> base + fromIntegral (d :: Int) - 8) <$> choose (0, 24)) + ] + wr <- frequency [(3, chooseBoundedIntegral (0, 3)), (1, chooseBoundedIntegral (0, 31))] + wa <- unpack <$> genW + let sys = + Sys + ((sysState (initSys (mkProg prog1))) + { stateFePc = base + 8, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = ma, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + }) + (Input True (pure w1)) + (MemFn memf) + P.pure (sys, wr, wa) + +-- | States the driver sends on a two-cycle hop, i.e. @driver == 1@. Two shapes +-- reach it, and they are generated separately because their invariant cases +-- constrain the fetch path differently: +-- +-- * startup -- every stage holds @Nop FirstCycle@ and nothing is on the bus; +-- * steady with a memory instruction in writeback -- it occupied the bus +-- last cycle, so no instruction was fetched and @fePc == exPc + 4@. +genArbSys1 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genArbSys1 = oneof [genStartup1, genSteady1] + +-- | Arbitrary running states sent on a three-cycle hop. The three satisfiable +-- driver branches are generated separately: +-- +-- * an environment instruction; +-- * a taken jump (JAL is unconditionally taken); +-- * memory instructions in both writeback and memory, with a non-memory +-- execute instruction. +-- +-- The driver's @storeHazard/nomem@ branch used to be an empty proof case: the +-- old pre-state aliasing assumption rejected even a one-byte overlap with the +-- decode-stage word, so no state could reach it. With that assumption gone the +-- branch is reachable and wants generator coverage. +genArbSys2 :: Gen (String, SysG RegFn MemFn, RegIdx, Address) +genArbSys2 = + oneof + [ genRunning2 "env" $ + elements + [ IType (Env Call) 0 0 0, + IType (Env Break) 0 0 0 + ], + genRunning2 "jump" $ + JType <$> gr3 <*> (fromIntegral . (2 *) <$> choose (0 :: Int, 7)), + genSteady2 + ] + +-- | Environment and jump states permit arbitrary earlier pipeline shapes. +-- Fetch-input shape follows writeback exactly as the invariant requires. +genRunning2 :: + String -> + Gen Instruction -> + Gen (String, SysG RegFn MemFn, RegIdx, Address) +genRunning2 label genEx = do + base <- genBase + ex0 <- genEx + let exI = roundTrips ex0 + meI <- genMeInstr exI + wbI <- oneof [genNonMem, genMemInstr] + nextI <- genDeInstr + let w0 = P.maybe 0 P.id (encode' exI) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + w2 <- genW + (memf, _) <- genMemWindow base w0 w1 w2 + rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW + mr <- genW + wbr <- genW + loaded <- genW + -- Keep memory-stage stores away from all three PC words so the non-alias + -- premise is exercised rather than making those samples vacuous. + let ma = base + 64 + wbMem = isMemInstr wbI + inp = if wbMem then Input False (pure loaded) else Input True (pure w1) + fePc = if wbMem then base + 4 else base + 8 + wr <- genWitnessReg + wa <- unpack <$> genW + let sys = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = fePc, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = ma, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + inp + (MemFn memf) + P.pure (label, sys, wr, wa) + +-- | The steady @wb=memory, me=memory, ex=non-memory@ branch. +genSteady2 :: Gen (String, SysG RegFn MemFn, RegIdx, Address) +genSteady2 = do + base <- genBase + exI <- + oneof + [ RType <$> elements [ADD, SUB, XOR, AND, SLT] <*> gr3 <*> gr3 <*> gr3, + (\op rd rs i -> IType (Arith op) rd rs i) + <$> elements [ADD, XOR] <*> gr3 <*> gr3 <*> gi15, + UType <$> elements [Zero, PC] <*> gr3 <*> (fromIntegral <$> choose (0 :: Int, 15)), + P.pure (Nop MemoryBusBusy) + ] + meI <- + oneof + [ (\sz sg rd rs i -> IType (Load sz sg) rd rs i) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> grAvoiding (P.concat [getRs1 exI, getRs2 exI]) + <*> gr3 + <*> gi15, + (\sz i r1 r2 -> SType sz i r1 r2) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> gi15 + <*> gr3 + <*> gr3 + ] + wbI <- genMemInstr + nextI <- genDeInstr + let w0 = P.maybe 0 P.id (encode' (roundTrips exI)) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + w2 <- genW + (memf, _) <- genMemWindow base w0 w1 w2 + rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW + mr <- genW + wbr <- genW + loaded <- genW + wr <- genWitnessReg + wa <- unpack <$> genW + let sys = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = base + 4, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = base + 64, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + (Input False (pure loaded)) + (MemFn memf) + P.pure ("steady", sys, wr, wa) + +-- | The startup shape. @fePc@ is where the ISA's PC sits, and the pipeline is +-- empty, so no memory word is pinned to any stage. +genStartup1 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genStartup1 = do + fePc <- genBase + firstI <- genNonMem + nextI <- genDeInstr + let w0 = P.maybe 0 P.id (encode' (roundTrips firstI)) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + w2 <- genW + (memf, _) <- genMemWindow fePc w0 w1 w2 + rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW + wr <- genWitnessReg + wa <- unpack <$> genW + let sys = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = fePc, + -- The other PCs are unconstrained by the startup case; give + -- them junk so nothing accidentally relies on them. + stateDePc = 0, + stateExPc = 0, + stateExInstr = Nop FirstCycle, + stateMeInstr = Nop FirstCycle, + stateWbInstr = Nop FirstCycle, + stateMeRes = pure 0, + stateWbRes = pure 0, + stateMeAddr = 0, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + (Input False (pure 0)) + (MemFn memf) + P.pure (sys, wr, wa) + +-- | The steady two-cycle shape: a load or store in writeback, a non-memory +-- instruction in the memory stage. Nothing is on the bus this cycle, so +-- @inputMem@ is the value the writeback-stage load reads, not an instruction. +genSteady1 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genSteady1 = do + base <- genBase + exI <- genExInstr + meI <- suchThat genNonMem (\i -> P.not (loadHazard exI i)) + wbI <- genMemInstr + nextI <- genDeInstr + let w0 = P.maybe 0 P.id (encode' (roundTrips exI)) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + w2 <- genW + (memf, _) <- genMemWindow base w0 w1 w2 + rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW + mr <- genW + wbr <- genW + -- The word the writeback-stage load takes its value from. + loaded <- genW + ma <- genStoreAddr base + wr <- genWitnessReg + wa <- unpack <$> genW + let sys = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = base + 4, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = ma, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + (Input False (pure loaded)) + (MemFn memf) + P.pure (sys, wr, wa) + +-- | Loads and stores, for the writeback stage of a @k = 1@ steady state. +genMemInstr :: Gen Instruction +genMemInstr = + oneof + [ (\sz sg rd rs i -> IType (Load sz sg) rd rs i) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> gr3 + <*> gr3 + <*> gi15, + (\sz i r1 r2 -> SType sz i r1 r2) + <$> elements [Types.Byte, Types.Half, Types.Word] + <*> gi15 + <*> gr3 + <*> gr3 + ] + +-- | A PC base, biased towards the top of the address space so hops that +-- straddle the 0xFFFFFFFF -> 0 wrap are sampled. See the wrap-around note on +-- 'genArbSys'. +genBase :: Gen Address +genBase = + frequency + [ (7, unpack <$> genW), + (1, elements [0xFFFFFFF4, 0xFFFFFFF8, 0xFFFFFFFC]) + ] + +-- | Three instruction words at @base@, @base+4@, @base+8@ over arbitrary +-- background bytes, with wrap-correct bounds. +genMemWindow :: Address -> Word -> Word -> Word -> Gen (Address -> Byte, ()) +genMemWindow base w0 w1 w2 = do + extra <- genFn (unpack <$> genW) (fromIntegral <$> choose (0 :: Int, 255)) (P.pure 0) + let byteOf w k = case k of + 0 -> slice d7 d0 w + 1 -> slice d15 d8 w + 2 -> slice d23 d16 w + _ -> slice d31 d24 w + memf a + | a - base P.< 4 = byteOf w0 (a - base) + | a - base P.< 8 = byteOf w1 (a - base - 4) + | a - base P.< 12 = byteOf w2 (a - base - 8) + | P.otherwise = extra a + P.pure (memf, ()) + +-- | Store addresses biased into the PC window, where the aliasing corner cases +-- live. +genStoreAddr :: Address -> Gen Address +genStoreAddr base = + frequency + [ (1, unpack <$> genW), + (1, (\d -> base + fromIntegral (d :: Int) - 8) <$> choose (0, 24)) + ] + +genWitnessReg :: Gen RegIdx +genWitnessReg = + frequency [(3, chooseBoundedIntegral (0, 3)), (1, chooseBoundedIntegral (0, 31))] + +isJumpShape :: Instruction -> Bool +isJumpShape (JType _ _) = True +isJumpShape (IType Jump _ _ _) = True +isJumpShape _ = False + +-- | Every program the tests check the invariant on: the hand-written ones plus +-- a deterministic sample of the generator. +allProgs :: Int -> [Vec PROG_SIZE Word] +allProgs n = + P.map P.snd progs + P.++ [unGen genProg (mkQCGen k) 30 | k <- [1 .. n]] + +-- | Which driver cases, and which memory-/writeback-stage instruction shapes, +-- the tests actually exercise at the states where the invariant is checked. +coverage :: Int -> [(String, Int)] +coverage n = tally (P.concatMap observations (allProgs n)) + where + observations prog = + P.concat + [ [ "driver:" P.++ driverCaseName sys, + "me:" P.++ shape (stateMeInstr (sysState sys)), + "wb:" P.++ shape (stateWbInstr (sysState sys)) + ] + | (_, _, sys) <- invTrace 40 prog + ] + tally xs = P.foldr bump [] xs + bump x [] = [(x, 1)] + bump x ((y, c) : rest) + | x == y = (y, c + 1) : rest + | otherwise = (y, c) : bump x rest + +-- | A coarse name for an instruction, for coverage purposes. +shape :: Instruction -> String +shape = \case + RType {} -> "RType" + IType (Arith _) _ _ _ -> "IType/Arith" + IType (Load _ _) _ _ _ -> "IType/Load" + IType Jump _ _ _ -> "IType/Jump" + IType (Env _) _ _ _ -> "IType/Env" + SType {} -> "SType" + BType {} -> "BType" + UType {} -> "UType" + JType {} -> "JType" + Nop _ -> "Nop" + +-- | Cases we want the random programs to actually reach. If any of these is +-- never hit, the passing property above says less than it appears to. +interesting :: [String] +interesting = + [ "driver:firstCycle", + "driver:env", + "driver:jump", + "driver:storeHazard/mem", + "driver:storeHazard/nomem", + "driver:loadHazard", + "driver:steady/wb-nomem", + "driver:steady/me-nomem", + "driver:steady/ex-nomem", + "driver:steady/all-mem", + "me:IType/Load", + "me:SType", + "wb:IType/Load", + "wb:SType" + ] + +prog1 :: Vec 3 Instruction +prog1 = + IType (Arith ADD) 2 0 5 + :> SType Word 0 0 2 + :> Instruction.break + :> Nil + +prog2 :: Vec 6 Instruction +prog2 = + IType (Arith ADD) 2 0 5 + :> SType Word 0 0 2 + :> IType (Load Word Signed) 3 0 0 + :> RType ADD 4 0 3 + :> SType Word 4 0 4 + :> Instruction.break + :> Nil + +prog3 :: Vec 6 Instruction +prog3 = + IType (Arith ADD) 2 0 3 + :> RType ADD 3 0 2 + :> BType EQ 8 2 3 + :> SType Word 0 0 2 + :> SType Word 4 0 2 + :> Instruction.break + :> Nil + +sumTo :: Int -> Vec 8 Instruction +sumTo n = + unsafeFromList + [ IType (Arith ADD) 1 0 (fromIntegral n), + IType (Arith ADD) 2 0 0, + BType EQ 16 1 0, + RType ADD 2 2 1, + IType (Arith ADD) 1 1 (-1), + JType 0 (-12), + SType Word 0 0 2, + Instruction.break + ] + +-- Targeted generators for the transfer and four-cycle shapes --------------------- +-- +-- 'genArbSys2' puts only a @JType@ in the execute stage, so a taken branch and +-- a @jalr@ -- the transfers whose target is data dependent -- need generators +-- of their own, as does the four-cycle hop. + +-- | A k=2 state whose execute stage is a /taken/ transfer: a branch whose +-- comparison holds, or a @jalr@. +genTakenTransfer :: Bool -> Gen (SysG RegFn MemFn, RegIdx, Address) +genTakenTransfer useJalr = do + -- Small base: a @jalr@ target has to fit a sign-extended 12-bit immediate to + -- be representable, and the target sits near the base. + base <- (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 200) + rs1 <- genSmallReg + rs2 <- genSmallReg + rd <- genSmallReg + delta <- (\k -> fromIntegral (k * 4)) <$> choose (-3 :: Int, 7) + meI <- genStageInstr + wbI <- genStageInstr + nextI <- genStageInstr + tgtI <- genStageInstr + rfF <- genFn genSmallReg genW genW + mr <- genW + wbr <- genW + loaded <- genW + wr <- genSmallReg + wa <- unpack <$> genW + + let target = base + delta + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + wT = P.maybe 0 P.id (encode' (roundTrips tgtI)) + wbMem = isLoad wbI || isStore wbI + inp = if wbMem then Input False (pure loaded) else Input True (pure w1) + fePc = if wbMem then base + 4 else base + 8 + ma = base + 4096 -- parked away from every PC and from the target + + mkSys w0 rfun = + Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = fePc, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = ma, + stateRegFile = RegFn (P.fmap Identity rfun), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + inp + (MemFn (memFor w0)) + where + memFor w a + | a - base P.< 4 = byteAt w (a - base) + | a - base P.< 8 = byteAt w1 (a - base - 4) + | a - target P.< 4 = byteAt wT (a - target) + | P.otherwise = 0 + + -- Probe the forwarded operands; 'Proof.Driver.exArg' never reads the execute + -- stage, so a provisional instruction there makes the probe exact. + let probe = mkSys 0 rfF + v1 = exArg probe rs1 + v2 = exArg probe rs2 + + if useJalr + then do + immv <- (\k -> fromIntegral (k * 2)) <$> choose (0 :: Int, 15) + let need = pack target - signExtend (immv :: Imm) + rfun i = if i P.== rs1 then need else rfF i + w0 = P.maybe 0 P.id (encode' (roundTrips (IType Jump rd rs1 immv))) + P.pure (mkSys w0 rfun, wr, wa) + else do + let cmp = if v1 P.== v2 then EQ else NE + w0 = P.maybe 0 P.id (encode' (roundTrips (BType cmp (fromIntegral (delta :: Address)) rs1 rs2))) + P.pure (mkSys w0 rfF, wr, wa) + +-- | States the driver sends on a four-cycle hop: a load-use hazard with the +-- incoming instruction, and memory instructions in all three older stages. The +-- store-hazard route into this case is reachable too, now that the aliasing +-- assumption is gone, and is not yet generated here. +genArbSys3 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genArbSys3 = oneof [genLoadHazard3, genAllMem3] + +genLoadHazard3 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genLoadHazard3 = do + base <- genBase + -- Full register range, not just 0..3: @ecall@ reads x17 and writes x10, so a + -- load into one of those is the only way an environment instruction can be + -- the one the hazard fires on. + rd <- frequency [(3, chooseBoundedIntegral (1, 3)), (1, elements [10, 17]), (1, chooseBoundedIntegral (1, 31))] + sz <- genStageSize + sg <- elements [Signed, Unsigned] + rs1 <- genSmallReg + let exI = roundTrips (IType (Load sz sg) rd rs1 0) + -- The incoming instruction must read rd; that is what makes the hazard. + nextI <- + oneof + [ (\op rd' r2 -> RType op rd' rd r2) <$> elements [ADD, SUB, XOR] <*> genSmallReg <*> genSmallReg, + (\op rd' -> IType (Arith op) rd' rd 0) <$> elements [ADD, XOR] <*> genSmallReg, + (\szz r2 -> SType szz 0 rd r2) <$> genStageSize <*> genSmallReg, + (\cmp r2 -> BType cmp 0 rd r2) <$> elements [EQ, NE, LT] <*> genSmallReg, + (\szz sgg rd' -> IType (Load szz sgg) rd' rd 0) <$> genStageSize <*> elements [Signed, Unsigned] <*> genSmallReg, + (\rd' -> IType Jump rd' rd 0) <$> genSmallReg, + P.pure (IType (Env Call) 0 0 0), + -- An @ebreak@ whose encoded rs1 is the load's destination. + -- 'Instruction.getRs1' reports that field -- it hardcodes x17 only for + -- @ecall@ -- so this is a genuine load-use hazard. + P.pure (IType (Env Break) 0 rd 1) + ] + meI <- suchThat genStageInstr (\m -> P.not (loadHazard exI m)) + wbI <- suchThat genStageInstr (\i -> P.not (isLoad i || isStore i)) + mk3 base exI meI wbI nextI False + +genAllMem3 :: Gen (SysG RegFn MemFn, RegIdx, Address) +genAllMem3 = do + base <- genBase + exI <- roundTrips <$> genStageMem + meI <- suchThat genStageMem (\m -> P.not (loadHazard exI m)) + wbI <- genStageMem + nextI <- genStageInstr + mk3 base exI meI wbI nextI True + +mk3 :: + Address -> Instruction -> Instruction -> Instruction -> Instruction -> Bool -> + Gen (SysG RegFn MemFn, RegIdx, Address) +mk3 base exI meI wbI nextI wbMem = do + aheadI <- genStageInstr + rfF <- genFn genSmallReg genW genW + mr <- genW + wbr <- genW + loaded <- genW + ma <- oneof [P.pure (base + 4096), genStoreAddr base] + wr <- genSmallReg + wa <- unpack <$> genW + let w0 = P.maybe 0 P.id (encode' exI) + w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) + -- A real instruction at base+8 as well: a load-hazard hop fetches it on + -- its first cycle and then discards it, and leaving it zero would never + -- exercise that discard against a decodable word. + w2 = P.maybe 0 P.id (encode' (roundTrips aheadI)) + memf a + | a - base P.< 4 = byteAt w0 (a - base) + | a - base P.< 8 = byteAt w1 (a - base - 4) + | a - base P.< 12 = byteAt w2 (a - base - 8) + | P.otherwise = 0 + P.pure + ( Sys + ( (sysState (initSys (mkProg prog1))) + { stateFePc = if wbMem then base + 4 else base + 8, + stateDePc = base + 4, + stateExPc = base, + stateExInstr = decode' w0, + stateMeInstr = meI, + stateWbInstr = wbI, + stateMeRes = pure mr, + stateWbRes = pure wbr, + stateMeAddr = ma, + stateRegFile = RegFn (P.fmap Identity rfF), + stateCtrl = initCtrl, + stateHalt = Nothing, + stateHaltNextPc = 0 + } + ) + (if wbMem then Input False (pure loaded) else Input True (pure w1)) + (MemFn memf), + wr, + wa + ) + +genSmallReg :: Gen RegIdx +genSmallReg = chooseBoundedIntegral (0, 3) + +genStageSize :: Gen Size +genStageSize = elements [Types.Byte, Types.Half, Types.Word] + +genStageMem :: Gen Instruction +genStageMem = + oneof + [ (\sz sg rd rs1 -> IType (Load sz sg) rd rs1 0) <$> genStageSize <*> elements [Signed, Unsigned] <*> genSmallReg <*> genSmallReg, + (\sz rs1 rs2 -> SType sz 0 rs1 rs2) <$> genStageSize <*> genSmallReg <*> genSmallReg + ] + +-- | Anything that can legitimately occupy a pipeline stage. +genStageInstr :: Gen Instruction +genStageInstr = + oneof + [ RType <$> elements [ADD, SUB, XOR, OR, AND, SLT] <*> genSmallReg <*> genSmallReg <*> genSmallReg, + IType <$> (Arith <$> elements [ADD, XOR, OR]) <*> genSmallReg <*> genSmallReg <*> (fromIntegral <$> choose (0 :: Int, 31)), + UType <$> elements [PC, Zero] <*> genSmallReg <*> (fromIntegral <$> choose (0 :: Int, 15)), + BType <$> elements [EQ, NE, LT, GE] <*> P.pure 0 <*> genSmallReg <*> genSmallReg, + genStageMem, + P.pure (IType (Env Call) 0 0 0), + IType (Env Break) 0 <$> genSmallReg <*> P.pure 1, + JType <$> genSmallReg <*> (fromIntegral . (2 *) <$> choose (0 :: Int, 7)), + P.pure (Nop MemoryBusBusy), + P.pure (Nop DecodeFail) + ] + +byteAt :: Word -> Address -> Byte +byteAt w k = case k of + 0 -> slice d7 d0 w + 1 -> slice d15 d8 w + 2 -> slice d23 d16 w + _ -> slice d31 d24 w diff --git a/test/Spec.hs b/test/Spec.hs index d7a2887..8de19e8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,6 +21,11 @@ import RegFile import Simulate import Memory.Types import Memory.Vec +import qualified Proof.SMT.Sanity as Sanity +import qualified Prelude +import qualified Proof.Functional.Induction +import IsaSpec (isaConformanceTests) +import ProofSpec (proofTests) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Test.Tasty.QuickCheck @@ -58,11 +63,52 @@ mkSecretPCLeakTest s prog = assertBool "" $ Leak.SecretPC.pcsEqual prog +-- | 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 refinement proof itself; see "Proof.Functional.Induction". +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 "arrRoundTrip" Proof.Functional.Induction.results @?= Just Nothing, + testCase "shift embeddings are sane" $ + lookup "shiftsSane" Proof.Functional.Induction.results @?= Just Nothing, + testCase "base case: invariant holds at reset" $ + lookup "baseCase" Proof.Functional.Induction.results @?= Just Nothing, + testCase "k = 0 inductive step is valid" $ + lookup "indStep0" Proof.Functional.Induction.results @?= Just Nothing, + testCase "k = 1 inductive step is valid" $ + lookup "indStep1" Proof.Functional.Induction.results @?= Just Nothing, + testCase "k = 2 inductive step is valid" $ + lookup "indStep2" Proof.Functional.Induction.results @?= Just Nothing, + testCase "k = 3 inductive step is valid" $ + lookup "indStep3" Proof.Functional.Induction.results @?= Just Nothing + -- The four leakage steps are omitted while Proof.Leakage.Induction is out + -- of the build; see the note in package.yaml. + ] + 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" + tests :: TestTree tests = testGroup "All Tests" - [ instructionTests, + [ sanityTests, + proofTests, + isaConformanceTests, + instructionTests, testGroup "Haskell simulation tests" [ testGroup From 29522424e4ae9aba6c7e63540515c486850885d0 Mon Sep 17 00:00:00 2001 From: Kristina Date: Thu, 10 Sep 2026 18:27:35 +0200 Subject: [PATCH 07/16] Put the SMT obligations behind a flag so CI can build without a solver The obligations in Proof.Functional.Induction and Proof.SMT.Sanity are discharged by the Pantomime plugin while GHC compiles them, so building those modules needs an SMT solver on PATH. Z3 is the only one packaged for Ubuntu and does not finish these queries in useful time, which is why the CI job ran until it was killed rather than failing. Move the two modules under proof-smt/ and gate them on a new smt-proof flag, on by default and off in CI, and drop the z3 install from the workflow. Everything else still runs there: the QuickCheck harness goes through the same Proof.Functional.Obligation definitions the symbolic proof does, so CI still checks the obligations on sampled states, along with driver/driverRef agreement, driver-case coverage and both rv32ui suites. Locally the flag stays on and bitwuzla discharges all seven properties in about a minute; package.yaml carries the invocation. Also add IsaSpec, which runs the ISA model itself against rv32ui. The refinement proof is stated against ISA, so it cannot say whether ISA is right; the only check until now was transitive, via the core passing the same suite, which validates the specification through the implementation. Co-Authored-By: Claude Opus 5 --- .github/workflows/stack-test.yml | 17 ++- .gitignore | 3 +- package.yaml | 33 ++++- .../Proof/Functional/Induction.hs | 0 {proof => proof-smt}/Proof/SMT/Sanity.hs | 0 test/IsaSpec.hs | 130 ++++++++++++++++++ test/Spec.hs | 12 +- 7 files changed, 184 insertions(+), 11 deletions(-) rename {proof => proof-smt}/Proof/Functional/Induction.hs (100%) rename {proof => proof-smt}/Proof/SMT/Sanity.hs (100%) create mode 100644 test/IsaSpec.hs diff --git a/.github/workflows/stack-test.yml b/.github/workflows/stack-test.yml index fae39e5..727eb4c 100644 --- a/.github/workflows/stack-test.yml +++ b/.github/workflows/stack-test.yml @@ -9,6 +9,7 @@ on: jobs: build: runs-on: ubuntu-latest + timeout-minutes: 60 steps: - name: Checkout code @@ -20,10 +21,6 @@ jobs: enable-stack: true stack-version: 'latest' - - name: Install dependencies - run: | - sudo apt-get update - sudo apt-get install -y z3 - name: Cache Stack uses: actions/cache@v4 @@ -36,7 +33,13 @@ jobs: ${{ runner.os }}-stack- - name: Install dependencies with Stack - run: stack test --only-dependencies --no-nix - + run: stack test --only-dependencies --no-nix --flag aimcore:-smt-proof + + # The proof obligations under proof-smt/ are discharged by an SMT solver + # while GHC compiles them. Z3 -- the only solver packaged for Ubuntu -- does + # not finish them in useful time, so CI builds without them and they are + # checked locally against bitwuzla instead. Everything else, including the + # QuickCheck harness for the same obligations and the rv32ui conformance + # suites, still runs here. - name: Build and run tests - run: stack test --no-nix + run: stack test --no-nix --flag aimcore:-smt-proof diff --git a/.gitignore b/.gitignore index c49df99..cebe2b2 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,5 @@ dist-newstyle/ *.cabal /log.txt *.log -/scratch \ No newline at end of file +/scratch +/bitwuzla/ diff --git a/package.yaml b/package.yaml index 7adf243..90b56ce 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,27 @@ extra-source-files: # common to point users to the README.md file. description: Please see the README on GitHub at +# The modules under proof-smt/ discharge their properties through an SMT solver +# while GHC compiles them, so building them needs a solver on PATH and takes as +# long as the solver does. Pantomime goes through SBV, and SBV's Z3 backend is +# pointed at a different binary with SBV_Z3; Z3 itself does not finish these in +# useful time, while bitwuzla takes seconds each: +# +# SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack test +# +# Do not add --fast: at -O0 GHC creates no unfoldings and the plugin fails with +# "Unbound variable in symbolise" rather than reporting a failed proof. +# +# Turn the flag off to build and test everything else without a solver, which is +# what CI does: +# +# stack test --flag aimcore:-smt-proof +flags: + smt-proof: + description: Discharge the symbolic proof obligations at compile time. + manual: true + default: true + default-extensions: - BinaryLiterals - DataKinds @@ -82,12 +103,18 @@ library: source-dirs: - src - proof + when: + - condition: flag(smt-proof) + source-dirs: proof-smt + exposed-modules: + - Proof.Functional.Induction + - Proof.SMT.Sanity + cpp-options: -DSMT_PROOF exposed-modules: - Proof.Machine - Proof.Driver - Proof.Functional.Invariant - Proof.Functional.Obligation - - Proof.Functional.Induction - Proof.Leakage.Model - Proof.Leakage.Simulator - Proof.Leakage.Obligation @@ -99,7 +126,6 @@ library: - Proof.SMT.Array - Proof.SMT.Axioms - Proof.SMT.Logged - - Proof.SMT.Sanity - Access - Core - Elf.ElfLoader @@ -148,6 +174,9 @@ tests: aimcore-test: main: Spec.hs source-dirs: test + when: + - condition: flag(smt-proof) + cpp-options: -DSMT_PROOF ghc-options: - -threaded - -rtsopts diff --git a/proof/Proof/Functional/Induction.hs b/proof-smt/Proof/Functional/Induction.hs similarity index 100% rename from proof/Proof/Functional/Induction.hs rename to proof-smt/Proof/Functional/Induction.hs diff --git a/proof/Proof/SMT/Sanity.hs b/proof-smt/Proof/SMT/Sanity.hs similarity index 100% rename from proof/Proof/SMT/Sanity.hs rename to proof-smt/Proof/SMT/Sanity.hs diff --git a/test/IsaSpec.hs b/test/IsaSpec.hs new file mode 100644 index 0000000..b2f5dbf --- /dev/null +++ b/test/IsaSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Direct validation of the ISA specification against the official RISC-V +-- conformance suite. +-- +-- The refinement proof is stated against "ISA", so nothing in the proof can +-- tell us whether "ISA" itself is right -- it is the thing being proved +-- against. The @rv32ui@ programs in @test/rv32ui@ are an external reference, so +-- running the ISA model on them and checking the suite's own pass condition is +-- evidence about the specification that does not come from the implementation. +-- +-- Without this, the only check on "ISA" is transitive: the core passes +-- @rv32ui@ (see "BenchmarkSpec") and the proof says the core refines +-- "ISA". That validates the specification /through/ the implementation, +-- which is the wrong direction. +-- +-- The pass condition is the one "BenchmarkSpec" applies to the core: at the +-- @ecall@ that ends the program, @gp@ (x3) is 1 and @a0@ (x10) is 0. +module IsaSpec (isaConformanceTests) where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import qualified Data.ByteString as BS +import Data.Functor.Identity (Identity (..)) +import qualified Data.Map.Strict as M +import Elf.ElfLoader (baseAddr, getElfSegments, readElf, startAddr) +import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import Memory.Types (MemOps (..)) +import RegFile +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) +import "aimcore" Types +import Prelude hiding (Ordering (..), Word, init, log, map, not, undefined, (!!), (&&), (++), (||)) +import qualified Prelude as P + +-- | Sparse memory over the full 32-bit space. +-- +-- 'Memory.Types.MemBytes' is a 'Vec' sized for the proof harness and far too +-- small for these binaries, and 'Memory.Types.MemFn' builds a closure chain one +-- link per byte written, which does not survive a few thousand stores. A map is +-- neither of those things. +newtype MemMap = MemMap (M.Map Address Byte) + +instance MemOps MemMap where + memReadByte a (MemMap m) = M.findWithDefault 0 a m + + memReadWord a m = + memReadByte (a + 3) m ++# memReadByte (a + 2) m ++# memReadByte (a + 1) m ++# memReadByte a m + + memWriteWord size a w (MemMap m) = + MemMap $ 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 = M.insert + +type IsaSys = IsaStateG RegFile MemMap + +-- | Step until the ISA halts. 'Left' if it runs past @fuel@ instructions, which +-- means the program never reached its terminating @ecall@. +runToHalt :: Int -> IsaSys -> Either String IsaSys +runToHalt fuel st + | fuel <= 0 = Left "fuel exhausted before the program halted" + | otherwise = case isaStep st of + IsaHalted -> Right st + Next st' -> runToHalt (fuel - 1) st' + +loadProgram :: FilePath -> IO IsaSys +loadProgram path = do + elf <- readElf path + entry <- startAddr elf + base <- baseAddr elf + let segments = getElfSegments elf + bytes = + M.fromList + [ (addr + fromIntegral i, fromIntegral b) + | (addr, bs) <- segments, + (i, b) <- P.zip [(0 :: Int) ..] (BS.unpack bs) + ] + -- The stack pointer the core harness uses; some tests touch the stack. + sp = fromIntegral base + 0x1000000 - 0x1000 + P.pure + IsaState + { isaPc = fromIntegral entry, + isaRegFile = modifyRF 2 (Identity sp) initRF, + isaMem = MemMap bytes + } + +-- | The suite's pass condition, read off the architectural register file. +checkPassed :: IsaSys -> Either String () +checkPassed st + | gp P./= 1 = Left ("gp = " P.++ show gp P.++ ", expected 1") + | a0 P./= 0 = Left ("a0 = " P.++ show a0 P.++ ", expected 0") + | otherwise = Right () + where + gp = runIdentity (lookupRFg 3 (isaRegFile st)) + a0 = runIdentity (lookupRFg 10 (isaRegFile st)) + +mkIsaTest :: String -> TestTree +mkIsaTest name = + testCase name $ do + st0 <- loadProgram ("test/rv32ui/" P.++ name) + case runToHalt 1000000 st0 P.>>= checkPassed of + Right () -> P.pure () + Left e -> assertFailure e + +-- | The same programs "BenchmarkSpec" runs against the core, run against the +-- ISA model instead. @fence_i@ is excluded for the same reason it is excluded +-- there: it is self-modifying code. +isaConformanceTests :: TestTree +isaConformanceTests = + testGroup + "ISA specification vs rv32ui" + (P.map (mkIsaTest . ("rv32ui-p-" P.++)) programs) + where + programs = + [ "add", "addi", "and", "andi", "auipc", + "beq", "bge", "bgeu", "blt", "bltu", "bne", + "jal", "jalr", + "lb", "lbu", "ld_st", "lh", "lhu", "lui", "lw", + "ma_data", + "or", "ori", + "sb", "sh", "simple", "sll", "slli", "slt", "slti", "sltiu", "sltu", + "sra", "srai", "srl", "srli", "st_ld", "sub", "sw", + "xor", "xori" + ] diff --git a/test/Spec.hs b/test/Spec.hs index 8de19e8..982f0b4 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,9 +22,13 @@ import 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.Functional.Induction +#endif import IsaSpec (isaConformanceTests) import ProofSpec (proofTests) import Test.Tasty (TestTree, defaultMain, testGroup) @@ -63,6 +68,7 @@ mkSecretPCLeakTest s prog = assertBool "" $ Leak.SecretPC.pcsEqual prog +#ifdef SMT_PROOF -- | The compile-time symbolic checks, read back out. -- -- The first three establish that the Pantomime plugin is wired in and actually @@ -100,12 +106,16 @@ sanityTests = 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" - [ sanityTests, + [ +#ifdef SMT_PROOF + sanityTests, +#endif proofTests, isaConformanceTests, instructionTests, From 805367ec0426bfeab45dd366f9af1f4f62df60b5 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 12:03:58 +0200 Subject: [PATCH 08/16] Quantify the architectural PC in the inductive steps The obligations derived the whole architectural state from the system state via isaOfG, which read isaPc off the execute stage. That is only the conjunct the running case uses to pin it: startup pins it to the fetch stage and the halted cases to stateHalt. So startup and halted states satisfied no case of the invariant as a pre-state, and their obligations held vacuously. isaPc is a scalar, so the invariant pins it exactly whichever case applies; only the register file and memory have to be derived, because the invariant compares those pointwise and a freely quantified pair would be tied to the system state at just the witness register and byte. So isaAt takes the PC as an argument and the four indStep properties quantify over it. Two consequences. isaOfHop goes away -- it existed solely to patch the startup case. And k=0 and k=1 can drop "IsaHalted -> True" in favour of requiring the invariant with the architectural state carried across, which, since the halted cases demand the architectural register file and memory equal the core's, says the core stands still once halted. That was previously established only by reading Core.hs. hopPc replaces isaOfHop for the callers that need a concrete architectural state rather than a quantified one: the leakage projection and the QuickCheck harness. Admitting startup states also turned up a bug in inductiveStep, which had been skipping them all along because isaOfG gave them a PC no case admits. It advanced the ISA across a startup hop, which retires nothing; indStepObligation1 already carved that case out. All seven symbolic properties re-discharged under bitwuzla; 143 tests pass. Co-Authored-By: Claude Opus 5 --- proof-smt/Proof/Functional/Induction.hs | 26 +++---- proof/Proof/Functional/Obligation.hs | 99 ++++++++++++++----------- proof/Proof/Leakage/Obligation.hs | 8 +- proof/Proof/Leakage/Simulator.hs | 10 +-- test/ProofSpec.hs | 48 ++++++------ 5 files changed, 105 insertions(+), 86 deletions(-) diff --git a/proof-smt/Proof/Functional/Induction.hs b/proof-smt/Proof/Functional/Induction.hs index 1e5855a..1c5a7fd 100644 --- a/proof-smt/Proof/Functional/Induction.hs +++ b/proof-smt/Proof/Functional/Induction.hs @@ -156,30 +156,30 @@ baseCase ra ma wr wa = -- | @k = 0@: the one-cycle hop (steady, writeback non-memory). {-# ANN indStep0 (Theory arrayAxioms) #-} -indStep0 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool -indStep0 ss i ra ma wr wa = - Pantomime.boolean $ indStepObligation wr wa (sysOf ss i ra ma) +indStep0 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Address -> Pantomime.Bool +indStep0 ss i ra ma wr wa ipc = + Pantomime.boolean $ indStepObligation wr wa ipc (sysOf ss i ra ma) -- | @k = 1@: the two-cycle hop (startup, or a memory instruction in writeback). {-# ANN indStep1 (Theory arrayAxioms) #-} -indStep1 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool -indStep1 ss i ra ma wr wa = - Pantomime.boolean $ indStepObligation1 wr wa (sysOf ss i ra ma) +indStep1 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Address -> Pantomime.Bool +indStep1 ss i ra ma wr wa ipc = + Pantomime.boolean $ indStepObligation1 wr wa ipc (sysOf ss i ra ma) -- | @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 only hop on which the ISA can halt. +-- The hop on which the ISA enters a halt; a halted state then sits at k = 0. {-# ANN indStep2 (Theory arrayAxioms) #-} -indStep2 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool -indStep2 ss i ra ma wr wa = - Pantomime.boolean $ indStepObligation2 wr wa (sysOf ss i ra ma) +indStep2 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Address -> Pantomime.Bool +indStep2 ss i ra ma wr wa ipc = + Pantomime.boolean $ indStepObligation2 wr wa ipc (sysOf ss i ra ma) -- | @k = 3@: the four-cycle hop (store hazard with a memory execute -- instruction, load hazard, or all three stages holding memory instructions). {-# ANN indStep3 (Theory arrayAxioms) #-} -indStep3 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool -indStep3 ss i ra ma wr wa = - Pantomime.boolean $ indStepObligation3 wr wa (sysOf ss i ra ma) +indStep3 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Address -> Pantomime.Bool +indStep3 ss i ra ma wr wa ipc = + Pantomime.boolean $ indStepObligation3 wr wa ipc (sysOf ss i ra ma) results :: [(String, Maybe String)] results = diff --git a/proof/Proof/Functional/Obligation.hs b/proof/Proof/Functional/Obligation.hs index 98ad04c..6aa5aac 100644 --- a/proof/Proof/Functional/Obligation.hs +++ b/proof/Proof/Functional/Obligation.hs @@ -6,8 +6,8 @@ -- built: symbolic scalars on one side, a generator on the other. That is the -- input space, not the property. module Proof.Functional.Obligation - ( isaOfG, - isaOfHop, + ( isaAt, + hopPc, isStartupShape, indStepObligation, indStepObligation1, @@ -29,15 +29,27 @@ import RegFile import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) --- | The architectural state the invariant claims @sys@ corresponds to. +-- | The architectural register file and memory that the invariant claims @sys@ +-- corresponds to, at an architectural PC supplied by the caller. -- --- Derived from @sys@ by the flush rather than taken as a further input: the --- invariant's container equalities then hold by construction, so assuming the --- invariant at one witness reduces to assuming its scalar conjuncts -- which is --- the full container invariant, not a weakening of it. -isaOfG :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m -isaOfG (Sys st inp mem) = - IsaState {isaPc = Core.stateExPc st, isaRegFile = frf, isaMem = fm} +-- The containers are /derived/ from @sys@ by the flush rather than taken as +-- further inputs. They have to be: the invariant compares them pointwise, at one +-- witness register and one witness byte, so a freely quantified register file +-- and memory would be tied to @sys@ only at those two points. 'ISA.isaStep' +-- reads memory at @isaPc@ and registers at @rs1@/@rs2@, which are elsewhere, so +-- the solver could pick an architectural state whose instruction at @isaPc@ +-- bears no relation to the one the core is executing. Deriving them makes the +-- container equalities hold by construction, and what is left in the premise is +-- the scalar conjuncts, assumed in full. +-- +-- @isaPc@ is different, and is quantified rather than derived. It is a scalar, +-- so the invariant pins it exactly -- but via a different conjunct in each case: +-- @stateExPc@ when running, @stateFePc@ at startup, and @stateHalt@ once halted. +-- Deriving it from any one of those would make the other two cases +-- unsatisfiable as premises. +isaAt :: (RegFileOps r, MemOps m) => Address -> SysG r m -> IsaStateG r m +isaAt ipc (Sys st inp mem) = + IsaState {isaPc = ipc, isaRegFile = frf, isaMem = fm} where (fm, frf) = flushMeStage @@ -64,21 +76,22 @@ isStartupShape (Sys st inp _) = && Core.stateExInstr st == Nop FirstCycle && not (Core.inputIsInstr inp) --- | The architectural state for a hop, startup included. --- --- 'isaOfG' reads the architectural PC off the /execute/ stage, which is right --- for a running state. A startup state has nothing in the pipe yet, and the --- invariant's startup case correspondingly pins @isaPc@ to the /fetch/ stage; --- deriving it from @exPc@ there would produce an architectural state that no --- case of the invariant admits, and the obligation would hold vacuously on --- every startup state instead of saying anything about it. +-- | The architectural PC a hop-aligned state corresponds to. -- --- The register file and memory need no special case: on a startup-shaped state --- both flushes are the identity, since every stage holds @Nop FirstCycle@. -isaOfHop :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m -isaOfHop sys - | isStartupShape sys = (isaOfG sys) {isaPc = Core.stateFePc (sysState sys)} - | otherwise = isaOfG sys +-- The symbolic obligations do not use this -- they quantify @isaPc@ and let the +-- invariant pin it, which is the whole point of quantifying rather than +-- deriving. It exists for the callers that need a concrete architectural state +-- rather than a quantified one: the QuickCheck harness and the leakage +-- projection. It reproduces, per case, the conjunct that pins @isaPc@ in the +-- invariant: the fetch stage at startup, the trapping instruction once halted, +-- the execute stage otherwise. +hopPc :: SysG r m -> Address +hopPc sys@(Sys st _ _) + | isStartupShape sys = Core.stateFePc st + | otherwise = case Core.stateHalt st of + Just (Core.EBreak a) -> a - 4 + Just (Core.Syscall a) -> a - 4 + _ -> Core.stateExPc st -- | The @k = 0@ inductive step: the driver's one-cycle hop. -- @@ -89,15 +102,17 @@ isaOfHop sys -- that rewrites an instruction in flight is handled by the core rather than -- assumed away here. -- --- @driver == 0@ excludes environment instructions, so the ISA cannot halt on --- this hop and the @IsaHalted@ branch is vacuous. Startup states all have --- @driver == 1@, so 'isaOfG' (rather than 'isaOfHop') is exact here. +-- @driver == 0@ covers two shapes: a running state whose hop retires one +-- instruction, and a halted one. The @IsaHalted@ branch is what says the halted +-- core stands still -- the halted cases of the invariant require the +-- architectural register file and memory to equal the core's, so carrying the +-- same @isa@ across the step asserts that neither changed. indStepObligation :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool -indStepObligation wr wa sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool +indStepObligation wr wa ipc sys = not premises || conclusion where - isa = isaOfG sys + isa = isaAt ipc sys sys' = stepSys sys premises = @@ -107,18 +122,18 @@ indStepObligation wr wa sys = conclusion = case isaStep isa of Next isa' -> invAtFree wr wa isa' sys' - IsaHalted -> True + IsaHalted -> invAtFree wr wa isa sys' -- | The @k = 1@ inductive step: the driver's two-cycle hop. -- -- One thing differs from @k = 0@ beyond the extra cycle: a startup hop does not -- retire an instruction, so the architectural state is carried across unchanged. indStepObligation1 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool -indStepObligation1 wr wa sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool +indStepObligation1 wr wa ipc sys = not premises || conclusion where - isa = isaOfHop sys + isa = isaAt ipc sys s1 = stepSys sys s2 = stepSys s1 @@ -131,9 +146,7 @@ indStepObligation1 wr wa sys = | otherwise = case isaStep isa of Next isa' -> invAtFree wr wa isa' s2 - -- driver == 1 excludes environment instructions (they route to a - -- three-cycle hop), so the ISA cannot halt here either. - IsaHalted -> True + IsaHalted -> invAtFree wr wa isa s2 -- | The @k = 2@ inductive step: the driver's three-cycle hop. -- @@ -141,11 +154,11 @@ indStepObligation1 wr wa sys = -- The architectural state then stays at the trapping instruction while the -- core reaches one of the two halted invariant cases. indStepObligation2 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool -indStepObligation2 wr wa sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool +indStepObligation2 wr wa ipc sys = not premises || conclusion where - isa = isaOfG sys + isa = isaAt ipc sys s1 = stepSys sys s2 = stepSys s1 s3 = stepSys s2 @@ -167,11 +180,11 @@ indStepObligation2 wr wa sys = -- covering it costs nothing and assuming it away would be an unchecked side -- argument. indStepObligation3 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool -indStepObligation3 wr wa sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool +indStepObligation3 wr wa ipc sys = not premises || conclusion where - isa = isaOfG sys + isa = isaAt ipc sys s1 = stepSys sys s2 = stepSys s1 s3 = stepSys s2 diff --git a/proof/Proof/Leakage/Obligation.hs b/proof/Proof/Leakage/Obligation.hs index 26ac8fd..df6ea0f 100644 --- a/proof/Proof/Leakage/Obligation.hs +++ b/proof/Proof/Leakage/Obligation.hs @@ -12,9 +12,9 @@ -- -- Only the simulator half of the projection is checked here. The architectural -- half commutes by construction: 'Proof.Leakage.Simulator.archOfLeak' is --- 'Proof.Functional.Obligation.isaOfHop' composed with +-- 'Proof.Functional.Obligation.isaAt' at 'Proof.Functional.Obligation.hopPc', composed with -- 'Proof.Leakage.Simulator.isaNext', and the functional obligations already --- establish that @isaOfHop@ advances by one 'isaStep' per hop. +-- establish that it advances by one 'isaStep' per hop. -- -- == What is assumed -- @@ -34,7 +34,7 @@ where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Proof.Functional.Invariant (invAtFree) -import Proof.Functional.Obligation (isaOfHop) +import Proof.Functional.Obligation (hopPc, isaAt) import Proof.Leakage.Model import Proof.Leakage.Simulator import Memory.Types (MemOps (..)) @@ -46,7 +46,7 @@ import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&& -- | The premises of 'leakObligation': the functional invariant. leakPremises :: (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool -leakPremises wr wa sys = invAtFree wr wa (isaOfHop sys) sys +leakPremises wr wa sys = invAtFree wr wa (isaAt (hopPc sys) sys) sys -- | @proj@ commutes with a driver hop, and the observations agree. leakObligation :: diff --git a/proof/Proof/Leakage/Simulator.hs b/proof/Proof/Leakage/Simulator.hs index ecf3d2e..8fbf65a 100644 --- a/proof/Proof/Leakage/Simulator.hs +++ b/proof/Proof/Leakage/Simulator.hs @@ -47,7 +47,7 @@ import Data.Functor.Identity import Data.Monoid (getFirst) import Instruction import Proof.Driver (driver) -import Proof.Functional.Obligation (isStartupShape, isaOfHop) +import Proof.Functional.Obligation (hopPc, isStartupShape, isaAt) import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) import Proof.Leakage.Model import Memory.Types (MemOps (..)) @@ -244,7 +244,7 @@ isaNext a = case isaStep a of -- | The architectural state a core state corresponds to, for the leakage proof. -- -- Fetch-aligned: the instruction at its PC is the one the pipeline is /taking --- in/, not the one in the execute stage. 'Proof.Functional.Obligation.isaOfHop' +-- in/, not the one in the execute stage. 'Proof.Functional.Obligation.hopPc' -- is execute-aligned, one instruction behind, so a single -- 'isaStep' converts between them. -- @@ -254,11 +254,11 @@ isaNext a = case isaStep a of -- the leakage a hop consumes must describe that one. -- -- At reset nothing is in flight and the PC comes off the fetch stage, exactly as --- 'Proof.Functional.Obligation.isaOfHop' already does there. +-- 'Proof.Functional.Obligation.hopPc' already does there. archOfLeak :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m archOfLeak sys - | isStartupShape sys = isaOfHop sys - | otherwise = isaNext (isaOfHop sys) + | isStartupShape sys = isaAt (hopPc sys) sys + | otherwise = isaNext (isaAt (hopPc sys) sys) -- | The refinement relation: an architectural state paired with a censored core. proj :: (RegFileOps r, MemOps m) => SysG r m -> (IsaStateG r m, SimSys r) diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index 92c708c..b7f5e3b 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -11,7 +11,7 @@ import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, import Instruction import Proof.Functional.Invariant import Proof.Machine -import Proof.Functional.Obligation (indStepObligation, indStepObligation1, indStepObligation2, isStartupShape, isaOfG, isaOfHop) +import Proof.Functional.Obligation (indStepObligation, indStepObligation1, indStepObligation2, hopPc, isStartupShape, isaAt) import Memory.Types import RegFile import Test.Tasty (TestTree, testGroup) @@ -378,7 +378,7 @@ proofTests = P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' sys')))) ) - (indStepObligation wr wa sys), + (indStepObligation wr wa (hopPc sys) sys), -- k = 1: the two-cycle hop. Both shapes that reach it are generated; -- 'coverage1' asserts each is actually sampled, since a premise this -- specific is easy to miss entirely and still see a green property. @@ -386,7 +386,7 @@ proofTests = -- 1e6 run by hand: 23s, no counterexample. 20k keeps the suite fast. withMaxSuccess 20000 $ forAllShow genArbSys1 (\_ -> "") $ \(sys, wr, wa) -> - let isa = isaOfHop sys + let isa = isaFromSys sys s2 = stepSysN 2 sys isa' = case isaStep isa of Next x -> x; IsaHalted -> isa in counterexample @@ -399,7 +399,7 @@ proofTests = P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' s2)))) ) - (indStepObligation1 wr wa sys), + (indStepObligation1 wr wa (hopPc sys) sys), testCase "k=1 generator reaches both hop shapes" $ let sample = [s | (s, _, _) <- unGen (vectorOf 4000 genArbSys1) (mkQCGen 7) 30] admitted p = @@ -407,28 +407,29 @@ proofTests = | s <- sample, p s, driver s P.== 1, - invAtFree 1 0 (isaOfHop s) s + invAtFree 1 0 (isaAt (hopPc s) s) s ] startups = admitted isStartupShape steadies = admitted (P.not . isStartupShape) in do assertBool "no startup state satisfied the k=1 premise" (P.not (P.null startups)) assertBool "no steady state satisfied the k=1 premise" (P.not (P.null steadies)), - -- Why 'isaOfHop' exists: deriving the architectural PC from the execute - -- stage, as 'isaOfG' does, leaves a startup state satisfying no case of - -- the invariant at all -- so the k=1 obligation would hold vacuously - -- there rather than saying anything. - testCase "startup states need the fetch-stage PC to be admitted" $ + -- Why the obligations quantify @isaPc@ rather than deriving it: the + -- conjunct that pins it differs per case. A startup state is admitted at + -- the fetch-stage PC and at no other, so deriving it from the execute + -- stage would leave every startup state satisfying no case of the + -- invariant, and the k=1 obligation vacuous there. + testCase "startup states are admitted at the fetch PC and not the execute PC" $ let sample = [s | (s, _, _) <- unGen (vectorOf 2000 genArbSys1) (mkQCGen 11) 30, isStartupShape s] - admits f s = invAtFree 1 0 (f s) s + admits pc s = invAtFree 1 0 (isaAt (pc s) s) s in do assertBool "generator produced no startup states" (P.not (P.null sample)) assertBool - "isaOfHop should admit some startup state" - (P.any (admits isaOfHop) sample) + "the fetch PC should admit some startup state" + (P.any (admits (stateFePc . sysState)) sample) assertBool - "isaOfG should admit no startup state (that is why isaOfHop exists)" - (P.not (P.any (admits isaOfG) sample)), + "the execute PC should admit no startup state" + (P.not (P.any (admits (stateExPc . sysState)) sample)), -- k = 2: jumps and the all-memory steady shape return to a running -- invariant case after three core cycles; ecall/ebreak return to one of -- the two halted cases. @@ -444,14 +445,14 @@ proofTests = P.++ "\nexPc=" P.++ show (stateExPc (sysState sys)) P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa ) - (indStepObligation2 wr wa sys), + (indStepObligation2 wr wa (hopPc sys) sys), testCase "k=2 generator reaches env, jump, and steady cases" $ let sample = [ (label, driverCaseName s) | (label, s, wr, wa) <- unGen (vectorOf 4000 genArbSys2) (mkQCGen 29) 30, driver s P.== 2, - invAtFree wr wa (isaOfG s) s + invAtFree wr wa (isaAt (hopPc s) s) s ] has label = P.any ((P.== label) . P.fst) sample in do @@ -481,7 +482,7 @@ proofTests = -- invariant claims it corresponds to. -- Shared with 'Proof.Functional.Induction.indStep0' via "Proof.Functional.Obligation", so the two cannot drift. isaFromSys :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m -isaFromSys = isaOfG +isaFromSys sys = isaAt (hopPc sys) sys -- | Take one driven step and report whether the invariant survived. Returns -- 'Nothing' when @sys@ does not satisfy the invariant to begin with (such a @@ -494,9 +495,14 @@ inductiveStep sys where isa = isaFromSys sys sys' = stepSysN (driver sys + 1) sys - isa' = case isaStep isa of - Next i -> i - IsaHalted -> isa + -- A startup hop brings the first instruction into the execute stage without + -- executing anything, so the architectural state does not advance across it. + -- 'Proof.Functional.Obligation.indStepObligation1' carves out the same case. + isa' + | isStartupShape sys = isa + | otherwise = case isaStep isa of + Next i -> i + IsaHalted -> isa inv' a s = P.any holdsCase (invCases a s) holdsCase c = P.all P.snd (caseConjuncts c) From 523afacf987bbbf47112216758c5732f506e3b49 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 12:38:24 +0200 Subject: [PATCH 09/16] Export KState to silence a spurious unused-constructor warning Nothing in Haskell 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, so -Wunused-top-binds sees a dead constructor. Exporting it says what is actually true -- the type is part of this module's interface -- rather than suppressing the warning. Co-Authored-By: Claude Opus 5 --- proof-smt/Proof/Functional/Induction.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/proof-smt/Proof/Functional/Induction.hs b/proof-smt/Proof/Functional/Induction.hs index 1c5a7fd..59d14f9 100644 --- a/proof-smt/Proof/Functional/Induction.hs +++ b/proof-smt/Proof/Functional/Induction.hs @@ -20,7 +20,13 @@ -- argument, a record containing a function cannot, and the Clash @Vec@ API is -- opaque to the plugin (see "Proof.SMT.Array"). module Proof.Functional.Induction - ( arrRoundTrip, + ( -- | 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@. It is also what a new + -- property in this module would take as its pipeline-state argument. + KState (..), + arrRoundTrip, shiftsSane, baseCase, indStep0, From f9ef8a99506dfb08504a3a3a6ce47c2601823b5b Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 13:33:38 +0200 Subject: [PATCH 10/16] Read the pointwise invariant off the real flush instead of hand copies invAtFree compared the architectural memory and register file against flushMemByteAt and flushRfWordAt, hand-written pointwise re-encodings of flushMeStage/flushWbStage. Their stated purpose was to spare the solver a select over a nested store chain, but isaAt already applies the real flush in every obligation, so that chain is in every query regardless. The copies only added risk. flushMemByteAt's four-way byte mux had to agree with memWriteWord, and flushRfWordAt's memory-over-writeback priority with the flush ordering, and the only check on either was the sampled fold-free/list agreement test, whose witness addresses step by 16 and so barely reach three of the four mux branches. runningCaseAt now applies flushMeStage . flushWbStage and reads the result at the witness, the same flush the container form compares whole. All seven obligations re-discharged under bitwuzla; solver time moved from 132s to 144s in single runs, within noise. 143 tests pass. Co-Authored-By: Claude Opus 5 --- proof/Proof/Functional/Invariant.hs | 101 ++++++---------------------- 1 file changed, 19 insertions(+), 82 deletions(-) diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs index c50cf73..82cbb81 100644 --- a/proof/Proof/Functional/Invariant.hs +++ b/proof/Proof/Functional/Invariant.hs @@ -51,7 +51,6 @@ import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, import Proof.Machine import RegFile import Types -import qualified Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) import qualified Prelude as P @@ -315,8 +314,25 @@ runningCaseAt wr wa (IsaState ipc irf imem) sys@(Sys st inp mem) = && runIdentity (inputMem inp) == memReadWord (stateDePc st) mem && stateFePc st == stateExPc st + 8 ) - && memReadByte wa imem == flushMemByteAt wa sys - && runIdentity (lookupRFg wr irf) == flushRfWordAt wr sys + && memReadByte wa imem == memReadByte wa fm + && runIdentity (lookupRFg wr irf) == runIdentity (lookupRFg wr frf) + where + -- The same flush the container form applies, read at the witness. Writing + -- it out pointwise by hand would duplicate 'flushMeStage' and 'memWriteWord' + -- for no gain: 'Proof.Functional.Obligation.isaAt' already puts this flush + -- into every query, and the solver rewrites @select@ over a @store@ chain + -- natively. + (fm, frf) = + flushMeStage + (stateMeInstr st) + (runIdentity (stateMeRes st)) + (stateMeAddr st) + ( flushWbStage + (stateWbInstr st) + (runIdentity (stateWbRes st)) + (runIdentity (inputMem inp)) + (mem, stateRegFile st) + ) -- | The startup case. startupCaseAt :: @@ -351,82 +367,3 @@ haltedCaseAt kind wr wa (IsaState ipc irf imem) (Sys st _ mem) = expected = case kind of HaltBreak -> EBreak (ipc + 4) HaltCall -> Core.Syscall (ipc + 4) - --- | Read one byte from the memory produced by the invariant's pipeline flush, --- without constructing that whole memory first. --- --- 'flushWbStage' never changes memory; 'flushMeStage' changes it only for a --- store, by writing up to four consecutive bytes. So this mux is exactly --- @memReadByte wa@ of the flushed memory, but it sends the solver a pointwise --- read-over-write formula instead of a @select@ over a nested @store@ chain. -flushMemByteAt :: (MemOps m) => Address -> SysG r m -> Byte -flushMemByteAt wa (Sys st _ mem) = - case stateMeInstr st of - SType size _ _ _ -> - let a = stateMeAddr st - w = runIdentity (stateMeRes st) - b0 = slice d7 d0 w - b1 = slice d15 d8 w - b2 = slice d23 d16 w - b3 = slice d31 d24 w - old = memReadByte wa mem - in case size of - Types.Byte -> - if wa == a then b0 else old - Types.Half -> - if wa == a - then b0 - else if wa == a + 1 then b1 else old - Types.Word -> - if wa == a - then b0 - else - if wa == a + 1 - then b1 - else - if wa == a + 2 - then b2 - else if wa == a + 3 then b3 else old - _ -> memReadByte wa mem - --- | Read one register from the register file produced by the invariant's --- pipeline flush, without constructing the two nested updates first. --- --- Writeback is applied before memory, so a memory-stage write to the witness --- register wins. Register zero is immutable. -flushRfWordAt :: - (RegFileOps r, MemOps m) => - RegIdx -> SysG r m -> Word -flushRfWordAt wr (Sys st inp mem) - | wr == 0 = 0 - | otherwise = applyMe (applyWb old) - where - old = runIdentity (lookupRFg wr (stateRegFile st)) - inputWord = runIdentity (inputMem inp) - - put rd value prior = if wr == rd then value else prior - - applyWb prior = - case stateWbInstr st of - RType _ rd _ _ -> put rd (runIdentity (stateWbRes st)) prior - IType (Arith _) rd _ _ -> put rd (runIdentity (stateWbRes st)) prior - IType (Load size sign) rd _ _ -> - put rd (loadExtend size sign inputWord) prior - JType rd _ -> put rd (runIdentity (stateWbRes st)) prior - IType Jump rd _ _ -> put rd (runIdentity (stateWbRes st)) prior - UType _ rd _ -> put rd (runIdentity (stateWbRes st)) prior - _ -> prior - - applyMe prior = - case stateMeInstr st of - RType _ rd _ _ -> put rd (runIdentity (stateMeRes st)) prior - IType (Arith _) rd _ _ -> put rd (runIdentity (stateMeRes st)) prior - IType (Load size sign) rd _ _ -> - put - rd - (loadExtend size sign (memReadWord (stateMeAddr st) mem)) - prior - JType rd _ -> put rd (runIdentity (stateMeRes st)) prior - IType Jump rd _ _ -> put rd (runIdentity (stateMeRes st)) prior - UType _ rd _ -> put rd (runIdentity (stateMeRes st)) prior - _ -> prior From 925a72b3c6b4f3a459d128c359eb4a5d9d219dbc Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 13:58:57 +0200 Subject: [PATCH 11/16] Bind the next architectural state before stating each conclusion Each inductive step's conclusion repeated invAtFree inside both arms of a case on isaStep, so it took reading both arms to see that they differ only in the architectural state. Bind that state as isa' first; the conclusion is then a single invAtFree call against the stepped system state. In k=1 the startup carve-out moves into isa' too, where it reads as what it is: a startup hop carries the architectural state across unchanged. No change in meaning. All seven obligations re-discharged under bitwuzla; 143 tests pass. Co-Authored-By: Claude Opus 5 --- proof/Proof/Functional/Obligation.hs | 40 +++++++++++++++------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/proof/Proof/Functional/Obligation.hs b/proof/Proof/Functional/Obligation.hs index 6aa5aac..c72884c 100644 --- a/proof/Proof/Functional/Obligation.hs +++ b/proof/Proof/Functional/Obligation.hs @@ -119,10 +119,11 @@ indStepObligation wr wa ipc sys = invAtFree wr wa isa sys && driver sys == 0 - conclusion = - case isaStep isa of - Next isa' -> invAtFree wr wa isa' sys' - IsaHalted -> invAtFree wr wa isa sys' + isa' = case isaStep isa of + Next next -> next + IsaHalted -> isa + + conclusion = invAtFree wr wa isa' sys' -- | The @k = 1@ inductive step: the driver's two-cycle hop. -- @@ -141,12 +142,13 @@ indStepObligation1 wr wa ipc sys = invAtFree wr wa isa sys && driver sys == 1 - conclusion - | isStartupShape sys = invAtFree wr wa isa s2 - | otherwise = - case isaStep isa of - Next isa' -> invAtFree wr wa isa' s2 - IsaHalted -> invAtFree wr wa isa s2 + isa' + | isStartupShape sys = isa + | otherwise = case isaStep isa of + Next next -> next + IsaHalted -> isa + + conclusion = invAtFree wr wa isa' s2 -- | The @k = 2@ inductive step: the driver's three-cycle hop. -- @@ -167,10 +169,11 @@ indStepObligation2 wr wa ipc sys = invAtFree wr wa isa sys && driver sys == 2 - conclusion = - case isaStep isa of - Next isa' -> invAtFree wr wa isa' s3 - IsaHalted -> invAtFree wr wa isa s3 + isa' = case isaStep isa of + Next next -> next + IsaHalted -> isa + + conclusion = invAtFree wr wa isa' s3 -- | The @k = 3@ inductive step: the driver's four-cycle hop, the longest. -- @@ -194,7 +197,8 @@ indStepObligation3 wr wa ipc sys = invAtFree wr wa isa sys && driver sys == 3 - conclusion = - case isaStep isa of - Next isa' -> invAtFree wr wa isa' s4 - IsaHalted -> invAtFree wr wa isa s4 + isa' = case isaStep isa of + Next next -> next + IsaHalted -> isa + + conclusion = invAtFree wr wa isa' s4 From 8e16e34d29576d2a301025208de9f1fc425840c5 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 13:58:57 +0200 Subject: [PATCH 12/16] Import only the ISA names each module uses When ISAStep was merged into ISA, every importer was given the same full explicit list, so six modules imported names they never use and GHC warned about each. Trim every list to what the module actually refers to. No change in behaviour: 0 errors, no remaining ISA import warnings, and 133 tests pass in the no-solver configuration. Co-Authored-By: Claude Opus 5 --- proof/Proof/Functional/Invariant.hs | 2 +- proof/Proof/Functional/Obligation.hs | 2 +- proof/Proof/Leakage/Model.hs | 2 +- proof/Proof/Leakage/Simulator.hs | 2 +- test/IsaSpec.hs | 2 +- test/ProofSpec.hs | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs index 82cbb81..aeb7082 100644 --- a/proof/Proof/Functional/Invariant.hs +++ b/proof/Proof/Functional/Invariant.hs @@ -47,7 +47,7 @@ import Data.Functor.Identity import Instruction import Memory.Types import Proof.Driver (isEnvInstr, isMemInstr) -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), IsaState) import Proof.Machine import RegFile import Types diff --git a/proof/Proof/Functional/Obligation.hs b/proof/Proof/Functional/Obligation.hs index c72884c..c72b1b7 100644 --- a/proof/Proof/Functional/Obligation.hs +++ b/proof/Proof/Functional/Obligation.hs @@ -20,7 +20,7 @@ import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import qualified Core import Data.Functor.Identity import Proof.Driver (driver) -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), StepG (..), isaStep) import Instruction import Proof.Functional.Invariant import Memory.Types (MemOps (..)) diff --git a/proof/Proof/Leakage/Model.hs b/proof/Proof/Leakage/Model.hs index 6e6f009..0531af0 100644 --- a/proof/Proof/Leakage/Model.hs +++ b/proof/Proof/Leakage/Model.hs @@ -40,7 +40,7 @@ import Data.Monoid (getFirst) import Instruction import qualified Instruction as I import Proof.Driver (exArg) -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), isaInstrAt) import Memory.Types (MemOps (..)) import Proof.Machine import RegFile diff --git a/proof/Proof/Leakage/Simulator.hs b/proof/Proof/Leakage/Simulator.hs index 8fbf65a..9c790ca 100644 --- a/proof/Proof/Leakage/Simulator.hs +++ b/proof/Proof/Leakage/Simulator.hs @@ -48,7 +48,7 @@ import Data.Monoid (getFirst) import Instruction import Proof.Driver (driver) import Proof.Functional.Obligation (hopPc, isStartupShape, isaAt) -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), StepG (..), isaStep) import Proof.Leakage.Model import Memory.Types (MemOps (..)) import Proof.Machine diff --git a/test/IsaSpec.hs b/test/IsaSpec.hs index b2f5dbf..b32f427 100644 --- a/test/IsaSpec.hs +++ b/test/IsaSpec.hs @@ -23,7 +23,7 @@ import qualified Data.ByteString as BS import Data.Functor.Identity (Identity (..)) import qualified Data.Map.Strict as M import Elf.ElfLoader (baseAddr, getElfSegments, readElf, startAddr) -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), StepG (..), isaStep) import Memory.Types (MemOps (..)) import RegFile import Test.Tasty (TestTree, testGroup) diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index b7f5e3b..0f77c29 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -7,7 +7,7 @@ import Clash.Sized.Vector (unsafeFromList) import Core import Data.Functor.Identity (Identity (..), runIdentity) import Proof.Driver -import ISA (IsaStateG (..), IsaState, StepG (..), Step, isaStep, isaStepDecoded, isaRun, isaInstrAt) +import ISA (IsaStateG (..), IsaState, StepG (..), isaStep, isaInstrAt) import Instruction import Proof.Functional.Invariant import Proof.Machine From 484d39dec5d4ebde4eb9c906061fe588c66562c0 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 14:19:35 +0200 Subject: [PATCH 13/16] State the reset hop as the base case instead of a startup invariant case The invariant had a startup case relating the reset state to the ISA's initial state. It made k=1 the one step that retires no instruction, so indStepObligation1 and the QuickCheck harness both needed an isStartupShape carve-out. Drop the startup case. The reset state is not related to the ISA at all; instead baseCase states the reset hop directly: the driver gives the reset state a two-cycle hop, and after those two core steps and zero ISA steps the running case holds. Every inductive step now retires exactly one instruction, so the carve-outs go. On the test side the concrete base case checks the same on the real reset state, including that stepping operationally agrees the hop is two cycles. invTrace no longer lists the reset state among the states the invariant is checked at, and the startup generator and its tests are removed. isStartupShape stays for hopPc and the leakage projection. The invariant note is updated to match. All seven obligations re-discharged under bitwuzla; 142 tests pass. Co-Authored-By: Claude Opus 5 --- proof-smt/Proof/Functional/Induction.hs | 46 ++++---- proof/Proof/Functional/Invariant.hs | 30 +---- proof/Proof/Functional/Obligation.hs | 28 ++--- proof/notes/invariant.txt | 26 ++--- test/ProofSpec.hs | 149 +++++++++--------------- test/Spec.hs | 2 +- 6 files changed, 104 insertions(+), 177 deletions(-) diff --git a/proof-smt/Proof/Functional/Induction.hs b/proof-smt/Proof/Functional/Induction.hs index 59d14f9..1edaa2a 100644 --- a/proof-smt/Proof/Functional/Induction.hs +++ b/proof-smt/Proof/Functional/Induction.hs @@ -1,6 +1,7 @@ -- | The inductive steps of the refinement proof, checked symbolically. -- --- 'baseCase' says the invariant holds at reset. Then one property per driver +-- 'baseCase' says the invariant holds once the reset state has taken its first +-- hop. Then one property per driver -- delay: if the invariant relates @(isa, sys)@ and the driver says the hop takes -- @k + 1@ cycles, then after those cycles (and one ISA step, where the hop -- retires an instruction) the invariant relates them again. Base case plus the @@ -48,6 +49,7 @@ import Proof.Functional.Invariant (invAtFree) import Proof.SMT.Logged (pantomime) import Proof.Machine import Memory.Types (initPc) +import Proof.Driver (driver) import Proof.Functional.Obligation import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime @@ -124,35 +126,37 @@ shiftsSane x = -- The base case ---------------------------------------------------------------- --- | The invariant holds of the pipeline's initial state. +-- | The invariant holds once the reset state has taken its first hop. -- -- Without this the four steps below say only that the invariant is /preserved/, -- which is vacuous if it never holds anywhere. Together they give the theorem: --- the invariant relates the core to the ISA at every state the driver lands on, --- starting from reset. +-- the invariant relates the core to the ISA at every state the driver lands on +-- after reset. -- --- 'Core.init' has nothing in flight and its fetch PC at 'initPc', which is --- exactly the invariant's startup case, so this holds for any loaded program -- --- hence the arbitrary memory rather than a particular one. What it therefore --- checks is the reset state's /shape/: three stages holding @Nop FirstCycle@, --- nothing on the bus, no halt raised or pending, and @stateFePc@ equal to the --- address the ISA starts at. +-- The reset state itself is not a case of the invariant. 'Core.init' has nothing +-- in the pipeline, so the driver gives it a two-cycle hop that fetches and +-- decodes the first instruction without executing anything. This property +-- states that hop directly: the driver does assign it two cycles, and after +-- them the running case relates the core to the ISA's /initial/ state -- zero +-- ISA steps. Handling it here rather than as a case of the invariant is what +-- lets every inductive step retire exactly one instruction. -- --- Every field except the register file comes from 'Core.init' itself, so the --- shape cannot drift from the real reset state. The register file has to be --- substituted because 'RegFileOps.initRFg' builds a Clash 'Vec' with the opaque --- 'repeat'. +-- It holds for any loaded program, hence the arbitrary memory. Every field +-- except the register file comes from 'Core.init' itself, so the reset shape +-- cannot drift from the real one. The register file has to be substituted +-- because 'RegFileOps.initRFg' builds a Clash 'Vec' with the opaque 'repeat'. -- -- Note what that substitution costs: memory and the register file are the same --- symbolic values on both sides, so the invariant's two container equalities --- hold by construction here and this property alone would not notice if the --- core's reset register file and the ISA's ('RegFile.initRF') disagreed. The --- concrete test in "ProofSpec" closes that gap -- it runs on the real --- 'Vec'-backed state, where both files are built independently. +-- symbolic values on both sides, and the reset hop writes neither, so the +-- invariant's two container equalities hold by construction here and this +-- property alone would not notice if the core's reset register file and the +-- ISA's ('RegFile.initRF') disagreed. The concrete test in "ProofSpec" closes +-- that gap -- it runs on the real 'Vec'-backed state, where both files are built +-- independently. {-# ANN baseCase (Theory arrayAxioms) #-} baseCase :: RegArr -> MemArr -> RegIdx -> Address -> Pantomime.Bool baseCase ra ma wr wa = - Pantomime.boolean $ invAtFree wr wa isa sys + Pantomime.boolean $ driver sys == 1 && invAtFree wr wa isa (stepSys (stepSys sys)) where st = (Core.init :: Core.StateG RegArrF Identity) {Core.stateRegFile = RegArrF ra} sys = Sys st Core.initInput ma @@ -166,7 +170,7 @@ indStep0 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Addre indStep0 ss i ra ma wr wa ipc = Pantomime.boolean $ indStepObligation wr wa ipc (sysOf ss i ra ma) --- | @k = 1@: the two-cycle hop (startup, or a memory instruction in writeback). +-- | @k = 1@: the two-cycle hop (a memory instruction in writeback). {-# ANN indStep1 (Theory arrayAxioms) #-} indStep1 :: KState -> Core.Input Identity -> RegArr -> MemArr -> RegIdx -> Address -> Address -> Pantomime.Bool indStep1 ss i ra ma wr wa ipc = diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs index aeb7082..8a3a5e1 100644 --- a/proof/Proof/Functional/Invariant.hs +++ b/proof/Proof/Functional/Invariant.hs @@ -2,7 +2,9 @@ -- -- The invariant relates an architectural state @(isaPc, isaRegFile, isaMem)@ to -- a system state @((core state), (input), mem)@. It is a disjunction of cases: --- one for startup, four for the running core, and two for the halted core. +-- four for the running core, and two for the halted core. The reset state is +-- not among them: 'Proof.Functional.Induction.baseCase' steps it two cycles, +-- into the running case, instead. -- -- Two forms of the same predicate live here: -- @@ -195,17 +197,6 @@ invCasesGen :: [Case] invCasesGen eqRF eqMem (IsaState ipc irf imem) sys@(Sys st inp mem) = [ runningCase, - Case - "startup" - [ ("running", running sys), - ("wb == Nop FirstCycle", stateWbInstr st == Nop FirstCycle), - ("me == Nop FirstCycle", stateMeInstr st == Nop FirstCycle), - ("ex == Nop FirstCycle", stateExInstr st == Nop FirstCycle), - ("not inputIsInstr", P.not (inputIsInstr inp)), - ("fePc == isaPc", stateFePc st == ipc), - ("isaRegFile == stateRegFile", eqRF irf (stateRegFile st)), - ("isaMem == stateMem", eqMem imem mem) - ], haltedCase "halted/ebreak" isBreak (EBreak (ipc + 4)), haltedCase "halted/ecall" isCall (Core.Syscall (ipc + 4)) ] @@ -288,7 +279,6 @@ invAtFree :: Bool invAtFree wr wa isa sys = runningCaseAt wr wa isa sys - || startupCaseAt wr wa isa sys || haltedCaseAt HaltBreak wr wa isa sys || haltedCaseAt HaltCall wr wa isa sys @@ -334,20 +324,6 @@ runningCaseAt wr wa (IsaState ipc irf imem) sys@(Sys st inp mem) = (mem, stateRegFile st) ) --- | The startup case. -startupCaseAt :: - (RegFileOps r, MemOps m) => - RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool -startupCaseAt wr wa (IsaState ipc irf imem) sys@(Sys st inp mem) = - running sys - && stateWbInstr st == Nop FirstCycle - && stateMeInstr st == Nop FirstCycle - && stateExInstr st == Nop FirstCycle - && not (inputIsInstr inp) - && stateFePc st == ipc - && runIdentity (lookupRFg wr irf) == runIdentity (lookupRFg wr (stateRegFile st)) - && memReadByte wa imem == memReadByte wa mem - -- | One halted case. haltedCaseAt :: (RegFileOps r, MemOps m) => diff --git a/proof/Proof/Functional/Obligation.hs b/proof/Proof/Functional/Obligation.hs index c72b1b7..195960a 100644 --- a/proof/Proof/Functional/Obligation.hs +++ b/proof/Proof/Functional/Obligation.hs @@ -63,12 +63,12 @@ isaAt ipc (Sys st inp mem) = (mem, Core.stateRegFile st) ) --- | Does the pipeline have the shape the invariant's startup case describes? +-- | Does the pipeline have the reset shape: nothing in flight, nothing on the bus? -- --- The distinction matters from @k = 1@ onwards: a startup hop brings the first --- instruction into the execute stage without executing anything, so the --- architectural state does not advance across it. Every other hop retires one --- instruction. +-- Not a case of the invariant -- 'Proof.Functional.Induction.baseCase' takes the +-- reset state two cycles into the running case -- so no obligation needs it. It +-- is kept for 'hopPc' and the leakage projection, which still assign an +-- architectural state to the reset shape. isStartupShape :: SysG r m -> Bool isStartupShape (Sys st inp _) = Core.stateWbInstr st == Nop FirstCycle @@ -83,8 +83,9 @@ isStartupShape (Sys st inp _) = -- deriving. It exists for the callers that need a concrete architectural state -- rather than a quantified one: the QuickCheck harness and the leakage -- projection. It reproduces, per case, the conjunct that pins @isaPc@ in the --- invariant: the fetch stage at startup, the trapping instruction once halted, --- the execute stage otherwise. +-- invariant -- the trapping instruction once halted, the execute stage +-- otherwise -- plus the fetch stage for the reset shape, which the invariant does +-- not admit but the leakage projection still assigns a PC. hopPc :: SysG r m -> Address hopPc sys@(Sys st _ _) | isStartupShape sys = Core.stateFePc st @@ -127,8 +128,9 @@ indStepObligation wr wa ipc sys = -- | The @k = 1@ inductive step: the driver's two-cycle hop. -- --- One thing differs from @k = 0@ beyond the extra cycle: a startup hop does not --- retire an instruction, so the architectural state is carried across unchanged. +-- The driver also gives the reset state a two-cycle hop, but no obligation +-- covers it: the invariant does not admit the reset state, and +-- 'Proof.Functional.Induction.baseCase' states that hop directly. indStepObligation1 :: (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool indStepObligation1 wr wa ipc sys = @@ -142,11 +144,9 @@ indStepObligation1 wr wa ipc sys = invAtFree wr wa isa sys && driver sys == 1 - isa' - | isStartupShape sys = isa - | otherwise = case isaStep isa of - Next next -> next - IsaHalted -> isa + isa' = case isaStep isa of + Next next -> next + IsaHalted -> isa conclusion = invAtFree wr wa isa' s2 diff --git a/proof/notes/invariant.txt b/proof/notes/invariant.txt index 542d285..dde9cc0 100644 --- a/proof/notes/invariant.txt +++ b/proof/notes/invariant.txt @@ -1,6 +1,6 @@ NOTE: this file has been reconciled with proof/Proof/Functional/Invariant.hs. -One change against the original: the 'stateCtrl == initCtrl' clause has been -dropped from every case. It is a holdover from an earlier Core that reset the +Two changes against the original. First, the 'stateCtrl == initCtrl' clause has +been dropped from every case. It is a holdover from an earlier Core that reset the control lines at the END of each clock cycle, so that they were back at their reset values by the time the next cycle began. Core.withCtrlReset now resets them at the START of the cycle and the stages then set them, so the lines seen @@ -11,6 +11,13 @@ every obligation vacuous. Dropping it is sound because the lines carry no information between cycles: withCtrlReset overwrites them before any stage reads them. +Second, the startup case has been removed. The invariant does not relate the +reset state to the ISA at all. Instead the base case steps the core two cycles +from reset -- the hop the driver assigns it, which fetches and decodes the first +instruction without executing anything -- and requires the running case to +relate the result to the ISA's initial state, after zero ISA steps. Every +inductive step then retires exactly one instruction. + The four running cases are collapsed into one in the Haskell. They differ only in the fetch conjuncts, and those track the writeback stage alone -- a memory instruction in writeback held the bus last cycle, so nothing was fetched. The @@ -115,21 +122,6 @@ flushMeStage stateMeInstr stateMeRes stateMeAddr (stateMem, stateRegFile) = INVARIANT: -- CASE: - (isaPc, isaRegFile, isaMem) ~ - ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), - IF stateHalt == Running AND - stateWbInstr == Nop FirstCycle AND - stateMeInstr == Nop FirstCycle AND - stateExInstr == Nop FirstCycle AND - inputIsInstr == False AND - fetchPc == isaPc AND - isaRegFile == stateRegFile AND - isaMem == stateMem - -------------------------------------------------------------------- -------------------------------------------------------------------- - - CASE: (isaPc, isaRegFile, isaMem) ~ ((stateFePc, stateDePc, stateExPc, stateExInstr, stateMeInstr, stateMeRes, stateMeAddr, stateWbInstr, stateWbRes, stateRegFile, stateCtrl, stateHalt), (inputIsInstr, inputMem), stateMem), diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index 0f77c29..639bbf8 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -11,7 +11,7 @@ import ISA (IsaStateG (..), IsaState, StepG (..), isaStep, isaInstrAt) import Instruction import Proof.Functional.Invariant import Proof.Machine -import Proof.Functional.Obligation (indStepObligation, indStepObligation1, indStepObligation2, hopPc, isStartupShape, isaAt) +import Proof.Functional.Obligation (indStepObligation, indStepObligation1, indStepObligation2, hopPc, isaAt) import Memory.Types import RegFile import Test.Tasty (TestTree, testGroup) @@ -66,13 +66,35 @@ walkReport k prog = initIsa :: Vec PROG_SIZE Word -> IsaState initIsa prog = IsaState initPc initRF (mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog) --- | The driver and the ISA walked in lockstep. +-- | The base case on a concrete program: the driver gives the reset state a +-- two-cycle hop, stepping operationally agrees, and after it the core relates +-- to the ISA's initial state. +baseHolds :: Vec PROG_SIZE Word -> Bool +baseHolds prog = + driver sys0 P.== 1 + P.&& driverRef 12 sys0 P.== Just 2 + P.&& inv (initIsa prog) (stepSysN 2 sys0) + where + sys0 = initSys prog + +baseReport :: Vec PROG_SIZE Word -> String +baseReport prog = + "driver=" P.++ show (driver sys0) + P.++ " driverRef=" P.++ show (driverRef 12 sys0) + P.++ "\n" P.++ explain (initIsa prog) (stepSysN 2 sys0) + where + sys0 = initSys prog + +-- | The driver and the ISA walked in lockstep, at every state the invariant is +-- meant to hold. -- --- The first hop (out of the startup state) brings the first instruction into +-- The reset state is not one of them. Its hop brings the first instruction into -- the execute stage without the ISA having executed anything, so the ISA state --- is unchanged across it. Every later hop advances the ISA by one step. +-- is unchanged across it and the trace starts after it, at the state +-- 'Proof.Functional.Induction.baseCase' is about. Every later hop advances the +-- ISA by one step. invTrace :: Int -> Vec PROG_SIZE Word -> [(Int, IsaState, Sys)] -invTrace k prog = (0, isa0, sys0) : go k 0 isa0 sys0 True +invTrace k prog = go k 0 isa0 sys0 True where isa0 = initIsa prog sys0 = initSys prog @@ -221,21 +243,22 @@ proofTests = -- file (Clash's 'repeat' is opaque to the symbolic executor), so the -- concrete check is what pins that the state it describes is the one -- 'Proof.Machine.initSys' actually produces -- including 'Core.init''s reset - -- register file and the loaded program. - testCase "invariant holds at reset" $ + -- register file and the loaded program. It also checks the reset hop's + -- length against the operational reading, since 'invTrace' does not + -- sample the reset state. + testCase "invariant holds after the reset hop" $ let bad = [ name | (name, prog) <- progs, - P.not (inv (initIsa prog) (initSys prog)) + P.not (baseHolds prog) ] in if P.null bad then pure () - else assertFailure (P.unlines [n P.++ ":\n" P.++ explain (initIsa prog) (initSys prog) | (n, prog) <- progs, P.elem n bad]), - testProperty "invariant holds at reset for any program" $ + else assertFailure (P.unlines [n P.++ ":\n" P.++ baseReport prog | (n, prog) <- progs, P.elem n bad]), + testProperty "invariant holds after the reset hop for any program" $ withMaxSuccess 2000 $ forAll genProg $ \prog -> - counterexample (explain (initIsa prog) (initSys prog)) $ - inv (initIsa prog) (initSys prog), + counterexample (baseReport prog) (baseHolds prog), testGroup "driver lands on aligned states" [ testCase name $ @@ -379,9 +402,9 @@ proofTests = P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' sys')))) ) (indStepObligation wr wa (hopPc sys) sys), - -- k = 1: the two-cycle hop. Both shapes that reach it are generated; - -- 'coverage1' asserts each is actually sampled, since a premise this - -- specific is easy to miss entirely and still see a green property. + -- k = 1: the two-cycle hop, a memory instruction in writeback. The test + -- below asserts generated states actually satisfy the premise, since one + -- this specific is easy to miss entirely and still see a green property. testProperty "k=1 inductive step on arbitrary pipeline states" $ -- 1e6 run by hand: 23s, no counterexample. 20k keeps the suite fast. withMaxSuccess 20000 $ @@ -390,8 +413,7 @@ proofTests = s2 = stepSysN 2 sys isa' = case isaStep isa of Next x -> x; IsaHalted -> isa in counterexample - ( "startupShape=" P.++ show (isStartupShape sys) - P.++ "\nme=" P.++ show (stateMeInstr (sysState sys)) + ( "me=" P.++ show (stateMeInstr (sysState sys)) P.++ "\nwb=" P.++ show (stateWbInstr (sysState sys)) P.++ "\nex=" P.++ show (exInstr sys) P.++ "\nexPc=" P.++ show (stateExPc (sysState sys)) @@ -400,36 +422,15 @@ proofTests = P.++ "\nfailing=" P.++ show (P.map P.fst (P.filter (P.not . P.snd) (P.concatMap caseConjuncts (invCasesAt wr wa isa' s2)))) ) (indStepObligation1 wr wa (hopPc sys) sys), - testCase "k=1 generator reaches both hop shapes" $ + testCase "k=1 generator satisfies the premise" $ let sample = [s | (s, _, _) <- unGen (vectorOf 4000 genArbSys1) (mkQCGen 7) 30] - admitted p = + admitted = [ () | s <- sample, - p s, driver s P.== 1, invAtFree 1 0 (isaAt (hopPc s) s) s ] - startups = admitted isStartupShape - steadies = admitted (P.not . isStartupShape) - in do - assertBool "no startup state satisfied the k=1 premise" (P.not (P.null startups)) - assertBool "no steady state satisfied the k=1 premise" (P.not (P.null steadies)), - -- Why the obligations quantify @isaPc@ rather than deriving it: the - -- conjunct that pins it differs per case. A startup state is admitted at - -- the fetch-stage PC and at no other, so deriving it from the execute - -- stage would leave every startup state satisfying no case of the - -- invariant, and the k=1 obligation vacuous there. - testCase "startup states are admitted at the fetch PC and not the execute PC" $ - let sample = [s | (s, _, _) <- unGen (vectorOf 2000 genArbSys1) (mkQCGen 11) 30, isStartupShape s] - admits pc s = invAtFree 1 0 (isaAt (pc s) s) s - in do - assertBool "generator produced no startup states" (P.not (P.null sample)) - assertBool - "the fetch PC should admit some startup state" - (P.any (admits (stateFePc . sysState)) sample) - assertBool - "the execute PC should admit no startup state" - (P.not (P.any (admits (stateExPc . sysState)) sample)), + in assertBool "no generated state satisfied the k=1 premise" (P.not (P.null admitted)), -- k = 2: jumps and the all-memory steady shape return to a running -- invariant case after three core cycles; ecall/ebreak return to one of -- the two halted cases. @@ -495,14 +496,9 @@ inductiveStep sys where isa = isaFromSys sys sys' = stepSysN (driver sys + 1) sys - -- A startup hop brings the first instruction into the execute stage without - -- executing anything, so the architectural state does not advance across it. - -- 'Proof.Functional.Obligation.indStepObligation1' carves out the same case. - isa' - | isStartupShape sys = isa - | otherwise = case isaStep isa of - Next i -> i - IsaHalted -> isa + isa' = case isaStep isa of + Next i -> i + IsaHalted -> isa inv' a s = P.any holdsCase (invCases a s) holdsCase c = P.all P.snd (caseConjuncts c) @@ -817,15 +813,13 @@ genArbSys = do (MemFn memf) P.pure (sys, wr, wa) --- | States the driver sends on a two-cycle hop, i.e. @driver == 1@. Two shapes --- reach it, and they are generated separately because their invariant cases --- constrain the fetch path differently: --- --- * startup -- every stage holds @Nop FirstCycle@ and nothing is on the bus; --- * steady with a memory instruction in writeback -- it occupied the bus --- last cycle, so no instruction was fetched and @fePc == exPc + 4@. +-- | States the driver sends on a two-cycle hop, i.e. @driver == 1@, that the +-- invariant admits: a memory instruction in writeback, which occupied the bus +-- last cycle, so no instruction was fetched and @fePc == exPc + 4@. The reset +-- state also gets a two-cycle hop, but it is not in the invariant; see +-- 'Proof.Functional.Induction.baseCase'. genArbSys1 :: Gen (SysG RegFn MemFn, RegIdx, Address) -genArbSys1 = oneof [genStartup1, genSteady1] +genArbSys1 = genSteady1 -- | Arbitrary running states sent on a three-cycle hop. The three satisfiable -- driver branches are generated separately: @@ -963,44 +957,6 @@ genSteady2 = do (MemFn memf) P.pure ("steady", sys, wr, wa) --- | The startup shape. @fePc@ is where the ISA's PC sits, and the pipeline is --- empty, so no memory word is pinned to any stage. -genStartup1 :: Gen (SysG RegFn MemFn, RegIdx, Address) -genStartup1 = do - fePc <- genBase - firstI <- genNonMem - nextI <- genDeInstr - let w0 = P.maybe 0 P.id (encode' (roundTrips firstI)) - w1 = P.maybe 0 P.id (encode' (roundTrips nextI)) - w2 <- genW - (memf, _) <- genMemWindow fePc w0 w1 w2 - rfF <- genFn (chooseBoundedIntegral (0, 3)) genW genW - wr <- genWitnessReg - wa <- unpack <$> genW - let sys = - Sys - ( (sysState (initSys (mkProg prog1))) - { stateFePc = fePc, - -- The other PCs are unconstrained by the startup case; give - -- them junk so nothing accidentally relies on them. - stateDePc = 0, - stateExPc = 0, - stateExInstr = Nop FirstCycle, - stateMeInstr = Nop FirstCycle, - stateWbInstr = Nop FirstCycle, - stateMeRes = pure 0, - stateWbRes = pure 0, - stateMeAddr = 0, - stateRegFile = RegFn (P.fmap Identity rfF), - stateCtrl = initCtrl, - stateHalt = Nothing, - stateHaltNextPc = 0 - } - ) - (Input False (pure 0)) - (MemFn memf) - P.pure (sys, wr, wa) - -- | The steady two-cycle shape: a load or store in writeback, a non-memory -- instruction in the memory stage. Nothing is on the bus this cycle, so -- @inputMem@ is the value the writeback-stage load reads, not an instruction. @@ -1151,8 +1107,7 @@ shape = \case -- never hit, the passing property above says less than it appears to. interesting :: [String] interesting = - [ "driver:firstCycle", - "driver:env", + [ "driver:env", "driver:jump", "driver:storeHazard/mem", "driver:storeHazard/nomem", diff --git a/test/Spec.hs b/test/Spec.hs index 982f0b4..163a095 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -88,7 +88,7 @@ sanityTests = lookup "arrRoundTrip" Proof.Functional.Induction.results @?= Just Nothing, testCase "shift embeddings are sane" $ lookup "shiftsSane" Proof.Functional.Induction.results @?= Just Nothing, - testCase "base case: invariant holds at reset" $ + testCase "base case: invariant holds after the reset hop" $ lookup "baseCase" Proof.Functional.Induction.results @?= Just Nothing, testCase "k = 0 inductive step is valid" $ lookup "indStep0" Proof.Functional.Induction.results @?= Just Nothing, From 7e1d5f9d30242b74c7cbc09dcf4b4c1a55934ca5 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 14:28:58 +0200 Subject: [PATCH 14/16] Refer to Syscall unqualified in the halted cases, like EBreak The ecall halted case wrote Core.Syscall while the ebreak case wrote a bare EBreak. The qualification guards against ISA's Instr constructor of the same name, but that has never been in scope in this module: it imported ISAStep originally and now takes only IsaStateG and IsaState from ISA. So a bare Syscall already resolves to Core's HaltState constructor, and the two cases now read alike. No change in meaning: an ambiguous or wrongly resolved Syscall would not compile. No-solver configuration builds cleanly; 132 tests pass. Co-Authored-By: Claude Opus 5 --- proof/Proof/Functional/Invariant.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs index 8a3a5e1..e24ba9a 100644 --- a/proof/Proof/Functional/Invariant.hs +++ b/proof/Proof/Functional/Invariant.hs @@ -198,7 +198,7 @@ invCasesGen :: invCasesGen eqRF eqMem (IsaState ipc irf imem) sys@(Sys st inp mem) = [ runningCase, haltedCase "halted/ebreak" isBreak (EBreak (ipc + 4)), - haltedCase "halted/ecall" isCall (Core.Syscall (ipc + 4)) + haltedCase "halted/ecall" isCall (Syscall (ipc + 4)) ] where inputWord = runIdentity (inputMem inp) @@ -342,4 +342,4 @@ haltedCaseAt kind wr wa (IsaState ipc irf imem) (Sys st _ mem) = HaltCall -> isCall expected = case kind of HaltBreak -> EBreak (ipc + 4) - HaltCall -> Core.Syscall (ipc + 4) + HaltCall -> Syscall (ipc + 4) From fcf63b201bdab13792e32f11557f6030fd7bfd80 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 14:30:54 +0200 Subject: [PATCH 15/16] Remove isArithOrJumpInstr, which only one test used Invariant defined isArithOrJumpInstr, the note's predicate, while its partner isMemInstr lives in Proof.Driver, and nothing in the invariant or the obligations used it: the running case states "not an environment instruction" directly. Its only caller was a test checking that the two predicates partition the non-environment instructions, which justified collapsing the note's four running cases into that form. Drop the definition, that test and its allInstrs helper. The note keeps the predicate as part of the specification; the collapse now rests on reading the two short case analyses rather than on a check that would only have caught a mismatch if allInstrs had been kept in step anyway. No-solver configuration builds cleanly with no new warnings; 131 tests pass. Co-Authored-By: Claude Opus 5 --- proof/Proof/Functional/Invariant.hs | 39 ++++++--------------------- test/ProofSpec.hs | 41 ----------------------------- 2 files changed, 8 insertions(+), 72 deletions(-) diff --git a/proof/Proof/Functional/Invariant.hs b/proof/Proof/Functional/Invariant.hs index e24ba9a..4cfe520 100644 --- a/proof/Proof/Functional/Invariant.hs +++ b/proof/Proof/Functional/Invariant.hs @@ -32,7 +32,6 @@ module Proof.Functional.Invariant ( flushWbStage, flushMeStage, - isArithOrJumpInstr, Case (..), inv, invAt, @@ -56,28 +55,6 @@ import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) import qualified Prelude as P --- | From @invariant.txt@: everything that is neither a memory instruction nor --- an environment instruction. --- --- Together with 'Proof.Driver.isMemInstr' this is what the note's four running --- cases split on. The two are complementary apart from @ecall@ and @ebreak@, --- which neither accepts, so requiring an instruction to satisfy one or the --- other is exactly requiring that it not be an environment instruction -- which --- is how the running case states it. -isArithOrJumpInstr :: Instruction -> Bool -isArithOrJumpInstr ir = - case ir of - RType {} -> True - IType (Arith _) _ _ _ -> True - IType (Load _ _) _ _ _ -> False - SType {} -> False - BType {} -> True - JType _ _ -> True - IType Jump _ _ _ -> True - UType {} -> True - IType (Env _) _ _ _ -> False - Nop _ -> True - -- | Apply the pending effect of the writeback-stage instruction. The load case -- reads its value off @inputMem@, matching 'Core.writeback'. flushWbStage :: @@ -211,14 +188,14 @@ invCasesGen eqRF eqMem (IsaState ipc irf imem) sys@(Sys st inp mem) = -- The note's four running cases, collapsed. -- - -- They split on @(isArithOrJumpInstr, isMemInstr)@ for the writeback and - -- memory stages, but the only conjuncts that vary across the four -- the - -- fetch triple -- vary with the writeback stage alone: when a memory - -- instruction is in writeback it held the bus last cycle, so nothing was - -- fetched. The memory stage's classification changes no conjunct; its sole - -- effect is to demand the stage hold something the two predicates cover, - -- which is everything but @ecall@ and @ebreak@. Both stages are therefore - -- stated directly as \"not an environment instruction\". + -- They split on the note's @isArithOrJumpInstr@ and @isMemInstr@ for the + -- writeback and memory stages, but the only conjuncts that vary across the + -- four -- the fetch triple -- vary with the writeback stage alone: when a + -- memory instruction is in writeback it held the bus last cycle, so nothing + -- was fetched. The memory stage's classification changes no conjunct; its + -- sole effect is to demand the stage hold something the two predicates + -- cover, which is everything but @ecall@ and @ebreak@. Both stages are + -- therefore stated directly as \"not an environment instruction\". runningCase = Case "running" $ [ ("running", running sys), diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index 639bbf8..2060161 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -321,18 +321,6 @@ proofTests = testCase "inductive with a jump in the memory stage" $ let bad = [e | sys <- sampleStates 200, Just e <- [inductiveStep (withJumpInMe sys)]] in if P.null bad then pure () else assertFailure (P.head bad), - -- The running case is stated as \"neither writeback nor memory holds an - -- environment instruction\", which is the note's four-way split on - -- @isArithOrJumpInstr@ / @isMemInstr@ only because those two predicates - -- partition everything else. If that ever stops being true the collapse is - -- unsound, so check it directly. - testCase "arith-or-jump and mem partition the non-env instructions" $ - let bad = - [ ir - | ir <- allInstrs, - (isArithOrJumpInstr ir || isMemInstr ir) /= P.not (isEnvInstr ir) - ] - in if P.null bad then pure () else assertFailure (show (P.take 5 bad)), -- The pointwise form is what symbolic execution uses, since function-backed -- register files and memories have no decidable equality. It must agree -- with the container form wherever the latter holds, or the witness @@ -520,35 +508,6 @@ withJumpInMe :: Sys -> Sys withJumpInMe s = s {sysState = (sysState s) {stateMeInstr = JType 5 0, stateMeRes = pure 0x1234}} --- | One instruction per constructor shape the invariant's predicates --- distinguish, so the partition check covers every branch of both. -allInstrs :: [Instruction] -allInstrs = - [ RType ADD 1 2 3, - IType (Arith ADD) 1 2 3, - IType (Load Word Signed) 1 2 3, - SType Word 0 1 2, - BType NE 0 1 2, - JType 1 0, - IType Jump 1 2 3, - UType Zero 1 0, - IType (Env Call) 0 0 0, - IType (Env Break) 0 0 0 - ] - P.++ P.map - Nop - [ JumpFirstCycle, - JumpSecondCycle, - LoadHazardFirstCycle, - LoadHazardSecondCycle, - StoreHazardFirstCycle, - StoreHazardSecondCycle, - MemoryBusBusy, - DecodeFail, - FirstCycle, - Halted - ] - -- The fifth counterexample, explained: address wraparound --------------------- -- -- History, kept because it is what this state tests. The earlier proof excluded From 9d7c0666d06b475a3d290f24d9a414ffa43af7f3 Mon Sep 17 00:00:00 2001 From: Kristina Date: Mon, 14 Sep 2026 14:36:15 +0200 Subject: [PATCH 16/16] Say in package.yaml that CI now discharges the proof with bitwuzla Since "Replace z3 with bitwuzla in CI", the workflow installs bitwuzla and runs stack test with the smt-proof flag on, so the comment claiming CI builds with the flag off was out of date. Also correct "seconds each" to "under a minute": indStep3 takes about 50s. Comment-only change. Co-Authored-By: Claude Opus 5 --- package.yaml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 90b56ce..bca72b4 100644 --- a/package.yaml +++ b/package.yaml @@ -23,15 +23,17 @@ description: Please see the README on GitHub at