From ae97be3bef785110c2dd195e98ecc1f1b980bb3f Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 03:06:43 +0100 Subject: [PATCH 1/6] Rename outMem to outputMem, give the cache arrays equality, wrap long lines Output's field is now outputMem, matching Input's inputMem. TagArr and DataArr get Eq through the OPAQUE tagEq and dataEq, so that cache states can be compared whole (the proof replaces both by SMT array equality). The cache server's header and comments describe the cache as it now behaves: a read is answered from the cache after filling each of its lines that misses, and a write is merged byte by byte into the lines that hold its block. Long lines in src/ are wrapped at 80 columns. Part of a series; it builds together with the commits that follow, the last of which is tested. Co-Authored-By: Claude Opus 5.5 --- src/Core.hs | 26 +++++++++++++++----------- src/Core/ISA.hs | 18 ++++++++++++------ src/Core/Instruction.hs | 7 +++++-- src/Core/RegFile.hs | 6 +++++- src/Elf/ElfLoader.hs | 28 ++++++++++++++++++++-------- src/Elf/Syscall.hs | 18 ++++++++++++++++-- src/HardwareSim.hs | 22 ++++++++++++++++++---- src/Memory/Cache4K.hs | 34 +++++++++++++++++++++++++++------- src/Memory/Cache4KServer.hs | 31 +++++++++++++++++-------------- src/Memory/IO.hs | 13 +++++++++---- src/Memory/ST.hs | 33 +++++++++++++++++++++++++++------ src/Memory/Types.hs | 12 ++++++++---- src/Simulate.hs | 18 +++++++++++++++--- 13 files changed, 194 insertions(+), 72 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 32a9f9e..b7cfda9 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -74,7 +74,7 @@ type Request = Maybe MemAccess -- | The output of the CPU. newtype Output = Output { -- | A memory access. - outMem :: Request + outputMem :: Request } deriving (Show, Generic, NFDataX) @@ -152,12 +152,14 @@ data Control = Control -- | Stores the jump address if the instruction in the `execute` stage -- results in a jump. ctrlExJumpAddr :: Maybe Address, - -- | Stores the write address and size if the instruction in the `execute` stage + -- | Stores the write address and size if the instruction in the `execute` + -- stage -- is a store. ctrlExStoreAddrSize :: Maybe (Address, Size), -- | `True` when the instruction in the `memory` stage is a store or a load. ctrlMeMemInstr :: Bool, - -- | Stores the write address and size if the instruction in the `memory` stage + -- | Stores the write address and size if the instruction in the `memory` + -- stage -- is a store. ctrlMeStoreAddrSize :: Maybe (Address, Size), -- | Forwards the `rd` register from the `memory` stage to the `execute` @@ -234,9 +236,9 @@ initCtrl = ctrlMemNotReady = False } --- | Fetch stage. Holds while memory has not answered (see 'writeback'), like the --- other stages before writeback: a stall then leaves every pipeline register --- as it was. +-- | Fetch stage. Holds while memory has not answered (see 'writeback'), like +-- the other stages before writeback: a stall then leaves every pipeline +-- register as it was. fetch :: CPUM r () fetch = do notReady <- gets (ctrlMemNotReady . stateCtrl) @@ -297,8 +299,10 @@ decodeFresh = do let break_current_cycle = maybe False isBreak (ctrlExInstr ctrl) let jump_previous_cycle = ctrlExInstr ctrl == Just (Nop JumpFirstCycle) - let store_hazard_previous_cycle = ctrlExInstr ctrl == Just (Nop StoreHazardFirstCycle) - let load_hazard_previous_cycle = ctrlExInstr ctrl == Just (Nop LoadHazardFirstCycle) + let store_hazard_previous_cycle = + ctrlExInstr ctrl == Just (Nop StoreHazardFirstCycle) + let load_hazard_previous_cycle = + ctrlExInstr ctrl == Just (Nop LoadHazardFirstCycle) let jump_current_cycle = isJust (ctrlExJumpAddr ctrl) @@ -596,16 +600,16 @@ readPC :: (MonadWriter Output m) => Address -> m () readPC addr = tell $ (mempty :: Output) - { outMem = pure $ MemFetch addr } + { outputMem = pure $ MemFetch addr } readRAM :: (MonadWriter Output m) => Address -> Size -> m () readRAM addr size = tell $ (mempty :: Output) - { outMem = pure $ MemRead addr size } + { outputMem = pure $ MemRead addr size } writeRAM :: (MonadWriter Output m) => Address -> Size -> Word -> m () writeRAM addr size val = tell $ (mempty :: Output) - { outMem = pure $ MemWrite addr size val } + { outputMem = pure $ MemWrite addr size val } diff --git a/src/Core/ISA.hs b/src/Core/ISA.hs index 8ae7a67..9339f3a 100644 --- a/src/Core/ISA.hs +++ b/src/Core/ISA.hs @@ -5,10 +5,11 @@ -- | The ISA specification: what each instruction means, and how the -- architectural state evolves. -- --- Two halves, both semantics. 'interp' turns an 'Core.Instruction.Instruction' into --- an @'Instr' 'Func'@ -- the effect it denotes -- and 'apply' evaluates one of --- those 'Func's against the two source-register values and the PC. On top of --- that, 'isaStep' says how the @(isaPc, isaRegFile, isaMem)@ triple moves. +-- Two halves, both semantics. 'interp' turns an 'Core.Instruction.Instruction' +-- into an @'Instr' 'Func'@ -- the effect it denotes -- and 'apply' evaluates +-- one of those 'Func's against the two source-register values and the PC. On +-- top of that, 'isaStep' says how the @(isaPc, isaRegFile, isaMem)@ triple +-- moves. -- -- The architectural state is parameterised over the register-file and memory -- representations because the @Vec@-backed ones cannot be symbolically @@ -37,7 +38,8 @@ module Core.ISA ) where -import Clash.Prelude hiding (Const, Log, Ordering (..), Word, def, init, lift, log) +import Clash.Prelude + hiding (Const, Log, Ordering (..), Word, def, init, lift, log) import Core hiding (Syscall) import Core.Instruction (Instruction, Sign, decode', loadExtend) import qualified Core.Instruction @@ -244,7 +246,11 @@ isaStepDecoded ir st@(IsaState pc rf mem) = isaRegFile = modifyRFg rd (bitCoerce (ap link)) rf } Store size addr rs2 -> - Next st {isaPc = pc + 4, isaMem = memWrite (ap addr) size (reg (Just rs2)) mem} + Next + st + { isaPc = pc + 4, + isaMem = memWrite (ap addr) size (reg (Just rs2)) mem + } Branch cond target -> Next st {isaPc = if ap cond then ap target else pc + 4} Nop -> Next st {isaPc = pc + 4} diff --git a/src/Core/Instruction.hs b/src/Core/Instruction.hs index c5f39bc..df707fe 100644 --- a/src/Core/Instruction.hs +++ b/src/Core/Instruction.hs @@ -103,7 +103,8 @@ data IOperation | Jump deriving (Eq, Show, Generic, NFDataX) --- | Reason for replacing an instruction with a nop. Some of these can be collapsed if we want to optimize later. +-- | Reason for replacing an instruction with a nop. Some of these can be +-- collapsed if we want to optimize later. data Reason4Stall = -- | First instruction discarded because of a jump. JumpFirstCycle @@ -373,7 +374,9 @@ encode' instruction = let rs1' = pack rs1 let rs2' = pack rs2 - pure $ imm12 ++# imm10to5 ++# rs2' ++# rs1' ++# funct3 ++# imm4to1 ++# imm11 ++# opcode + pure $ + imm12 ++# imm10to5 ++# rs2' ++# rs1' ++# funct3 ++# imm4to1 ++# imm11 + ++# opcode UType base rd imm -> do let opcode :: BitVector 7 = case base of Zero -> 0b011_0111 diff --git a/src/Core/RegFile.hs b/src/Core/RegFile.hs index 13bf6af..c887ac9 100644 --- a/src/Core/RegFile.hs +++ b/src/Core/RegFile.hs @@ -26,7 +26,11 @@ newtype RegFile = RegFile (Vec ((2 ^ 5) - 1) Word) regIdxName :: RegIdx -> String regIdxName idx = - ["zero", "ra", "sp", "gp", "tp", "t0", "t1", "t2", "s0", "s1", "a0", "a1", "a2", "a3", "a4", "a5", "a6", "a7", "s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9", "s10", "s11", "t3", "t4", "t5", "t6"] + [ "zero", "ra", "sp", "gp", "tp", "t0", "t1", "t2", + "s0", "s1", "a0", "a1", "a2", "a3", "a4", "a5", + "a6", "a7", "s2", "s3", "s4", "s5", "s6", "s7", + "s8", "s9", "s10", "s11", "t3", "t4", "t5", "t6" + ] P.!! (fromIntegral idx) instance Show RegFile where diff --git a/src/Elf/ElfLoader.hs b/src/Elf/ElfLoader.hs index 24cf652..70de775 100644 --- a/src/Elf/ElfLoader.hs +++ b/src/Elf/ElfLoader.hs @@ -37,22 +37,26 @@ loadElf elf@(Elf classS _) = withSingElfClassI classS $ do forM_ (zip [0 ..] bytes) $ \(i, byte) -> ramWrite (addr + fromIntegral i) Byte (zeroExtend $ bitCoerce byte) --- | Extract all loadable sections from an ELF into a list of (Address, ByteString) +-- | Extract all loadable sections from an ELF into a list of (Address, +-- ByteString) getElfSegments :: Elf -> [(Address, BS.ByteString)] getElfSegments (Elf classS elfs) = withSingElfClassI classS $ let loadable = loadableSegments elfs in P.concatMap extractSegmentSections loadable where - extractSegmentSections :: (SingElfClassI a) => ElfXX 'Segment a -> [(Address, BS.ByteString)] + extractSegmentSections :: + (SingElfClassI a) => ElfXX 'Segment a -> [(Address, BS.ByteString)] extractSegmentSections ElfSegment {..} = let sections = gatherSections epData in -- We ignore epAddMemSize here to avoid massive allocations; -- BSS should be handled by the memory model (zero-initialized). sections - gatherSections :: (SingElfClassI a) => ElfListXX a -> [(Address, BS.ByteString)] + gatherSections :: + (SingElfClassI a) => ElfListXX a -> [(Address, BS.ByteString)] gatherSections ElfListNull = [] - gatherSections (ElfListCons (ElfSection {esData = ElfSectionData d, ..}) xs) = + gatherSections + (ElfListCons (ElfSection {esData = ElfSectionData d, ..}) xs) = (fromIntegral esAddr, BSL.toStrict d) : gatherSections xs gatherSections (ElfListCons _ xs) = gatherSections xs @@ -84,7 +88,8 @@ baseAddr (Elf SELFCLASS32 elfs) = go elfs go ElfListNull = pure 0 -- | Read a string from memory starting at the given address for count bytes -readStringFromMemory :: (MonadMemory m) => Unsigned 32 -> Unsigned 32 -> m String +readStringFromMemory :: + (MonadMemory m) => Unsigned 32 -> Unsigned 32 -> m String readStringFromMemory addr count = do bytes <- forM [0 .. count - 1] $ \i -> do @@ -92,10 +97,16 @@ readStringFromMemory addr count = do pure $ fromIntegral (byte .&. 0xFF) pure $ P.map chr $ takeWhile (/= 0) bytes --- | Called when the core halts with a syscall. Return the value to write to a0, or Nothing to truly exit. +-- | Called when the core halts with a syscall. Return the value to write to a0, +-- or Nothing to truly exit. type Instrument m = Core.State -> m (Maybe Types.Word) -runElf :: forall m. (MonadIO m, MonadMemory m) => Instrument m -> CircuitSim m Core.Input Core.State Core.Output -> m () +runElf :: + forall m. + (MonadIO m, MonadMemory m) => + Instrument m -> + CircuitSim m Core.Input Core.State Core.Output -> + m () runElf instr c = go c where go sim@(CircuitSim i s step next) = do @@ -111,6 +122,7 @@ runElf instr c = go c case mRet of Nothing -> pure () Just ret -> do - let s'' = Core.initAt resumePc (modifyRF 10 ret (Core.stateRegFile s')) + let rf' = modifyRF 10 ret (Core.stateRegFile s') + s'' = Core.initAt resumePc rf' go $ sim {circuitInput = Core.initInput, circuitState = s''} Just (Core.EBreak _) -> pure () \ No newline at end of file diff --git a/src/Elf/Syscall.hs b/src/Elf/Syscall.hs index ef28693..09049da 100644 --- a/src/Elf/Syscall.hs +++ b/src/Elf/Syscall.hs @@ -2,7 +2,20 @@ module Elf.Syscall (handleSyscall, ProgramExitException(..)) where -import Clash.Prelude hiding (Log, Ordering (..), Word, break, def, init, lift, log, resize, zip, (++)) +import Clash.Prelude + hiding + ( Log, + Ordering (..), + Word, + break, + def, + init, + lift, + log, + resize, + zip, + (++) + ) import Prelude hiding (Ordering (..), Word, break, init, log, map, not, repeat, undefined, (&&), (||)) import Memory.Types import Elf.ElfLoader @@ -76,7 +89,8 @@ handleSyscall s = do "/dev/random" -> randomFd "/dev/urandom" -> randomFd _ -> bitCoerce (-1 :: Int32) - 676767 -> -- mark_memory_region: accepted and ignored; the core tracks no secrets + -- mark_memory_region: accepted and ignored; the core tracks no secrets + 676767 -> pure $ Just 0 n -> do liftIO $ putStrLn $ "Syscall: Unknown " ++ show (toInteger n) diff --git a/src/HardwareSim.hs b/src/HardwareSim.hs index 5ee0611..6bb03d8 100644 --- a/src/HardwareSim.hs +++ b/src/HardwareSim.hs @@ -21,20 +21,34 @@ topEntity :: Signal System Output topEntity = exposeClockResetEnable $ system prog3 -cpu :: forall dom. (HiddenClockResetEnable dom) => Signal dom Input -> Signal dom Output +cpu :: + forall dom. + (HiddenClockResetEnable dom) => + Signal dom Input -> + Signal dom Output cpu = mealy (circuit @RegFile) (init @RegFile) -system :: forall dom. (HiddenClockResetEnable dom) => Vec PROG_SIZE Word -> Signal dom Output +system :: + forall dom. + (HiddenClockResetEnable dom) => + Vec PROG_SIZE Word -> + Signal dom Output system prog = cpuOut where cpuInput :: Signal dom Input cpuInput = register initInput input cpuOut = cpu cpuInput - ram = HardwareSim.mkRAM @PROG_SIZE @RAM_SIZE prog (fromMaybe (MemRead 0 Word) . outMem <$> cpuOut) + ram = + HardwareSim.mkRAM @PROG_SIZE @RAM_SIZE prog + (fromMaybe (MemRead 0 Word) . outputMem <$> cpuOut) input = Input . Just <$> ram mkRAM :: forall progSize ramSize dom. - (HiddenClockResetEnable dom, KnownNat ((GHC.TypeNats.*) ramSize 4), KnownNat (progSize + ramSize), KnownNat ((GHC.TypeNats.*) (progSize + ramSize) 4)) => + ( HiddenClockResetEnable dom, + KnownNat ((GHC.TypeNats.*) ramSize 4), + KnownNat (progSize + ramSize), + KnownNat ((GHC.TypeNats.*) (progSize + ramSize) 4) + ) => Vec progSize Word -> Signal dom MemAccess -> Signal dom Word diff --git a/src/Memory/Cache4K.hs b/src/Memory/Cache4K.hs index c364a27..f6bb2bb 100644 --- a/src/Memory/Cache4K.hs +++ b/src/Memory/Cache4K.hs @@ -8,7 +8,7 @@ -- -- The arrays are 'Vec's, read and written only through the wrappers below. -- Those are @OPAQUE@ so that the proof can replace them by SMT array operations --- ("Proof.Cache.Array"), as it does for the register file and memory: the +-- ("Proof.Cache.SMT.Array"), as it does for the register file and memory: the -- Clash 'Vec' operations themselves cannot be symbolically executed. module Memory.Cache4K ( -- * Arrays @@ -16,10 +16,12 @@ module Memory.Cache4K tagRead, tagWrite, tagEmpty, + tagEq, DataArr (..), dataRead, dataWrite, dataZero, + dataEq, -- * Addresses Tag, @@ -53,7 +55,10 @@ import Prelude hiding (Ordering (..), Word, init, log, not, repeat, undefined, ( -- | The tag entries, one per set: the valid bit, then the tag. newtype TagArr = TagArr (Vec 256 (BitVector 21)) - deriving (Eq, Show) + deriving (Show) + +instance Eq TagArr where + (==) = tagEq -- | The tag entry of set @si@. {-# OPAQUE tagRead #-} @@ -70,9 +75,17 @@ tagWrite si e (TagArr v) = TagArr (replace si e v) tagEmpty :: TagArr tagEmpty = TagArr (repeat 0) +-- | Are two tag arrays equal at every set? +{-# OPAQUE tagEq #-} +tagEq :: TagArr -> TagArr -> Bool +tagEq (TagArr v) (TagArr w) = v == w + -- | The data, one word per set and word within the line. newtype DataArr = DataArr (Vec 1024 Word) - deriving (Eq, Show) + deriving (Show) + +instance Eq DataArr where + (==) = dataEq -- | The word at index @i@ (set, then word within the line). {-# OPAQUE dataRead #-} @@ -89,6 +102,11 @@ dataWrite i w (DataArr v) = DataArr (replace i w v) dataZero :: DataArr dataZero = DataArr (repeat 0) +-- | Are two data arrays equal at every index? +{-# OPAQUE dataEq #-} +dataEq :: DataArr -> DataArr -> Bool +dataEq (DataArr v) (DataArr w) = v == w + -- Addresses --------------------------------------------------------------------- -- | Which block of memory a line holds, among those that map to its set: bits @@ -211,15 +229,17 @@ cacheWriteByteInWord bi b w = case bi of -- address's block; otherwise leave the cache alone (no allocation). cacheWriteByte :: Address -> Byte -> Cache4K -> Cache4K cacheWriteByte addr b c - | cacheHit addr c = c {dataArr = dataWrite i (cacheWriteByteInWord (byteOf addr) b w) (dataArr c)} + | cacheHit addr c = + c {dataArr = dataWrite i (cacheWriteByteInWord (byteOf addr) b w) dat} | otherwise = c where i = setOf addr ++# wordOf addr - w = dataRead i (dataArr c) + dat = dataArr c + w = dataRead i dat -- | What a write does to the cache. Memory always takes the write --- (write-through); the cache only makes sure its copy does not go stale. Byte by --- byte, as memory stores it ('Memory.Types.memWrite'): each byte goes into +-- (write-through); the cache only makes sure its copy does not go stale. Byte +-- by byte, as memory stores it ('Memory.Types.memWrite'): each byte goes into -- its cached word if its line hits, so a write may cross a word or line -- boundary. cacheWrite :: Address -> Size -> Word -> Cache4K -> Cache4K diff --git a/src/Memory/Cache4KServer.hs b/src/Memory/Cache4KServer.hs index 0d447b4..a59dfed 100644 --- a/src/Memory/Cache4KServer.hs +++ b/src/Memory/Cache4KServer.hs @@ -4,12 +4,12 @@ -- | The 4 KiB cache ("Memory.Cache4K") as a server between the core and memory: -- how it answers the core's memory requests, cycle by cycle. -- --- A read miss takes 'penalty' extra cycles and then fills the line with the --- four words of its block; a read that leaves its word bypasses the cache with --- the same delay. A write goes through to memory at once: inside one word, on a --- hit, it is merged into the cached word; if it crosses a word boundary, the --- lines it touches are invalidated instead ('Memory.Cache4K.write'). Fetches --- bypass the cache. +-- A read touches the lines of its first and last byte. Each of them that misses +-- takes 'penalty' extra cycles and is filled with the four words of its block; +-- the read is then answered from the cache. A write goes through to memory at +-- once, and each of its bytes is merged into its cached word if that word's +-- line holds its block; a line that misses is left alone, with no allocation +-- ('Memory.Cache4K.cacheWrite'). Fetches bypass the cache. module Memory.Cache4KServer ( Cycles, CacheSrv (..), @@ -28,29 +28,32 @@ import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -- | Cycles of a miss penalty: a small counter, sized as hardware would size it. --- (This also keeps the symbolic proof in the bitvector fragment Bitwuzla reads.) +-- (This also keeps the symbolic proof in the bitvector fragment Bitwuzla +-- reads.) type Cycles = Unsigned 8 -- | Extra cycles of a read miss: the four words of a line. penalty :: Cycles penalty = 4 --- | The address of the last byte of an access. An access touches at most two --- lines: the lines of its first and last byte. +-- | Ready for a request, or waiting for memory: the cycles left, and the word a +-- read will be answered with. data CacheSrvState = CacheSrvReady | CacheSrvStall Cycles Word deriving (Show, Eq) --- | A cache in front of memory, as a server: the cache, a read waiting for --- memory, and memory. +-- | A cache in front of memory, as a server: the cache, memory, and whether a +-- read is waiting for memory. data CacheSrv m = CacheSrv { srvCache :: Cache4K, srvMem :: m, - -- | A read waiting for memory: its address and width, and the cycles left. + -- | Ready, or a read waiting for memory. srvState :: CacheSrvState } deriving instance (Show m) => Show (CacheSrv m) +deriving instance (Eq m) => Eq (CacheSrv m) + -- | The cache server at start: no line valid and no read waiting, in front of -- memory @mem@. initCacheSrv :: m -> CacheSrv m @@ -73,7 +76,7 @@ serve (CacheSrv c mem st) req = case st of Byte -> 0 Half -> 1 Word -> 3 - + hit1stLine = cacheHit addr c penalty1stLine = if hit1stLine then 0 else penalty c1 = if hit1stLine then c else cacheFill addr mem c @@ -87,7 +90,7 @@ serve (CacheSrv c mem st) req = case st of in if n > 0 then (CacheSrv c2 mem (CacheSrvStall (n - 1) w), Input Nothing) - else (CacheSrv c2 mem CacheSrvReady, Input $ Just w) + else (CacheSrv c2 mem CacheSrvReady, Input (Just w)) Just (MemWrite addr size val) -> ( CacheSrv (cacheWrite addr size val c) diff --git a/src/Memory/IO.hs b/src/Memory/IO.hs index 094d699..4c5a801 100644 --- a/src/Memory/IO.hs +++ b/src/Memory/IO.hs @@ -7,7 +7,8 @@ module Memory.IO ) where -import Clash.Prelude hiding (Log, Ordering (..), Word, break, def, init, lift, log, resize) +import Clash.Prelude + hiding (Log, Ordering (..), Word, break, def, init, lift, log, resize) import Clash.Sized.Vector (unsafeFromList) import Control.Monad (forM_) import Control.Monad.Reader @@ -69,6 +70,10 @@ instance {-# OVERLAPPING #-} MonadMemory (IOMemT IO) where forM_ (P.zip [0 ..] bytes) $ \(i, byte) -> lift $ writeArray ramArray (fromIntegral addr + i) byte case size of - Byte -> writeBytes [bitCoerce b0] -- Write 1 byte - Half -> writeBytes [bitCoerce b0, bitCoerce b1] -- Write 2 bytes (halfword) - Word -> writeBytes [bitCoerce b0, bitCoerce b1, bitCoerce b2, bitCoerce b3] -- Write 4 bytes (word) + -- Write 1 byte + Byte -> writeBytes [bitCoerce b0] + -- Write 2 bytes (halfword) + Half -> writeBytes [bitCoerce b0, bitCoerce b1] + -- Write 4 bytes (word) + Word -> + writeBytes [bitCoerce b0, bitCoerce b1, bitCoerce b2, bitCoerce b3] diff --git a/src/Memory/ST.hs b/src/Memory/ST.hs index 91a1f72..b4185a5 100644 --- a/src/Memory/ST.hs +++ b/src/Memory/ST.hs @@ -39,12 +39,21 @@ data STMemory s = STMemory -- | STMemory monad transformer. newtype STMemoryT s m a = STMemoryT {unSTMemoryT :: ReaderT (STMemory s) m a} - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (STMemory s), MonadTrans) + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadReader (STMemory s), + MonadTrans + ) runSTMemoryT :: STMemory s -> STMemoryT s m a -> m a runSTMemoryT mem (STMemoryT m) = runReaderT m mem -instance {-# OVERLAPPING #-} (MonadIO m) => MonadMemory (STMemoryT RealWorld m) where +instance {-# OVERLAPPING #-} + (MonadIO m) => MonadMemory (STMemoryT RealWorld m) + where ramRead addr size = do st <- ask let offset = addr - stDataBase st @@ -74,7 +83,11 @@ readDataArray addr size arr = case size of b1 <- readArray arr (addr + 1) b2 <- readArray arr (addr + 2) b3 <- readArray arr (addr + 3) - pure $ (bitCoerce b3 :: Byte) ++# (bitCoerce b2 :: Byte) ++# (bitCoerce b1 :: Byte) ++# (bitCoerce b0 :: Byte) + pure $ + (bitCoerce b3 :: Byte) + ++# (bitCoerce b2 :: Byte) + ++# (bitCoerce b1 :: Byte) + ++# (bitCoerce b0 :: Byte) -- | Write a sized value to the data array. writeDataArray :: Address -> Size -> Word -> STUArray s Address Word8 -> ST s () @@ -98,12 +111,20 @@ newSTMemory entry base = do pure $ STMemory arr base entry -- | Run a simulation in the ST monad. -runSTSim :: forall i s o a. (forall st. CircuitSim (ST st) i s o -> ST st a) -> CircuitSim (ST s) i s o -> ST s a +runSTSim :: + forall i s o a. + (forall st. CircuitSim (ST st) i s o -> ST st a) -> + CircuitSim (ST s) i s o -> + ST s a runSTSim f sim = f sim -- | Utility to run a full simulation until halt. --- Uses deepseqX to ensure the state is fully evaluated and prevent thunk leaks. -runUntilHalt :: (MonadMemory m) => CircuitSim m Core.Input Core.State Core.Output -> m Core.State +-- Uses deepseqX to ensure the state is fully evaluated and prevent thunk +-- leaks. +runUntilHalt :: + (MonadMemory m) => + CircuitSim m Core.Input Core.State Core.Output -> + m Core.State runUntilHalt sim = go sim where go sim' = do diff --git a/src/Memory/Types.hs b/src/Memory/Types.hs index d10e4b4..64235dd 100644 --- a/src/Memory/Types.hs +++ b/src/Memory/Types.hs @@ -36,9 +36,9 @@ type MemBytes = Vec MEM_SIZE_BYTES Byte -- | The operations a memory representation has to provide. -- --- Parameterised for the same reason as 'Core.RegFile.RegFileOps': the @Vec@-backed --- 'MemBytes' cannot be symbolically executed, while the function-backed 'MemFn' --- can. +-- Parameterised for the same reason as 'Core.RegFile.RegFileOps': the +-- @Vec@-backed 'MemBytes' cannot be symbolically executed, while the +-- function-backed 'MemFn' can. class MemOps m where memReadWord :: Address -> m -> Word memWrite :: Address -> Size -> Word -> m -> m @@ -121,7 +121,11 @@ mkProg prog = type MemSizeFrom progSize ramSizeBytes = ramSizeBytes + ((GHC.TypeNats.*) progSize 4) -mkRAM :: forall progSize ramSize. (KnownNat ramSize) => Vec progSize Word -> Vec (MemSizeFrom progSize ramSize) Byte +mkRAM :: + forall progSize ramSize. + (KnownNat ramSize) => + Vec progSize Word -> + Vec (MemSizeFrom progSize ramSize) Byte mkRAM prog = (repeat 0 :: Vec ramSize Byte) ++ Clash.Prelude.concatMap splitWord prog where diff --git a/src/Simulate.hs b/src/Simulate.hs index f5fa58e..358a6a7 100644 --- a/src/Simulate.hs +++ b/src/Simulate.hs @@ -56,15 +56,27 @@ simulator = runSimulator :: forall ramSize progSize a. (KnownNat ramSize, KnownNat (MemSizeFrom progSize ramSize)) => - ( CircuitSim (State (Mem (MemSizeFrom progSize ramSize))) Input Core.State Output -> + ( CircuitSim + (State (Mem (MemSizeFrom progSize ramSize))) + Input + Core.State + Output -> State (Mem (MemSizeFrom progSize ramSize)) a ) -> Vec progSize Word -> a runSimulator f = evalState (f simulator) . Mem . mkRAM -watchSim :: forall ramSize progSize. (KnownNat ramSize, KnownNat (MemSizeFrom progSize ramSize)) => Vec progSize Word -> [(Core.State, Output, Maybe Input)] +watchSim :: + forall ramSize progSize. + (KnownNat ramSize, KnownNat (MemSizeFrom progSize ramSize)) => + Vec progSize Word -> + [(Core.State, Output, Maybe Input)] watchSim = runSimulator @ramSize @progSize watch -simResult :: forall ramSize progSize. (KnownNat ramSize, KnownNat (MemSizeFrom progSize ramSize)) => Vec progSize Word -> Vec (MemSizeFrom progSize ramSize) Byte +simResult :: + forall ramSize progSize. + (KnownNat ramSize, KnownNat (MemSizeFrom progSize ramSize)) => + Vec progSize Word -> + Vec (MemSizeFrom progSize ramSize) Byte simResult = runSimulator result From b3d61ec1a9a4db68a6db14a37d433d67e0b8a2be Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 03:06:43 +0100 Subject: [PATCH 2/6] Core proof: halting bubbles, initial states, and the simulator's driver The driver no longer counts Nop Halted as a bubble while the core has not halted yet (isBubble looks at stateHalt). The leakage simulator gets two pending-halt states, PendingHaltFirstCycle and PendingHaltSecondCycle, so it follows the core through the cycles before a halt, and resets its control lines at the end of every cycle, as the core does. The core's invariant gives its ISA state a name, isaOf (was isaAt in Obligation), with archPc, archRegFile and archMem, and sysInvAt for the invariant at the ISA state the system determines. New properties: the driver and the simulator's driver agree with their operational readings on initial states (driverMatchesSpecInit, simDriverMatchesSpecInit), and the simulator's driver does on every state related to the core by both invariants (simDriverMatchesSpec, which takes the instruction's leakage and assumes sysInvAt). The obligations run hops through helpers (stepSysN, stepSysOutN, simCircuitN), and the leakage steps compare traces of their own Trace type, whose derived equality the solver can unroll. Proof.SMT gets equality on register files and memories (eqRA, eqM) and an embedding of toInteger on Unsigned. Every property of Proof.Core.Functional.Solver and Proof.Core.Leakage.Solver is valid, each module run on its own. Part of a series; see the last commit. Co-Authored-By: Claude Opus 5.5 --- proof/Proof/Core/Functional/Driver.hs | 109 +++++++---- proof/Proof/Core/Functional/Invariant.hs | 215 ++++++++++++++++++---- proof/Proof/Core/Functional/Machine.hs | 9 +- proof/Proof/Core/Functional/Obligation.hs | 144 +++++---------- proof/Proof/Core/Functional/Solver.hs | 174 ++++++++++++----- proof/Proof/Core/Leakage/Driver.hs | 68 ++++++- proof/Proof/Core/Leakage/Model.hs | 20 +- proof/Proof/Core/Leakage/Obligation.hs | 154 +++++++++------- proof/Proof/Core/Leakage/Simulator.hs | 50 +++-- proof/Proof/Core/Leakage/Solver.hs | 80 +++++--- proof/Proof/SMT/Array.hs | 76 +++++++- proof/Proof/SMT/Axioms.hs | 26 ++- proof/Proof/SMT/Sanity.hs | 3 +- 13 files changed, 786 insertions(+), 342 deletions(-) diff --git a/proof/Proof/Core/Functional/Driver.hs b/proof/Proof/Core/Functional/Driver.hs index 5ddf546..047ed68 100644 --- a/proof/Proof/Core/Functional/Driver.hs +++ b/proof/Proof/Core/Functional/Driver.hs @@ -1,10 +1,10 @@ --- | The driver: how many cycles 'Proof.Core.Functional.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: +-- | The driver: how many cycles 'Proof.Core.Functional.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', a case table over the pipeline state, and --- * 'driverRef', the operational reading, obtained by actually stepping. +-- * 'driverSpec', the operational reading, obtained by actually stepping. -- -- Checking these two against each other is the first thing the test suite does. -- @@ -16,7 +16,10 @@ module Proof.Core.Functional.Driver ( driver, driverCaseName, - driverRef, + driverSpec, + driverMatchesSpecInit, + driverMatchesSpec, + driverValues, takingJump, storeHazard, loadHazard, @@ -27,10 +30,12 @@ where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Core -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Core.Instruction hiding (loadHazard, storeHazard) import qualified Core.Instruction import Memory.Types (MemOps (..)) +import Core.ISA (IsaStateG) +import Proof.Core.Functional.Invariant (invAt) import Proof.Core.Functional.Machine import Core.RegFile import Types @@ -57,7 +62,8 @@ wbFwd (Sys core inp _) = case stateWbInstr core of RType _ rd _ _ -> Just (rd, res) IType (Arith _) rd _ _ -> Just (rd, res) - IType (Load size sign) rd _ _ -> Just (rd, loadExtend size sign (fromMaybe 0 (inputMem inp))) + IType (Load size sign) rd _ _ -> + Just (rd, loadExtend size sign (fromMaybe 0 (inputMem inp))) JType rd _ -> Just (rd, res) IType Jump rd _ _ -> Just (rd, res) UType _ rd _ -> Just (rd, res) @@ -83,7 +89,7 @@ takingJump :: (RegFileOps r) => SysG r m -> Bool takingJump sys@(Sys core _ _) = case stateExInstr core of BType cmp _ rs1 rs2 -> - (branch cmp (exArg sys rs1) (exArg sys rs2)) + branch cmp (exArg sys rs1) (exArg sys rs2) JType _ _ -> True IType Jump _ _ _ -> True _ -> False @@ -92,12 +98,13 @@ takingJump sys@(Sys core _ _) = -- decode-stage PC overlaps a store either in the execute stage or in the memory -- stage. -- --- The overlap test is 'Core.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@. +-- The overlap test is 'Core.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 core _ _) = maybe False (Core.Instruction.storeHazard dePc) exStore @@ -129,7 +136,7 @@ loadHazard (Sys core inp _) = -- | The driver's case table. The cases are checked in order. The driver is -- only ever run from states that satisfy the invariant -- ('Proof.Core.Functional.Invariant.invAt'); elsewhere it need not agree --- with 'driverRef'. +-- with 'driverSpec'. driver :: (RegFileOps r) => SysG r m -> Int driver sys@(Sys core _ _) | stateExInstr core == Nop FirstCycle = 1 @@ -143,6 +150,14 @@ driver sys@(Sys core _ _) | not (isMemInstr (stateExInstr core)) = 2 | otherwise = 3 +-- | The driver is 0 to 3: the hop lengths of the core's steps +-- ('Proof.Core.Functional.Obligation.indStep0' to +-- 'Proof.Core.Functional.Obligation.indStep3'), which so cover every hop. +driverValues :: (RegFileOps r) => SysG r m -> Bool +driverValues sys = k == 0 || k == 1 || k == 2 || k == 3 + where + k = driver 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 @@ -151,38 +166,70 @@ driverCaseName sys@(Sys core _ _) | stateExInstr core == Nop Halted = "halted" | isEnvInstr (stateExInstr core) = "env" | takingJump sys = "jump" - | storeHazard sys = if isMemInstr (stateExInstr core) then "storeHazard/mem" else "storeHazard/nomem" + | storeHazard sys = + if isMemInstr (stateExInstr core) + then "storeHazard/mem" + else "storeHazard/nomem" | loadHazard sys = "loadHazard" | not (isMemInstr (stateWbInstr core)) = "steady/wb-nomem" | not (isMemInstr (stateMeInstr core)) = "steady/me-nomem" | not (isMemInstr (stateExInstr core)) = "steady/ex-nomem" | otherwise = "steady/all-mem" --- | Is this a pipeline bubble, as opposed to a real instruction? +-- | Does the execute stage hold 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 +-- at that PC and the ISA steps over it like any other. Nor is @Nop Halted@ +-- once the core has halted: it then stays where it is, as the ISA does. While +-- the halt is still on its way through the pipeline -- an @ecall@ or @ebreak@ +-- that has left the execute stage but not yet halted the core -- @Nop Halted@ +-- is a bubble like the stall reasons, so the hop runs on until the core halts. +isBubble :: SysG r m -> Bool +isBubble (Sys core _ _) = case stateExInstr core of + Nop DecodeFail -> False + Nop Halted -> isNothing (stateHalt core) + Nop _ -> True + _ -> False -- | 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.Core.Functional.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). +-- 'Proof.Core.Functional.Machine.stepSys' steps taken after the first, so that +-- it agrees with 'driver', or 'Nothing' if @fuel@ ran out. -- -- \"No longer a no-op\" is read as '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) +driverSpec :: (RegFileOps r, MemOps m) => Int -> SysG r m -> Maybe Int +driverSpec fuel sys0 = go 0 (stepSys sys0) where - go n s@(Sys core _ _) - | not (isBubble (stateExInstr core)) = Just n + go n s + | not (isBubble s) = Just n | n >= fuel = Nothing | otherwise = go (n + 1) (stepSys s) + +-- | On the initial system the driver agrees with its operational reading: the +-- first hop, from the start PC @pc@ with register file @rf@ and memory @mem@ +-- ('Proof.Core.Functional.Machine.initSys'). The invariant does not cover the +-- initial system, so 'driverMatchesSpec' does not either. +driverMatchesSpecInit :: + (RegFileOps r, MemOps m) => Address -> r -> m -> Bool +driverMatchesSpecInit pc rf mem = + driverSpec 3 sys == Just (driver sys) + where + sys = initSys pc rf mem + +-- | On every other hop -- from the states the invariant relates to an ISA +-- state -- the driver agrees with its operational reading as well. Three cycles +-- of fuel cover the longest hop. +driverMatchesSpec :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +driverMatchesSpec wr wa isa sys = + not premises || conclusion + where + premises = invAt wr wa isa sys + + conclusion = driverSpec 3 sys == Just (driver sys) diff --git a/proof/Proof/Core/Functional/Invariant.hs b/proof/Proof/Core/Functional/Invariant.hs index 123f834..ed599b3 100644 --- a/proof/Proof/Core/Functional/Invariant.hs +++ b/proof/Proof/Core/Functional/Invariant.hs @@ -20,11 +20,11 @@ -- from drifting. -- -- The invariant describes the core attached to memory that answers every --- request in the next cycle ('Proof.Core.Functional.Machine.stepSys'), so the bus always holds --- an answer ('Core.inputMem' is 'Just'). +-- request in the next cycle ('Proof.Core.Functional.Machine.stepSys'), so the +-- bus always holds an answer ('Core.inputMem' is 'Just'). module Proof.Core.Functional.Invariant - ( flushWbStage, - flushMeStage, + ( applyWbStage, + applyMeStage, Case (..), inv, invAtList, @@ -32,6 +32,15 @@ module Proof.Core.Functional.Invariant invCasesAt, invAt, explain, + isaOf, + sysInvAt, + archPc, + archRegFile, + archMem, + pcUnderInv, + regFileUnderInv, + memUnderInv, + invFunctional, ) where @@ -49,18 +58,19 @@ import qualified Prelude as P -- | Apply the pending effect of the writeback-stage instruction. The load case -- reads its value off @inputMem@, matching 'Core.writeback'. -flushWbStage :: +applyWbStage :: (RegFileOps r) => Instruction -> Word -> Word -> (m, r) -> (m, r) -flushWbStage ir res inputWord (mem, rf) = +applyWbStage 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)) + IType (Load size sign) rd _ _ -> + (mem, put rd (loadExtend size sign inputWord)) SType {} -> (mem, rf) BType {} -> (mem, rf) JType rd _ -> (mem, put rd res) @@ -73,17 +83,17 @@ flushWbStage ir res inputWord (mem, 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 :: +-- The two jump cases write @rd@, matching 'applyWbStage': 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. +applyMeStage :: (RegFileOps r, MemOps m) => Instruction -> Word -> Address -> (m, r) -> (m, r) -flushMeStage ir res addr (mem, rf) = +applyMeStage ir res addr (mem, rf) = case ir of RType _ rd _ _ -> (mem, put rd res) IType (Arith _) rd _ _ -> (mem, put rd res) @@ -120,7 +130,9 @@ inv isa sys = P.any holds (invCases isa sys) -- -- Built from the named cases ('invCasesAt'), for the tests; the proofs use the -- fold-free 'invAt', which the tests check agrees with it. -invAtList :: (RegFileOps r, MemOps m) => RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +invAtList :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool invAtList wr wa isa sys = P.any holds (invCasesAt wr wa isa sys) -- | Human-readable account of why the invariant failed: for each case, the @@ -128,7 +140,10 @@ invAtList wr wa isa sys = P.any holds (invCasesAt wr wa isa sys) 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))) + [ " case " + P.++ caseName c + P.++ ": failed " + P.++ show (P.map fst (P.filter (P.not . snd) (caseConjuncts c))) | c <- invCases isa sys ] @@ -148,9 +163,9 @@ invCasesAt wr wa = -- | The cases of the invariant, parameterised over how register files and -- memories are compared. -- --- No case constrains @stateCtrl@. The control lines carry no information between --- cycles: 'Core.pipe' resets them at the start of each cycle, before any stage --- reads them. +-- No case constrains @stateCtrl@. The control lines carry no information +-- between cycles: 'Core.pipe' resets them at the start of each cycle, before +-- any stage reads them. invCasesGen :: (RegFileOps r, MemOps m) => (r -> r -> Bool) -> @@ -186,19 +201,30 @@ invCasesGen eqRF eqMem (IsaState ipc irf imem) (Sys core inp mem) = Case "running" $ [ ("running", stateHalt core == Nothing), ("memory answered", isJust (inputMem inp)), - ("wb is not an env instruction", P.not (isEnvInstr (stateWbInstr core))), - ("me is not an env instruction", P.not (isEnvInstr (stateMeInstr core))), + ( "wb is not an env instruction", + P.not (isEnvInstr (stateWbInstr core)) + ), + ( "me is not an env instruction", + P.not (isEnvInstr (stateMeInstr core)) + ), ("exPc == isaPc", stateExPc core == ipc), ("ex == decode (mem[isaPc])", stateExInstr core == isaInstr), ("dePc == exPc + 4", stateDePc core == stateExPc core + 4), - ("no load-use hazard me->ex", P.not (loadHazard (stateExInstr core) (stateMeInstr core))), - ( "(isaMem, isaRegFile) == flush", + ( "no load-use hazard me->ex", + P.not (loadHazard (stateExInstr core) (stateMeInstr core)) + ), + ( "(isaMem, isaRegFile) == pending writes applied", let (fm, frf) = - flushMeStage + applyMeStage (stateMeInstr core) (stateMeRes core) (stateMeAddr core) - (flushWbStage (stateWbInstr core) (stateWbRes core) inputWord (mem, stateRegFile core)) + ( applyWbStage + (stateWbInstr core) + (stateWbRes core) + inputWord + (mem, stateRegFile core) + ) in eqMem imem fm && eqRF irf frf ) ] @@ -213,10 +239,11 @@ invCasesGen eqRF eqMem (IsaState ipc irf imem) (Sys core inp mem) = ("fePc == exPc + 8", stateFePc core == stateExPc core + 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; "Core.ISA" leaves - -- the architectural state where it was, so the ISA is still \"at\" the trap. + -- 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; + -- "Core.ISA" leaves the architectural state where it was, so the ISA is + -- still \"at\" the trap. haltedCase name isKind expected = Case name @@ -264,7 +291,9 @@ runningCaseAt wr wa (IsaState ipc irf imem) (Sys core inp mem) = && stateDePc core == stateExPc core + 4 && not (loadHazard (stateExInstr core) (stateMeInstr core)) && ( if isMemInstr (stateWbInstr core) - then not (stateDeExpInstr core) && stateFePc core == stateExPc core + 4 + then + not (stateDeExpInstr core) + && stateFePc core == stateExPc core + 4 else stateDeExpInstr core && inputMem inp == Just (memReadWord (stateDePc core) mem) @@ -273,17 +302,16 @@ runningCaseAt wr wa (IsaState ipc irf imem) (Sys core inp mem) = && memReadByte wa imem == memReadByte wa fm && lookupRFg wr irf == 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 'memWrite' - -- for no gain: 'Proof.Core.Functional.Obligation.isaAt' already puts this flush - -- into every query, and the solver rewrites @select@ over a @store@ chain - -- natively. + -- The pending writes the container form applies, read at the witness. + -- Writing it out pointwise by hand would duplicate 'applyMeStage' and + -- 'memWrite' for no gain: 'isaOf' already puts them into every query, and + -- the solver rewrites @select@ over a @store@ chain natively. (fm, frf) = - flushMeStage + applyMeStage (stateMeInstr core) (stateMeRes core) (stateMeAddr core) - ( flushWbStage + ( applyWbStage (stateWbInstr core) (stateWbRes core) (fromMaybe 0 (inputMem inp)) @@ -310,3 +338,120 @@ haltedCaseAt kind wr wa (IsaState ipc irf imem) (Sys core inp mem) = expected = case kind of HaltBreak -> EBreak (ipc + 4) HaltCall -> Syscall (ipc + 4) + +-- The architectural state, and properties of the invariant -------------------- + +-- | The architectural state that the invariant claims @sys@ corresponds to: +-- its PC, register file and memory ('archPc', 'archRegFile', 'archMem'). +-- +-- The containers are /derived/ from @sys@ ('archRegFile', 'archMem') 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. 'Core.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 derived as well. The invariant pins it via a different conjunct +-- in each case -- @stateExPc@ when running and @stateHalt@ once halted -- and +-- 'archPc' splits on the case accordingly, so deriving it makes neither case +-- unsatisfiable as a premise. +isaOf :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m +isaOf sys = + IsaState + { isaPc = archPc sys, + isaRegFile = archRegFile sys, + isaMem = archMem sys + } + +-- | The system is one the invariant covers: it is related to its own +-- architectural state ('isaOf'), at register @wr@ and byte @wa@. +sysInvAt :: (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +sysInvAt wr wa sys = invAt wr wa (isaOf sys) sys + +-- | The PC the core stands for: the execute stage's while running; once halted, +-- the trapping instruction's, which is the resume address the halt carries +-- minus 4. +archPc :: SysG r m -> Address +archPc (Sys core _ _) = case Core.stateHalt core of + Nothing -> Core.stateExPc core + Just (EBreak resume) -> resume - 4 + Just (Syscall resume) -> resume - 4 + +-- | The register file the core stands for: its own, with the writes still in +-- the pipeline (the memory and writeback stages) applied. +archRegFile :: (RegFileOps r, MemOps m) => SysG r m -> r +archRegFile = snd . archMemRegFile + +-- | The memory the core stands for: its own, with the stores still in the +-- pipeline (the memory and writeback stages) applied. +archMem :: (RegFileOps r, MemOps m) => SysG r m -> m +archMem = fst . archMemRegFile + +-- | The pipeline's pending writes applied to memory and the register file. +archMemRegFile :: (RegFileOps r, MemOps m) => SysG r m -> (m, r) +archMemRegFile (Sys core inp mem) = + applyMeStage + (Core.stateMeInstr core) + (Core.stateMeRes core) + (Core.stateMeAddr core) + ( applyWbStage + (Core.stateWbInstr core) + (Core.stateWbRes core) + (fromMaybe 0 (Core.inputMem inp)) + (mem, Core.stateRegFile core) + ) + +-- | The invariant relating the core to the ISA implies that the ISA's PC is +-- the core's architectural one ('archPc'). +pcUnderInv :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +pcUnderInv wr wa isa sys = + not premises || conclusion + where + premises = invAt wr wa isa sys + + conclusion = isaPc isa == archPc sys + +-- | The invariant relating the core to the ISA implies that the ISA's register +-- file is the core's architectural one ('archRegFile'), at register @wr@. +regFileUnderInv :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +regFileUnderInv wr wa isa sys = + not premises || conclusion + where + premises = invAt wr wa isa sys + + conclusion = lookupRFg wr (isaRegFile isa) == lookupRFg wr (archRegFile sys) + +-- | The invariant relating the core to the ISA implies that the ISA's memory is +-- the core's architectural one ('archMem'), at byte @wa@. +memUnderInv :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool +memUnderInv wr wa isa sys = + not premises || conclusion + where + premises = invAt wr wa isa sys + + conclusion = memReadByte wa (isaMem isa) == memReadByte wa (archMem sys) + +-- | The invariant is functional: two ISA states it relates to the same system +-- are equal, at register @wr@ and byte @wa@. Quantifying over @wr@ and @wa@ +-- gives equality of the states. +invFunctional :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> IsaStateG r m -> IsaStateG r m -> SysG r m -> Bool +invFunctional wr wa isa1 isa2 sys = + not premises || conclusion + where + premises = invAt wr wa isa1 sys && invAt wr wa isa2 sys + + conclusion = + isaPc isa1 == isaPc isa2 + && lookupRFg wr (isaRegFile isa1) == lookupRFg wr (isaRegFile isa2) + && memReadByte wa (isaMem isa1) == memReadByte wa (isaMem isa2) diff --git a/proof/Proof/Core/Functional/Machine.hs b/proof/Proof/Core/Functional/Machine.hs index 50bfa25..6b907c4 100644 --- a/proof/Proof/Core/Functional/Machine.hs +++ b/proof/Proof/Core/Functional/Machine.hs @@ -13,6 +13,7 @@ module Proof.Core.Functional.Machine ( SysG (..), Sys, + initSys, stepSys, stepSysOut, ) @@ -23,6 +24,7 @@ import Core import Memory.Types import Memory.Ideal (idealServe) import Core.RegFile +import Types (Address) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -- | Core state, the input it is about to consume, and memory. @@ -44,6 +46,11 @@ instance (Eq r, Eq m) => Eq (SysG r m) where && inputMem i1 == inputMem i2 && m1 == m2 +-- | The system at start: the core at start with PC @pc@ and register file @rf@ +-- ('Core.initAt'), its input at start ('Core.initInput'), and memory @mem@. +initSys :: Address -> r -> m -> SysG r m +initSys pc rf mem = Sys (Core.initAt pc rf) Core.initInput mem + -- | 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. @@ -61,5 +68,5 @@ stepSys = fst . stepSysOut stepSysOut :: (RegFileOps r, MemOps m) => SysG r m -> (SysG r m, Output) stepSysOut (Sys core inp mem) = let (core', o) = Core.circuit core inp - (mem', inp') = idealServe mem (outMem o) + (mem', inp') = idealServe mem (outputMem o) in (Sys core' inp' mem', o) diff --git a/proof/Proof/Core/Functional/Obligation.hs b/proof/Proof/Core/Functional/Obligation.hs index 706f17b..d4e5e46 100644 --- a/proof/Proof/Core/Functional/Obligation.hs +++ b/proof/Proof/Core/Functional/Obligation.hs @@ -1,17 +1,12 @@ -- | The proof obligations, in one place. -- --- Both the symbolic properties ("Proof.Core.Functional.Solver") 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. +-- Both the symbolic properties ("Proof.Core.Functional.Solver") 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.Core.Functional.Obligation - ( isaAt, - flushedRegFile, - flushedMem, - regFileUnderInv, - memUnderInv, - baseCase, + ( baseCase, indStep0, indStep1, indStep2, @@ -20,8 +15,6 @@ module Proof.Core.Functional.Obligation where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Data.Maybe (fromMaybe) -import qualified Core import Proof.Core.Functional.Driver (driver) import Core.ISA (IsaStateG (..), StepG (..), isaStep) import Proof.Core.Functional.Invariant @@ -31,64 +24,7 @@ import Core.RegFile import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) --- | The architectural register file and memory that the invariant claims @sys@ --- corresponds to, at an architectural PC supplied by the caller. --- --- 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. 'Core.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 and @stateHalt@ once halted. Deriving it from either --- one would make the other case unsatisfiable as a premise. -isaAt :: (RegFileOps r, MemOps m) => Address -> SysG r m -> IsaStateG r m -isaAt ipc sys = - IsaState {isaPc = ipc, isaRegFile = flushedRegFile sys, isaMem = flushedMem sys} - --- | The register file the core stands for: its own, with the writes still in --- the pipeline (the memory and writeback stages) applied. -flushedRegFile :: (RegFileOps r, MemOps m) => SysG r m -> r -flushedRegFile = snd . flushed - --- | The memory the core stands for: its own, with the stores still in the --- pipeline (the memory and writeback stages) applied. -flushedMem :: (RegFileOps r, MemOps m) => SysG r m -> m -flushedMem = fst . flushed - --- | The pipeline's pending writes applied to memory and the register file. -flushed :: (RegFileOps r, MemOps m) => SysG r m -> (m, r) -flushed (Sys core inp mem) = - flushMeStage - (Core.stateMeInstr core) - (Core.stateMeRes core) - (Core.stateMeAddr core) - ( flushWbStage - (Core.stateWbInstr core) - (Core.stateWbRes core) - (fromMaybe 0 (Core.inputMem inp)) - (mem, Core.stateRegFile core) - ) - --- | The invariant relating the core to the ISA implies that the ISA's register --- file is the core's, flushed ('flushedRegFile'), at register @wr@. -regFileUnderInv :: (RegFileOps r, MemOps m) => RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool -regFileUnderInv wr wa isa sys = - not (invAt wr wa isa sys) - || lookupRFg wr (isaRegFile isa) == lookupRFg wr (flushedRegFile sys) - --- | The invariant relating the core to the ISA implies that the ISA's memory is --- the core's, flushed ('flushedMem'), at byte @wa@. -memUnderInv :: (RegFileOps r, MemOps m) => RegIdx -> Address -> IsaStateG r m -> SysG r m -> Bool -memUnderInv wr wa isa sys = - not (invAt wr wa isa sys) - || memReadByte wa (isaMem isa) == memReadByte wa (flushedMem sys) +-- The base case ---------------------------------------------------------------- -- | The base case: the invariant holds once the initial state has taken its -- first hop. @@ -117,19 +53,19 @@ memUnderInv wr wa isa sys = -- values on both sides, and the first 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 initial register file and the ISA's --- ('Core.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. +-- ('Core.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. baseCase :: (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> r -> m -> Bool baseCase wr wa pc rf mem = - driver sys == 1 && invAt wr wa isa sys2 + driver sys == 1 && invAt wr wa isa sys' where isa = IsaState {isaPc = pc, isaRegFile = rf, isaMem = mem} - sys = Sys (Core.initAt pc rf) Core.initInput mem + sys = initSys pc rf mem + sys' = stepSysN 1 sys - sys1 = stepSys sys - sys2 = stepSys sys1 +-- The inductive steps ---------------------------------------------------------- -- | The @k = 0@ inductive step: the driver's one-cycle hop. -- @@ -146,11 +82,11 @@ baseCase wr wa pc rf mem = -- architectural register file and memory to equal the core's, so carrying the -- same @isa@ across the step asserts that neither changed. indStep0 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool -indStep0 wr wa ipc sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStep0 wr wa sys = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys isa' = case isaStep isa of Next next -> next IsaHalted -> isa @@ -169,23 +105,22 @@ indStep0 wr wa ipc sys = -- covers it: the invariant does not admit the reset state, and -- 'Proof.Core.Functional.Solver.baseCase' states that hop directly. indStep1 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool -indStep1 wr wa ipc sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStep1 wr wa sys = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys isa' = case isaStep isa of Next next -> next IsaHalted -> isa - sys1 = stepSys sys - sys2 = stepSys sys1 + sys' = stepSysN 1 sys premises = invAt wr wa isa sys && driver sys == 1 - conclusion = invAt wr wa isa' sys2 + conclusion = invAt wr wa isa' sys' -- | The @k = 2@ inductive step: the driver's three-cycle hop. -- @@ -193,24 +128,22 @@ indStep1 wr wa ipc sys = -- The architectural state then stays at the trapping instruction while the -- core reaches one of the two halted invariant cases. indStep2 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool -indStep2 wr wa ipc sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStep2 wr wa sys = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys isa' = case isaStep isa of Next next -> next IsaHalted -> isa - sys1 = stepSys sys - sys2 = stepSys sys1 - sys3 = stepSys sys2 + sys' = stepSysN 2 sys premises = invAt wr wa isa sys && driver sys == 2 - conclusion = invAt wr wa isa' sys3 + conclusion = invAt wr wa isa' sys' -- | The @k = 3@ inductive step: the driver's four-cycle hop, the longest. -- @@ -220,22 +153,29 @@ indStep2 wr wa ipc sys = -- covering it costs nothing and assuming it away would be an unchecked side -- argument. indStep3 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> Bool -indStep3 wr wa ipc sys = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> Bool +indStep3 wr wa sys = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys isa' = case isaStep isa of Next next -> next IsaHalted -> isa - sys1 = stepSys sys - sys2 = stepSys sys1 - sys3 = stepSys sys2 - sys4 = stepSys sys3 + sys' = stepSysN 3 sys premises = invAt wr wa isa sys && driver sys == 3 - conclusion = invAt wr wa isa' sys4 + conclusion = invAt wr wa isa' sys' + +-- Helpers ---------------------------------------------------------------------- + +-- | A hop of the system: @n + 1@ steps, the cycle the hop starts with and the +-- @n@ cycles the driver counts after it. Recursive on @n@, which each step +-- fixes to a literal. +stepSysN :: (RegFileOps r, MemOps m) => Int -> SysG r m -> SysG r m +stepSysN n sys + | n == 0 = stepSys sys + | otherwise = stepSysN (n - 1) (stepSys sys) diff --git a/proof/Proof/Core/Functional/Solver.hs b/proof/Proof/Core/Functional/Solver.hs index 9f2f7ca..6c7fa66 100644 --- a/proof/Proof/Core/Functional/Solver.hs +++ b/proof/Proof/Core/Functional/Solver.hs @@ -1,11 +1,11 @@ -- | The inductive steps of the refinement proof, checked symbolically. -- -- '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 --- four steps is the whole refinement theorem. +-- 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 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)@ @@ -13,21 +13,26 @@ -- -- 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.Core.Functional.Obligation", shared with the QuickCheck --- harness so the two cannot drift. +-- statements themselves live in "Proof.Core.Functional.Obligation", shared with +-- the QuickCheck harness so the two cannot drift. -- -- The pipeline state is passed as a 'KState' plus SMT-array register file and -- memory; see "Proof.Core.Functional.System". module Proof.Core.Functional.Solver ( arrRoundTripP, shiftsSaneP, + driverMatchesSpecP, + driverMatchesSpecInitP, + driverValuesP, baseCaseP, indStep0P, indStep1P, indStep2P, indStep3P, + pcUnderInvP, regFileUnderInvP, memUnderInvP, + invFunctionalP, results, ) where @@ -37,6 +42,17 @@ import qualified Core import Core.ISA (IsaStateG (..)) import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime +import Proof.Core.Functional.Driver + ( driverMatchesSpec, + driverMatchesSpecInit, + driverValues, + ) +import Proof.Core.Functional.Invariant + ( invFunctional, + memUnderInv, + pcUnderInv, + regFileUnderInv, + ) import Proof.Core.Functional.Obligation import Proof.SMT.Array import Proof.SMT.Axioms (arrayAxioms) @@ -47,9 +63,9 @@ import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&& -- 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 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. @@ -73,6 +89,87 @@ shiftsSaneP x = where sign = slice d31 d31 x +-- The driver ------------------------------------------------------------------- + +-- | The driver is 0 to 3, on any system. +{-# ANN driverValuesP (Theory arrayAxioms) #-} +driverValuesP :: KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool +driverValuesP ss i ra ma = + Pantomime.boolean $ driverValues (sysOf ss i ra ma) + +-- | On states the invariant relates to a free ISA state, the driver agrees +-- with its operational reading. +{-# ANN driverMatchesSpecP (Theory arrayAxioms) #-} +driverMatchesSpecP :: + RegIdx -> Address -> Address -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +driverMatchesSpecP wr wa ipc ira ima ss i ra ma = + Pantomime.boolean $ + driverMatchesSpec wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) + +-- | On the initial system, the driver agrees with its operational reading, for +-- any start PC, register file and memory. +{-# ANN driverMatchesSpecInitP (Theory arrayAxioms) #-} +driverMatchesSpecInitP :: Address -> RegArr -> MemArr -> Pantomime.Bool +driverMatchesSpecInitP pc ra ma = + Pantomime.boolean $ driverMatchesSpecInit pc (RegArrF ra) ma + +-- The invariant and the architectural state ------------------------------------- + +-- | The invariant relating the core to the ISA implies that the ISA's PC is +-- the core's architectural one. The ISA state is free, not derived from the +-- core. +{-# ANN pcUnderInvP (Theory arrayAxioms) #-} +pcUnderInvP :: + RegIdx -> Address -> Address -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +pcUnderInvP wr wa ipc ira ima ss i ra ma = + Pantomime.boolean $ + pcUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) + +-- | The invariant relating the core to the ISA implies that the ISA's register +-- file is the core's architectural one. The ISA state is free, not derived from +-- the core. +{-# ANN regFileUnderInvP (Theory arrayAxioms) #-} +regFileUnderInvP :: + RegIdx -> Address -> Address -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +regFileUnderInvP wr wa ipc ira ima ss i ra ma = + Pantomime.boolean $ + regFileUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) + +-- | The invariant relating the core to the ISA implies that the ISA's memory is +-- the core's architectural one. +{-# ANN memUnderInvP (Theory arrayAxioms) #-} +memUnderInvP :: + RegIdx -> Address -> Address -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +memUnderInvP wr wa ipc ira ima ss i ra ma = + Pantomime.boolean $ + memUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) + +-- | The invariant is functional: two ISA states, both free, related to the +-- same system are equal. +{-# ANN invFunctionalP (Theory arrayAxioms) #-} +invFunctionalP :: + RegIdx -> Address -> + Address -> RegArr -> MemArr -> + Address -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +invFunctionalP wr wa ipc1 ira1 ima1 ipc2 ira2 ima2 ss i ra ma = + Pantomime.boolean $ + invFunctional + wr + wa + (IsaState ipc1 (RegArrF ira1) ima1) + (IsaState ipc2 (RegArrF ira2) ima2) + (sysOf ss i ra ma) + -- The base case ---------------------------------------------------------------- {-# ANN baseCaseP (Theory arrayAxioms) #-} @@ -84,58 +181,53 @@ baseCaseP wr wa pc ra ma = -- | @k = 0@: the one-cycle hop (steady, writeback non-memory). {-# ANN indStep0P (Theory arrayAxioms) #-} -indStep0P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -indStep0P wr wa ipc ss i ra ma = - Pantomime.boolean $ indStep0 wr wa ipc (sysOf ss i ra ma) +indStep0P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +indStep0P wr wa ss i ra ma = + Pantomime.boolean $ indStep0 wr wa (sysOf ss i ra ma) -- | @k = 1@: the two-cycle hop (a memory instruction in writeback). {-# ANN indStep1P (Theory arrayAxioms) #-} -indStep1P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -indStep1P wr wa ipc ss i ra ma = - Pantomime.boolean $ indStep1 wr wa ipc (sysOf ss i ra ma) +indStep1P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +indStep1P wr wa ss i ra ma = + Pantomime.boolean $ indStep1 wr wa (sysOf ss i ra ma) -- | @k = 2@: the three-cycle hop (environment, taken jump, store hazard with a -- non-memory execute instruction, or memory instructions in both older stages). -- The hop on which the ISA enters a halt; a halted state then sits at k = 0. {-# ANN indStep2P (Theory arrayAxioms) #-} -indStep2P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -indStep2P wr wa ipc ss i ra ma = - Pantomime.boolean $ indStep2 wr wa ipc (sysOf ss i ra ma) +indStep2P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +indStep2P wr wa ss i ra ma = + Pantomime.boolean $ indStep2 wr wa (sysOf ss i ra ma) -- | @k = 3@: the four-cycle hop (store hazard with a memory execute -- instruction, load hazard, or all three stages holding memory instructions). {-# ANN indStep3P (Theory arrayAxioms) #-} -indStep3P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -indStep3P wr wa ipc ss i ra ma = - Pantomime.boolean $ indStep3 wr wa ipc (sysOf ss i ra ma) - --- The invariant and the flush --------------------------------------------------- - --- | The invariant relating the core to the ISA implies that the ISA's register --- file is the core's, flushed. The ISA state is free, not derived from the core. -{-# ANN regFileUnderInvP (Theory arrayAxioms) #-} -regFileUnderInvP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -regFileUnderInvP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ regFileUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) - --- | The invariant relating the core to the ISA implies that the ISA's memory is --- the core's, flushed. -{-# ANN memUnderInvP (Theory arrayAxioms) #-} -memUnderInvP :: - RegIdx -> Address -> Address -> RegArr -> MemArr -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -memUnderInvP wr wa ipc ira ima ss i ra ma = - Pantomime.boolean $ memUnderInv wr wa (IsaState ipc (RegArrF ira) ima) (sysOf ss i ra ma) +indStep3P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +indStep3P wr wa ss i ra ma = + Pantomime.boolean $ indStep3 wr wa (sysOf ss i ra ma) results :: [(String, Maybe String)] results = [ ("arrRoundTripP", $(pantomime 'arrRoundTripP)), ("shiftsSaneP", $(pantomime 'shiftsSaneP)), + ("driverMatchesSpecP", $(pantomime 'driverMatchesSpecP)), + ("driverMatchesSpecInitP", $(pantomime 'driverMatchesSpecInitP)), + ("driverValuesP", $(pantomime 'driverValuesP)), ("baseCaseP", $(pantomime 'baseCaseP)), ("indStep0P", $(pantomime 'indStep0P)), ("indStep1P", $(pantomime 'indStep1P)), ("indStep2P", $(pantomime 'indStep2P)), ("indStep3P", $(pantomime 'indStep3P)), + ("pcUnderInvP", $(pantomime 'pcUnderInvP)), ("regFileUnderInvP", $(pantomime 'regFileUnderInvP)), - ("memUnderInvP", $(pantomime 'memUnderInvP)) + ("memUnderInvP", $(pantomime 'memUnderInvP)), + ("invFunctionalP", $(pantomime 'invFunctionalP)) ] diff --git a/proof/Proof/Core/Leakage/Driver.hs b/proof/Proof/Core/Leakage/Driver.hs index e84a71d..0988612 100644 --- a/proof/Proof/Core/Leakage/Driver.hs +++ b/proof/Proof/Core/Leakage/Driver.hs @@ -1,9 +1,13 @@ -- | The simulator's driver: how many cycles the simulator takes for an -- instruction, computed from its own state and the instruction's leakage. The --- counterpart of 'Proof.Core.Functional.Driver.driver', case for case; the leakage --- proof's first step is that the two agree. +-- counterpart of 'Proof.Core.Functional.Driver.driver', case for case; the +-- leakage proof's first step is that the two agree. module Proof.Core.Leakage.Driver ( simDriver, + simDriverSpec, + simDriverMatchesSpecInit, + simDriverMatchesSpec, + simIsBubble, simStoreHazard, simLoadHazard ) @@ -11,8 +15,14 @@ where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import qualified Core.Instruction +import Core.RegFile (RegFileOps) +import Memory.Types (MemOps) +import Proof.Core.Functional.Invariant (sysInvAt) +import Proof.Core.Functional.Machine (SysG) +import Proof.Core.Leakage.Invariant (simInv) import Proof.Core.Leakage.Model import Proof.Core.Leakage.Simulator +import Types (Address, RegIdx) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -- | The store-hazard condition of 'Core.decode': the instruction word at the @@ -49,3 +59,57 @@ simDriver inp st | not (isMemLeak (simStateMeInstr st)) = 1 | not (maybe False isMemLeak inp) = 2 | otherwise = 3 + +-- | Is the simulator's execute stage a pipeline bubble, as opposed to an +-- instruction? The counterpart of 'Proof.Core.Functional.Driver.isBubble': a +-- decoded instruction is not, and neither is a halted simulator; the stall +-- reasons are. +simIsBubble :: SimState -> Bool +simIsBubble sim = case simStateExInstrType sim of + DecodedInstr -> False + Halted -> False + _ -> True + +-- | The operational reading of 'simDriver', as +-- 'Proof.Core.Functional.Driver.driverSpec' is of the core's: step on the +-- instruction's leakage, then with no input until the execute stage is no +-- longer a bubble ('simIsBubble'), and count the steps after the first. +-- 'Nothing' if @fuel@ ran out. +simDriverSpec :: Int -> SimInput -> SimState -> Maybe Int +simDriverSpec fuel inp sim0 = go 0 (fst (simCircuit sim0 inp)) + where + go n sim + | not (simIsBubble sim) = Just n + | n >= fuel = Nothing + | otherwise = go (n + 1) (fst (simCircuit sim Nothing)) + +-- | On the initial simulator its driver agrees with its operational reading: +-- the first hop, from the start PC @pc@, which starts with no input +-- ('simInit'). The invariant does not cover the initial simulator, so +-- 'simDriverMatchesSpec' does not either. +simDriverMatchesSpecInit :: Address -> Bool +simDriverMatchesSpecInit pc = + simDriverSpec 3 Nothing sim == Just (simDriver Nothing sim) + where + sim = simInit {simStateFePc = pc} + +-- | On every other hop the simulator's driver agrees with its operational +-- reading as well, as 'Proof.Core.Functional.Driver.driverMatchesSpec' for the +-- core: the simulator is related to a system ('simInv') that the core's +-- invariant covers ('Proof.Core.Functional.Invariant.sysInvAt'), and the input +-- is the leakage of any instruction -- every hop but the first starts with one. +-- The core's invariant is needed for the +-- pipeline's shape: without it, the fetch and decode PCs, which 'simInv' copies +-- from the core, are not related, and a store hazard between the input's store +-- and the fetch PC would go unseen by the driver. Three cycles of fuel cover +-- the longest hop. +simDriverMatchesSpec :: + (RegFileOps r, MemOps m) => + RegIdx -> Address -> Leak -> SimState -> SysG r m -> Bool +simDriverMatchesSpec wr wa leak sim sys = + not premises || conclusion + where + premises = sysInvAt wr wa sys && simInv sim sys + + conclusion = + simDriverSpec 3 (Just leak) sim == Just (simDriver (Just leak) sim) diff --git a/proof/Proof/Core/Leakage/Model.hs b/proof/Proof/Core/Leakage/Model.hs index e14c7fb..9370ea9 100644 --- a/proof/Proof/Core/Leakage/Model.hs +++ b/proof/Proof/Core/Leakage/Model.hs @@ -1,8 +1,8 @@ -- | What an attacker sees, and what one architectural instruction leaks. -- --- The leakage proof ("Proof.Core.Leakage.Obligation") establishes that an attacker --- watching the memory bus learns nothing beyond 'Leak'. Two definitions carry --- that statement: +-- The leakage proof ("Proof.Core.Leakage.Obligation") establishes that an +-- attacker watching the memory bus learns nothing beyond 'Leak'. Two +-- definitions carry that statement: -- -- * 'obsOf' -- what the attacker sees in one cycle: the kind of access, its -- address, and for a data access its width. @@ -71,13 +71,9 @@ instance Monoid Obs where -- | The observation a cycle's 'Core.Output' produces: that of its request. obsOf :: Output -> Obs -obsOf o = obsReq (outMem o) +obsOf o = obsReq (outputMem o) -- | The observation of a request on the bus: the request without its data. --- --- This is also what a cache in front of the core leaks about each request it --- receives ("Proof.Cache.Server4K"), which is what lets the core's leakage proof --- and the cache's compose. obsReq :: Request -> Obs obsReq req = case req of Nothing -> NoAccess @@ -93,11 +89,11 @@ obsReq req = case req of -- instruction set: -- -- * 'LArith' -- nothing beyond the fetch trace. No data access, and the next --- fetch is @pc + 4@. Arithmetic, upper immediates, an untaken branch, and an --- undecodable word all land here, and are indistinguishable. +-- fetch is @pc + 4@. Arithmetic, upper immediates, an untaken branch, and +-- an undecodable word all land here, and are indistinguishable. -- * 'LJump' -- control goes somewhere other than @pc + 4@, and the target is --- the next fetch address. A taken branch, @jal@ and @jalr@ are one case: the --- attacker sees an address, not which instruction produced it. +-- the next fetch address. A taken branch, @jal@ and @jalr@ are one case: +-- the attacker sees an address, not which instruction produced it. -- * 'LLoad' -- a data read of the given width at the given address, plus -- whether the instruction at @pc + 4@ has a load-use hazard against this -- load. That bit is the one thing here not already in the fetch trace: it diff --git a/proof/Proof/Core/Leakage/Obligation.hs b/proof/Proof/Core/Leakage/Obligation.hs index f527e81..ebc30b4 100644 --- a/proof/Proof/Core/Leakage/Obligation.hs +++ b/proof/Proof/Core/Leakage/Obligation.hs @@ -20,11 +20,9 @@ module Proof.Core.Leakage.Obligation where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core import Memory.Types (MemOps (..)) import Proof.Core.Functional.Driver -import Proof.Core.Functional.Invariant (invAt) -import Proof.Core.Functional.Obligation +import Proof.Core.Functional.Invariant (invAt, isaOf) import Proof.Core.Leakage.Driver import Proof.Core.Leakage.Invariant import Proof.Core.Leakage.Model @@ -34,6 +32,15 @@ import Core.RegFile import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) +-- | The observations of a run, cycle by cycle: what the attacker sees over a +-- hop. A type of its own, rather than a list, so that its equality is derived +-- here and the solver can unroll it; the equality of lists comes from @base@, +-- whose definitions the solver cannot see. +data Trace = TraceSingle Obs | TraceCons Obs Trace + deriving (Show, Eq) + +-- The base case ---------------------------------------------------------------- + -- | The base case: from the initial state, the core and the simulator agree -- on the first hop. -- @@ -47,132 +54,143 @@ baseCaseLeak :: (RegFileOps r, MemOps m) => Address -> r -> m -> Bool baseCaseLeak pc rf mem = simDriver Nothing sim == 1 - && obs1 == obsOf out1 - && obs2 == obsOf out2 - && simInv sim2 sys2 + && tr1 == tr2 + && simInv sim' sys' where - sys = Sys (Core.initAt pc rf) Core.initInput mem + sys = initSys pc rf mem sim = simInit {simStateFePc = pc} - (sys1, out1) = stepSysOut sys - (sim1, obs1) = simCircuit sim Nothing + (tr1, sys') = stepSysOutN 1 sys + (tr2, sim') = simCircuitN 1 sim Nothing - (sys2, out2) = stepSysOut sys1 - (sim2, obs2) = simCircuit sim1 Nothing +-- The inductive steps ---------------------------------------------------------- -- | The @k = 0@ leakage step: the one-cycle hop. -- -- > inv(isa, sys) /\ simInv(sim, sys) /\ driver(sys) = 0 --- > ==> simDriver(leak, sim) = 0 /\ obs(sim) = obs(sys) /\ simInv(sim', sys') +-- > ==> simDriver(leak, sim) = 0 /\ obs(sim) = obs(sys) +-- > /\ simInv(sim', sys') -- -- The simulator gets @leakOf isa@ on the hop's first cycle and nothing after. indStepLeak0 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> SimState -> Bool -indStepLeak0 wr wa ipc sys sim = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> SimState -> Bool +indStepLeak0 wr wa sys sim = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys leak = leakOf isa - (sys', out') = stepSysOut sys - (sim', obs') = simCircuit sim (Just leak) + hopLength = 0 + + (tr1, sys') = stepSysOutN hopLength sys + (tr2, sim') = simCircuitN hopLength sim (Just leak) premises = invAt wr wa isa sys - && driver sys == 0 && simInv sim sys + && driver sys == hopLength conclusion = - simDriver (Just leak) sim == 0 - && obs' == obsOf out' + simDriver (Just leak) sim == hopLength + && tr1 == tr2 && simInv sim' sys' -- | The @k = 1@ leakage step: the two-cycle hop. indStepLeak1 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> SimState -> Bool -indStepLeak1 wr wa ipc sys sim = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> SimState -> Bool +indStepLeak1 wr wa sys sim = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys leak = leakOf isa - (sys1, out1) = stepSysOut sys - (sim1, obs1) = simCircuit sim (Just leak) + hopLength = 1 - (sys2, out2) = stepSysOut sys1 - (sim2, obs2) = simCircuit sim1 Nothing + (tr1, sys') = stepSysOutN hopLength sys + (tr2, sim') = simCircuitN hopLength sim (Just leak) premises = invAt wr wa isa sys - && driver sys == 1 && simInv sim sys + && driver sys == hopLength conclusion = - simDriver (Just leak) sim == 1 - && obs1 == obsOf out1 - && obs2 == obsOf out2 - && simInv sim2 sys2 + simDriver (Just leak) sim == hopLength + && tr1 == tr2 + && simInv sim' sys' -- | The @k = 2@ leakage step: the three-cycle hop. indStepLeak2 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> SimState -> Bool -indStepLeak2 wr wa ipc sys sim = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> SimState -> Bool +indStepLeak2 wr wa sys sim = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys leak = leakOf isa - (sys1, out1) = stepSysOut sys - (sim1, obs1) = simCircuit sim (Just leak) - - (sys2, out2) = stepSysOut sys1 - (sim2, obs2) = simCircuit sim1 Nothing + hopLength = 2 - (sys3, out3) = stepSysOut sys2 - (sim3, obs3) = simCircuit sim2 Nothing + (tr1, sys') = stepSysOutN hopLength sys + (tr2, sim') = simCircuitN hopLength sim (Just leak) premises = invAt wr wa isa sys - && driver sys == 2 && simInv sim sys + && driver sys == hopLength conclusion = - simDriver (Just leak) sim == 2 - && obs1 == obsOf out1 - && obs2 == obsOf out2 - && obs3 == obsOf out3 - && simInv sim3 sys3 + simDriver (Just leak) sim == hopLength + && tr1 == tr2 + && simInv sim' sys' -- | The @k = 3@ leakage step: the four-cycle hop, the longest. indStepLeak3 :: - (RegFileOps r, MemOps m) => RegIdx -> Address -> Address -> SysG r m -> SimState -> Bool -indStepLeak3 wr wa ipc sys sim = + (RegFileOps r, MemOps m) => RegIdx -> Address -> SysG r m -> SimState -> Bool +indStepLeak3 wr wa sys sim = not premises || conclusion where - isa = isaAt ipc sys + isa = isaOf sys leak = leakOf isa - (sys1, out1) = stepSysOut sys - (sim1, obs1) = simCircuit sim (Just leak) + hopLength = 3 - (sys2, out2) = stepSysOut sys1 - (sim2, obs2) = simCircuit sim1 Nothing - - (sys3, out3) = stepSysOut sys2 - (sim3, obs3) = simCircuit sim2 Nothing - - (sys4, out4) = stepSysOut sys3 - (sim4, obs4) = simCircuit sim3 Nothing + (tr1, sys') = stepSysOutN hopLength sys + (tr2, sim') = simCircuitN hopLength sim (Just leak) premises = invAt wr wa isa sys - && driver sys == 3 && simInv sim sys + && driver sys == hopLength conclusion = - simDriver (Just leak) sim == 3 - && obs1 == obsOf out1 - && obs2 == obsOf out2 - && obs3 == obsOf out3 - && obs4 == obsOf out4 - && simInv sim4 sys4 + simDriver (Just leak) sim == hopLength + && tr1 == tr2 + && simInv sim' sys' + +-- Helpers ---------------------------------------------------------------------- + +-- | A hop of the system: @n + 1@ steps ('stepSysOut' repeated). Returns the +-- trace of its bus observations and the system after the hop. Recursive on +-- @n@, which each step fixes to a literal. +stepSysOutN :: + (RegFileOps r, MemOps m) => Int -> SysG r m -> (Trace, SysG r m) +stepSysOutN n sys + | n == 0 = (TraceSingle obs, sys') + | otherwise = + let (tr, sys'') = stepSysOutN (n - 1) sys' + in (TraceCons obs tr, sys'') + where + (sys', out) = stepSysOut sys + obs = obsOf out + +-- | The simulator's counterpart of 'stepSysOutN' ('simCircuit' repeated): its +-- input in the first cycle, then no input, as in the middle of a driver hop. +-- Returns the trace of its bus observations and the simulator after the hop. +simCircuitN :: Int -> SimState -> SimInput -> (Trace, SimState) +simCircuitN n sim inp + | n == 0 = (TraceSingle obs, sim') + | otherwise = + let (tr, sim'') = simCircuitN (n - 1) sim' Nothing + in (TraceCons obs tr, sim'') + where + (sim', obs) = simCircuit sim inp diff --git a/proof/Proof/Core/Leakage/Simulator.hs b/proof/Proof/Core/Leakage/Simulator.hs index d36a964..be3c703 100644 --- a/proof/Proof/Core/Leakage/Simulator.hs +++ b/proof/Proof/Core/Leakage/Simulator.hs @@ -31,7 +31,8 @@ import Proof.Core.Leakage.Model import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) --- | The input of the simulator. +-- | The input of the simulator: the leakage of the instruction a hop starts +-- with, or 'Nothing' in the middle of a driver hop. type SimInput = Maybe Leak -- | The output of the simulator. @@ -57,6 +58,12 @@ data SimExInstrType StallNoInstruction | -- | First cycle. FirstCycle + | -- | First cycle after an environment instruction: the halt is on its way + -- through the pipeline, in the memory stage. + PendingHaltFirstCycle + | -- | Second cycle after an environment instruction: the halt is in the + -- writeback stage, which halts the core. + PendingHaltSecondCycle | -- | The core has halted. Halted deriving (Eq, Show, Generic, NFDataX) @@ -87,8 +94,8 @@ data SimControl = SimControl -- a store hazard with the instruction in the `execute` stage or the -- instruction in the `memory` stage. simCtrlDeStoreHazard :: Maybe Address, - -- | Stores the type of instruction in the `execute` stage (if it's a decoded - -- instruction versus various stalls). + -- | Stores the type of instruction in the `execute` stage (if it's a + -- decoded instruction versus various stalls). simCtrlExInstrType :: Maybe SimExInstrType, -- | `True` when the leaked instruction is an environment instruction. To -- maintain consistency with the core, the execute stage is the only one @@ -97,7 +104,8 @@ data SimControl = SimControl -- | Stores the jump address if the instruction in the `execute` stage -- results in a jump. simCtrlExJumpAddr :: Maybe Address, - -- | Stores the write address and size if the instruction in the `execute` stage + -- | Stores the write address and size if the instruction in the `execute` + -- stage -- is a store. simCtrlExStoreAddrSize :: Maybe (Address, Size), -- | Stores the load hazard bit if the instruction in the `execute` stage @@ -105,7 +113,8 @@ data SimControl = SimControl simCtrlExLoadHazard :: Maybe Bool, -- | `True` when the instruction in the `memory` stage is a store or a load. simCtrlMeMemInstr :: Bool, - -- | Stores the write address and size if the instruction in the `memory` stage + -- | Stores the write address and size if the instruction in the `memory` + -- stage -- is a store. simCtrlMeStoreAddrSize :: Maybe (Address, Size) } @@ -130,6 +139,9 @@ simPipe = do simExecute simDecode simFetch + -- The lines only carry values within a tick, so none of them survives it, + -- as in 'Core.pipe'. + modify $ \s -> s {simStateCtrl = simInitCtrl} simInit :: SimState simInit = @@ -198,31 +210,41 @@ simDecode = do let irt = if expInstr then DecodedInstr else StallNoInstruction let halted = simCtrlExInstrType ctrl == Just Halted - let env_instr_current_cycle = simCtrlExEnvInstr ctrl - + let env_instr_two_cycles_ago = + simCtrlExInstrType ctrl == Just PendingHaltSecondCycle + let env_instr_previous_cycle = + simCtrlExInstrType ctrl == Just PendingHaltFirstCycle let jump_previous_cycle = simCtrlExInstrType ctrl == Just StallJumpFirstCycle - let store_hazard_previous_cycle = simCtrlExInstrType ctrl == Just StallStoreHazardFirstCycle - let load_hazard_previous_cycle = simCtrlExInstrType ctrl == Just StallLoadHazardFirstCycle + let store_hazard_previous_cycle = + simCtrlExInstrType ctrl == Just StallStoreHazardFirstCycle + let load_hazard_previous_cycle = + simCtrlExInstrType ctrl == Just StallLoadHazardFirstCycle + let env_instr_current_cycle = simCtrlExEnvInstr ctrl let jump_current_cycle = isJust (simCtrlExJumpAddr ctrl) let store_hazard_current_cycle = maybe False (storeHazard pc) (simCtrlExStoreAddrSize ctrl) || maybe False (storeHazard pc) (simCtrlMeStoreAddrSize ctrl) - let load_hazard_current_cycle = expInstr && fromMaybe False (simCtrlExLoadHazard ctrl) + let load_hazard_current_cycle = + expInstr && fromMaybe False (simCtrlExLoadHazard ctrl) let irt' - -- Halt if the core is not running anymore. + -- Stay halted once the core has halted. | halted = Halted - -- Halt if there is an environment instruction in this cycle. - | env_instr_current_cycle = Halted + -- The halt reaches the writeback stage after the second pending cycle. + | env_instr_two_cycles_ago = Halted + -- The halt moves on from the memory stage to the writeback stage. + | env_instr_previous_cycle = PendingHaltSecondCycle -- Stall if there was a jump in the previous cycle. | jump_previous_cycle = StallJumpSecondCycle -- Stall if there was a store hazard in the previous cycle. | store_hazard_previous_cycle = StallStoreHazardSecondCycle -- Stall if there was a load hazard in the previous cycle. | load_hazard_previous_cycle = StallLoadHazardSecondCycle + -- An environment instruction in this cycle starts the halt. + | env_instr_current_cycle = PendingHaltFirstCycle -- Stall if there is a jump in this cycle. | jump_current_cycle = StallJumpFirstCycle -- Stall if there is a store hazard in this cycle. @@ -247,7 +269,7 @@ simExecute = do irt <- gets simStateExInstrType simSetLines $ \c -> c {simCtrlExInstrType = Just irt} - + case irt of DecodedInstr -> case input of diff --git a/proof/Proof/Core/Leakage/Solver.hs b/proof/Proof/Core/Leakage/Solver.hs index c431935..b4a341e 100644 --- a/proof/Proof/Core/Leakage/Solver.hs +++ b/proof/Proof/Core/Leakage/Solver.hs @@ -1,24 +1,24 @@ -- | The leakage proof, checked symbolically. -- -- 'baseCaseLeak' plus one property per driver delay: on a hop of that length, --- the corresponding obligation in "Proof.Core.Leakage.Obligation" holds. Split by --- @k@ because the number of unrolled cycles has to be concrete -- Pantomime +-- the corresponding obligation in "Proof.Core.Leakage.Obligation" 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. -- --- Together with "Proof.Core.Functional.Solver" these are the leakage theorem: the --- functional proof establishes that the invariant holds wherever the driver +-- Together with "Proof.Core.Functional.Solver" these are the leakage theorem: +-- the functional proof establishes that the invariant holds wherever the driver -- lands, which each step here assumes as a premise. -- -- Each query runs both the core and the simulator over the hop and compares -- their per-cycle bus observations, the two drivers' hop lengths and the -- simulator invariant, so they are larger than the corresponding functional --- ones. The statements live in "Proof.Core.Leakage.Obligation"; this module only --- instantiates them. +-- ones. The statements live in "Proof.Core.Leakage.Obligation"; this module +-- only instantiates them. -- -- The system state is passed as a 'KState' plus SMT-array register file and --- memory (see "Proof.Core.Functional.System"); the simulator state is passed directly, --- since it holds no register file or memory. +-- memory (see "Proof.Core.Functional.System"); the simulator state is passed +-- directly, since it holds no register file or memory. -- -- == Running them -- @@ -26,7 +26,9 @@ -- -- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build module Proof.Core.Leakage.Solver - ( baseCaseLeakP, + ( simDriverMatchesSpecP, + simDriverMatchesSpecInitP, + baseCaseLeakP, indStepLeak0P, indStepLeak1P, indStepLeak2P, @@ -39,6 +41,11 @@ import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import qualified Core import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime +import Proof.Core.Leakage.Driver + ( simDriverMatchesSpec, + simDriverMatchesSpecInit, + ) +import Proof.Core.Leakage.Model (Leak) import Proof.Core.Leakage.Obligation import Proof.Core.Leakage.Simulator import Proof.SMT.Array @@ -48,6 +55,25 @@ import Proof.Core.Functional.System import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) +-- The driver ------------------------------------------------------------------- + +-- | On the simulator states the invariant covers, the simulator's driver agrees +-- with its operational reading, for the leakage of any instruction. +{-# ANN simDriverMatchesSpecP (Theory arrayAxioms) #-} +simDriverMatchesSpecP :: + RegIdx -> Address -> + Leak -> SimState -> KState -> Core.Input -> RegArr -> MemArr -> + Pantomime.Bool +simDriverMatchesSpecP wr wa leak sim ss i ra ma = + Pantomime.boolean $ simDriverMatchesSpec wr wa leak sim (sysOf ss i ra ma) + +-- | On the initial simulator, its driver agrees with its operational reading, +-- for any start PC. +{-# ANN simDriverMatchesSpecInitP (Theory arrayAxioms) #-} +simDriverMatchesSpecInitP :: Address -> Pantomime.Bool +simDriverMatchesSpecInitP pc = + Pantomime.boolean $ simDriverMatchesSpecInit pc + -- The base case ---------------------------------------------------------------- -- | The first hop from the initial state, for any start PC, register file and @@ -61,34 +87,44 @@ baseCaseLeakP pc ra ma = -- | @k = 0@: the one-cycle hop (steady, writeback non-memory). {-# ANN indStepLeak0P (Theory arrayAxioms) #-} -indStepLeak0P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> Pantomime.Bool -indStepLeak0P wr wa ipc ss i ra ma sim = - Pantomime.boolean $ indStepLeak0 wr wa ipc (sysOf ss i ra ma) sim +indStepLeak0P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> + Pantomime.Bool +indStepLeak0P wr wa ss i ra ma sim = + Pantomime.boolean $ indStepLeak0 wr wa (sysOf ss i ra ma) sim -- | @k = 1@: the two-cycle hop (a memory instruction in writeback). {-# ANN indStepLeak1P (Theory arrayAxioms) #-} -indStepLeak1P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> Pantomime.Bool -indStepLeak1P wr wa ipc ss i ra ma sim = - Pantomime.boolean $ indStepLeak1 wr wa ipc (sysOf ss i ra ma) sim +indStepLeak1P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> + Pantomime.Bool +indStepLeak1P wr wa ss i ra ma sim = + Pantomime.boolean $ indStepLeak1 wr wa (sysOf ss i ra ma) sim -- | @k = 2@: the three-cycle hop (environment, taken jump, store hazard with a -- non-memory execute instruction, or memory instructions in both older stages). -- The hop on which the ISA enters a halt; a halted state then sits at k = 0. {-# ANN indStepLeak2P (Theory arrayAxioms) #-} -indStepLeak2P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> Pantomime.Bool -indStepLeak2P wr wa ipc ss i ra ma sim = - Pantomime.boolean $ indStepLeak2 wr wa ipc (sysOf ss i ra ma) sim +indStepLeak2P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> + Pantomime.Bool +indStepLeak2P wr wa ss i ra ma sim = + Pantomime.boolean $ indStepLeak2 wr wa (sysOf ss i ra ma) sim -- | @k = 3@: the four-cycle hop (store hazard with a memory execute -- instruction, load hazard, or all three stages holding memory instructions). {-# ANN indStepLeak3P (Theory arrayAxioms) #-} -indStepLeak3P :: RegIdx -> Address -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> Pantomime.Bool -indStepLeak3P wr wa ipc ss i ra ma sim = - Pantomime.boolean $ indStepLeak3 wr wa ipc (sysOf ss i ra ma) sim +indStepLeak3P :: + RegIdx -> Address -> KState -> Core.Input -> RegArr -> MemArr -> SimState -> + Pantomime.Bool +indStepLeak3P wr wa ss i ra ma sim = + Pantomime.boolean $ indStepLeak3 wr wa (sysOf ss i ra ma) sim results :: [(String, Maybe String)] results = - [ ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), + [ ("simDriverMatchesSpecP", $(pantomime 'simDriverMatchesSpecP)), + ("simDriverMatchesSpecInitP", $(pantomime 'simDriverMatchesSpecInitP)), + ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), ("indStepLeak0P", $(pantomime 'indStepLeak0P)), ("indStepLeak1P", $(pantomime 'indStepLeak1P)), ("indStepLeak2P", $(pantomime 'indStepLeak2P)), diff --git a/proof/Proof/SMT/Array.hs b/proof/Proof/SMT/Array.hs index f06519e..741d4a9 100644 --- a/proof/Proof/SMT/Array.hs +++ b/proof/Proof/SMT/Array.hs @@ -1,4 +1,5 @@ {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MagicHash #-} -- | A register file embedded as an SMT array. @@ -27,6 +28,8 @@ module Proof.SMT.Array storeM, loadME, storeME, + eqM, + eqME, RegArrSMT (..), loadRA, storeRA, @@ -34,9 +37,12 @@ module Proof.SMT.Array zeroRAE, loadRAE, storeRAE, + eqRA, + eqRAE, sllWordE, srlWordE, sraWordE, + unsignedToIntegerE, ) where @@ -114,10 +120,26 @@ storeRAE = coerce go go (RegArrSMT arr) (Clash.BitVecP k) (Clash.BitVecP v) = RegArrSMT (P.astore arr k v) +-- | Equality, so that whole register files can be compared. Replaced by 'eqRAE' +-- under the term axiom; OPAQUE for the same reason as 'loadRA'. +{-# OPAQUE eqRA #-} +eqRA :: RegArr -> RegArr -> Bool +eqRA (RegArr v) (RegArr w) = v == w + +instance Eq RegArr where + (==) = eqRA + +-- | Embedding of 'eqRA' as array equality. +eqRAE :: forall arr. (Coercible RegArrSMT arr) => arr -> arr -> Bool +eqRAE = coerce go + where + go :: RegArrSMT -> RegArrSMT -> Bool + go (RegArrSMT a) (RegArrSMT b) = a == b + -- | The all-zero register file. -- --- 'Proof.Core.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. +-- 'Proof.Core.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'. @@ -132,6 +154,7 @@ zeroRAE = coerce (RegArrSMT (P.aconst 0)) -- | The array-backed register file, wrapped so it fits 'RegFileOps'. A -- verification-only representation. newtype RegArrF = RegArrF RegArr + deriving (Eq) instance RegFileOps RegArrF where lookupRFg idx (RegArrF a) = if idx == 0 then 0 else loadRA a idx @@ -144,10 +167,11 @@ instance RegFileOps RegArrF where -- 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. +-- 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 @@ -195,6 +219,27 @@ sraWordE = coerce go go (Clash.BitVecP x) (Clash.BitVecP n) = Clash.BitVecP (P.bvashr x (P.bvzext n)) +-- Unsigned to Integer --------------------------------------------------------- +-- +-- pantomime-clash embeds @toInteger@ on 'BitVector' but not on 'Unsigned', and +-- Clash's primitive is @OPAQUE@, so even a literal such as +-- 'Memory.Cache4KServer.penalty' converted with 'fromIntegral' stops symbolic +-- execution. Both types are embedded as 'Clash.BitVec', so the embedding is +-- the same. On a constant, the solver library folds the conversion away, so +-- the query stays in the bitvector fragment. + +-- | @toInteger@ on an 'Unsigned' as @ubv_to_int@. +unsignedToIntegerE :: + forall (bv :: Nat -> Type) (n :: Nat). + (Coercible Clash.BitVec bv) => + bv n -> + Integer +unsignedToIntegerE = coerce go + where + go :: Clash.BitVec n -> Integer + go Clash.BitVecZ = 0 + go (Clash.BitVecP x) = P.toInteger (P.bvu2i x) + -- Memory as an SMT array ------------------------------------------------------ -- | The Haskell-side memory. @@ -249,6 +294,22 @@ storeME = coerce go go (MemArrSMT arr) (Clash.BitVecP a) (Clash.BitVecP v) = MemArrSMT (P.astore arr a v) +-- | Equality, so that whole memories can be compared. Replaced by 'eqME' under +-- the term axiom; OPAQUE for the same reason as 'loadM'. +{-# OPAQUE eqM #-} +eqM :: MemArr -> MemArr -> Bool +eqM (MemArr v) (MemArr w) = v == w + +instance Eq MemArr where + (==) = eqM + +-- | Embedding of 'eqM' as array equality. +eqME :: forall arr. (Coercible MemArrSMT arr) => arr -> arr -> Bool +eqME = coerce go + where + go :: MemArrSMT -> MemArrSMT -> Bool + go (MemArrSMT a) (MemArrSMT b) = a == b + instance MemOps MemArr where memReadByte a m = loadM m a @@ -259,7 +320,8 @@ instance MemOps MemArr where 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))) + 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 diff --git a/proof/Proof/SMT/Axioms.hs b/proof/Proof/SMT/Axioms.hs index 5b235ae..b60bc4d 100644 --- a/proof/Proof/SMT/Axioms.hs +++ b/proof/Proof/SMT/Axioms.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + -- | The axiom set used by the proof properties. -- -- This lives in its own module because GHC's stage restriction requires a value @@ -10,18 +12,28 @@ import qualified Data.Map as Map import Pantomime (PluginAxioms (..)) import qualified Pantomime.Base as Base import qualified Pantomime.Clash as Clash +import qualified Clash.Sized.Internal.Unsigned as Unsigned -- | '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\". +-- 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 +axioms = Base.axioms <> Clash.axioms <> unsignedAxioms <> shiftAxioms + +-- | What pantomime-clash leaves out for 'Unsigned': its conversion to +-- 'Integer', which 'fromIntegral' goes through. +unsignedAxioms :: PluginAxioms +unsignedAxioms = + PluginAxioms + { typeAxioms = Map.empty, + termAxioms = [('Unsigned.toInteger#, 'unsignedToIntegerE)] + } -- | The ALU shifts, mapped to the SMT bitvector shifts. -- @@ -55,7 +67,9 @@ arrayAxioms = [ ('loadRA, 'loadRAE), ('zeroRA, 'zeroRAE), ('storeRA, 'storeRAE), + ('eqRA, 'eqRAE), ('loadM, 'loadME), - ('storeM, 'storeME) + ('storeM, 'storeME), + ('eqM, 'eqME) ] } diff --git a/proof/Proof/SMT/Sanity.hs b/proof/Proof/SMT/Sanity.hs index 441ecf3..daf5938 100644 --- a/proof/Proof/SMT/Sanity.hs +++ b/proof/Proof/SMT/Sanity.hs @@ -35,7 +35,8 @@ 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). +-- 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 From b5e9077211f3e44ef60b6e3687f622dd82555b4a Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 03:06:43 +0100 Subject: [PATCH 3/6] Cache proofs: standalone functional and leakage halves, and link 2 The standalone cache proof moves to Proof.Cache.Server.Functional and gains its leakage half, Proof.Cache.Server.Leakage: an attacker model (the request's observation, and whether the cache answers), a simulator on the tags alone, its driver and the invariant relating it to the server (srvSimInvAt, with simOf, the simulator a server determines). The contract between core and cache is generic in memory: srvReady is defined by behaviour, srvDriverSpec is the operational reading of a memory's driver, and srvReadyIffAnswered, srvReadyUnderInv, srvDriverMatchesSpec and corePatient state what each side promises. Link 2, the core behind the cache refining the core behind ideal memory, is back under Proof.Cache.CachedCore, in a functional half (cachedInvAt, one step per hop length) and a leakage half (a simulator that adds the cycles the core waits, cachedSimInvAt, simCachedOf). Its obligations follow from the contract and the standalone proofs, and are kept as sanity checks. The old Proof.Cache.Server4K and Proof.Cache.Induction4K, superseded by these, are deleted. Every property of the four cache solver modules is valid, each run on its own. Part of a series; see the last commit. Co-Authored-By: Claude Opus 5.5 --- .../Cache/CachedCore/Functional/Driver.hs | 86 ++++++ .../Cache/CachedCore/Functional/Invariant.hs | 54 ++++ .../Cache/CachedCore/Functional/Machine.hs | 65 +++++ .../Cache/CachedCore/Functional/Obligation.hs | 171 ++++++++++++ .../Cache/CachedCore/Functional/Solver.hs | 178 ++++++++++++ .../Proof/Cache/CachedCore/Leakage/Driver.hs | 63 +++++ .../Cache/CachedCore/Leakage/Invariant.hs | 32 +++ .../Cache/CachedCore/Leakage/Obligation.hs | 224 +++++++++++++++ .../Cache/CachedCore/Leakage/Simulator.hs | 70 +++++ .../Proof/Cache/CachedCore/Leakage/Solver.hs | 107 +++++++ proof/Proof/Cache/Functional/Contract.hs | 83 ------ proof/Proof/Cache/Functional/Driver.hs | 54 ---- proof/Proof/Cache/Functional/Obligation.hs | 139 ---------- proof/Proof/Cache/Functional/Solver.hs | 180 ------------ proof/Proof/Cache/Induction4K.hs | 52 ---- proof/Proof/Cache/SMT/Array.hs | 20 +- proof/Proof/Cache/SMT/Axioms.hs | 25 +- proof/Proof/Cache/SMT/Coherent.hs | 15 +- proof/Proof/Cache/SMT/Raw.hs | 2 +- .../Proof/Cache/Server/Functional/Contract.hs | 117 ++++++++ proof/Proof/Cache/Server/Functional/Driver.hs | 54 ++++ .../{ => Server}/Functional/Invariant.hs | 22 +- .../Cache/Server/Functional/Obligation.hs | 212 ++++++++++++++ proof/Proof/Cache/Server/Functional/Solver.hs | 262 ++++++++++++++++++ proof/Proof/Cache/Server/Leakage/Driver.hs | 77 +++++ proof/Proof/Cache/Server/Leakage/Invariant.hs | 43 +++ proof/Proof/Cache/Server/Leakage/Model.hs | 28 ++ .../Proof/Cache/Server/Leakage/Obligation.hs | 56 ++++ proof/Proof/Cache/Server/Leakage/Simulator.hs | 113 ++++++++ proof/Proof/Cache/Server/Leakage/Solver.hs | 76 +++++ proof/Proof/Cache/Server4K.hs | 157 ----------- 31 files changed, 2154 insertions(+), 683 deletions(-) create mode 100644 proof/Proof/Cache/CachedCore/Functional/Driver.hs create mode 100644 proof/Proof/Cache/CachedCore/Functional/Invariant.hs create mode 100644 proof/Proof/Cache/CachedCore/Functional/Machine.hs create mode 100644 proof/Proof/Cache/CachedCore/Functional/Obligation.hs create mode 100644 proof/Proof/Cache/CachedCore/Functional/Solver.hs create mode 100644 proof/Proof/Cache/CachedCore/Leakage/Driver.hs create mode 100644 proof/Proof/Cache/CachedCore/Leakage/Invariant.hs create mode 100644 proof/Proof/Cache/CachedCore/Leakage/Obligation.hs create mode 100644 proof/Proof/Cache/CachedCore/Leakage/Simulator.hs create mode 100644 proof/Proof/Cache/CachedCore/Leakage/Solver.hs delete mode 100644 proof/Proof/Cache/Functional/Contract.hs delete mode 100644 proof/Proof/Cache/Functional/Driver.hs delete mode 100644 proof/Proof/Cache/Functional/Obligation.hs delete mode 100644 proof/Proof/Cache/Functional/Solver.hs delete mode 100644 proof/Proof/Cache/Induction4K.hs create mode 100644 proof/Proof/Cache/Server/Functional/Contract.hs create mode 100644 proof/Proof/Cache/Server/Functional/Driver.hs rename proof/Proof/Cache/{ => Server}/Functional/Invariant.hs (68%) create mode 100644 proof/Proof/Cache/Server/Functional/Obligation.hs create mode 100644 proof/Proof/Cache/Server/Functional/Solver.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Driver.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Invariant.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Model.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Obligation.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Simulator.hs create mode 100644 proof/Proof/Cache/Server/Leakage/Solver.hs delete mode 100644 proof/Proof/Cache/Server4K.hs diff --git a/proof/Proof/Cache/CachedCore/Functional/Driver.hs b/proof/Proof/Cache/CachedCore/Functional/Driver.hs new file mode 100644 index 0000000..6c864e2 --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Functional/Driver.hs @@ -0,0 +1,86 @@ +-- | The driver of link 2: how many cycles the core behind the cache +-- ("Proof.Cache.CachedCore.Functional.Machine") takes beyond one cycle of the +-- core behind ideal memory, before the two can be compared again -- the +-- counterpart of "Proof.Cache.Server.Functional.Driver". +-- +-- * 'cachedDriver', the server's driver on the request the core makes, and +-- * 'cachedDriverSpec', the operational reading, obtained by actually +-- stepping. +module Proof.Cache.CachedCore.Functional.Driver + ( cachedDriver, + cachedDriverValues, + cachedDriverSpec, + cachedDriverMatchesSpec, + ) +where + +import Core (Input (..), Output (..)) +import qualified Core +import Core.RegFile (RegFileOps) +import Data.Maybe (isJust) +import Memory.Cache4K (SetIdx, WordIdx) +import Memory.Cache4KServer +import Memory.Types (MemOps (..)) +import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..), stepCached) +import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Core.Functional.Machine (SysG) +import Types + +-- | The cycles after this one until the cache has answered the request the +-- core makes in this cycle: the server's driver +-- ('Proof.Cache.Server.Functional.Driver.srvDriver') on that request. The +-- driver is only ever run from systems that satisfy the invariant +-- ('Proof.Cache.CachedCore.Functional.Invariant.cachedInvAt'), whose cache is +-- ready; elsewhere it need not agree with 'cachedDriverSpec'. +cachedDriver :: (RegFileOps r) => CachedSysG r m -> Int +cachedDriver (CachedSys core inp srv) = + let (_, Output req) = Core.circuit core inp + in srvDriver srv req + +-- | The driver is 0, 'penalty' or twice 'penalty': the hop lengths of the +-- steps ('Proof.Cache.CachedCore.Functional.Obligation.indStep0', +-- 'Proof.Cache.CachedCore.Functional.Obligation.indStep4', +-- 'Proof.Cache.CachedCore.Functional.Obligation.indStep8'), which so cover +-- every hop. Follows from the server's +-- ('Proof.Cache.Server.Functional.Driver.srvDriverValues'), since +-- 'cachedDriver' is the server's driver on the core's request. +cachedDriverValues :: (RegFileOps r) => CachedSysG r m -> Bool +cachedDriverValues csys = + k == 0 || k == fromIntegral penalty || k == 2 * fromIntegral penalty + where + k = cachedDriver csys + +-- | The operational reading of 'cachedDriver': step the system until the cache +-- answers the core, and count the cycles after the first. 'Nothing' if more +-- than @fuel@ cycles follow the first. +cachedDriverSpec :: + (RegFileOps r, MemOps m) => Int -> CachedSysG r m -> Maybe Int +cachedDriverSpec fuel csys0 = go 0 (stepCached csys0) + where + go n csys + | isJust (inputMem (cachedInput csys)) = Just n + | n >= fuel = Nothing + | otherwise = go (n + 1) (stepCached csys) + +-- | On systems the invariant relates to an ideal system, the driver agrees with +-- its operational reading, as 'Proof.Core.Functional.Driver.driverMatchesSpec' +-- for the core: the driver reads the core's request, which only matches the +-- stepping on states the invariant covers. Eight cycles of fuel, 2 * 'penalty', +-- cover the longest hop, two missed lines. Follows from the server's +-- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec'): under the +-- invariant the server is ready +-- ('Proof.Cache.Server.Functional.Contract.srvReadyUnderInv'), and while it +-- has not answered, the core makes no request +-- ('Proof.Cache.Server.Functional.Contract.corePatient'), so the server is +-- stepped exactly as 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' +-- steps it. +cachedDriverMatchesSpec :: + (RegFileOps r, Eq r, MemOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> CachedSysG r m -> Bool +cachedDriverMatchesSpec wa wsi wwi sys csys = + not premises || conclusion + where + premises = cachedInvAt wa wsi wwi sys csys + + conclusion = cachedDriverSpec 8 csys == Just (cachedDriver csys) diff --git a/proof/Proof/Cache/CachedCore/Functional/Invariant.hs b/proof/Proof/Cache/CachedCore/Functional/Invariant.hs new file mode 100644 index 0000000..5b5f2cd --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Functional/Invariant.hs @@ -0,0 +1,54 @@ +-- | The invariant of link 2, relating the core behind the cache to the core +-- behind ideal memory -- the counterpart of "Proof.Core.Functional.Invariant". +-- +-- The two cores are the same, and so are their inputs; the cache relates to +-- ideal memory as in the cache's own proof +-- ('Proof.Cache.Server.Functional.Invariant.srvInvAt'): ready, holding ideal +-- memory's byte @wa@, and coherent at word @wwi@ of set @wsi@. The cache holds +-- 1024 words and memory many more bytes, so the invariant is stated at +-- witnesses, and the obligations quantify over them. +module Proof.Cache.CachedCore.Functional.Invariant + ( cachedInvAt, + cachedInvFunctional, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Memory.Cache4K (SetIdx, WordIdx) +import Memory.Types (MemOps (..)) +import Proof.Cache.Server.Functional.Invariant (srvInvAt) +import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Core.Functional.Machine (SysG (..)) +import Types (Address) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The invariant at byte @wa@ and word @wwi@ of set @wsi@: the cores and their +-- inputs are equal, and the server satisfies the cache's invariant against +-- ideal memory. +cachedInvAt :: + (Eq r, MemOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> CachedSysG r m -> Bool +cachedInvAt wa wsi wwi (Sys core inp mem) (CachedSys ccore cinp srv) = + ccore == core + && cinp == inp + && srvInvAt wa wsi wwi mem srv + +-- | The invariant is functional: two ideal systems it relates to the same +-- cached system are equal, at byte @wa@. Quantifying over @wa@ gives equality +-- of the systems. Follows from the server's invariant being functional +-- ('Proof.Cache.Server.Functional.Invariant.srvInvFunctional'): the cores and +-- inputs are each equal to the cached system's, and the memories are the ones +-- the server's invariant relates to the same server. +cachedInvFunctional :: + (Eq r, MemOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> SysG r m -> CachedSysG r m -> Bool +cachedInvFunctional wa wsi wwi sys1 sys2 csys = + not premises || conclusion + where + premises = + cachedInvAt wa wsi wwi sys1 csys && cachedInvAt wa wsi wwi sys2 csys + + conclusion = + sysCore sys1 == sysCore sys2 + && sysInput sys1 == sysInput sys2 + && memReadByte wa (sysMem sys1) == memReadByte wa (sysMem sys2) diff --git a/proof/Proof/Cache/CachedCore/Functional/Machine.hs b/proof/Proof/Cache/CachedCore/Functional/Machine.hs new file mode 100644 index 0000000..1bca6a8 --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Functional/Machine.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | The system link 2 reasons about: the core together with the cache in front +-- of memory -- the counterpart of +-- "Proof.Core.Functional.Machine", with the cache server ('serve') in place of +-- ideal memory ('Memory.Ideal.idealServe'). +-- +-- A single system step is one 'Core.circuit' step plus the cache server's +-- answer, and the state the proofs reason about is the triple +-- +-- > (Core.State, Input, cache server) +module Proof.Cache.CachedCore.Functional.Machine + ( CachedSysG (..), + CachedSys, + initCachedSys, + stepCached, + stepCachedOut, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core +import Memory.Cache4KServer +import Memory.Types +import Core.RegFile +import Types (Address) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | Core state, the input it is about to consume, and the cache server. +data CachedSysG r m = CachedSys + { cachedCore :: Core.StateG r, + cachedInput :: Input, + cachedSrv :: CacheSrv m + } + +-- | The concrete system the QuickCheck harness runs: @Vec@-backed throughout. +type CachedSys = CachedSysG RegFile MemBytes + +deriving instance (Show r, Show m) => Show (CachedSysG r m) + +deriving instance (Eq r, Eq m) => Eq (CachedSysG r m) + +-- | The system at start: the core at start with PC @pc@ and register file @rf@ +-- ('Core.initAt'), its input at start ('Core.initInput'), and the cache server +-- at start in front of memory @mem@ ('Memory.Cache4KServer.initCacheSrv'). +initCachedSys :: Address -> r -> m -> CachedSysG r m +initCachedSys pc rf mem = + CachedSys (Core.initAt pc rf) Core.initInput (initCacheSrv mem) + +-- | One system step: run the pipeline for a cycle, then let the cache server +-- answer whatever memory access it emitted. +stepCached :: (RegFileOps r, MemOps m) => CachedSysG r m -> CachedSysG r m +stepCached = fst . stepCachedOut + +-- | 'stepCached', but also returning the pipeline's 'Output' for that cycle. +-- +-- The system is the core in a loop with 'serve': the core's request goes to the +-- cache, and the cache's answer is the core's input in the next cycle. +stepCachedOut :: + (RegFileOps r, MemOps m) => CachedSysG r m -> (CachedSysG r m, Output) +stepCachedOut (CachedSys core inp srv) = + let (core', o) = Core.circuit core inp + (srv', inp') = serve srv (outputMem o) + in (CachedSys core' inp' srv', o) diff --git a/proof/Proof/Cache/CachedCore/Functional/Obligation.hs b/proof/Proof/Cache/CachedCore/Functional/Obligation.hs new file mode 100644 index 0000000..866fd5b --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Functional/Obligation.hs @@ -0,0 +1,171 @@ +-- | The obligations of link 2, in one place: the core behind the cache refines +-- the core behind ideal memory -- the counterpart of +-- "Proof.Core.Functional.Obligation". +-- +-- One cycle of the core behind ideal memory ("Memory.Ideal") corresponds to +-- 'Proof.Cache.CachedCore.Functional.Driver.cachedDriver' + 1 cycles of the +-- core behind the cache. As the core's obligations build the ISA state from the +-- system ('Proof.Core.Functional.Invariant.isaOf'), these build the cached +-- system from the ideal one ('cachedOf'), with a cache that is coherent by +-- construction; the conclusion compares the two after the hop. +-- +-- From a system that satisfies the invariant the driver is 0, 'penalty' or +-- twice 'penalty' (no, one or two lines missed; +-- 'Proof.Cache.CachedCore.Functional.Driver.cachedDriverValues'), so there is +-- one step per hop length, named after it for @'penalty' = 4@. Split by length +-- because Pantomime unrolls recursion only when its count is concrete. +-- +-- == Why they hold +-- +-- The base case and the steps follow from the standalone cache's proof +-- ("Proof.Cache.Server.Functional") and the contract between core and cache +-- ("Proof.Cache.Server.Functional.Contract"); they are checked here only as a +-- sanity check of that argument. +-- +-- * Base case: the server at start satisfies the cache's invariant against +-- its memory ('Proof.Cache.Server.Functional.Obligation.baseCase'), and the +-- cores and inputs are the same by construction. +-- +-- * Step of length @k@: the invariant ('cachedInvAt') gives the same core, +-- the same input, and the cache's invariant against ideal memory. In the +-- first cycle both cores therefore make the same request. The server is +-- ready ('Proof.Cache.Server.Functional.Contract.srvReadyUnderInv') and +-- answers it @k@ cycles later +-- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec'), with +-- ideal memory's answer and its invariant again +-- ('Proof.Cache.Server.Functional.Obligation.indStep0', +-- 'Proof.Cache.Server.Functional.Obligation.indStep4', +-- 'Proof.Cache.Server.Functional.Obligation.indStep8'). In the @k@ cycles +-- in between it answers 'Nothing', and the core, given 'Nothing' after a +-- request, makes no request and stays the same +-- ('Proof.Cache.Server.Functional.Contract.corePatient', once per cycle), +-- so the server is served no request, as its own steps assume. After the +-- hop the cores and inputs are those of the ideal system after one step, +-- and the cache's invariant holds: 'cachedInvAt' again. +module Proof.Cache.CachedCore.Functional.Obligation + ( cachedOf, + baseCase, + indStep0, + indStep4, + indStep8, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core.RegFile (RegFileOps) +import Memory.Cache4K +import Memory.Cache4KServer +import Memory.Types (MemOps (..)) +import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) +import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.Cache.CachedCore.Functional.Driver (cachedDriver) +import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Cache.CachedCore.Functional.Machine + ( CachedSysG (..), + initCachedSys, + stepCached, + ) +import Proof.Core.Functional.Machine (SysG (..), initSys, stepSys) +import Types (Address) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- The starting state ----------------------------------------------------------- + +-- | The cached system for the ideal system @sys@: the same core and input, and +-- in front of its memory a ready cache with the tag array @tags@ that is +-- coherent by construction -- valid lines hold memory's words, invalid lines +-- those of @raw@. The steps start from it, as the cache's own steps do +-- ('Proof.Cache.Server.Functional.Obligation.indStep0'), so that coherence +-- holds by construction instead of being assumed; it shows what the cache adds +-- to the ideal system: its tags and the contents of its invalid lines. +cachedOf :: (CoherentOps m) => SysG r m -> TagArr -> RawData -> CachedSysG r m +cachedOf (Sys core inp mem) tags raw = + CachedSys core inp (CacheSrv cache mem CacheSrvReady) + where + cache = Cache4K tags (mkData mem tags raw) + +-- The base case ---------------------------------------------------------------- + +-- | The base case: the core at start behind the cache at start, in front of +-- any memory, and the same core behind ideal memory satisfy the invariant. A +-- sanity check: it follows from the cache's base case (see the module header). +baseCase :: + (Eq r, MemOps m) => + Address -> SetIdx -> WordIdx -> Address -> r -> m -> Bool +baseCase wa wsi wwi pc rf mem = + cachedInvAt wa wsi wwi sys csys + where + sys = initSys pc rf mem + csys = initCachedSys pc rf mem + +-- The inductive steps ---------------------------------------------------------- + +-- | The one-cycle hop: a request the cache answers at once. A sanity check: +-- it follows from the cache's step and the contract (see the module header). +indStep0 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStep0 wa wsi wwi sys tags raw = + not premises || conclusion + where + sys' = stepSys sys + + csys = cachedOf sys tags raw + csys' = stepCached csys + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedDriver csys == 0 + + conclusion = cachedInvAt wa wsi wwi sys' csys' + +-- | The hop of a read that misses one line: 'penalty' + 1 cycle. A sanity +-- check: it follows from the cache's step and the contract (see the module +-- header). +indStep4 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStep4 wa wsi wwi sys tags raw = + not premises || conclusion + where + sys' = stepSys sys + + csys = cachedOf sys tags raw + csys' = stepCachedN (fromIntegral penalty) csys + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedDriver csys == fromIntegral penalty + + conclusion = cachedInvAt wa wsi wwi sys' csys' + +-- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycle. A +-- sanity check: it follows from the cache's step and the contract (see the +-- module header). +indStep8 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStep8 wa wsi wwi sys tags raw = + not premises || conclusion + where + sys' = stepSys sys + + csys = cachedOf sys tags raw + csys' = stepCachedN (2 * fromIntegral penalty) csys + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedDriver csys == 2 * fromIntegral penalty + + conclusion = cachedInvAt wa wsi wwi sys' csys' + +-- Helpers ---------------------------------------------------------------------- + +-- | A hop of the cached system: @n + 1@ steps, the request's cycle and the @n@ +-- cycles the driver counts after it. Recursive on @n@, which each step fixes +-- to a constant, so that the solver can unroll it. +stepCachedN :: + (RegFileOps r, MemOps m) => Int -> CachedSysG r m -> CachedSysG r m +stepCachedN n csys + | n == 0 = stepCached csys + | otherwise = stepCachedN (n - 1) (stepCached csys) diff --git a/proof/Proof/Cache/CachedCore/Functional/Solver.hs b/proof/Proof/Cache/CachedCore/Functional/Solver.hs new file mode 100644 index 0000000..31b126a --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Functional/Solver.hs @@ -0,0 +1,178 @@ +-- | The proof that the core behind the cache refines the core behind ideal +-- memory, checked symbolically: the counterpart of +-- "Proof.Core.Functional.Solver". +-- +-- The statements live in "Proof.Cache.CachedCore.Functional.Driver" and +-- "Proof.Cache.CachedCore.Functional.Obligation"; this module only instantiates +-- them, over every core state, input, register file, memory, tag array, +-- request and witness. +-- Each property is named after the statement it checks, with a @P@: +-- +-- * the driver against its operational reading +-- ('cachedDriverMatchesSpecP'), and its values, the hop lengths of the +-- steps ('cachedDriverValuesP'); +-- * the invariant being functional ('cachedInvFunctionalP'); +-- * the base case, and one step per hop length (0, 'penalty', +-- 2 * 'penalty'), each starting from a cache coherent by construction +-- ('Proof.Cache.Server.Functional.Obligation.mkData'). +-- +-- The array embeddings these rely on are checked in +-- "Proof.Cache.Server.Functional.Solver". +-- +-- == Running them +-- +-- Under Bitwuzla, not Z3: +-- +-- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build +module Proof.Cache.CachedCore.Functional.Solver + ( cachedDriverMatchesSpecP, + cachedDriverValuesP, + cachedInvFunctionalP, + baseCaseP, + indStep0P, + indStep4P, + indStep8P, + results, + ) +where + +import qualified Core +import Memory.Cache4K +import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Cache.SMT.Raw (RawData) +import Proof.Cache.CachedCore.Functional.Driver + ( cachedDriverMatchesSpec, + cachedDriverValues, + ) +import Proof.Cache.CachedCore.Functional.Invariant (cachedInvFunctional) +import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Cache.CachedCore.Functional.Obligation +import Proof.Core.Functional.Machine (SysG (..)) +import Proof.Core.Functional.System (KState, sysOf) +import Proof.SMT.Array (MemArr, RegArr, RegArrF (..)) +import Proof.SMT.Logged (pantomime) +import Types + +-- The driver ------------------------------------------------------------------- +-- +-- The cached system has the ideal system's core and input, and a cache with +-- arbitrary tags, data, memory and state. + +-- | On systems the invariant relates to an ideal system, the driver agrees with +-- its operational reading. +{-# ANN cachedDriverMatchesSpecP (Theory cacheAxioms) #-} +cachedDriverMatchesSpecP :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> DataArr -> MemArr -> CacheSrvState -> + Pantomime.Bool +cachedDriverMatchesSpecP wa wsi wwi ss i ra ma tags dat cma st = + Pantomime.boolean $ cachedDriverMatchesSpec wa wsi wwi sys csys + where + sys = sysOf ss i ra ma + csys = + CachedSys + (sysCore sys) + (sysInput sys) + (CacheSrv (Cache4K tags dat) cma st) + +-- | The driver is 0, 'penalty' or twice 'penalty', on any system. +{-# ANN cachedDriverValuesP (Theory cacheAxioms) #-} +cachedDriverValuesP :: + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> DataArr -> MemArr -> CacheSrvState -> + Pantomime.Bool +cachedDriverValuesP ss i ra ma tags dat cma st = + Pantomime.boolean $ cachedDriverValues csys + where + sys = sysOf ss i ra ma + csys = + CachedSys + (sysCore sys) + (sysInput sys) + (CacheSrv (Cache4K tags dat) cma st) + +-- The invariant ---------------------------------------------------------------- + +-- | The invariant is functional: two ideal systems related to the same cached +-- system are equal. The cached system's core and input come from a third +-- symbolic system; its cache is arbitrary. +{-# ANN cachedInvFunctionalP (Theory cacheAxioms) #-} +cachedInvFunctionalP :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> MemArr -> + KState -> Core.Input -> RegArr -> + TagArr -> DataArr -> MemArr -> CacheSrvState -> + Pantomime.Bool +cachedInvFunctionalP + wa wsi wwi ss1 i1 ra1 ma1 ss2 i2 ra2 ma2 ss i ra tags dat cma st = + Pantomime.boolean $ cachedInvFunctional wa wsi wwi sys1 sys2 csys + where + sys1 = sysOf ss1 i1 ra1 ma1 + sys2 = sysOf ss2 i2 ra2 ma2 + csys0 = sysOf ss i ra cma + csys = + CachedSys + (sysCore csys0) + (sysInput csys0) + (CacheSrv (Cache4K tags dat) cma st) + +-- The base case ---------------------------------------------------------------- + +-- | Under 'cacheAxioms': the initial cache is the empty one +-- ('Memory.Cache4K.dataZero'), not a constructed one. +{-# ANN baseCaseP (Theory cacheAxioms) #-} +baseCaseP :: + Address -> SetIdx -> WordIdx -> Address -> RegArr -> MemArr -> Pantomime.Bool +baseCaseP wa wsi wwi pc ra ma = + Pantomime.boolean $ baseCase wa wsi wwi pc (RegArrF ra) ma + +-- The inductive steps ---------------------------------------------------------- +-- +-- The ideal system is built from symbolic parts as in the core's proof +-- ('Proof.Core.Functional.System.sysOf'); the cache adds its tags and the +-- contents of its invalid lines. + +-- | The one-cycle hop: a request the cache answers at once. +{-# ANN indStep0P (Theory coherentAxioms) #-} +indStep0P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStep0P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStep0 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The hop of a read that misses one line. +{-# ANN indStep4P (Theory coherentAxioms) #-} +indStep4P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStep4P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStep4 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The hop of a read that misses both its lines. +{-# ANN indStep8P (Theory coherentAxioms) #-} +indStep8P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStep8P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStep8 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the +-- property is valid. +results :: [(String, Maybe String)] +results = + [ ("cachedDriverMatchesSpecP", $(pantomime 'cachedDriverMatchesSpecP)), + ("cachedDriverValuesP", $(pantomime 'cachedDriverValuesP)), + ("cachedInvFunctionalP", $(pantomime 'cachedInvFunctionalP)), + ("baseCaseP", $(pantomime 'baseCaseP)), + ("indStep0P", $(pantomime 'indStep0P)), + ("indStep4P", $(pantomime 'indStep4P)), + ("indStep8P", $(pantomime 'indStep8P)) + ] diff --git a/proof/Proof/Cache/CachedCore/Leakage/Driver.hs b/proof/Proof/Cache/CachedCore/Leakage/Driver.hs new file mode 100644 index 0000000..822042b --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Leakage/Driver.hs @@ -0,0 +1,63 @@ +-- | The driver of link 2's leakage half: how many cycles the core behind the +-- cache waits after a request, computed from the request's observation alone +-- -- the counterpart of "Proof.Cache.CachedCore.Functional.Driver". +module Proof.Cache.CachedCore.Leakage.Driver + ( simCachedDriver, + simCachedDriverSpec, + simCachedDriverMatchesSpec, + ) +where + +import Data.Maybe (fromMaybe) +import Proof.Cache.Server.Leakage.Driver (simSrvDriver) +import Proof.Cache.CachedCore.Leakage.Simulator + ( SimCachedInput, + SimCachedSys (..), + simStepCached, + ) +import Proof.Cache.Server.Leakage.Simulator (simSrvReady) +import Proof.Core.Leakage.Model (Obs (..)) + +-- | The cycles the core waits after a request observed as @inp@: the cache +-- simulator's driver ('Proof.Cache.Server.Leakage.Driver.simSrvDriver') on that +-- observation. Only ever run from a ready simulator, so whether the last cycle +-- brought an answer is not consulted. +simCachedDriver :: SimCachedSys -> SimCachedInput -> Int +simCachedDriver (SimCachedSys sim _) inp = + simSrvDriver sim (fromMaybe NoAccess inp) + +-- | The operational reading of 'simCachedDriver', as +-- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverSpec' is of the cache +-- simulator's: step on the observed request, then with no input until the +-- simulator answers, and count the cycles after the request's. 'Nothing' if +-- more than @fuel@ cycles follow the request's. +simCachedDriverSpec :: Int -> SimCachedSys -> SimCachedInput -> Maybe Int +simCachedDriverSpec fuel sim0 inp = go 0 (fst (simStepCached sim0 inp)) + where + go n sim + | simCachedAnswered sim = Just n + | n >= fuel = Nothing + | otherwise = go (n + 1) (fst (simStepCached sim Nothing)) + +-- | From a ready simulator -- its last cycle brought an answer, and the cache's +-- simulator is ready ('Proof.Cache.Server.Leakage.Simulator.simSrvReady') -- +-- its driver agrees with its operational reading, for the observation of any +-- request: a hop starts with one, never in the middle of a driver hop. Eight +-- cycles of fuel, 2 * 'penalty', cover the longest hop. +-- +-- Follows from the cache simulator's +-- ('Proof.Cache.Server.Leakage.Driver.simSrvDriverMatchesSpec'): since the last +-- cycle brought an answer, 'simStepCached' passes the input on to the cache's +-- simulator, and until it answers again passes it no input, so the cache's +-- simulator is stepped exactly as +-- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverSpec' steps it, and +-- 'simCachedDriver' is its driver. +simCachedDriverMatchesSpec :: SimCachedSys -> Obs -> Bool +simCachedDriverMatchesSpec sim@(SimCachedSys srvSim answered) obs = + not premises || conclusion + where + premises = answered && simSrvReady srvSim + + conclusion = + simCachedDriverSpec 8 sim (Just obs) + == Just (simCachedDriver sim (Just obs)) diff --git a/proof/Proof/Cache/CachedCore/Leakage/Invariant.hs b/proof/Proof/Cache/CachedCore/Leakage/Invariant.hs new file mode 100644 index 0000000..d386e3f --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Leakage/Invariant.hs @@ -0,0 +1,32 @@ +-- | The invariant of link 2's leakage half: the cache's simulator agrees with +-- the server of the core behind the cache -- the counterpart of +-- "Proof.Cache.CachedCore.Functional.Invariant". +-- +-- The steps assume link 2's functional invariant +-- ('Proof.Cache.CachedCore.Functional.Invariant.cachedInvAt') as well, so this +-- only adds the simulator ("Proof.Cache.CachedCore.Leakage.Simulator"). +module Proof.Cache.CachedCore.Leakage.Invariant + ( cachedSimInvAt, + simCachedOf, + ) +where + +import Memory.Cache4K (SetIdx) +import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Cache.Server.Leakage.Invariant (simOf, srvSimInvAt) +import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..)) + +-- | The simulator agrees with the cached system at a hop boundary: the cache's +-- simulator agrees with the server at set @wsi@, as in the cache's leakage +-- proof ('Proof.Cache.Server.Leakage.Invariant.srvSimInvAt'), and the +-- simulator records that an answer has just arrived. +cachedSimInvAt :: SetIdx -> SimCachedSys -> CachedSysG r m -> Bool +cachedSimInvAt wsi (SimCachedSys sim answered) (CachedSys _ _ srv) = + srvSimInvAt wsi sim srv && answered + +-- | The simulator a cached system determines at the start of a hop: the +-- cache's simulator built from its server +-- ('Proof.Cache.Server.Leakage.Invariant.simOf'), and an answer in the +-- previous cycle, as at every hop boundary. +simCachedOf :: CachedSysG r m -> SimCachedSys +simCachedOf (CachedSys _ _ srv) = SimCachedSys (simOf srv) True diff --git a/proof/Proof/Cache/CachedCore/Leakage/Obligation.hs b/proof/Proof/Cache/CachedCore/Leakage/Obligation.hs new file mode 100644 index 0000000..63919ee --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Leakage/Obligation.hs @@ -0,0 +1,224 @@ +-- | The obligations of link 2's leakage half, in one place: what the bus +-- between the core and the cache shows follows from what the bus between the +-- core and ideal memory shows -- the counterpart of +-- "Proof.Cache.CachedCore.Functional.Obligation". +-- +-- One cycle of the core behind ideal memory, with observation @o@, corresponds +-- to @k + 1@ cycles of the core behind the cache: the first shows @o@ too, the +-- other @k@ show no request. The cache's simulator, given @o@ alone, computes +-- @k@ ('Proof.Cache.CachedCore.Leakage.Driver.simCachedDriver') and answers in +-- the same cycles as the server. Together with the core's leakage proof, which +-- gives the ideal observations from the ISA leakage, this gives the +-- observations of the core behind the cache from the ISA leakage, with no +-- combination of stalls to consider: the stalls are inserted one ideal cycle +-- at a time. +-- +-- The steps build the cached system from the ideal system, as the functional +-- half does ('Proof.Cache.CachedCore.Functional.Obligation.cachedOf'), and the +-- simulator from the cached system ('simCachedOf'), as the cache's leakage +-- proof does from the server ('Proof.Cache.Server.Leakage.Invariant.simOf'). +-- They assume link 2's functional invariant, which the functional half +-- establishes, and add only the simulator's. One step per hop length, as in +-- the functional half. +-- +-- == Why they hold +-- +-- The base case and the steps follow from the cache's leakage proof +-- ("Proof.Cache.Server.Leakage.Obligation"), the contract +-- ("Proof.Cache.Server.Functional.Contract") and link 2's functional half; they +-- are checked here only as a sanity check of that argument. +-- +-- * Base case: the cache's simulator and the server at start agree +-- ('Proof.Cache.Server.Leakage.Obligation.baseCaseLeak'), and the core's +-- input at start holds an answer, as the simulator at start records. The +-- functional invariant at start is the functional half's base case. +-- +-- * Step of length @k@: by the functional half, the first cycle's request is +-- the ideal one, and in the @k@ cycles after it the core makes no request +-- ('Proof.Cache.Server.Functional.Contract.corePatient'). In every cycle, +-- the simulator, given the observation of the request, answers exactly +-- when the server does and agrees with it afterwards +-- ('Proof.Cache.Server.Leakage.Obligation.indStepLeak', once per cycle). +-- The simulator's wait is the functional driver's: both are the cache's +-- drivers, which agree with their operational readings +-- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec', +-- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverMatchesSpec'). +module Proof.Cache.CachedCore.Leakage.Obligation + ( baseCaseLeak, + indStepLeak0, + indStepLeak4, + indStepLeak8, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core.RegFile (RegFileOps) +import Memory.Cache4K +import Memory.Cache4KServer +import Memory.Types (MemOps (..)) +import Proof.Cache.CachedCore.Functional.Driver (cachedDriver) +import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Cache.CachedCore.Functional.Machine + ( CachedSysG (..), + initCachedSys, + stepCachedOut, + ) +import Proof.Cache.CachedCore.Functional.Obligation (cachedOf) +import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriver) +import Proof.Cache.CachedCore.Leakage.Invariant + ( cachedSimInvAt, + simCachedOf, + ) +import Proof.Cache.CachedCore.Leakage.Simulator + ( SimCachedInput, + SimCachedSys (..), + simInitCachedSys, + simStepCached, + ) +import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) +import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.Core.Functional.Machine (SysG (..), stepSysOut) +import Proof.Core.Leakage.Model (Obs, obsOf) +import Types (Address) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The observations of a run, cycle by cycle: what the attacker sees over a +-- hop. A type of its own, rather than a list, so that its equality is derived +-- here and the solver can unroll it; the equality of lists comes from @base@, +-- whose definitions the solver cannot see. +data Trace = TraceSingle Obs | TraceCons Obs Trace + deriving (Show, Eq) + +-- The base case ---------------------------------------------------------------- + +-- | The base case: the simulator at start agrees with the core at start behind +-- the cache at start, in front of any memory. Link 2's functional invariant +-- at start is its functional base case +-- ('Proof.Cache.CachedCore.Functional.Obligation.baseCase'). A sanity check: +-- it follows from the cache's leakage base case (see the module header). +baseCaseLeak :: SetIdx -> Address -> r -> m -> Bool +baseCaseLeak wsi pc rf mem = + cachedSimInvAt wsi simInitCachedSys (initCachedSys pc rf mem) + +-- The inductive steps ---------------------------------------------------------- + +-- | The one-cycle hop: a request the cache answers at once. A sanity check: it +-- follows from the cache's leakage step and the contract (see the module +-- header). +indStepLeak0 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStepLeak0 wa wsi wwi sys tags raw = + not premises || conclusion + where + csys = cachedOf sys tags raw + sim = simCachedOf csys + + (_, out) = stepSysOut sys + obs = obsOf out + + hopLength = 0 + + (tr1, csys') = stepCachedOutN hopLength csys + (tr2, sim') = simStepCachedN hopLength sim (Just obs) + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedSimInvAt wsi sim csys + && cachedDriver csys == hopLength + + conclusion = + simCachedDriver sim (Just obs) == hopLength + && tr1 == tr2 + && cachedSimInvAt wsi sim' csys' + +-- | The hop of a read that misses one line: 'penalty' + 1 cycle. A sanity +-- check: it follows from the cache's leakage step and the contract (see the +-- module header). +indStepLeak4 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStepLeak4 wa wsi wwi sys tags raw = + not premises || conclusion + where + csys = cachedOf sys tags raw + sim = simCachedOf csys + + (_, out) = stepSysOut sys + obs = obsOf out + + hopLength = fromIntegral penalty + + (tr1, csys') = stepCachedOutN hopLength csys + (tr2, sim') = simStepCachedN hopLength sim (Just obs) + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedSimInvAt wsi sim csys + && cachedDriver csys == hopLength + + conclusion = + simCachedDriver sim (Just obs) == hopLength + && tr1 == tr2 + && cachedSimInvAt wsi sim' csys' + +-- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycle. A +-- sanity check: it follows from the cache's leakage step and the contract (see +-- the module header). +indStepLeak8 :: + (RegFileOps r, Eq r, CoherentOps m) => + Address -> SetIdx -> WordIdx -> SysG r m -> TagArr -> RawData -> Bool +indStepLeak8 wa wsi wwi sys tags raw = + not premises || conclusion + where + csys = cachedOf sys tags raw + sim = simCachedOf csys + + (_, out) = stepSysOut sys + obs = obsOf out + + hopLength = 2 * fromIntegral penalty + + (tr1, csys') = stepCachedOutN hopLength csys + (tr2, sim') = simStepCachedN hopLength sim (Just obs) + + premises = + cachedInvAt wa wsi wwi sys csys + && cachedSimInvAt wsi sim csys + && cachedDriver csys == hopLength + + conclusion = + simCachedDriver sim (Just obs) == hopLength + && tr1 == tr2 + && cachedSimInvAt wsi sim' csys' + +-- Helpers ---------------------------------------------------------------------- + +-- | A hop of the cached system: @n + 1@ steps, the request's cycle and the @n@ +-- cycles the driver counts after it ('stepCachedOut' repeated). Returns the +-- trace of the bus's observations and the system after the hop. Recursive on +-- @n@, which each step fixes to a literal. +stepCachedOutN :: + (RegFileOps r, MemOps m) => + Int -> CachedSysG r m -> (Trace, CachedSysG r m) +stepCachedOutN n csys + | n == 0 = (TraceSingle obs, csys') + | otherwise = + let (tr, csys'') = stepCachedOutN (n - 1) csys' + in (TraceCons obs tr, csys'') + where + (csys', out) = stepCachedOut csys + obs = obsOf out + +-- | The simulator's counterpart of 'stepCachedOutN' ('simStepCached' +-- repeated): its input in the first cycle, then no input, as in the middle of +-- a driver hop. Returns the trace of what it shows on the bus and the +-- simulator after the hop. +simStepCachedN :: Int -> SimCachedSys -> SimCachedInput -> (Trace, SimCachedSys) +simStepCachedN n sim inp + | n == 0 = (TraceSingle bus, sim') + | otherwise = + let (tr, sim'') = simStepCachedN (n - 1) sim' Nothing + in (TraceCons bus tr, sim'') + where + (sim', bus) = simStepCached sim inp diff --git a/proof/Proof/Cache/CachedCore/Leakage/Simulator.hs b/proof/Proof/Cache/CachedCore/Leakage/Simulator.hs new file mode 100644 index 0000000..8c9383a --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Leakage/Simulator.hs @@ -0,0 +1,70 @@ +-- | The simulator of link 2's leakage half: what the bus between the core and +-- the cache shows, computed from what the bus between the core and ideal +-- memory shows -- the counterpart of +-- "Proof.Cache.CachedCore.Functional.Machine". +-- +-- It runs cycle by cycle, as the core behind the cache does. In a cycle in +-- which the core does not wait, its input is the observation the core behind +-- ideal memory makes; while the core waits, it has no input. It carries only +-- the cache's simulator ("Proof.Cache.Server.Leakage.Simulator"), which +-- decides from the observations alone in which cycles the answer comes. +module Proof.Cache.CachedCore.Leakage.Simulator + ( SimCachedInput, + SimCachedSys (..), + simInitCachedSys, + simStepCached, + ) +where + +import Data.Maybe (fromMaybe) +import Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrv, + simInitCacheSrv, + simServe, + ) +import Proof.Core.Leakage.Model (Obs (..)) + +-- | The simulator's input in one cycle: the observation of the core behind +-- ideal memory, or 'Nothing' while the core behind the cache waits. +-- +-- 'Nothing' means the simulator is in the middle of a driver hop: the core +-- behind ideal memory has no cycle here, and its trace does not advance. It is +-- not the same as @'Just' 'NoAccess'@, a cycle of that core with no request, +-- which does advance it. +type SimCachedInput = Maybe Obs + +-- | The simulator's counterpart of +-- 'Proof.Cache.CachedCore.Functional.Machine.CachedSysG': the cache's +-- simulator, and what the core can see of its input -- whether the cache +-- answered in the previous cycle, and so whether the core is no longer +-- waiting. +data SimCachedSys = SimCachedSys + { -- | The cache's simulator. + simCachedSrv :: SimCacheSrv, + -- | Did the cache answer in the previous cycle? + simCachedAnswered :: Bool + } + deriving (Show, Eq) + +-- | The simulator at start: the cache's simulator at start +-- ('Proof.Cache.Server.Leakage.Simulator.simInitCacheSrv'), and an answer in +-- the previous cycle, as the core's input at start holds one +-- ('Core.initInput'). +simInitCachedSys :: SimCachedSys +simInitCachedSys = SimCachedSys simInitCacheSrv True + +-- | One cycle of the core behind the cache, as +-- 'Proof.Cache.CachedCore.Functional.Machine.stepCachedOut'. If the cache +-- answered in the previous cycle, the core makes the ideal observation, and the +-- cache's simulator is given it; otherwise the core waits, the bus shows no +-- request and the simulator has no input. Returns the simulator afterwards and +-- the bus's observation. +simStepCached :: SimCachedSys -> SimCachedInput -> (SimCachedSys, Obs) +simStepCached (SimCachedSys sim answered) inp + | answered = + let obs = fromMaybe NoAccess inp + (sim', ans) = simServe sim obs + in (SimCachedSys sim' ans, obs) + | otherwise = + let (sim', ans) = simServe sim NoAccess + in (SimCachedSys sim' ans, NoAccess) diff --git a/proof/Proof/Cache/CachedCore/Leakage/Solver.hs b/proof/Proof/Cache/CachedCore/Leakage/Solver.hs new file mode 100644 index 0000000..d75e41b --- /dev/null +++ b/proof/Proof/Cache/CachedCore/Leakage/Solver.hs @@ -0,0 +1,107 @@ +-- | Link 2's leakage half, checked symbolically: the counterpart of +-- "Proof.Cache.CachedCore.Functional.Solver". +-- +-- The statements live in "Proof.Cache.CachedCore.Leakage.Driver" and +-- "Proof.Cache.CachedCore.Leakage.Obligation"; this module only instantiates +-- them, over every core state, input, register file, memory, tag array and +-- witness. Each property is named after the statement it checks, with a @P@: +-- +-- * the simulator's driver against its operational reading +-- ('simCachedDriverMatchesSpecP'); +-- * the base case, and one step per hop length (0, 'penalty', +-- 2 * 'penalty'), each starting from a cache coherent by construction. +-- +-- == Running them +-- +-- Under Bitwuzla, not Z3: +-- +-- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build +module Proof.Cache.CachedCore.Leakage.Solver + ( simCachedDriverMatchesSpecP, + baseCaseLeakP, + indStepLeak0P, + indStepLeak4P, + indStepLeak8P, + results, + ) +where + +import qualified Core +import Memory.Cache4K +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) +import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..)) +import Proof.Core.Leakage.Model (Obs) +import Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrv (..), + SimCacheSrvState, + ) +import Proof.Cache.CachedCore.Leakage.Obligation +import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Cache.SMT.Raw (RawData) +import Proof.Core.Functional.System (KState, sysOf) +import Proof.SMT.Array (MemArr, RegArr, RegArrF (..)) +import Proof.SMT.Logged (pantomime) +import Types + +-- The driver ------------------------------------------------------------------- + +-- | From a ready simulator, its driver agrees with its operational reading, for +-- the observation of any request. +{-# ANN simCachedDriverMatchesSpecP (Theory cacheAxioms) #-} +simCachedDriverMatchesSpecP :: + TagArr -> SimCacheSrvState -> Bool -> Obs -> Pantomime.Bool +simCachedDriverMatchesSpecP tags sst answered obs = + Pantomime.boolean $ simCachedDriverMatchesSpec sim obs + where + sim = SimCachedSys (SimCacheSrv tags sst) answered + +-- The base case ---------------------------------------------------------------- + +-- | The simulator at start agrees with the system at start, for any start +-- PC, register file and memory. +{-# ANN baseCaseLeakP (Theory cacheAxioms) #-} +baseCaseLeakP :: SetIdx -> Address -> RegArr -> MemArr -> Pantomime.Bool +baseCaseLeakP wsi pc ra ma = + Pantomime.boolean $ baseCaseLeak wsi pc (RegArrF ra) ma + +-- The inductive steps ---------------------------------------------------------- + +-- | The one-cycle hop: a request the cache answers at once. +{-# ANN indStepLeak0P (Theory coherentAxioms) #-} +indStepLeak0P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStepLeak0P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStepLeak0 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The hop of a read that misses one line. +{-# ANN indStepLeak4P (Theory coherentAxioms) #-} +indStepLeak4P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStepLeak4P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStepLeak4 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The hop of a read that misses both its lines. +{-# ANN indStepLeak8P (Theory coherentAxioms) #-} +indStepLeak8P :: + Address -> SetIdx -> WordIdx -> + KState -> Core.Input -> RegArr -> MemArr -> + TagArr -> RawData -> Pantomime.Bool +indStepLeak8P wa wsi wwi ss i ra ma tags raw = + Pantomime.boolean $ indStepLeak8 wa wsi wwi (sysOf ss i ra ma) tags raw + +-- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the +-- property is valid. +results :: [(String, Maybe String)] +results = + [ ("simCachedDriverMatchesSpecP", $(pantomime 'simCachedDriverMatchesSpecP)), + ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), + ("indStepLeak0P", $(pantomime 'indStepLeak0P)), + ("indStepLeak4P", $(pantomime 'indStepLeak4P)), + ("indStepLeak8P", $(pantomime 'indStepLeak8P)) + ] diff --git a/proof/Proof/Cache/Functional/Contract.hs b/proof/Proof/Cache/Functional/Contract.hs deleted file mode 100644 index 865378b..0000000 --- a/proof/Proof/Cache/Functional/Contract.hs +++ /dev/null @@ -1,83 +0,0 @@ --- | The contract between the core and the 4 KiB cache in front of memory: what --- each side promises beyond the cache's proof against ideal memory --- ("Proof.Cache.Functional.Obligation"), so that the core runs behind the --- cache as it would behind ideal memory, with stutter steps inserted. --- --- The two sides are not symmetric: the core makes the requests and the cache --- answers them. --- --- * The core waits for what it asked for ('waitsAfterRequest'): after a --- request, given no answer, it makes no request and its state stays the --- same. --- * The cache answers 'Nothing' only while a request is outstanding: a --- server related to ideal memory by the invariant is ready --- ('readyUnderInv'), and a ready server asked nothing answers within the --- cycle ('readyIdleNoWait'). While a request is outstanding, the driver and the --- cache's step obligations say how it answers: 'Nothing' for as many cycles --- as the driver counts, then ideal memory's answer. --- --- The properties are checked in "Proof.Cache.Functional.Solver". -module Proof.Cache.Functional.Contract - ( isReady, - readyUnderInv, - readyIdleNoWait, - sameCoreAt, - waitsAfterRequest, - ) -where - -import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), Output (..), StateG (..), circuit) -import Data.Maybe (isNothing) -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) -import Memory.Types (MemOps) -import Proof.Cache.Functional.Driver (driver) -import Proof.Cache.Functional.Invariant (srvInvAt) -import Core.RegFile (RegFileOps (..)) -import Types (Address, RegIdx) -import Memory.Cache4K (SetIdx, WordIdx) -import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) - --- The cache's side -------------------------------------------------------------- - --- | Is the server ready for a request: no read waiting for memory? -isReady :: CacheSrv m -> Bool -isReady (CacheSrv _ _ st) = st == CacheSrvReady - --- | A server related to ideal memory by the invariant is ready. -readyUnderInv :: (MemOps m) => Address -> SetIdx -> WordIdx -> m -> CacheSrv m -> Bool -readyUnderInv wa wsi wwi ideal srv = not (srvInvAt wa wsi wwi ideal srv) || isReady srv - --- | A ready server that is asked nothing answers within the cycle. -readyIdleNoWait :: CacheSrv m -> Bool -readyIdleNoWait srv = not (isReady srv) || driver srv Nothing == 0 - --- The core's side --------------------------------------------------------------- - --- | Two core states agree at register @wr@: every field is equal, the register --- file at @wr@. Quantifying over @wr@ gives equality of the states. -sameCoreAt :: (RegFileOps r) => RegIdx -> StateG r -> StateG r -> Bool -sameCoreAt wr s1 s2 = - stateFePc s1 == stateFePc s2 - && stateDePc s1 == stateDePc s2 - && stateDeExpInstr s1 == stateDeExpInstr s2 - && stateExPc s1 == stateExPc s2 - && stateExInstr s1 == stateExInstr s2 - && stateMeInstr s1 == stateMeInstr s2 - && stateMeRes s1 == stateMeRes s2 - && stateMeAddr s1 == stateMeAddr s2 - && stateWbInstr s1 == stateWbInstr s2 - && stateWbRes s1 == stateWbRes s2 - && lookupRFg wr (stateRegFile s1) == lookupRFg wr (stateRegFile s2) - && stateCtrl s1 == stateCtrl s2 - && stateHalt s1 == stateHalt s2 - --- | The core waits for what it asked for: after a request, given no answer, it --- makes no request and stays where it was (at register @wr@). -waitsAfterRequest :: (RegFileOps r) => RegIdx -> StateG r -> Input -> Bool -waitsAfterRequest wr s inp = case outMem o of - Nothing -> True - Just _ -> isNothing (outMem o') && sameCoreAt wr s'' s' - where - (s', o) = circuit s inp - (s'', o') = circuit s' (Input Nothing) diff --git a/proof/Proof/Cache/Functional/Driver.hs b/proof/Proof/Cache/Functional/Driver.hs deleted file mode 100644 index a699231..0000000 --- a/proof/Proof/Cache/Functional/Driver.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | The cache's driver: how many cycles after a request the cache's answer is --- final -- the cache's counterpart of "Proof.Core.Functional.Driver". --- --- * 'driver', a case table over the cache and the request, and --- * 'driverRef', the operational reading, obtained by actually serving. -module Proof.Cache.Functional.Driver - ( driver, - driverRef, - ) -where - -import Core (MemAccess (..), Request) -import Memory.Cache4K (cacheHit, setOf) -import Memory.Cache4KServer -import Memory.Types (MemOps (..)) -import Types - --- | The cycles after the request until the cache's answer is final: 'penalty' --- for every line a data read misses, nothing for anything else. A read touches --- the lines of its first and last byte; within four bytes those are different --- lines exactly when they are in different sets. The driver is only ever run --- from servers that satisfy the invariant --- ('Proof.Cache.Functional.Invariant.srvInvAt'), which are ready, so the --- server's state is not consulted; elsewhere it need not agree with --- 'driverRef'. -driver :: CacheSrv m -> Request -> Cycles -driver (CacheSrv c _ _) req = case req of - Just (MemRead addr size) -> - let off = case size of - Byte -> 0 - Half -> 1 - Word -> 3 - - hit1stLine = cacheHit addr c - penalty1stLine = if hit1stLine then 0 else penalty - - hit2ndLine = setOf (addr + off) == setOf addr || cacheHit (addr + off) c - penalty2ndLine = if hit2ndLine then 0 else penalty - - in penalty1stLine + penalty2ndLine - _ -> 0 - --- | The operational reading of 'driver': serve the request, then serve without --- one until the server is ready again, and count every cycle of the hop, --- including the request's. So, from a server that satisfies the invariant, --- @'driverRef' fuel srv0 req == Just ('driver' srv0 req + 1)@. 'Nothing' if the --- hop takes more than @fuel@ cycles. -driverRef :: (MemOps m) => Int -> CacheSrv m -> Request -> Maybe Int -driverRef fuel srv0 req = go 1 (fst (serve srv0 req)) - where - go n srv - | srvState srv == CacheSrvReady = Just n - | n >= fuel = Nothing - | otherwise = go (n + 1) (fst (serve srv Nothing)) diff --git a/proof/Proof/Cache/Functional/Obligation.hs b/proof/Proof/Cache/Functional/Obligation.hs deleted file mode 100644 index 0943dfe..0000000 --- a/proof/Proof/Cache/Functional/Obligation.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} --- | The cache's proof obligations, in one place: the cache's counterpart of --- "Proof.Core.Functional.Obligation". --- --- They relate the cached memory to ideal memory ("Memory.Ideal") one request at --- a time: ideal memory answers in one cycle, the cached memory in --- 'Proof.Cache.Functional.Driver.driver' + 1 cycles. As the core's obligations --- build the ISA state from the system ('Proof.Core.Functional.Obligation.isaAt'), --- these take ideal memory to be the server's memory before the hop; the --- conclusion compares the memory ideal memory steps to with the server's after --- the hop. --- --- From a server that satisfies the invariant the driver is 0, 'penalty' or --- twice 'penalty' (no, one or two lines missed), so there is one step --- obligation per hop length, named after it for @'penalty' = 4@. Split by --- length because Pantomime unrolls recursion only when its count is concrete. -module Proof.Cache.Functional.Obligation - ( CoherentOps (..), - mkDataMem, - baseCase, - indStep0, - indStep4, - indStep8, - ) -where - -import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), Request) -import Memory.Cache4K -import Memory.Cache4KServer -import Memory.Ideal (idealServe) -import Memory.Types (MemOps (..)) -import Proof.Cache.Functional.Driver (driver) -import Proof.Cache.Functional.Invariant (srvInvAt) -import Proof.Cache.SMT.Raw (RawData (..)) -import Proof.SMT.Array (MemArr) -import Types (Address, Word) -import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) - --- | Memories a coherent cache can be built from. A class, as memory's --- operations are ('MemOps'), so that the obligations stay polymorphic in memory --- and the solver only meets the monomorphic 'mkDataMem'. -class (MemOps m) => CoherentOps m where - -- | The data array of a coherent cache with tags @t@ in front of @mem@: a - -- valid line holds memory's words at the address its tag gives, an invalid - -- line the words of @raw@. - mkData :: m -> TagArr -> RawData -> DataArr - -instance CoherentOps MemArr where - mkData :: MemArr -> TagArr -> RawData -> DataArr - mkData = mkDataMem - --- | 'mkData' on the solver's memory. The solver does not run this body: --- 'Proof.Cache.SMT.Axioms.coherentAxioms' replaces it by --- 'Proof.Cache.SMT.Coherent.mkDataC'. -{-# OPAQUE mkDataMem #-} -mkDataMem :: MemArr -> TagArr -> RawData -> DataArr -mkDataMem mem t (RawData raw) = DataArr (imap word raw) - where - word :: Index 1024 -> Word -> Word - word i w - | entryValid e = memReadWord (wordAddr (entryTag e) si wi 0) mem - | otherwise = w - where - idx = fromIntegral i :: BitVector 10 - si = slice d9 d2 idx - wi = slice d1 d0 idx - e = tagRead si t - --- | The base case: the server at start, in front of any memory, satisfies the --- invariant against that memory. -baseCase :: - (MemOps m) => Address -> SetIdx -> WordIdx -> m -> Bool -baseCase wa wsi wwi mem = - srvInvAt wa wsi wwi mem (initCacheSrv mem) - --- | The one-cycle hop: a request the cache answers at once. -indStep0 :: - (CoherentOps m) => Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool -indStep0 wa wsi wwi mem t raw req = - not premises || conclusion - where - ideal = mem - srv = CacheSrv (Cache4K t (mkData mem t raw)) mem CacheSrvReady - - (ideal', idealAns) = idealServe ideal req - - premises = - srvInvAt wa wsi wwi ideal srv - && driver srv req == 0 - - conclusion = conclusionN 0 wa wsi wwi ideal' idealAns srv req - --- | The hop of a read that misses one line: 'penalty' + 1 cycle. -indStep4 :: - (CoherentOps m) => Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool -indStep4 wa wsi wwi mem t raw req = - not premises || conclusion - where - ideal = mem - srv = CacheSrv (Cache4K t (mkData mem t raw)) mem CacheSrvReady - - (ideal', idealAns) = idealServe ideal req - - premises = - srvInvAt wa wsi wwi ideal srv - && driver srv req == penalty - - conclusion = conclusionN penalty wa wsi wwi ideal' idealAns srv req - --- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycle. -indStep8 :: - (CoherentOps m) => Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool -indStep8 wa wsi wwi mem t raw req = - not premises || conclusion - where - ideal = mem - srv = CacheSrv (Cache4K t (mkData mem t raw)) mem CacheSrvReady - - (ideal', idealAns) = idealServe ideal req - - premises = - srvInvAt wa wsi wwi ideal srv - && driver srv req == 2 * penalty - - conclusion = conclusionN (2 * penalty) wa wsi wwi ideal' idealAns srv req - --- | The conclusion of a hop of @n@ + 1 cycles: serve the request, then @n@ --- cycles without one. A stalling server ignores its requests, so this covers --- any requests in those cycles. The first @n@ --- answers are 'Nothing', the last is ideal memory's answer @idealAns@, and after it --- the server satisfies the invariant against @ideal'@, the memory ideal memory --- stepped to. Recursive on @n@, which each obligation fixes to a constant. -conclusionN :: (MemOps m) => Cycles -> Address -> SetIdx -> WordIdx -> m -> Input -> CacheSrv m -> Request -> Bool -conclusionN n wa wsi wwi ideal' idealAns srv req - | n == 0 = ans == idealAns && srvInvAt wa wsi wwi ideal' srv' - | otherwise = - ans == Input Nothing && conclusionN (n - 1) wa wsi wwi ideal' idealAns srv' Nothing - where (srv', ans) = serve srv req diff --git a/proof/Proof/Cache/Functional/Solver.hs b/proof/Proof/Cache/Functional/Solver.hs deleted file mode 100644 index d136a5a..0000000 --- a/proof/Proof/Cache/Functional/Solver.hs +++ /dev/null @@ -1,180 +0,0 @@ --- | The cache's functional proof, checked symbolically: the cache's counterpart --- of "Proof.Core.Functional.Solver". --- --- 'baseCase' plus one property per hop length: on a hop of that length, the --- corresponding obligation in "Proof.Cache.Functional.Obligation" holds. The --- statements live there; this module only instantiates them, over every tag --- array, data array, memory, request and witness. --- --- Each step starts from a ready server whose cache is coherent by --- construction ('mkData'). --- --- == Running them --- --- Under Bitwuzla, not Z3: --- --- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build -module Proof.Cache.Functional.Solver - ( cacheArraysP, - coherentDataP, - coherentWriteP, - coherentLayoutP, - baseCaseP, - indStep0P, - indStep4P, - indStep8P, - readyUnderInvP, - readyIdleNoWaitP, - waitsAfterRequestP, - results, - ) -where - -import Clash.Prelude (BitVector, d0, d1, d2, d9, not, slice, (++#), (||)) -import Core (Request) -import qualified Core -import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) -import Memory.Cache4K -import Memory.Types (MemOps (..)) -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) -import Proof.Cache.SMT.Raw (RawData, rawRead) -import Proof.Cache.Functional.Contract (readyIdleNoWait, readyUnderInv, waitsAfterRequest) -import Proof.Cache.Functional.Obligation -import Proof.Core.Functional.Machine (SysG (..)) -import Proof.Core.Functional.System (KState, sysOf) -import Proof.SMT.Array (MemArr, RegArr) -import Proof.SMT.Axioms (arrayAxioms) -import Proof.SMT.Logged (pantomime) -import Types -import Prelude hiding (Word, not, (||)) - --- Sanity probes for the trusted embeddings ------------------------------------- - --- | The tag and data array embeddings, which are trusted, against facts a --- broken one would get wrong. -{-# ANN cacheArraysP (Theory cacheAxioms) #-} -cacheArraysP :: - TagArr -> DataArr -> SetIdx -> BitVector 21 -> BitVector 10 -> Word -> Pantomime.Bool -cacheArraysP t d s e i w = - Pantomime.boolean $ - tagRead s (tagWrite s e t) == e - && dataRead i (dataWrite i w d) == w - && tagRead s tagEmpty == 0 - && dataRead i dataZero == 0 - --- | The embedding of the coherent cache ('mkData' as --- 'Proof.Cache.SMT.Coherent.DataC'), which is trusted, against what 'mkData' --- defines: a read of the constructed array is memory's word if the line is --- valid, else the raw word. Writes are checked by 'coherentWrite'. -{-# ANN coherentDataP (Theory coherentAxioms) #-} -coherentDataP :: MemArr -> TagArr -> RawData -> BitVector 10 -> Pantomime.Bool -coherentDataP ma t raw i = - Pantomime.boolean $ dataRead i (mkData ma t raw) == constructed i - where - constructed k - | entryValid e = memReadWord (wordAddr (entryTag e) si (slice d1 d0 k) 0) ma - | otherwise = rawRead k raw - where - si = slice d9 d2 k - e = tagRead si t - --- | A write on any data array of the coherent cache's embedding, including one --- that already holds writes: a read after it gives the written word at its --- index and leaves the other slots as they were. Since it holds for every --- array, it covers any sequence of writes. -{-# ANN coherentWriteP (Theory coherentAxioms) #-} -coherentWriteP :: DataArr -> BitVector 10 -> BitVector 10 -> Word -> Pantomime.Bool -coherentWriteP d i j w = - Pantomime.boolean $ - dataRead i (dataWrite i w d) == w - && (i == j || dataRead j (dataWrite i w d) == dataRead j d) - --- | The coherent cache's index layout agrees with the cache's addressing: at --- any address whose line is valid and holds its block, the cache's word (index --- set, then word, as 'Memory.Cache4K' composes it) is memory's word there. -{-# ANN coherentLayoutP (Theory coherentAxioms) #-} -coherentLayoutP :: MemArr -> TagArr -> RawData -> Address -> Pantomime.Bool -coherentLayoutP ma t raw a = - Pantomime.boolean $ - not (entryValid e && entryTag e == tagOf a) - || dataRead (setOf a ++# wordOf a) (mkData ma t raw) - == memReadWord (wordAddr (tagOf a) (setOf a) (wordOf a) 0) ma - where - e = tagRead (setOf a) t - --- The base case ---------------------------------------------------------------- - --- | Under 'cacheAxioms': the initial cache is the empty one ('Memory.Cache4K.dataZero'), --- not a constructed one. -{-# ANN baseCaseP (Theory cacheAxioms) #-} -baseCaseP :: - Address -> SetIdx -> WordIdx -> MemArr -> Pantomime.Bool -baseCaseP wa wsi wwi ma = - Pantomime.boolean $ baseCase wa wsi wwi ma - --- The inductive steps ---------------------------------------------------------- - --- | The one-cycle hop: a request the cache answers at once. -{-# ANN indStep0P (Theory coherentAxioms) #-} -indStep0P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> Pantomime.Bool -indStep0P wa wsi wwi ma t raw req = - Pantomime.boolean $ indStep0 wa wsi wwi ma t raw req - --- | The hop of a read that misses one line. -{-# ANN indStep4P (Theory coherentAxioms) #-} -indStep4P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> Pantomime.Bool -indStep4P wa wsi wwi ma t raw req = - Pantomime.boolean $ indStep4 wa wsi wwi ma t raw req - --- | The hop of a read that misses both its lines. -{-# ANN indStep8P (Theory coherentAxioms) #-} -indStep8P :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> Pantomime.Bool -indStep8P wa wsi wwi ma t raw req = - Pantomime.boolean $ indStep8 wa wsi wwi ma t raw req - --- The contract ----------------------------------------------------------------- --- --- The properties of "Proof.Cache.Functional.Contract": the cache's over a --- server with arbitrary tags, data, memory and state, the core's over a core --- state built from symbolic parts as in the core's proof --- ('Proof.Core.Functional.System.sysOf'). - --- | A server related to ideal memory by the invariant is ready. -{-# ANN readyUnderInvP (Theory cacheAxioms) #-} -readyUnderInvP :: - Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool -readyUnderInvP wa wsi wwi ideal t d ma st = - Pantomime.boolean $ readyUnderInv wa wsi wwi ideal (CacheSrv (Cache4K t d) ma st) - --- | A ready server that is asked nothing answers within the cycle. -{-# ANN readyIdleNoWaitP (Theory cacheAxioms) #-} -readyIdleNoWaitP :: TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool -readyIdleNoWaitP t d ma st = Pantomime.boolean $ readyIdleNoWait (CacheSrv (Cache4K t d) ma st) - --- | The core waits for what it asked for. -{-# ANN waitsAfterRequestP (Theory arrayAxioms) #-} -waitsAfterRequestP :: RegIdx -> KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool -waitsAfterRequestP wr ss i ra ma = - Pantomime.boolean $ waitsAfterRequest wr (sysCore (sysOf ss i ra ma)) i - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("cacheArraysP", $(pantomime 'cacheArraysP)), - ("coherentDataP", $(pantomime 'coherentDataP)), - ("coherentWriteP", $(pantomime 'coherentWriteP)), - ("coherentLayoutP", $(pantomime 'coherentLayoutP)), - ("baseCaseP", $(pantomime 'baseCaseP)), - ("indStep0P", $(pantomime 'indStep0P)), - ("indStep4P", $(pantomime 'indStep4P)), - ("indStep8P", $(pantomime 'indStep8P)), - ("readyUnderInvP", $(pantomime 'readyUnderInvP)), - ("readyIdleNoWaitP", $(pantomime 'readyIdleNoWaitP)), - ("waitsAfterRequestP", $(pantomime 'waitsAfterRequestP)) - ] diff --git a/proof/Proof/Cache/Induction4K.hs b/proof/Proof/Cache/Induction4K.hs deleted file mode 100644 index 00806e6..0000000 --- a/proof/Proof/Cache/Induction4K.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | The server proof for the 4 KiB cache ("Proof.Cache.Server4K"), checked --- symbolically, over every tag array, data array, memory and request, with the --- witnesses quantified. The array embeddings are checked in --- 'Proof.Cache.Server.Functional.Induction.cacheArrays'. -module Proof.Cache.Induction4K - ( srvInitP, - srvRefineP, - srvLeakP, - stallsOnReadsP, - results, - ) -where - -import qualified Core -import Data.Functor.Identity -import Memory.Cache4K -import Pantomime (Theory (..)) -import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.Server4K (srvInit, srvLeak, srvRefine, stallsOnReads) -import Memory.Cache4KServer (CacheSrv (..)) -import Proof.SMT.Array (MemArr) -import Proof.Cache.SMT.Axioms (cacheAxioms) -import Proof.SMT.Logged (pantomime) -import Clash.Prelude (BitVector) -import Types -import Prelude hiding (Word) - -{-# ANN srvInitP (Theory cacheAxioms) #-} -srvInitP :: SetIdx -> WordIdx -> MemArr -> Pantomime.Bool -srvInitP s w ma = Pantomime.boolean $ srvInit s w ma - -{-# ANN srvRefineP (Theory cacheAxioms) #-} -srvRefineP :: Address -> SetIdx -> WordIdx -> TagArr -> DataArr -> MemArr -> Maybe (Core.MemAccess Identity) -> Pantomime.Bool -srvRefineP wa ws ww t d ma q = Pantomime.boolean $ srvRefine wa ws ww (CacheSrv (Cache4K t d) Nothing ma) q - -{-# ANN srvLeakP (Theory cacheAxioms) #-} -srvLeakP :: SetIdx -> TagArr -> DataArr -> MemArr -> Maybe (Core.MemAccess Identity) -> Pantomime.Bool -srvLeakP ws t d ma q = Pantomime.boolean $ srvLeak ws (CacheSrv (Cache4K t d) Nothing ma) q - -{-# ANN stallsOnReadsP (Theory cacheAxioms) #-} -stallsOnReadsP :: TagArr -> DataArr -> MemArr -> Maybe (Core.MemAccess Identity) -> Pantomime.Bool -stallsOnReadsP t d ma q = Pantomime.boolean $ stallsOnReads (CacheSrv (Cache4K t d) Nothing ma) q - --- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the --- property is valid. -results :: [(String, Maybe String)] -results = - [ ("srvInitP", $(pantomime 'srvInitP)), - ("srvRefineP", $(pantomime 'srvRefineP)), - ("srvLeakP", $(pantomime 'srvLeakP)), - ("stallsOnReadsP", $(pantomime 'stallsOnReadsP)) - ] diff --git a/proof/Proof/Cache/SMT/Array.hs b/proof/Proof/Cache/SMT/Array.hs index 8391abe..eb07aad 100644 --- a/proof/Proof/Cache/SMT/Array.hs +++ b/proof/Proof/Cache/SMT/Array.hs @@ -9,10 +9,12 @@ module Proof.Cache.SMT.Array tagReadE, tagWriteE, tagEmptyE, + tagEqE, DataArrSMT (..), dataReadE, dataWriteE, dataZeroE, + dataEqE, ) where @@ -50,11 +52,18 @@ tagWriteE :: tagWriteE = coerce go where go :: Clash.BitVec 8 -> Clash.BitVec 21 -> TagArrSMT -> TagArrSMT - go (Clash.BitVecP k) (Clash.BitVecP v) (TagArrSMT arr) = TagArrSMT (P.astore arr k v) + go (Clash.BitVecP k) (Clash.BitVecP v) (TagArrSMT arr) = + TagArrSMT (P.astore arr k v) tagEmptyE :: forall arr. (Coercible TagArrSMT arr) => arr tagEmptyE = coerce (TagArrSMT (P.aconst 0)) +tagEqE :: forall arr. (Coercible TagArrSMT arr) => arr -> arr -> Bool +tagEqE = coerce go + where + go :: TagArrSMT -> TagArrSMT -> Bool + go (TagArrSMT a) (TagArrSMT b) = a == b + -- | 'Memory.Cache4K.DataArr' on the SMT side. newtype DataArrSMT = DataArrSMT (P.Array (P.BitVec 10) (P.BitVec 32)) @@ -83,7 +92,14 @@ dataWriteE :: dataWriteE = coerce go where go :: Clash.BitVec 10 -> Clash.BitVec 32 -> DataArrSMT -> DataArrSMT - go (Clash.BitVecP k) (Clash.BitVecP v) (DataArrSMT arr) = DataArrSMT (P.astore arr k v) + go (Clash.BitVecP k) (Clash.BitVecP v) (DataArrSMT arr) = + DataArrSMT (P.astore arr k v) dataZeroE :: forall arr. (Coercible DataArrSMT arr) => arr dataZeroE = coerce (DataArrSMT (P.aconst 0)) + +dataEqE :: forall arr. (Coercible DataArrSMT arr) => arr -> arr -> Bool +dataEqE = coerce go + where + go :: DataArrSMT -> DataArrSMT -> Bool + go (DataArrSMT a) (DataArrSMT b) = a == b diff --git a/proof/Proof/Cache/SMT/Axioms.hs b/proof/Proof/Cache/SMT/Axioms.hs index 351d8d0..375c939 100644 --- a/proof/Proof/Cache/SMT/Axioms.hs +++ b/proof/Proof/Cache/SMT/Axioms.hs @@ -4,11 +4,22 @@ module Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) where import qualified Data.Map as Map -import Memory.Cache4K (DataArr, TagArr, dataRead, dataWrite, dataZero, tagEmpty, tagRead, tagWrite) +import Memory.Cache4K + ( DataArr, + TagArr, + dataEq, + dataRead, + dataWrite, + dataZero, + tagEmpty, + tagEq, + tagRead, + tagWrite, + ) import Pantomime (PluginAxioms (..)) import Proof.SMT.Axioms (arrayAxioms) import Proof.Cache.SMT.Array -import Proof.Cache.Functional.Obligation (mkDataMem) +import Proof.Cache.Server.Functional.Obligation (mkDataMem) import Proof.Cache.SMT.Coherent import Proof.Cache.SMT.Raw @@ -25,18 +36,20 @@ cacheAxioms = [ ('tagRead, 'tagReadE), ('tagWrite, 'tagWriteE), ('tagEmpty, 'tagEmptyE), + ('tagEq, 'tagEqE), ('dataRead, 'dataReadE), ('dataWrite, 'dataWriteE), - ('dataZero, 'dataZeroE) + ('dataZero, 'dataZeroE), + ('dataEq, 'dataEqE) ] } -- | The axioms for the cache's proof: as 'cacheAxioms', but the data array is -- embedded as 'Proof.Cache.SMT.Coherent.DataC', so that --- 'Proof.Cache.Functional.Obligation.mkData' builds a cache coherent by +-- 'Proof.Cache.Server.Functional.Obligation.mkData' builds a cache coherent by -- construction (through its 'MemArr' instance, --- 'Proof.Cache.Functional.Obligation.mkDataMem'). The raw-array and tag axioms --- come first: an embedding that calls another wrapper ('dataReadC' calls +-- 'Proof.Cache.Server.Functional.Obligation.mkDataMem'). The raw-array and tag +-- axioms come first: an embedding that calls another wrapper ('dataReadC' calls -- 'rawRead' and 'tagRead') only sees the axioms listed before its own. coherentAxioms :: PluginAxioms coherentAxioms = diff --git a/proof/Proof/Cache/SMT/Coherent.hs b/proof/Proof/Cache/SMT/Coherent.hs index 562158b..bc60002 100644 --- a/proof/Proof/Cache/SMT/Coherent.hs +++ b/proof/Proof/Cache/SMT/Coherent.hs @@ -1,5 +1,5 @@ -- | The SMT side of a cache that is coherent by construction --- ('Proof.Cache.Functional.Obligation.cachedOf'): the term axioms in +-- ('Proof.Cache.Server.Functional.Obligation.cachedOf'): the term axioms in -- "Proof.Cache.SMT.Axioms" ('Proof.Cache.SMT.Axioms.coherentAxioms') embed -- 'Memory.Cache4K.DataArr' as 'DataC', which carries only arrays: -- @@ -46,12 +46,15 @@ dataReadC i a e = tagRead si tags -- | The embedding of 'Memory.Cache4K.dataWrite'. -dataWriteC :: forall arr. (Coercible DataC arr) => BitVector 10 -> Word -> arr -> arr -dataWriteC i v a = coerce (DataC (rawWrite i v ws) (rawWrite i 1 written) mem tags raw) +dataWriteC :: + forall arr. (Coercible DataC arr) => BitVector 10 -> Word -> arr -> arr +dataWriteC i v a = + coerce (DataC (rawWrite i v ws) (rawWrite i 1 written) mem tags raw) where DataC ws written mem tags raw = coerce a --- | The embedding of 'Proof.Cache.Functional.Obligation.mkDataMem': nothing --- written yet. -mkDataC :: forall arr. (Coercible DataC arr) => MemArr -> TagArr -> RawData -> arr +-- | The embedding of 'Proof.Cache.Server.Functional.Obligation.mkDataMem': +-- nothing written yet. +mkDataC :: + forall arr. (Coercible DataC arr) => MemArr -> TagArr -> RawData -> arr mkDataC mem t raw = coerce (DataC rawZero rawZero mem t raw) diff --git a/proof/Proof/Cache/SMT/Raw.hs b/proof/Proof/Cache/SMT/Raw.hs index 24adb26..ee3a2ee 100644 --- a/proof/Proof/Cache/SMT/Raw.hs +++ b/proof/Proof/Cache/SMT/Raw.hs @@ -1,6 +1,6 @@ -- | A raw array of 1024 words, indexed like the cache's data array: the -- arbitrary contents of a coherent cache's invalid lines --- ('Proof.Cache.Functional.Obligation.cachedOf'). The term axioms in +-- ('Proof.Cache.Server.Functional.Obligation.cachedOf'). The term axioms in -- "Proof.Cache.SMT.Axioms" embed it as 'Proof.Cache.SMT.Array.DataArrSMT'. -- -- In a module of its own, without the solver's types, so that the obligations diff --git a/proof/Proof/Cache/Server/Functional/Contract.hs b/proof/Proof/Cache/Server/Functional/Contract.hs new file mode 100644 index 0000000..95cc561 --- /dev/null +++ b/proof/Proof/Cache/Server/Functional/Contract.hs @@ -0,0 +1,117 @@ +-- | The contract between the core and the 4 KiB cache in front of memory: what +-- each side promises beyond the cache's proof against ideal memory +-- ("Proof.Cache.Server.Functional.Obligation"), so that the core runs behind +-- the cache as it would behind ideal memory, with stutter steps inserted. +-- +-- The two sides are not symmetric: the core makes the requests and the cache +-- answers them. +-- +-- * The core waits for what it asked for ('corePatient'): after a request, +-- given no answer, it makes no request and its state stays the same. +-- * The cache answers 'Nothing' only while a request is outstanding. Ready +-- is defined by behaviour ('srvReady'): asked nothing, the server answers +-- within the cycle and stays the same. After a step, a server is ready +-- exactly when it has answered ('srvReadyIffAnswered'), a server related +-- to ideal memory by the invariant is ready ('srvReadyUnderInv'), and from +-- a ready server the driver agrees with its operational reading +-- ('srvDriverMatchesSpec'). +-- While a request is outstanding, the driver and the cache's step +-- obligations say how it answers: 'Nothing' for as many cycles as the +-- driver counts, then ideal memory's answer. +-- +-- Both sides are treated as opaque: states are compared whole, with '==', +-- not field by field. +-- +-- The properties are checked in "Proof.Cache.Server.Functional.Solver". +module Proof.Cache.Server.Functional.Contract + ( srvReady, + srvDriverSpec, + srvReadyIffAnswered, + srvReadyUnderInv, + srvDriverMatchesSpec, + corePatient, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core (Input (..), Output (..), Request, StateG (..), circuit) +import Data.Maybe (isJust, isNothing) +import Memory.Cache4KServer (CacheSrv (..), serve) +import Memory.Types (MemOps) +import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Cache.Server.Functional.Invariant (srvInvAt) +import Core.RegFile (RegFileOps (..)) +import Types (Address) +import Memory.Cache4K (SetIdx, WordIdx) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- The cache's side -------------------------------------------------------------- + +-- | Is the server ready for a request? Defined by its behaviour, not by its +-- fields: asked nothing, it answers within the cycle and stays the same. +srvReady :: (MemOps m, Eq m) => CacheSrv m -> Bool +srvReady srv = + let (srv', ans) = serve srv Nothing + in srv' == srv && ans == Input (Just 0) + +-- | After a step, the server is ready exactly when it has answered. +srvReadyIffAnswered :: (MemOps m, Eq m) => CacheSrv m -> Request -> Bool +srvReadyIffAnswered srv req = + let (srv', ans) = serve srv req + in srvReady srv' == isJust (inputMem ans) + +-- | A server related to ideal memory by the invariant is ready. +srvReadyUnderInv :: + (MemOps m, Eq m) => + Address -> SetIdx -> WordIdx -> m -> CacheSrv m -> Bool +srvReadyUnderInv wa wsi wwi ideal srv = + not premises || conclusion + where + premises = srvInvAt wa wsi wwi ideal srv + + conclusion = srvReady srv + +-- | How many cycles after a request the server answers, by serving: serve the +-- request, then serve without one until the server answers, and count the +-- cycles after the request's. 'Nothing' if more than @fuel@ cycles follow the +-- request's. The operational reading of a memory's driver, such as +-- 'Proof.Cache.Server.Functional.Driver.srvDriver' ('srvDriverMatchesSpec'). +srvDriverSpec :: (MemOps m) => Int -> CacheSrv m -> Request -> Maybe Int +srvDriverSpec fuel srv0 req = + let (srv', ans) = serve srv0 req + in go 0 srv' (isJust (inputMem ans)) + where + go n srv answered + | answered = Just n + | n >= fuel = Nothing + | otherwise = + let (srv', ans) = serve srv Nothing + in go (n + 1) srv' (isJust (inputMem ans)) + +-- | From a ready server ('srvReady'), the driver +-- ('Proof.Cache.Server.Functional.Driver.srvDriver') agrees with its +-- operational reading ('srvDriverSpec'). +-- Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two missed +-- lines, and no more, since Pantomime unrolls all of them. Readiness suffices, +-- unlike for the core ('Proof.Core.Functional.Driver.driverMatchesSpec'): the +-- driver only asks which lines hit, so every ready server is a valid start, +-- and the invariant, which implies readiness, would only narrow the statement. +srvDriverMatchesSpec :: (MemOps m, Eq m) => CacheSrv m -> Request -> Bool +srvDriverMatchesSpec srv req = + not premises || conclusion + where + premises = srvReady srv + + conclusion = srvDriverSpec 8 srv req == Just (srvDriver srv req) + +-- The core's side --------------------------------------------------------------- + +-- | The core waits for what it asked for: after a request, given no answer, it +-- makes no request and stays where it was. +corePatient :: (RegFileOps r, Eq r) => StateG r -> Input -> Bool +corePatient s inp = case outputMem o of + Nothing -> True + Just _ -> s'' == s' && isNothing (outputMem o') + where + (s', o) = circuit s inp + (s'', o') = circuit s' (Input Nothing) diff --git a/proof/Proof/Cache/Server/Functional/Driver.hs b/proof/Proof/Cache/Server/Functional/Driver.hs new file mode 100644 index 0000000..7469e4d --- /dev/null +++ b/proof/Proof/Cache/Server/Functional/Driver.hs @@ -0,0 +1,54 @@ +-- | The cache's driver: how many cycles after a request the cache's answer is +-- final -- the cache's counterpart of "Proof.Core.Functional.Driver". +-- +-- 'srvDriver' is a case table over the cache and the request. Its operational +-- reading, obtained by actually serving, makes sense for any memory and so +-- lives in the contract +-- ('Proof.Cache.Server.Functional.Contract.srvDriverSpec'), together with the +-- property that the two agree. +module Proof.Cache.Server.Functional.Driver + ( srvDriver, + srvDriverValues, + ) +where + +import Core (MemAccess (..), Request) +import Memory.Cache4K (cacheHit, setOf) +import Memory.Cache4KServer +import Types + +-- | The cycles after the request until the cache's answer is final: 'penalty' +-- for every line a data read misses, nothing for anything else. A read touches +-- the lines of its first and last byte; within four bytes those are different +-- lines exactly when they are in different sets. The driver is only ever run +-- from servers that satisfy the invariant +-- ('Proof.Cache.Server.Functional.Invariant.srvInvAt'), which are ready, so the +-- server's state is not consulted; elsewhere it need not agree with +-- 'srvDriverSpec'. +srvDriver :: CacheSrv m -> Request -> Int +srvDriver (CacheSrv c _ _) req = case req of + Just (MemRead addr size) -> + let off = case size of + Byte -> 0 + Half -> 1 + Word -> 3 + + hit1stLine = cacheHit addr c + penalty1stLine = if hit1stLine then 0 else fromIntegral penalty + + hit2ndLine = setOf (addr + off) == setOf addr || cacheHit (addr + off) c + penalty2ndLine = if hit2ndLine then 0 else fromIntegral penalty + + in penalty1stLine + penalty2ndLine + _ -> 0 + +-- | The driver is 0, 'penalty' or twice 'penalty': the hop lengths of the +-- cache's steps ('Proof.Cache.Server.Functional.Obligation.indStep0', +-- 'Proof.Cache.Server.Functional.Obligation.indStep4', +-- 'Proof.Cache.Server.Functional.Obligation.indStep8'), which so cover every +-- hop. +srvDriverValues :: CacheSrv m -> Request -> Bool +srvDriverValues srv req = + k == 0 || k == fromIntegral penalty || k == 2 * fromIntegral penalty + where + k = srvDriver srv req diff --git a/proof/Proof/Cache/Functional/Invariant.hs b/proof/Proof/Cache/Server/Functional/Invariant.hs similarity index 68% rename from proof/Proof/Cache/Functional/Invariant.hs rename to proof/Proof/Cache/Server/Functional/Invariant.hs index bfb678d..497a8ff 100644 --- a/proof/Proof/Cache/Functional/Invariant.hs +++ b/proof/Proof/Cache/Server/Functional/Invariant.hs @@ -3,9 +3,10 @@ -- many more bytes, so the invariant is stated at a witness byte and a witness -- word, and the obligations quantify over them, as the core's invariant does -- over a register and a byte. -module Proof.Cache.Functional.Invariant +module Proof.Cache.Server.Functional.Invariant ( coherentAt, - srvInvAt + srvInvAt, + srvInvFunctional, ) where @@ -30,8 +31,23 @@ coherentAt wsi wwi mem c = -- server to ideal memory @ideal@: no miss is pending, the server's memory holds -- ideal memory's byte @wa@, and if the line is valid, its word @wwi@ is the -- server's memory's. -srvInvAt :: (MemOps m) => Address -> SetIdx -> WordIdx -> m -> CacheSrv m -> Bool +srvInvAt :: + (MemOps m) => Address -> SetIdx -> WordIdx -> m -> CacheSrv m -> Bool srvInvAt wa wsi wwi ideal (CacheSrv c mem st) = st == CacheSrvReady && memReadByte wa ideal == memReadByte wa mem && coherentAt wsi wwi mem c + +-- | The invariant is functional: two ideal memories it relates to the same +-- server are equal, at byte @wa@. Quantifying over @wa@ gives equality of the +-- memories. +srvInvFunctional :: + (MemOps m) => + Address -> SetIdx -> WordIdx -> m -> m -> CacheSrv m -> Bool +srvInvFunctional wa wsi wwi ideal1 ideal2 srv = + not premises || conclusion + where + premises = + srvInvAt wa wsi wwi ideal1 srv && srvInvAt wa wsi wwi ideal2 srv + + conclusion = memReadByte wa ideal1 == memReadByte wa ideal2 diff --git a/proof/Proof/Cache/Server/Functional/Obligation.hs b/proof/Proof/Cache/Server/Functional/Obligation.hs new file mode 100644 index 0000000..3dd305c --- /dev/null +++ b/proof/Proof/Cache/Server/Functional/Obligation.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE InstanceSigs #-} +-- | The cache's proof obligations, in one place: the cache's counterpart of +-- "Proof.Core.Functional.Obligation". +-- +-- They relate the cached memory to ideal memory ("Memory.Ideal") one request at +-- a time: ideal memory answers in one cycle, the cached memory in +-- 'Proof.Cache.Server.Functional.Driver.srvDriver' + 1 cycles. As the core's +-- obligations build the ISA state from the system +-- ('Proof.Core.Functional.Invariant.isaOf'), these take ideal memory to be the +-- server's memory before the hop; the conclusion compares the memory ideal +-- memory steps to with the server's after the hop. +-- +-- Every step starts from a ready server whose cache is coherent by +-- construction ('mkData'): valid lines hold memory's words, invalid lines +-- arbitrary ones. So coherence is not assumed but built in, as the core's ISA +-- state is built from the system. +-- +-- From a server that satisfies the invariant the driver is 0, 'penalty' or +-- twice 'penalty' (no, one or two lines missed), so there is one step +-- obligation per hop length, named after it for @'penalty' = 4@. Split by +-- length because Pantomime unrolls recursion only when its count is concrete. +-- A step states only the last answer and the invariant after the hop; that the +-- answers before the last are 'Nothing' is stated apart, as a sanity check +-- ('indStepWaits4', 'indStepWaits8'), since it follows from the driver's +-- agreement with its operational reading. +module Proof.Cache.Server.Functional.Obligation + ( CoherentOps (..), + mkDataMem, + baseCase, + indStep0, + indStep4, + indStepWaits4, + indStep8, + indStepWaits8, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core (Input (..), Request) +import Memory.Cache4K +import Memory.Cache4KServer +import Memory.Ideal (idealServe) +import Memory.Types (MemOps (..)) +import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Cache.Server.Functional.Invariant (srvInvAt) +import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.SMT.Array (MemArr) +import Types (Address, Word) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- The coherent cache ----------------------------------------------------------- + +-- | Memories a coherent cache can be built from. A class, as memory's +-- operations are ('MemOps'), so that the obligations stay polymorphic in memory +-- and the solver only meets the monomorphic 'mkDataMem'. +class (MemOps m) => CoherentOps m where + -- | The data array of a coherent cache with the tag array @tags@ in front of + -- @mem@: a valid line holds memory's words at the address its tag gives, an + -- invalid line the words of @raw@. + mkData :: m -> TagArr -> RawData -> DataArr + +instance CoherentOps MemArr where + mkData :: MemArr -> TagArr -> RawData -> DataArr + mkData = mkDataMem + +-- | 'mkData' on the solver's memory. The solver does not run this body: +-- 'Proof.Cache.SMT.Axioms.coherentAxioms' replaces it by +-- 'Proof.Cache.SMT.Coherent.mkDataC'. +{-# OPAQUE mkDataMem #-} +mkDataMem :: MemArr -> TagArr -> RawData -> DataArr +mkDataMem mem tags (RawData raw) = DataArr (imap word raw) + where + word :: Index 1024 -> Word -> Word + word i w + | entryValid e = memReadWord (wordAddr (entryTag e) si wi 0) mem + | otherwise = w + where + idx = fromIntegral i :: BitVector 10 + si = slice d9 d2 idx + wi = slice d1 d0 idx + e = tagRead si tags + +-- The base case ---------------------------------------------------------------- + +-- | The base case: the server at start, in front of any memory, satisfies the +-- invariant against that memory. +baseCase :: + (MemOps m) => Address -> SetIdx -> WordIdx -> m -> Bool +baseCase wa wsi wwi mem = + srvInvAt wa wsi wwi mem (initCacheSrv mem) + +-- The inductive steps ---------------------------------------------------------- + +-- | The one-cycle hop: a request the cache answers at once. +indStep0 :: + (CoherentOps m) => + Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool +indStep0 wa wsi wwi mem tags raw req = + not premises || conclusion + where + ideal = mem + srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + + (ideal', idealAns) = idealServe ideal req + (srv', ans) = serve srv req + + premises = + srvInvAt wa wsi wwi ideal srv + && srvDriver srv req == 0 + + conclusion = + ans == idealAns + && srvInvAt wa wsi wwi ideal' srv' + +-- | The hop of a read that misses one line: 'penalty' + 1 cycle. +indStep4 :: + (CoherentOps m) => + Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool +indStep4 wa wsi wwi mem tags raw req = + not premises || conclusion + where + ideal = mem + srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + + (ideal', idealAns) = idealServe ideal req + (srv', ans) = serveN (fromIntegral penalty) srv req + + premises = + srvInvAt wa wsi wwi ideal srv + && srvDriver srv req == fromIntegral penalty + + conclusion = + ans == idealAns + && srvInvAt wa wsi wwi ideal' srv' + +-- | Sanity check for 'indStep4': during the hop, the first 'penalty' answers +-- are 'Nothing'. Implied by +-- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec': +-- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' counts the cycles +-- until the first answer. +indStepWaits4 :: + (CoherentOps m) => + Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool +indStepWaits4 wa wsi wwi mem tags raw req = + not premises || conclusion + where + srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + + premises = + srvInvAt wa wsi wwi mem srv + && srvDriver srv req == fromIntegral penalty + + conclusion = stallsFor (fromIntegral penalty) srv req + +-- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycle. +indStep8 :: + (CoherentOps m) => + Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool +indStep8 wa wsi wwi mem tags raw req = + not premises || conclusion + where + ideal = mem + srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + + (ideal', idealAns) = idealServe ideal req + (srv', ans) = serveN (2 * fromIntegral penalty) srv req + + premises = + srvInvAt wa wsi wwi ideal srv + && srvDriver srv req == 2 * fromIntegral penalty + + conclusion = + ans == idealAns + && srvInvAt wa wsi wwi ideal' srv' + +-- | Sanity check for 'indStep8': during the hop, the first 2 * 'penalty' +-- answers are 'Nothing'. Implied by +-- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec': +-- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' counts the cycles +-- until the first answer. +indStepWaits8 :: + (CoherentOps m) => + Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool +indStepWaits8 wa wsi wwi mem tags raw req = + not premises || conclusion + where + srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + + premises = + srvInvAt wa wsi wwi mem srv + && srvDriver srv req == 2 * fromIntegral penalty + + conclusion = stallsFor (2 * fromIntegral penalty) srv req + +-- Helpers ---------------------------------------------------------------------- + +-- | Serve a request, then @n@ - 1 cycles without one: are all @n@ answers +-- 'Nothing'? +stallsFor :: (MemOps m) => Int -> CacheSrv m -> Request -> Bool +stallsFor n srv req + | n == 0 = True + | otherwise = + ans == Input Nothing && stallsFor (n - 1) srv' Nothing + where (srv', ans) = serve srv req + +-- | Serve a request, then @n@ cycles without one: the server and the last +-- answer. Recursive on @n@, which each obligation fixes to a constant. +serveN :: (MemOps m) => Int -> CacheSrv m -> Request -> (CacheSrv m, Input) +serveN n srv req + | n == 0 = (srv', ans) + | otherwise = serveN (n - 1) srv' Nothing + where (srv', ans) = serve srv req diff --git a/proof/Proof/Cache/Server/Functional/Solver.hs b/proof/Proof/Cache/Server/Functional/Solver.hs new file mode 100644 index 0000000..daddf21 --- /dev/null +++ b/proof/Proof/Cache/Server/Functional/Solver.hs @@ -0,0 +1,262 @@ +-- | The cache's functional proof, checked symbolically: the cache's counterpart +-- of "Proof.Core.Functional.Solver". +-- +-- The statements live in "Proof.Cache.Server.Functional.Obligation", +-- "Proof.Cache.Server.Functional.Driver" and +-- "Proof.Cache.Server.Functional.Contract"; this module only instantiates them, +-- over every tag array, data array, memory, request and witness. Each property +-- is named after the statement it checks, with a @P@: +-- +-- * sanity probes for the trusted array embeddings; +-- * the driver against its operational reading ('srvDriverMatchesSpecP'), and +-- its values, the hop lengths of the steps ('srvDriverValuesP'); +-- * the base case, and one step per hop length (0, 'penalty', 2 * 'penalty'), +-- each starting from a ready server whose cache is coherent by construction +-- ('mkData'); for the hops that stall, a sanity check that the answers +-- before the last are 'Nothing' ('indStepWaits4P', 'indStepWaits8P'); +-- * the contract between core and cache. +-- +-- == Running them +-- +-- Under Bitwuzla, not Z3: +-- +-- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build +module Proof.Cache.Server.Functional.Solver + ( cacheArraysP, + coherentDataP, + coherentWriteP, + coherentLayoutP, + srvDriverMatchesSpecP, + srvDriverValuesP, + srvInvFunctionalP, + baseCaseP, + indStep0P, + indStep4P, + indStepWaits4P, + indStep8P, + indStepWaits8P, + srvReadyIffAnsweredP, + srvReadyUnderInvP, + corePatientP, + results, + ) +where + +import Clash.Prelude (BitVector, d0, d1, d2, d9, not, slice, (++#), (||)) +import Core (Request) +import qualified Core +import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) +import Memory.Cache4K +import Memory.Types (MemOps (..)) +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Cache.SMT.Raw (RawData, rawRead) +import Proof.Cache.Server.Functional.Contract + ( srvReadyIffAnswered, + srvReadyUnderInv, + corePatient, + srvDriverMatchesSpec, + ) +import Proof.Cache.Server.Functional.Driver (srvDriverValues) +import Proof.Cache.Server.Functional.Invariant (srvInvFunctional) +import Proof.Cache.Server.Functional.Obligation +import Proof.Core.Functional.Machine (SysG (..)) +import Proof.Core.Functional.System (KState, sysOf) +import Proof.SMT.Array (MemArr, RegArr) +import Proof.SMT.Axioms (arrayAxioms) +import Proof.SMT.Logged (pantomime) +import Types +import Prelude hiding (Word, not, (||)) + +-- Sanity probes for the trusted embeddings ------------------------------------- + +-- | The tag and data array embeddings, which are trusted, against facts a +-- broken one would get wrong. +{-# ANN cacheArraysP (Theory cacheAxioms) #-} +cacheArraysP :: + TagArr -> DataArr -> SetIdx -> BitVector 21 -> BitVector 10 -> Word -> + Pantomime.Bool +cacheArraysP tags dat s e i w = + Pantomime.boolean $ + tagRead s (tagWrite s e tags) == e + && dataRead i (dataWrite i w dat) == w + && tagRead s tagEmpty == 0 + && dataRead i dataZero == 0 + +-- | The embedding of the coherent cache ('mkData' as +-- 'Proof.Cache.SMT.Coherent.DataC'), which is trusted, against what 'mkData' +-- defines: a read of the constructed array is memory's word if the line is +-- valid, else the raw word. Writes are checked by 'coherentWriteP'. +{-# ANN coherentDataP (Theory coherentAxioms) #-} +coherentDataP :: MemArr -> TagArr -> RawData -> BitVector 10 -> Pantomime.Bool +coherentDataP ma tags raw i = + Pantomime.boolean $ dataRead i (mkData ma tags raw) == constructed i + where + constructed k + | entryValid e = + memReadWord (wordAddr (entryTag e) si (slice d1 d0 k) 0) ma + | otherwise = rawRead k raw + where + si = slice d9 d2 k + e = tagRead si tags + +-- | A write on any data array of the coherent cache's embedding, including one +-- that already holds writes: a read after it gives the written word at its +-- index and leaves the other slots as they were. Since it holds for every +-- array, it covers any sequence of writes. +{-# ANN coherentWriteP (Theory coherentAxioms) #-} +coherentWriteP :: + DataArr -> BitVector 10 -> BitVector 10 -> Word -> Pantomime.Bool +coherentWriteP dat i j w = + Pantomime.boolean $ + dataRead i (dataWrite i w dat) == w + && (i == j || dataRead j (dataWrite i w dat) == dataRead j dat) + +-- | The coherent cache's index layout agrees with the cache's addressing: at +-- any address whose line is valid and holds its block, the cache's word (index +-- set, then word, as 'Memory.Cache4K' composes it) is memory's word there. +{-# ANN coherentLayoutP (Theory coherentAxioms) #-} +coherentLayoutP :: MemArr -> TagArr -> RawData -> Address -> Pantomime.Bool +coherentLayoutP ma tags raw a = + Pantomime.boolean $ + not (entryValid e && entryTag e == tagOf a) + || dataRead (setOf a ++# wordOf a) (mkData ma tags raw) + == memReadWord (wordAddr (tagOf a) (setOf a) (wordOf a) 0) ma + where + e = tagRead (setOf a) tags + +-- The driver ------------------------------------------------------------------- + +-- | The driver is 0, 'penalty' or twice 'penalty', on any server. +{-# ANN srvDriverValuesP (Theory cacheAxioms) #-} +srvDriverValuesP :: + TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool +srvDriverValuesP tags dat ma st req = + Pantomime.boolean $ srvDriverValues (CacheSrv (Cache4K tags dat) ma st) req + +-- | From a ready server, the driver agrees with its operational reading. +{-# ANN srvDriverMatchesSpecP (Theory cacheAxioms) #-} +srvDriverMatchesSpecP :: + TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool +srvDriverMatchesSpecP tags dat ma st req = + Pantomime.boolean $ + srvDriverMatchesSpec (CacheSrv (Cache4K tags dat) ma st) req + +-- The invariant ---------------------------------------------------------------- + +-- | The invariant is functional: two ideal memories related to the same server +-- are equal. +{-# ANN srvInvFunctionalP (Theory cacheAxioms) #-} +srvInvFunctionalP :: + Address -> SetIdx -> WordIdx -> MemArr -> MemArr -> + TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool +srvInvFunctionalP wa wsi wwi ideal1 ideal2 tags dat ma st = + Pantomime.boolean $ + srvInvFunctional wa wsi wwi ideal1 ideal2 srv + where + srv = CacheSrv (Cache4K tags dat) ma st + +-- The base case ---------------------------------------------------------------- + +-- | Under 'cacheAxioms': the initial cache is the empty one +-- ('Memory.Cache4K.dataZero'), not a constructed one. +{-# ANN baseCaseP (Theory cacheAxioms) #-} +baseCaseP :: + Address -> SetIdx -> WordIdx -> MemArr -> Pantomime.Bool +baseCaseP wa wsi wwi ma = + Pantomime.boolean $ baseCase wa wsi wwi ma + +-- The inductive steps ---------------------------------------------------------- + +-- | The one-cycle hop: a request the cache answers at once. +{-# ANN indStep0P (Theory coherentAxioms) #-} +indStep0P :: + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> + Pantomime.Bool +indStep0P wa wsi wwi ma tags raw req = + Pantomime.boolean $ indStep0 wa wsi wwi ma tags raw req + +-- | The hop of a read that misses one line: 'penalty' + 1 cycles. +{-# ANN indStep4P (Theory coherentAxioms) #-} +indStep4P :: + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> + Pantomime.Bool +indStep4P wa wsi wwi ma tags raw req = + Pantomime.boolean $ indStep4 wa wsi wwi ma tags raw req + +-- | Sanity check: during that hop, the answers before the last are 'Nothing'. +{-# ANN indStepWaits4P (Theory coherentAxioms) #-} +indStepWaits4P :: + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> + Pantomime.Bool +indStepWaits4P wa wsi wwi ma tags raw req = + Pantomime.boolean $ indStepWaits4 wa wsi wwi ma tags raw req + +-- | The hop of a read that misses both its lines: 2 * 'penalty' + 1 cycles. +{-# ANN indStep8P (Theory coherentAxioms) #-} +indStep8P :: + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> + Pantomime.Bool +indStep8P wa wsi wwi ma tags raw req = + Pantomime.boolean $ indStep8 wa wsi wwi ma tags raw req + +-- | Sanity check: during that hop, the answers before the last are 'Nothing'. +{-# ANN indStepWaits8P (Theory coherentAxioms) #-} +indStepWaits8P :: + Address -> SetIdx -> WordIdx -> MemArr -> TagArr -> RawData -> Request -> + Pantomime.Bool +indStepWaits8P wa wsi wwi ma tags raw req = + Pantomime.boolean $ indStepWaits8 wa wsi wwi ma tags raw req + +-- The contract ----------------------------------------------------------------- +-- +-- The properties of "Proof.Cache.Server.Functional.Contract": the cache's over +-- a server with arbitrary tags, data, memory and state, the core's over a core +-- state built from symbolic parts as in the core's proof +-- ('Proof.Core.Functional.System.sysOf'). + +-- | After a step, the server is ready exactly when it has answered. +{-# ANN srvReadyIffAnsweredP (Theory cacheAxioms) #-} +srvReadyIffAnsweredP :: + TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> Pantomime.Bool +srvReadyIffAnsweredP tags dat ma st req = + Pantomime.boolean $ + srvReadyIffAnswered (CacheSrv (Cache4K tags dat) ma st) req + +-- | A server related to ideal memory by the invariant is ready. +{-# ANN srvReadyUnderInvP (Theory cacheAxioms) #-} +srvReadyUnderInvP :: + Address -> SetIdx -> WordIdx -> MemArr -> + TagArr -> DataArr -> MemArr -> CacheSrvState -> Pantomime.Bool +srvReadyUnderInvP wa wsi wwi ideal tags dat ma st = + Pantomime.boolean $ + srvReadyUnderInv wa wsi wwi ideal (CacheSrv (Cache4K tags dat) ma st) + +-- | The core waits for what it asked for. +{-# ANN corePatientP (Theory arrayAxioms) #-} +corePatientP :: KState -> Core.Input -> RegArr -> MemArr -> Pantomime.Bool +corePatientP ss i ra ma = + Pantomime.boolean $ corePatient (sysCore (sysOf ss i ra ma)) i + +-- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the +-- property is valid. +results :: [(String, Maybe String)] +results = + [ ("cacheArraysP", $(pantomime 'cacheArraysP)), + ("coherentDataP", $(pantomime 'coherentDataP)), + ("coherentWriteP", $(pantomime 'coherentWriteP)), + ("coherentLayoutP", $(pantomime 'coherentLayoutP)), + ("srvDriverMatchesSpecP", $(pantomime 'srvDriverMatchesSpecP)), + ("srvDriverValuesP", $(pantomime 'srvDriverValuesP)), + ("srvInvFunctionalP", $(pantomime 'srvInvFunctionalP)), + ("baseCaseP", $(pantomime 'baseCaseP)), + ("indStep0P", $(pantomime 'indStep0P)), + ("indStep4P", $(pantomime 'indStep4P)), + ("indStepWaits4P", $(pantomime 'indStepWaits4P)), + ("indStep8P", $(pantomime 'indStep8P)), + ("indStepWaits8P", $(pantomime 'indStepWaits8P)), + ("srvReadyIffAnsweredP", $(pantomime 'srvReadyIffAnsweredP)), + ("srvReadyUnderInvP", $(pantomime 'srvReadyUnderInvP)), + ("corePatientP", $(pantomime 'corePatientP)) + ] diff --git a/proof/Proof/Cache/Server/Leakage/Driver.hs b/proof/Proof/Cache/Server/Leakage/Driver.hs new file mode 100644 index 0000000..abebd9d --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Driver.hs @@ -0,0 +1,77 @@ +-- | The cache simulator's driver: how many cycles after an observed request the +-- simulator answers -- the counterpart of +-- "Proof.Cache.Server.Functional.Driver" for +-- "Proof.Cache.Server.Leakage.Simulator". +-- +-- The cache's leakage proof does not need it: the simulator runs cycle by +-- cycle. The proof of the core behind the cache does, to know how long a hop +-- takes from the simulators alone. +module Proof.Cache.Server.Leakage.Driver + ( simSrvDriver, + simSrvDriverSpec, + simSrvDriverMatchesSpec, + ) +where + +import Memory.Cache4K (setOf) +import Memory.Cache4KServer (penalty) +import Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrv (..), + simServe, + simSrvReady, + tagHit, + ) +import Proof.Core.Leakage.Model (Obs (..)) +import Types + +-- | The cycles after the observed request until the simulator answers: +-- 'penalty' for every line a data read misses, nothing for anything else, as +-- 'Proof.Cache.Server.Functional.Driver.srvDriver' computes for the server. +-- Only ever run from a ready simulator, so its state is not consulted. +simSrvDriver :: SimCacheSrv -> Obs -> Int +simSrvDriver (SimCacheSrv t _) obs = case obs of + DataRead addr size -> + let off = case size of + Byte -> 0 + Half -> 1 + Word -> 3 + + hit1stLine = tagHit addr t + penalty1stLine = if hit1stLine then 0 else fromIntegral penalty + + hit2ndLine = setOf (addr + off) == setOf addr || tagHit (addr + off) t + penalty2ndLine = if hit2ndLine then 0 else fromIntegral penalty + + in penalty1stLine + penalty2ndLine + _ -> 0 + +-- | The operational reading of 'simSrvDriver', as +-- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' is of the server's: +-- step on the observed request, then with no input until the simulator +-- answers, and count the cycles after the request's. 'Nothing' if more than +-- @fuel@ cycles follow the request's. +simSrvDriverSpec :: Int -> SimCacheSrv -> Obs -> Maybe Int +simSrvDriverSpec fuel sim0 obs = + let (sim', ans) = simServe sim0 obs + in go 0 sim' ans + where + go n sim answered + | answered = Just n + | n >= fuel = Nothing + | otherwise = + let (sim', ans) = simServe sim NoAccess + in go (n + 1) sim' ans + +-- | From a ready simulator ('simSrvReady'), its driver agrees with its +-- operational reading, as +-- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec' for the server. +-- Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two missed +-- lines. Readiness suffices, as for the server: the driver only asks which +-- lines hit. +simSrvDriverMatchesSpec :: SimCacheSrv -> Obs -> Bool +simSrvDriverMatchesSpec sim obs = + not premises || conclusion + where + premises = simSrvReady sim + + conclusion = simSrvDriverSpec 8 sim obs == Just (simSrvDriver sim obs) diff --git a/proof/Proof/Cache/Server/Leakage/Invariant.hs b/proof/Proof/Cache/Server/Leakage/Invariant.hs new file mode 100644 index 0000000..f1da6e4 --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Invariant.hs @@ -0,0 +1,43 @@ +-- | The invariant of the cache's leakage proof: the simulator's tags are the +-- server's, at a witness set, and both wait for memory alike -- the leakage +-- counterpart of "Proof.Cache.Server.Functional.Invariant". +module Proof.Cache.Server.Leakage.Invariant + ( srvSimInvAt, + simOf, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Memory.Cache4K +import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) +import Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrv (..), + SimCacheSrvState (..), + ) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The simulator and the server agree at set @wsi@: their tags are equal +-- there, and they are in the same state ('sameSrvState'). +srvSimInvAt :: SetIdx -> SimCacheSrv -> CacheSrv m -> Bool +srvSimInvAt wsi (SimCacheSrv tags sst) (CacheSrv c _ st) = + tagRead wsi tags == tagRead wsi (tagArr c) + && sameSrvState sst st + +-- | Both are ready, or both wait for memory with the same number of cycles +-- left. The word the server will answer is not compared: the simulator does +-- not know it. +sameSrvState :: SimCacheSrvState -> CacheSrvState -> Bool +sameSrvState SimCacheSrvReady CacheSrvReady = True +sameSrvState (SimCacheSrvStall n) (CacheSrvStall m _) = n == m +sameSrvState _ _ = False + +-- | The simulator a server determines: its tags, and its state without the +-- word it will answer. The simulator the invariant relates to the server, as +-- 'Proof.Core.Functional.Invariant.isaOf' is the ISA state the core's +-- invariant relates to the system. +simOf :: CacheSrv m -> SimCacheSrv +simOf (CacheSrv c _ st) = SimCacheSrv (tagArr c) simSt + where + simSt = case st of + CacheSrvReady -> SimCacheSrvReady + CacheSrvStall n _ -> SimCacheSrvStall n diff --git a/proof/Proof/Cache/Server/Leakage/Model.hs b/proof/Proof/Cache/Server/Leakage/Model.hs new file mode 100644 index 0000000..1b87c6b --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Model.hs @@ -0,0 +1,28 @@ +-- | What an attacker sees of the cache server: the cache's counterpart of +-- "Proof.Core.Leakage.Model". +-- +-- The attacker watches the bus between the core and the server. In one cycle +-- it sees: +-- +-- * the request without its data ('obsReq', the core's observation: the same +-- bus), and +-- * whether the server answers, not the answer itself ('obsAns'). +-- +-- The server's internals -- the cache's contents, line fills, write-through to +-- memory, the stall counter -- are hidden. What the cache adds to the bus is +-- timing: the cycles in which it does not answer. +module Proof.Cache.Server.Leakage.Model + ( Obs (..), + obsReq, + obsAns, + ) +where + +import Core (Input (..)) +import Data.Maybe (isJust) +import Proof.Core.Leakage.Model (Obs (..), obsReq) + +-- | What the attacker sees of the server's answer in one cycle: whether there +-- is one. +obsAns :: Input -> Bool +obsAns ans = isJust (inputMem ans) diff --git a/proof/Proof/Cache/Server/Leakage/Obligation.hs b/proof/Proof/Cache/Server/Leakage/Obligation.hs new file mode 100644 index 0000000..b094010 --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Obligation.hs @@ -0,0 +1,56 @@ +-- | The cache's leakage obligations: the simulator +-- ("Proof.Cache.Server.Leakage.Simulator"), which sees only the observations of +-- the requests, answers in the same cycles as the server. +-- +-- The simulator runs cycle by cycle, as the server does, so there is no driver +-- and one step obligation, for one cycle, from any state of the server: ready +-- or waiting for memory. +-- +-- As in the functional proof, the simulator is built from the server ('simOf'), +-- as the core's ISA state is built from the system +-- ('Proof.Core.Functional.Invariant.isaOf'): a simulator that satisfies the +-- invariant at every set is the one built from the server. The conclusion +-- compares the two after the cycle, at a witness set. +module Proof.Cache.Server.Leakage.Obligation + ( baseCaseLeak, + indStepLeak, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Core (Request) +import Memory.Cache4K +import Memory.Cache4KServer +import Memory.Types (MemOps) +import Proof.Cache.Server.Leakage.Invariant (simOf, srvSimInvAt) +import Proof.Cache.Server.Leakage.Model (obsAns, obsReq) +import Proof.Cache.Server.Leakage.Simulator +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- The base case ---------------------------------------------------------------- + +-- | The base case: the server at start, in front of any memory, and the +-- simulator at start agree. +baseCaseLeak :: SetIdx -> m -> Bool +baseCaseLeak wsi mem = srvSimInvAt wsi simInitCacheSrv (initCacheSrv mem) + +-- The inductive step ----------------------------------------------------------- + +-- | The step: in one cycle, the simulator, given the observation of the +-- request, answers exactly when the server does, and the two agree afterwards. +indStepLeak :: + (MemOps m) => + SetIdx -> CacheSrv m -> Request -> Bool +indStepLeak wsi srv req = + not premises || conclusion + where + sim = simOf srv + + (srv', ans) = serve srv req + (sim', simAns) = simServe sim (obsReq req) + + premises = srvSimInvAt wsi sim srv + + conclusion = + simAns == obsAns ans + && srvSimInvAt wsi sim' srv' diff --git a/proof/Proof/Cache/Server/Leakage/Simulator.hs b/proof/Proof/Cache/Server/Leakage/Simulator.hs new file mode 100644 index 0000000..b2a0af6 --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Simulator.hs @@ -0,0 +1,113 @@ +-- | The simulator for the cache's leakage proof: what an attacker on the bus +-- between core and server can reconstruct of the server. It knows only the +-- cache's tags, and it is driven only by the observations of the requests +-- ('Proof.Core.Leakage.Model.obsReq'), never by data. +-- +-- It runs cycle by cycle, as the server does ('simServe' against +-- 'Memory.Cache4KServer.serve'): from the tags and the observation of a cycle's +-- request it computes whether the server answers in that cycle, and the tags +-- and stall counter afterwards. The leakage proof +-- ("Proof.Cache.Server.Leakage.Obligation") shows that the server agrees, so +-- the stalls -- the only thing the cache adds to the bus trace -- depend on the +-- observations alone. +-- +-- Readiness is defined by behaviour, as for the server ('simSrvReady'), with +-- its property ('simSrvReadyIffAnswered'). +module Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrvState (..), + SimCacheSrv (..), + simInitCacheSrv, + simServe, + simSrvReady, + simSrvReadyIffAnswered, + tagHit, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Memory.Cache4K +import Memory.Cache4KServer (Cycles, penalty) +import Proof.Core.Leakage.Model (Obs (..)) +import Types (Address, Size (..)) +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- | The simulator's counterpart of 'Memory.Cache4KServer.CacheSrvState': ready, +-- or waiting for memory with the cycles left. Unlike the server, it does not +-- know the word it will answer. +data SimCacheSrvState = SimCacheSrvReady | SimCacheSrvStall Cycles + deriving (Show, Eq) + +-- | The simulator's counterpart of 'Memory.Cache4KServer.CacheSrv': the cache's +-- tags, without its data or memory. +data SimCacheSrv = SimCacheSrv + { -- | The tag entries, one per set, as in the cache. + simTagArr :: TagArr, + -- | Ready, or waiting for memory with the cycles left. + simSrvState :: SimCacheSrvState + } + deriving (Show, Eq) + +-- | The simulator at start, as 'Memory.Cache4KServer.initCacheSrv': no line +-- valid and no read waiting. +simInitCacheSrv :: SimCacheSrv +simInitCacheSrv = SimCacheSrv tagEmpty SimCacheSrvReady + +-- | One cycle, as 'Memory.Cache4KServer.serve', from the observation of the +-- cycle's request ('Nothing' for no input): whether the server answers in +-- this cycle ('Proof.Cache.Server.Leakage.Model.obsAns'), and the simulator +-- afterwards. A read that misses fills the line's tag and stalls 'penalty' +-- cycles per missed line; everything else is answered at once. +simServe :: SimCacheSrv -> Obs -> (SimCacheSrv, Bool) +simServe (SimCacheSrv t st) obs = case st of + SimCacheSrvStall n + | n > 0 -> + (SimCacheSrv t (SimCacheSrvStall (n - 1)), False) + | otherwise -> + (SimCacheSrv t SimCacheSrvReady, True) + SimCacheSrvReady -> case obs of + DataRead addr size -> + let off = case size of + Byte -> 0 + Half -> 1 + Word -> 3 + + hit1stLine = tagHit addr t + penalty1stLine = if hit1stLine then 0 else penalty + t1 = if hit1stLine then t else tagFill addr t + + hit2ndLine = tagHit (addr + off) t1 + penalty2ndLine = if hit2ndLine then 0 else penalty + t2 = if hit2ndLine then t1 else tagFill (addr + off) t1 + + n = penalty1stLine + penalty2ndLine + + in if n > 0 + then (SimCacheSrv t2 (SimCacheSrvStall (n - 1)), False) + else (SimCacheSrv t2 SimCacheSrvReady, True) + _ -> (SimCacheSrv t SimCacheSrvReady, True) + +-- | Does the line of an address hold its block? +tagHit :: Address -> TagArr -> Bool +tagHit addr t = entryValid e && entryTag e == tagOf addr + where + e = tagRead (setOf addr) t + +-- | Mark the line of an address as holding its block: valid, with its tag. +{- HLINT ignore tagFill "Eta reduce" -} +tagFill :: Address -> TagArr -> TagArr +tagFill addr t = tagWrite (setOf addr) ((1 :: BitVector 1) ++# tagOf addr) t + +-- | Is the simulator ready for a request? As +-- 'Proof.Cache.Server.Functional.Contract.srvReady', defined by its behaviour: +-- given no input, it answers within the cycle and stays the same. +simSrvReady :: SimCacheSrv -> Bool +simSrvReady sim = + let (sim', ans) = simServe sim NoAccess + in sim' == sim && ans + +-- | After a step, the simulator is ready exactly when it has answered: the +-- counterpart of 'Proof.Cache.Server.Functional.Contract.srvReadyIffAnswered'. +simSrvReadyIffAnswered :: SimCacheSrv -> Obs -> Bool +simSrvReadyIffAnswered sim obs = + let (sim', ans) = simServe sim obs + in simSrvReady sim' == ans diff --git a/proof/Proof/Cache/Server/Leakage/Solver.hs b/proof/Proof/Cache/Server/Leakage/Solver.hs new file mode 100644 index 0000000..2d372cc --- /dev/null +++ b/proof/Proof/Cache/Server/Leakage/Solver.hs @@ -0,0 +1,76 @@ +-- | The cache's leakage proof, checked symbolically: the cache's counterpart of +-- "Proof.Core.Leakage.Solver". +-- +-- The statements live in "Proof.Cache.Server.Leakage.Obligation"; this module +-- only instantiates them, over every memory, request and witness set, and for +-- the step over a server with arbitrary tags, data, memory and state. Each +-- property is named after the statement it checks, with a @P@. +-- +-- == Running them +-- +-- Under Bitwuzla, not Z3: +-- +-- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build +module Proof.Cache.Server.Leakage.Solver + ( simSrvReadyIffAnsweredP, + simSrvDriverMatchesSpecP, + baseCaseLeakP, + indStepLeakP, + results, + ) +where + +import Core (Request) +import Memory.Cache4K +import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) +import Proof.Cache.Server.Leakage.Simulator + ( SimCacheSrv (..), + SimCacheSrvState (..), + simSrvReadyIffAnswered, + ) +import Pantomime (Theory (..)) +import qualified Pantomime.BuiltIn as Pantomime +import Proof.Cache.Server.Leakage.Driver (simSrvDriverMatchesSpec) +import Proof.Cache.Server.Leakage.Obligation +import Proof.Cache.Server.Leakage.Model (Obs) +import Proof.Cache.SMT.Axioms (cacheAxioms) +import Proof.SMT.Array (MemArr) +import Proof.SMT.Logged (pantomime) + +-- | After a step, the simulator is ready exactly when it has answered. +{-# ANN simSrvReadyIffAnsweredP (Theory cacheAxioms) #-} +simSrvReadyIffAnsweredP :: + TagArr -> SimCacheSrvState -> Obs -> Pantomime.Bool +simSrvReadyIffAnsweredP tags sst obs = + Pantomime.boolean $ simSrvReadyIffAnswered (SimCacheSrv tags sst) obs + +-- | From a ready simulator, its driver agrees with its operational reading. +{-# ANN simSrvDriverMatchesSpecP (Theory cacheAxioms) #-} +simSrvDriverMatchesSpecP :: + TagArr -> SimCacheSrvState -> Obs -> Pantomime.Bool +simSrvDriverMatchesSpecP tags sst obs = + Pantomime.boolean $ simSrvDriverMatchesSpec (SimCacheSrv tags sst) obs + +-- | The base case: the server and the simulator at start agree. +{-# ANN baseCaseLeakP (Theory cacheAxioms) #-} +baseCaseLeakP :: SetIdx -> MemArr -> Pantomime.Bool +baseCaseLeakP wsi ma = Pantomime.boolean $ baseCaseLeak wsi ma + +-- | The step: in one cycle, the simulator answers exactly when the server does, +-- and the two agree afterwards. +{-# ANN indStepLeakP (Theory cacheAxioms) #-} +indStepLeakP :: + SetIdx -> TagArr -> DataArr -> MemArr -> CacheSrvState -> Request -> + Pantomime.Bool +indStepLeakP wsi tags dat ma st req = + Pantomime.boolean $ indStepLeak wsi (CacheSrv (Cache4K tags dat) ma st) req + +-- | The verdicts, spliced in by the plugin at compile time: 'Nothing' when the +-- property is valid. +results :: [(String, Maybe String)] +results = + [ ("simSrvReadyIffAnsweredP", $(pantomime 'simSrvReadyIffAnsweredP)), + ("simSrvDriverMatchesSpecP", $(pantomime 'simSrvDriverMatchesSpecP)), + ("baseCaseLeakP", $(pantomime 'baseCaseLeakP)), + ("indStepLeakP", $(pantomime 'indStepLeakP)) + ] diff --git a/proof/Proof/Cache/Server4K.hs b/proof/Proof/Cache/Server4K.hs deleted file mode 100644 index 84ddbac..0000000 --- a/proof/Proof/Cache/Server4K.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - --- | The server proof for the 4 KiB cache ("Memory.Cache4K"), served by --- 'Memory.Cache4KServer.serve'. --- --- The artifacts: the hop of a request ('Proof.Cache.Server.Functional.Driver.driver' --- cycles after it), --- the invariant (no miss pending, every valid line holds memory's words), the --- flush 'srvMem', the censor 'srvTag' (the tag array), and the simulator --- 'simStep', derived from the cache itself. --- --- The cache holds 1024 words, so the invariant is stated at one word, --- 'srvInvAt', and the obligations quantify over that word, as the functional --- invariant does over a register and a byte. 'srvRefine' also assumes the --- invariant at the word the request accesses. Both assumptions are instances of --- the invariant at every word, so 'srvRefine' for every witness gives the --- obligation for the whole invariant. -module Proof.Cache.Server4K - ( srvTag, - simStep, - simBus, - srvInit, - srvRefine, - srvLeak, - stallsOnReads, - CacheSys (..), - initCacheSys, - stepCachedOut, - ) -where - -import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), MemAccess (..), Output (..), Request, circuit) -import Data.Functor.Identity -import Memory.Cache4K -import Memory.Types (MemOps (..)) -import Proof.Core.Leakage.Model (Obs (..), obsReq) -import Memory.Cache4KServer -import Proof.Cache.Server.Functional.Driver (driver) -import Proof.Cache.Server.Functional.Invariant (noMiss, srvInvAt) -import Proof.Core.Functional.Machine (SysG (..)) -import Memory.Ideal (idealServe) -import Core.RegFile (RegFileOps) -import Types -import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -import qualified Prelude as P - --- | The censor: the tags. -srvTag :: CacheSrv m -> TagArr -srvTag y = tagArr (srvCache y) - --- | The simulator's memory: zeros, and writes are dropped. The simulator knows --- no data. -data NoMem = NoMem - deriving (Eq, Show) - -instance MemOps NoMem where - memReadWord _ _ = 0 - memWrite _ _ _ m = m - memReadByte _ _ = 0 - --- | A request with a given observation: a fetch of a word, and a write of zero. -reqOf :: Obs -> Request -reqOf o = case o of - NoAccess -> Nothing - Fetch addr -> Just (MemAccess True addr Types.Word Nothing) - DataRead addr size -> Just (MemAccess False addr size Nothing) - DataWrite addr size -> Just (MemAccess False addr size (Just (Identity 0))) - --- | The simulator: the cache's own hop, on the tags with no data, in front of --- 'NoMem', on a request with the observation. Returns the next tags and how many --- responses are not ready. -simStep :: TagArr -> Obs -> (TagArr, Cycles) -simStep t o = (srvTag y', k) - where - y0 = CacheSrv (Cache4K t dataZero) Nothing NoMem - q = reqOf o - n = driver y0 q - k = fromIntegral n - (y', _) = serveN n y0 q - --- | The simulator as it shows on the bus: the observed request, then one cycle --- without a request per response that is not ready. -simBus :: TagArr -> Obs -> (TagArr, [Obs]) -simBus t o = (t', o : P.replicate (fromIntegral k) NoAccess) - where - (t', k) = simStep t o - -sameInput :: Input Identity -> Input Identity -> Bool -sameInput a b = - runIdentity (inputMem a) == runIdentity (inputMem b) - && inputMemReady a == inputMemReady b - --- | The empty cache, in front of any memory, satisfies the invariant. Its --- censor is 'tagEmpty' for every memory by definition. -srvInit :: (MemOps m) => SetIdx -> WordIdx -> m -> Bool -srvInit s w mem = srvInvAt s w (CacheSrv emptyCache4K Nothing mem) - --- | The refinement proof, at witnesses: memory at byte @wa@ and the invariant at --- word @ww@ of set @ws@. The hop of a request ends with ideal memory's response, --- and with memory and the invariant as ideal memory leaves them. -srvRefine :: (MemOps m) => Address -> SetIdx -> WordIdx -> CacheSrv m -> Request -> Bool -srvRefine wa ws ww y q = - not (srvInvAt ws ww y && accessed) - || ( sameInput x xI - && srvInvAt ws ww y' - && memReadByte wa (srvMem y') == memReadByte wa mI - ) - where - (y', x) = serveN (driver y q) y q - (mI, xI) = idealServe (srvMem y) q - accessed = case q of - Just (MemAccess _ addr _ _) -> srvInvAt (setOf addr) (wordOf addr) y - Nothing -> True - --- | The leakage proof, at a witness set: with no miss pending, how many --- responses of the hop are not ready, and the next tags, are what 'simStep' computes --- from the tags and the observation of the request. -srvLeak :: (MemOps m) => SetIdx -> CacheSrv m -> Request -> Bool -srvLeak ws y q = - not (noMiss y) || (k == fromIntegral kS && tagRead ws (srvTag y') == tagRead ws tS) - where - k = driver y q - (y', _) = serveN k y q - (tS, kS) = simStep (srvTag y) (obsReq q) - --- | The cache answers late only to a data read. With the core's patience --- ('Proof.CachedCore.Obligation.waitObligation'), the core's leakage proof carries --- over to the core behind this cache too. -stallsOnReads :: (MemOps m) => CacheSrv m -> Request -> Bool -stallsOnReads y q = not (noMiss y) || inputMemReady x || isDataRead - where - (_, x) = serve y q - isDataRead = case q of - Just (MemAccess False _ _ Nothing) -> True - _ -> False - --- | System state paired with a cache model. -data CacheSys r m c = CacheSys - { cacheSysCore :: SysG r m, - cacheSysCache :: c, - -- | A read waiting for memory: its address and width, and the cycles left. - cacheSysPending :: Maybe (Address, Size, Cycles) - } - -deriving instance (Show (r Identity), Show m, Show c) => Show (CacheSys r m c) - -initCacheSys :: SysG r m -> c -> CacheSys r m c -initCacheSys sys cache = CacheSys sys cache Nothing - --- | The core in a loop with the cache in front of memory. -stepCachedOut :: (RegFileOps r, MemOps m) => CacheSys r m Cache4K -> (CacheSys r m Cache4K, Output Identity) -stepCachedOut (CacheSys (Sys s i m) cache pending) = - let (s', o) = circuit s i - (CacheSrv cache' pending' m', i') = serve (CacheSrv cache pending m) (outMem o) - in (CacheSys (Sys s' i' m') cache' pending', o) From 8596335361ce2bf0e424e81eba88857d1fd8c926 Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 03:06:43 +0100 Subject: [PATCH 4/6] Test the cache and the core behind it again Cache4KSpec now tests the cache alone: reads across two lines, and concrete runs of the server. CacheProofSpec is the cache's counterpart of ProofSpec: the cache's and link 2's obligations and the contract on random states, and end-to-end runs of real programs on the core behind the cache, which check what no single proof states, that link 1 and link 2 compose (the stutter steps, the bus trace from the two simulators, secret-free programs). The helpers of CompositionSpec move there, and CompositionSpec, whose own tests the contract supersedes, is deleted. Both test modules and all proof modules are listed in package.yaml again. The six solver modules, each run on its own, are valid throughout; stack test without the solver passes: 164 of 164. Co-Authored-By: Claude Opus 5.5 --- package.yaml | 30 +- test/BenchmarkSpec.hs | 2 +- test/Cache4KSpec.hs | 418 +++++++----------------- test/CacheProofSpec.hs | 683 ++++++++++++++++++++++++++++++++++++++++ test/CompositionSpec.hs | 332 ------------------- test/ProofSpec.hs | 81 +++-- test/Spec.hs | 82 ++++- 7 files changed, 930 insertions(+), 698 deletions(-) create mode 100644 test/CacheProofSpec.hs delete mode 100644 test/CompositionSpec.hs diff --git a/package.yaml b/package.yaml index a49a311..d722f44 100644 --- a/package.yaml +++ b/package.yaml @@ -108,7 +108,10 @@ library: when: - condition: flag(smt-proof) exposed-modules: - - Proof.Cache.Functional.Solver + - Proof.Cache.Server.Functional.Solver + - Proof.Cache.Server.Leakage.Solver + - Proof.Cache.CachedCore.Functional.Solver + - Proof.Cache.CachedCore.Leakage.Solver - Proof.Core.Functional.Solver - Proof.Core.Leakage.Solver - Proof.SMT.Axioms @@ -123,10 +126,23 @@ library: # live in proof/ too, and must only be built with the smt-proof flag. other-modules: [] exposed-modules: - - Proof.Cache.Functional.Contract - - Proof.Cache.Functional.Driver - - Proof.Cache.Functional.Invariant - - Proof.Cache.Functional.Obligation + - Proof.Cache.Server.Functional.Contract + - Proof.Cache.Server.Functional.Driver + - Proof.Cache.Server.Functional.Invariant + - Proof.Cache.Server.Functional.Obligation + - Proof.Cache.Server.Leakage.Driver + - Proof.Cache.Server.Leakage.Invariant + - Proof.Cache.Server.Leakage.Model + - Proof.Cache.Server.Leakage.Obligation + - Proof.Cache.Server.Leakage.Simulator + - Proof.Cache.CachedCore.Functional.Driver + - Proof.Cache.CachedCore.Functional.Invariant + - Proof.Cache.CachedCore.Functional.Machine + - Proof.Cache.CachedCore.Functional.Obligation + - Proof.Cache.CachedCore.Leakage.Driver + - Proof.Cache.CachedCore.Leakage.Invariant + - Proof.Cache.CachedCore.Leakage.Obligation + - Proof.Cache.CachedCore.Leakage.Simulator - Proof.Cache.SMT.Raw - Proof.SMT.Array - Proof.Core.Functional.Machine @@ -173,10 +189,10 @@ tests: aimcore-test: main: Spec.hs source-dirs: test - # Listed explicitly: Cache4KSpec and CompositionSpec are still written - # against the cache's old interface and wait for the cache's leakage proof. other-modules: - BenchmarkSpec + - Cache4KSpec + - CacheProofSpec - InstructionSpec - IsaSpec - ProofSpec diff --git a/test/BenchmarkSpec.hs b/test/BenchmarkSpec.hs index b9e30ac..611f6a4 100644 --- a/test/BenchmarkSpec.hs +++ b/test/BenchmarkSpec.hs @@ -69,7 +69,7 @@ mkBenchmarkTest testName _benchmark = -- Run the simulator with STMemory and MonadMemory interface; loadElf -- copies the program's segments into memory. stMem <- stToIO $ newSTMemory (fromIntegral entryOffset) (fromIntegral base) - + _ <- runSTMemoryT stMem $ do loadElf elf let sim :: CircuitSim (STMemoryT RealWorld IO) (Core.Input) (Core.State) (Core.Output) diff --git a/test/Cache4KSpec.hs b/test/Cache4KSpec.hs index a4c09d8..8e1ca91 100644 --- a/test/Cache4KSpec.hs +++ b/test/Cache4KSpec.hs @@ -1,30 +1,25 @@ {-# LANGUAGE PackageImports #-} --- | The 4 KiB cache ("Memory.Cache4K"): a few concrete runs, its server proof --- ("Proof.Cache.Server4K") on random states, and the composition end to end. +-- | The 4 KiB cache ("Memory.Cache4K") and its server ("Memory.Cache4KServer") +-- on their own: reads that cross lines, and a few concrete runs. The cache's +-- proof and the core behind the cache are tested in "CacheProofSpec". module Cache4KSpec ( cache4KTests, + TestMem (..), + genMem, + genTag, + genAddr, + genWord, ) where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Clash.Sized.Vector (unsafeFromList) -import CompositionSpec (coreDiff, ctTrace, genByteProg, genCTProg, genData, genSecretFreeProg, genWord, sameModuloCtrl, simHops, withData) -import Core -import Data.Functor.Identity (Identity (..)) -import Data.Maybe (isNothing) -import Core.Instruction +import Core (Input (..), MemAccess (..), Request) import Memory.Cache4K import Memory.Cache4KServer +import Memory.Ideal (idealServe) import Memory.Types -import Proof.Cache.Server.Functional.Driver (driver) -import Proof.Cache.Server.Functional.Invariant (coherentAt, srvInvAt) -import Proof.Cache.Server4K -import Proof.Core.Functional.Obligation (isaAt) -import Proof.Core.Leakage.Model -import Proof.Core.Functional.Machine -import ProofSpec (initSys) -import Core.RegFile (RegFile) +import Proof.Cache.Server.Functional.Driver (srvDriver) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck @@ -35,144 +30,54 @@ import qualified Prelude as P cache4KTests :: TestTree cache4KTests = testGroup - "Core behind a 4 KiB cache" - [ runTests, - testProperty "read, from the lines of the first and last byte, answers as memory does" $ + "4 KiB cache" + [ testProperty "a read, from the lines of its first and last byte, answers as memory does" $ withMaxSuccess 2000 $ checkCoverage $ - forAllShow genMem (const "") $ \mem -> forAll genAddr $ \a -> forAll (elements [Byte, Half, Types.Word]) $ \size -> + forAll genMem $ \mem -> forAll genAddr $ \a -> forAll (elements [Byte, Half, Types.Word]) $ \size -> let c = cacheFill (lastByteOf a size) mem (cacheFill a mem emptyCache4K) - in cover 10 (straddles a size) "straddling" (cacheRead a size c == readResp a size mem), - serverTests, - testProperty "composition: the cached core's bus trace follows from the leakage alone" $ - withMaxSuccess 300 $ checkCoverage $ - forAll genCTProg $ \prog -> - let sys = initSys prog - r = compositeReport sys - in cover 30 (stallCycles sys > 0) "the core waits for the cache" (counterexample r (P.null r)), - testProperty "... also with reads and writes of every width and alignment" $ - withMaxSuccess 300 $ checkCoverage $ - forAll genByteProg $ \prog -> forAll genData $ \ds -> - let sys = withData ds (initSys prog) - r = compositeReport sys - in cover 30 (stallCycles sys > 0) "the core waits for the cache" (counterexample r (P.null r)), - testProperty "the cached run is the ideal run with stall cycles inserted" $ - withMaxSuccess 300 $ - forAll genCTProg $ \prog -> - let r = stutterReport 300 (initSys prog) - in counterexample r (P.null r), - testProperty "... also with reads and writes of every width and alignment" $ - withMaxSuccess 300 $ - forAll genByteProg $ \prog -> - forAll genData $ \ds -> - let r = stutterReport 300 (withData ds (initSys prog)) - in counterexample r (P.null r), - testProperty "a secret-free program leaks nothing about its data, behind the cache" $ - withMaxSuccess 300 $ - forAll genSecretFreeProg $ \prog -> - forAll genData $ \da -> - forAll genData $ \db -> - let s1 = withData da (initSys prog) - s2 = withData db (initSys prog) - in ctTrace 100 (isaAt initPc s1) == ctTrace 100 (isaAt initPc s2) - P.&& cachedObs 300 s1 == cachedObs 300 s2, - testProperty "a load through a loaded pointer leaks it, even to a timing attacker" $ - -- The control: @lw x5, 0(x0); lw x1, 0(x5); lw x2, 0(x0); ebreak@. The - -- second load's address is data. With the pointer at 0 the second load - -- hits the line the first one filled; with the pointer at 16, in the next - -- set, it misses. So even an attacker who sees only in which cycles a - -- request is made tells the two apart. - let prog = - map encode $ - unsafeFromList $ - [ IType (Load Types.Word Signed) 5 0 0, - IType (Load Types.Word Signed) 1 5 0, - IType (Load Types.Word Signed) 2 0 0 - ] - P.++ P.replicate 47 Core.Instruction.break - timing p = P.map (/= NoAccess) (cachedObs 100 (withData [(0, p)] (initSys prog))) - in once (timing 0 /= timing 16) + in cover 10 (straddles a size) "straddling" $ + Just (cacheRead a size c) == idealAnswer mem (Just (MemRead a size)), + runTests ] --- Concrete runs ------------------------------------------------------------------- - -memU :: MemFn -memU = MemFn (\a -> slice d7 d0 (pack (a * 13 + 7))) - -rdReq :: Address -> Size -> Request -rdReq a sz = Just (MemAccess False a sz Nothing) - -wrReq :: Address -> Size -> Word -> Request -wrReq a sz v = Just (MemAccess False a sz (Just (Identity v))) - --- | Serve requests one hop each, from the empty cache in front of 'memU': --- the stall count and the response word of each. -hops :: [Request] -> [(Cycles, Word)] -hops = go (CacheSrv emptyCache4K Nothing memU) - where - go _ [] = [] - go y (q : qs) = - let k = driver y q - (y', x) = serveN k y q - in (fromIntegral k, runIdentity (inputMem x)) : go y' qs - -runTests :: TestTree -runTests = - testGroup - "concrete runs" - [ testCase "a read miss stalls, then the rest of its line hits" $ - hops [rdReq 0x100 Types.Word, rdReq 0x10C Types.Word, rdReq 0x106 Half] - @?= [ (penalty, memReadWord 0x100 memU), - (0, memReadWord 0x10C memU), - (0, loadExtend Half Unsigned (memReadWord 0x106 memU)) - ], - testCase "lines 4 KiB apart evict each other" $ - P.map fst (hops [rdReq 0x100 Types.Word, rdReq 0x1100 Types.Word, rdReq 0x100 Types.Word]) - @?= [penalty, penalty, penalty], - testCase "a write hit is merged into the cached word" $ - hops [rdReq 0x100 Types.Word, wrReq 0x101 Byte 0xAB, rdReq 0x100 Types.Word] - @?= [ (penalty, memReadWord 0x100 memU), - (0, 0), - (0, memReadWord 0x100 (memWrite 0x101 Byte 0xAB memU)) - ], - testCase "a write that leaves its word drops its lines" $ - P.map fst (hops [rdReq 0x100 Types.Word, rdReq 0x110 Types.Word, wrReq 0x10E Types.Word 1, rdReq 0x100 Types.Word, rdReq 0x110 Types.Word]) - @?= [penalty, penalty, 0, penalty, penalty] - ] - --- The server proof on random states ------------------------------------------------- - --- | A memory whose bytes are a function of their address, different in every --- test. -genMem :: Gen MemFn -genMem = do - k1 <- genU32 - k2 <- genU32 - pure (MemFn (\a -> slice d7 d0 (pack ((a * (k1 .|. 1) + k2) `xor` (a `shiftR` 9))))) +-- Memory -------------------------------------------------------------------------- + +-- | A memory for the tests: bytes that are a function of their address and two +-- seeds, and the bytes written since, newest first. Unlike 'MemFn' it has +-- equality, which 'Proof.Cache.Server.Functional.Contract.srvReady' needs, and +-- it shows. Equality compares the representation, so two memories that agree +-- byte for byte may still differ; a server that leaves memory alone leaves it +-- equal. +data TestMem = TestMem (Unsigned 32) (Unsigned 32) [(Address, Byte)] + deriving (Eq, Show) + +instance MemOps TestMem where + memReadByte a (TestMem k1 k2 ws) = case P.lookup a ws of + Just b -> b + Nothing -> slice d7 d0 (pack ((a * (k1 .|. 1) + k2) `xor` (a `shiftR` 9))) + memReadWord a m = + memReadByte (a + 3) m ++# memReadByte (a + 2) m ++# memReadByte (a + 1) m ++# memReadByte a m + memWrite a size w (TestMem k1 k2 ws) = TestMem k1 k2 (bytes P.++ ws) + where + bytes = case size of + Byte -> [(a, b0)] + Half -> [(a + 1, b1), (a, b0)] + Types.Word -> [(a + 3, b3), (a + 2, b2), (a + 1, b1), (a, b0)] + b0 = slice d7 d0 w + b1 = slice d15 d8 w + b2 = slice d23 d16 w + b3 = slice d31 d24 w + +-- | A memory different in every test, nothing written yet. +genMem :: Gen TestMem +genMem = (\k1 k2 -> TestMem k1 k2 []) <$> genU32 <*> genU32 where - genU32 = fromIntegral <$> choose (0 :: Integer, 0xFFFFFFFF) :: Gen (Unsigned 32) + genU32 = fromIntegral <$> choose (0 :: Integer, 0xFFFFFFFF) -- | Tags of the first three 4 KiB blocks of memory, sometimes others. genTag :: Gen Tag genTag = frequency [(10, elements [0, 1, 2]), (1, fromIntegral <$> choose (0 :: Int, 0xFFFFF))] --- | The cache in front of memory, with no miss pending: lines mostly valid, --- holding memory's words, and rarely a wrong word, which takes the server out of --- its invariant at that word. -genSrv :: Gen (CacheSrv MemFn) -genSrv = do - mem <- genMem - es <- vectorOf 256 (frequency [(2, pure 0), (8, ((1 :: BitVector 1) ++#) <$> genTag)]) - ws <- P.mapM (genData1 mem es) [0 .. 1023] - pure (CacheSrv (Cache4K (TagArr (unsafeFromList es)) (DataArr (unsafeFromList ws))) Nothing mem) - where - genData1 mem es i = - let s = fromIntegral (i `P.div` 4) :: SetIdx - w = fromIntegral (i `P.mod` 4) :: WordIdx - e = es P.!! (i `P.div` 4) - in if entryValid e - then frequency [(60, pure (memReadWord (wordAddr (entryTag e) s w 0) mem)), (1, genWord)] - else genWord - -- | Addresses in the first three 4 KiB blocks, sometimes anywhere. genAddr :: Gen Address genAddr = @@ -181,185 +86,86 @@ genAddr = (1, fromIntegral <$> choose (0 :: Integer, 0xFFFFFFFF)) ] --- | Requests: none, fetches, and reads and writes of every width and alignment, --- and also requests the core never makes. -genReq :: Gen Request -genReq = - frequency - [ (1, pure Nothing), - (2, (\a -> Just (MemAccess True a Types.Word Nothing)) <$> genAddr), - (1, (\a sz -> Just (MemAccess True a sz Nothing)) <$> genAddr <*> genSize), - (1, (\a sz v -> Just (MemAccess True a sz (Just (Identity v)))) <$> genAddr <*> genSize <*> genWord), - (8, (\a sz -> Just (MemAccess False a sz Nothing)) <$> genAddr <*> genSize), - (4, (\a sz v -> Just (MemAccess False a sz (Just (Identity v)))) <$> genAddr <*> genSize <*> genWord) - ] - where - genSize = elements [Byte, Half, Types.Word] - --- | Witnesses, half of the time at the request's own set, word and bytes. -genWitness :: Request -> Gen (Address, SetIdx, WordIdx) -genWitness q = do - let a = maybe 0 memAddress q - wa <- frequency [(1, (\o -> a + fromIntegral o) <$> choose (0 :: Int, 4)), (1, genAddr)] - ws <- frequency [(1, pure (setOf a)), (1, fromIntegral <$> choose (0 :: Int, 255))] - ww <- frequency [(1, pure (wordOf a)), (1, fromIntegral <$> choose (0 :: Int, 3))] - pure (wa, ws, ww) - --- | Serve a request, then @n@ cycles without one. A harness helper: the proofs --- write their cycles out. -serveN :: (MemOps m) => Int -> CacheSrv m -> Request -> (CacheSrv m, Input) -serveN n srv req = go n (serve srv req) - where - go k (y', x) - | k <= 0 = (y', x) - | otherwise = go (k - 1) (serve y' Nothing) +genWord :: Gen Word +genWord = oneof [elements [0, 1, 0xFF, 0x1234, 0x80000000, 0xDEADBEEF], fromIntegral <$> (arbitrary :: Gen Int)] --- | Has the core not halted yet? -running :: SysG r m -> Bool -running = isNothing . stateHalt . sysCore +-- | Ideal memory's answer to a request. +idealAnswer :: (MemOps m) => m -> Request -> Maybe Word +idealAnswer mem req = inputMem (snd (idealServe mem req)) -- | The address of the last byte of an access. lastByteOf :: Address -> Size -> Address -lastByteOf a sz = - a + case sz of +lastByteOf a size = + a + case size of Byte -> 0 Half -> 1 Types.Word -> 3 -- | Does an access cross a word boundary? straddles :: Address -> Size -> Bool -straddles a sz = a `shiftR` 2 /= lastByteOf a sz `shiftR` 2 +straddles a size = a `shiftR` 2 /= lastByteOf a size `shiftR` 2 --- | What kind of request, against what cache. -reqKind :: CacheSrv MemFn -> Request -> String -reqKind y q = case q of - Nothing -> "none" - Just (MemAccess _ a sz (Just _)) - | straddles a sz -> "straddling write" - | hit a c -> "write hit" - | otherwise -> "write miss" - Just (MemAccess True _ _ Nothing) -> "fetch" - Just (MemAccess False a sz Nothing) - | straddles a sz -> "straddling read" - | hit a c -> "hit" - | otherwise -> "miss" - where - c = srvCache y - -coverKinds :: CacheSrv MemFn -> Request -> Property -> Property -coverKinds y q = - P.foldr - (\k f -> cover 3 (reqKind y q == k) k . f) - id - ["none", "fetch", "write hit", "write miss", "straddling write", "hit", "miss", "straddling read"] - -serverTests :: TestTree -serverTests = - testGroup - "server proof" - [ testProperty "the empty cache starts in the invariant" $ - forAllShow genMem (const "") $ \mem -> - forAll (fromIntegral <$> choose (0 :: Int, 255)) $ \s -> - forAll (fromIntegral <$> choose (0 :: Int, 3)) $ \w -> srvInit s w mem, - testProperty "refinement: the hop of a request ends with ideal memory's response" $ - withMaxSuccess 4000 $ checkCoverage $ - forAllShow genSrv (const "") $ \y -> forAll genReq $ \q -> forAll (genWitness q) $ \(wa, ws, ww) -> - coverKinds y q $ - cover 80 (srvInvAt ws ww y) "in the invariant at the witness" $ - cover 10 (ws == maybe 0 (setOf . memAddress) q P.&& ww == maybe 0 (wordOf . memAddress) q) "the witness is the accessed word" $ - srvRefine wa ws ww y q, - testProperty "leakage: the stalls and the next tags follow from the tags and the observed request" $ - withMaxSuccess 4000 $ checkCoverage $ - forAllShow genSrv (const "") $ \y -> forAll genReq $ \q -> forAll (genWitness q) $ \(_, ws, _) -> - coverKinds y q (property (srvLeak ws y q)), - testProperty "the cache answers late only to a data read" $ - withMaxSuccess 2000 $ - forAllShow genSrv (const "") $ \y -> forAll genReq $ \q -> stallsOnReads y q - ] +-- Concrete runs ------------------------------------------------------------------- --- Composition, end to end ----------------------------------------------------------- +memU :: MemFn +memU = MemFn (\a -> slice d7 d0 (pack (a * 13 + 7))) --- | The requests the core makes behind the 4 KiB cache, cycle by cycle, until it --- halts. -cachedObs :: Int -> Sys -> [Obs] -cachedObs n sys = go n (initCacheSys sys emptyCache4K) - where - go :: Int -> CacheSys RegFile MemBytes Cache4K -> [Obs] - go 0 _ = [] - go j cs - | P.not (running (cacheSysCore cs)) = [] - | otherwise = let (cs', o) = stepCachedOut cs in obsOf o : go (j - 1) cs' +rdReq :: Address -> Size -> Request +rdReq a size = Just (MemRead a size) --- | The same trace from the leakage alone: the core's simulator produces each --- hop's requests as behind ideal memory, and the cache's simulator adds the --- cycles in which the core waits. -compositeTrace :: Int -> Sys -> [Obs] -compositeTrace n sys0 = go (P.take n (simHops sys0)) tagEmpty - where - go [] _ = [] - go (os : rest) t = - let (t', bus) = serveAll t os - in bus P.++ go rest t' - serveAll t [] = (t, []) - serveAll t (o : os) = - let (t1, xs) = simBus t o - (t2, ys) = serveAll t1 os - in (t2, xs P.++ ys) +wrReq :: Address -> Size -> Word -> Request +wrReq a size v = Just (MemWrite a size v) -compositeReport :: Sys -> String -compositeReport sys0 - | cached == P.take (P.length cached) composite = "" - | otherwise = "first difference at cycle " P.++ show i P.++ ": " P.++ show (P.take 6 (P.drop i cached)) P.++ " vs " P.++ show (P.take 6 (P.drop i composite)) +-- | Serve requests one hop each, from the server at start in front of 'memU': +-- the driver's count of each hop, and the answer that ends it. +hops :: [Request] -> [(Int, Maybe Word)] +hops = go (initCacheSrv memU) where - cached = cachedObs 600 sys0 - composite = compositeTrace 600 sys0 - i = P.length (P.takeWhile id (P.zipWith (==) cached composite)) + go _ [] = [] + go srv (req : reqs) = + let k = srvDriver srv req + (srv', ans) = serveN k srv req + in (k, inputMem ans) : go srv' reqs --- | The cycles in which the core behind the cache waits, until it halts. -stallCycles :: Sys -> Int -stallCycles sys0 = go (600 :: Int) (initCacheSys sys0 emptyCache4K) - where - go 0 _ = 0 - go j cs - | P.not (running (cacheSysCore cs)) = 0 - | otherwise = - (if inputMemReady (sysInput (cacheSysCore cs)) then 0 else 1) - + go (j - 1) (fst (stepCachedOut cs)) +-- | Serve a request, then @n@ cycles without one. +serveN :: (MemOps m) => Int -> CacheSrv m -> Request -> (CacheSrv m, Input) +serveN n srv req + | n <= 0 = serve srv req + | otherwise = serveN (n - 1) (fst (serve srv req)) Nothing --- | Is the cache coherent with memory at every set the harness's memory can --- fill? Memory is 'MEM_SIZE' words, below address 512, so only sets 0 to 31. -coherentLow :: MemBytes -> Cache4K -> Bool -coherentLow mem c = P.and [coherentAt mem s w c | s <- [0 .. 31], w <- [0 .. 3]] +p :: Int +p = fromIntegral penalty --- | Walk the cached system and the ideal one together for @n@ cycles of the --- cached one, skipping the cached run's stall cycles -- those whose bus input is --- not ready -- in the ideal one. Returns @\"\"@ if every stall cycle makes no --- request and leaves the core alone, the cache stays coherent with memory, and --- every other cycle makes the ideal run's request from the ideal run's state, up --- to 'sameModuloCtrl'. -stutterReport :: Int -> Sys -> String -stutterReport n sys0 = go n (0 :: Int) (initCacheSys sys0 emptyCache4K) sys0 +runTests :: TestTree +runTests = + testGroup + "concrete runs" + [ testCase "a read miss stalls, then the rest of its line hits" $ + hops [rdReq 0x100 Types.Word, rdReq 0x10C Types.Word, rdReq 0x106 Half] + @?= [ (p, idealAnswer memU (rdReq 0x100 Types.Word)), + (0, idealAnswer memU (rdReq 0x10C Types.Word)), + (0, idealAnswer memU (rdReq 0x106 Half)) + ], + testCase "a read that crosses into a missing line stalls for both" $ + P.map fst (hops [rdReq 0x10E Types.Word, rdReq 0x100 Types.Word, rdReq 0x110 Types.Word]) + @?= [2 * p, 0, 0], + testCase "lines 4 KiB apart evict each other" $ + P.map fst (hops [rdReq 0x100 Types.Word, rdReq 0x1100 Types.Word, rdReq 0x100 Types.Word]) + @?= [p, p, p], + testCase "a write hit is merged into the cached word" $ + hops [rdReq 0x100 Types.Word, wrReq 0x101 Byte 0xAB, rdReq 0x100 Types.Word] + @?= [ (p, idealAnswer memU (rdReq 0x100 Types.Word)), + (0, Just 0), + (0, idealAnswer (memWrite 0x101 Byte 0xAB memU) (rdReq 0x100 Types.Word)) + ], + testCase "a write that crosses into the next line is merged into both" $ + hops [rdReq 0x100 Types.Word, rdReq 0x110 Types.Word, wrReq 0x10E Types.Word 0x01020304, rdReq 0x10C Types.Word, rdReq 0x110 Types.Word] + @?= [ (p, idealAnswer memU (rdReq 0x100 Types.Word)), + (p, idealAnswer memU (rdReq 0x110 Types.Word)), + (0, Just 0), + (0, idealAnswer memW (rdReq 0x10C Types.Word)), + (0, idealAnswer memW (rdReq 0x110 Types.Word)) + ] + ] where - go :: Int -> Int -> CacheSys RegFile MemBytes Cache4K -> Sys -> String - go 0 _ _ _ = "" - go j c cs ideal - | P.not (running core) = "" - | P.not (coherentLow (sysMem core) (cacheSysCache cs)) = failAt "the cache is not coherent with memory" "" - | P.not ready = - if obsOf oC /= NoAccess - then failAt "a stall cycle made a request: " (show (obsOf oC)) - else - -- The bus input is the memory's answer, which may arrive now. - if P.not (sameModuloCtrl (withInput (cacheSysCore cs')) core) - then failAt "a stall cycle changed the core: " (P.unwords (coreDiff core (cacheSysCore cs'))) - else go (j - 1) (c + 1) cs' ideal - | P.not (sameModuloCtrl core ideal) = failAt "the cached core left the ideal run: " (P.unwords (coreDiff ideal core)) - | obsOf oC /= obsOf oI = failAt "different requests: " (show (obsOf oC, obsOf oI)) - | otherwise = go (j - 1) (c + 1) cs' ideal' - where - core = cacheSysCore cs - ready = inputMemReady (sysInput core) - withInput (Sys st _ m) = Sys st (sysInput core) m - (cs', oC) = stepCachedOut cs - (ideal', oI) = stepSysOut ideal - failAt what detail = "\ncycle " P.++ show c P.++ ": " P.++ what P.++ detail P.++ "\n" + memW = memWrite 0x10E Types.Word 0x01020304 memU diff --git a/test/CacheProofSpec.hs b/test/CacheProofSpec.hs new file mode 100644 index 0000000..783e641 --- /dev/null +++ b/test/CacheProofSpec.hs @@ -0,0 +1,683 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | The cache's proof and link 2 on random states, and the core behind the +-- cache end to end: the cache's counterpart of "ProofSpec". +-- +-- The statements are the ones "Proof.Cache.Server.Functional.Solver", +-- "Proof.Cache.Server.Leakage.Solver", +-- "Proof.Cache.CachedCore.Functional.Solver" and +-- "Proof.Cache.CachedCore.Leakage.Solver" prove. Here they run on concrete +-- states, without the trusted array embeddings the solver relies on. +-- +-- The end-to-end runs check what no single proof states: that link 1 (the +-- core behind ideal memory refines the ISA) and link 2 (the core behind the +-- cache refines the core behind ideal memory) compose, on real programs. +module CacheProofSpec + ( cacheProofTests, + ) +where + +import Cache4KSpec (TestMem (..), genAddr, genMem, genTag, genWord) +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Clash.Sized.Vector (unsafeFromList) +import Core +import Core.ISA (IsaState, IsaStateG (..), StepG (..), isaStep) +import Core.Instruction +import Core.RegFile (RegFile, RegFileOps (..), RegFn (..)) +import Data.Maybe (isJust, isNothing) +import Memory.Cache4K +import Memory.Cache4KServer +import Memory.Types +import Proof.Cache.CachedCore.Functional.Driver (cachedDriver, cachedDriverMatchesSpec) +import Proof.Cache.CachedCore.Functional.Machine +import qualified Proof.Cache.CachedCore.Functional.Obligation as Cached +import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) +import Proof.Cache.CachedCore.Leakage.Invariant (simCachedOf) +import qualified Proof.Cache.CachedCore.Leakage.Obligation as CachedLeak +import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..), simInitCachedSys, simStepCached) +import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.Cache.Server.Functional.Contract + ( corePatient, + srvDriverMatchesSpec, + srvReadyIffAnswered, + srvReadyUnderInv, + ) +import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Cache.Server.Functional.Invariant (coherentAt) +import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) +import qualified Proof.Cache.Server.Functional.Obligation as Srv +import Proof.Cache.Server.Leakage.Driver (simSrvDriverMatchesSpec) +import Proof.Cache.Server.Leakage.Invariant (simOf) +import Proof.Cache.Server.Leakage.Model (obsReq) +import qualified Proof.Cache.Server.Leakage.Obligation as SrvLeak +import Proof.Core.Functional.Machine +import Proof.Core.Leakage.Driver (simDriver) +import Proof.Core.Leakage.Model (Leak, Obs (..), leakOf, obsOf) +import Proof.Core.Leakage.Simulator (SimInput, SimState, simCircuit, simInit) +import ProofSpec (genArbSys, genArbSys1, initSysProg) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck +import "aimcore" Types +import Prelude hiding (Ordering (..), Word, init, log, map, not, undefined, (!!), (&&), (++), (||)) +import qualified Prelude as P + +cacheProofTests :: TestTree +cacheProofTests = + testGroup + "Cache proof and the core behind the cache" + [ serverTests, + cachedCoreTests, + endToEndTests + ] + +-- The coherent cache --------------------------------------------------------------- + +-- | A coherent cache in front of the tests' memories, as +-- 'Proof.Cache.Server.Functional.Obligation.mkDataMem' builds one in front of +-- the solver's: a valid line holds memory's words, an invalid line raw ones. +coherentData :: (MemOps m) => m -> TagArr -> RawData -> DataArr +coherentData mem tags (RawData raw) = DataArr (imap word raw) + where + word :: Index 1024 -> Word -> Word + word i w + | entryValid e = memReadWord (wordAddr (entryTag e) si wi 0) mem + | otherwise = w + where + idx = fromIntegral i :: BitVector 10 + si = slice d9 d2 idx + wi = slice d1 d0 idx + e = tagRead si tags + +instance CoherentOps TestMem where + mkData = coherentData + +instance CoherentOps MemFn where + mkData = coherentData + +-- Generators ----------------------------------------------------------------------- + +-- | Tag entries: mostly valid, with the tags of the first three 4 KiB blocks. +genTags :: Gen TagArr +genTags = + TagArr . unsafeFromList + <$> vectorOf 256 (frequency [(2, pure 0), (8, ((1 :: BitVector 1) ++#) <$> genTag)]) + +-- | The words of the invalid lines, or of any line for a cache that need not be +-- coherent. +genRaw :: Gen RawData +genRaw = RawData . unsafeFromList <$> vectorOf 1024 genWord + +-- | Ready, or waiting for memory with up to 2 * 'penalty' cycles left. +genSrvState :: Gen CacheSrvState +genSrvState = + frequency + [ (4, pure CacheSrvReady), + (1, CacheSrvStall <$> (fromIntegral <$> choose (0 :: Int, 7)) <*> genWord) + ] + +-- | Requests: none, fetches, and reads and writes of every width and alignment. +genReq :: Gen Request +genReq = + frequency + [ (1, pure Nothing), + (2, Just . MemFetch <$> genAddr), + (8, (\a size -> Just (MemRead a size)) <$> genAddr <*> genSize), + (4, (\a size v -> Just (MemWrite a size v)) <$> genAddr <*> genSize <*> genWord) + ] + where + genSize = elements [Byte, Half, Types.Word] + +-- | The address a request accesses, 0 for none. +reqAddr :: Request -> Address +reqAddr req = case req of + Just (MemFetch a) -> a + Just (MemRead a _) -> a + Just (MemWrite a _ _) -> a + Nothing -> 0 + +-- | Witnesses, half of the time at the request's own bytes, set and word. +genWitness :: Address -> Gen (Address, SetIdx, WordIdx) +genWitness a = do + wa <- frequency [(1, (\o -> a + fromIntegral o) <$> choose (0 :: Int, 4)), (1, genAddr)] + wsi <- frequency [(1, pure (setOf a)), (1, fromIntegral <$> choose (0 :: Int, 255))] + wwi <- frequency [(1, pure (wordOf a)), (1, fromIntegral <$> choose (0 :: Int, 3))] + pure (wa, wsi, wwi) + +-- | The register file of a generated state, as a 'Vec', so that cores can be +-- compared. +toRegFile :: RegFn -> RegFile +toRegFile (RegFn g) = P.foldr (\i -> modifyRFg i (g i)) initRFg [1 .. 31] + +-- | An arbitrary system from "ProofSpec"'s generators, sometimes with a load in +-- the memory stage, so that the cycle makes a data read. +genSys :: Gen (SysG RegFile MemFn, Address) +genSys = do + (Sys core inp mem, _, wa) <- oneof [genArbSys, genArbSys1] + me <- frequency [(1, pure Nothing), (1, Just <$> genLoad)] + let core' = maybe core (\ir -> core {stateMeInstr = ir}) me + pure (Sys core' {stateRegFile = toRegFile (stateRegFile core)} inp mem, wa) + where + genLoad = + (\size sign rd rs1 imm -> IType (Load size sign) rd rs1 imm) + <$> elements [Byte, Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> (fromIntegral <$> choose (0 :: Int, 31)) + <*> (fromIntegral <$> choose (0 :: Int, 31)) + <*> (fromIntegral <$> choose (0 :: Int, 63)) + +p :: Int +p = fromIntegral penalty + +-- | Cover each hop length of the cache. +coverHops :: Int -> Property -> Property +coverHops k = + cover 20 (k == 0) "hop of 1 cycle" + . cover 10 (k == p) "hop of penalty + 1 cycles" + . cover 1 (k == 2 * p) "hop of 2 * penalty + 1 cycles" + +-- The cache's proof ---------------------------------------------------------------- + +serverTests :: TestTree +serverTests = + testGroup + "the cache's proof" + [ testProperty "functional: base case" $ + forAll genMem $ \mem -> forAll (genWitness 0) $ \(wa, wsi, wwi) -> + Srv.baseCase wa wsi wwi mem, + -- The step for the hop length the driver gives, from a ready server whose + -- cache is coherent by construction, as in the solver. + testProperty "functional: the step for the driver's hop length" $ + withMaxSuccess 4000 $ checkCoverage $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll genReq $ \req -> forAll (genWitness (reqAddr req)) $ \(wa, wsi, wwi) -> + let srv = CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady + k = srvDriver srv req + step + | k == 0 = Srv.indStep0 wa wsi wwi mem tags raw req + | k == p = + Srv.indStep4 wa wsi wwi mem tags raw req + P.&& Srv.indStepWaits4 wa wsi wwi mem tags raw req + | k == 2 * p = + Srv.indStep8 wa wsi wwi mem tags raw req + P.&& Srv.indStepWaits8 wa wsi wwi mem tags raw req + | otherwise = False + in coverHops k (counterexample ("driver=" P.++ show k) step), + testProperty "the driver agrees with its operational reading" $ + withMaxSuccess 4000 $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll genSrvState $ \st -> forAll genReq $ \req -> + srvDriverMatchesSpec (CacheSrv (Cache4K tags (DataArr (rawVec raw))) mem st) req, + testProperty "contract: after a step, the server is ready exactly when it has answered" $ + withMaxSuccess 4000 $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll genSrvState $ \st -> forAll genReq $ \req -> + srvReadyIffAnswered (CacheSrv (Cache4K tags (DataArr (rawVec raw))) mem st) req, + testProperty "contract: a server related to ideal memory is ready" $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll (genWitness 0) $ \(wa, wsi, wwi) -> + srvReadyUnderInv wa wsi wwi mem (CacheSrv (Cache4K tags (mkData mem tags raw)) mem CacheSrvReady), + testProperty "contract: the core waits for what it asked for" $ + withMaxSuccess 4000 $ checkCoverage $ + forAllShow genSys (const "") $ \(Sys core inp _, _) -> + cover 30 (isJust (outputMem (snd (circuit core inp)))) "the cycle makes a request" $ + corePatient core inp, + testProperty "leakage: base case" $ + forAll genMem $ \mem -> forAll (fromIntegral <$> choose (0 :: Int, 255)) $ \wsi -> + SrvLeak.baseCaseLeak wsi mem, + testProperty "leakage: the step, on any server" $ + withMaxSuccess 4000 $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll genSrvState $ \st -> forAll genReq $ \req -> forAll (genWitness (reqAddr req)) $ \(_, wsi, _) -> + SrvLeak.indStepLeak wsi (CacheSrv (Cache4K tags (DataArr (rawVec raw))) mem st) req, + testProperty "leakage: the simulator's driver agrees with its operational reading" $ + withMaxSuccess 4000 $ + forAll genMem $ \mem -> forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll genSrvState $ \st -> forAll genReq $ \req -> + simSrvDriverMatchesSpec (simOf (CacheSrv (Cache4K tags (DataArr (rawVec raw))) mem st)) (obsReq req) + ] + where + rawVec (RawData v) = v + +-- Link 2 --------------------------------------------------------------------------- + +cachedCoreTests :: TestTree +cachedCoreTests = + testGroup + "link 2: the core behind the cache" + [ -- The step for the hop length the driver gives, functional and leakage + -- halves together, from the cached system built from an arbitrary one. + testProperty "the step for the driver's hop length" $ + withMaxSuccess 4000 $ checkCoverage $ + forAllShow genSys (const "") $ \(sys, wa) -> + forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll (genWitness wa) $ \(_, wsi, wwi) -> + let k = cachedDriver (Cached.cachedOf sys tags raw) + step + | k == 0 = + Cached.indStep0 wa wsi wwi sys tags raw + P.&& CachedLeak.indStepLeak0 wa wsi wwi sys tags raw + | k == p = + Cached.indStep4 wa wsi wwi sys tags raw + P.&& CachedLeak.indStepLeak4 wa wsi wwi sys tags raw + | k == 2 * p = + Cached.indStep8 wa wsi wwi sys tags raw + P.&& CachedLeak.indStepLeak8 wa wsi wwi sys tags raw + | otherwise = False + in coverHops k (counterexample ("driver=" P.++ show k) step), + testProperty "the driver agrees with its operational reading" $ + withMaxSuccess 4000 $ + forAllShow genSys (const "") $ \(sys, wa) -> + forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + forAll (genWitness wa) $ \(_, wsi, wwi) -> + cachedDriverMatchesSpec wa wsi wwi sys (Cached.cachedOf sys tags raw), + testProperty "the simulator's driver agrees with its operational reading" $ + withMaxSuccess 4000 $ + forAllShow genSys (const "") $ \(sys, _) -> + forAll genTags $ \tags -> forAllShow genRaw (const "") $ \raw -> + simCachedDriverMatchesSpec + (simCachedOf (Cached.cachedOf sys tags raw)) + (obsOf (snd (stepSysOut sys))) + ] + +-- End to end ----------------------------------------------------------------------- + +endToEndTests :: TestTree +endToEndTests = + testGroup + "end to end" + [ testProperty "the cached run is the ideal run with stall cycles inserted" $ + withMaxSuccess 300 $ checkCoverage $ + forAll genCTProg $ \prog -> + let sys = initSysProg prog + r = stutterReport 300 sys + in cover 30 (stallCycles sys > 0) "the core waits for the cache" (counterexample r (P.null r)), + testProperty "... also with reads and writes of every width and alignment" $ + withMaxSuccess 300 $ checkCoverage $ + forAll genByteProg $ \prog -> forAll genData $ \ds -> + let sys = withData ds (initSysProg prog) + r = stutterReport 300 sys + in cover 30 (stallCycles sys > 0) "the core waits for the cache" (counterexample r (P.null r)), + testProperty "the cached core's bus trace follows from the leakage alone" $ + withMaxSuccess 300 $ + forAll genCTProg $ \prog -> + let r = compositeReport (initSysProg prog) + in counterexample r (P.null r), + testProperty "... also with reads and writes of every width and alignment" $ + withMaxSuccess 300 $ + forAll genByteProg $ \prog -> forAll genData $ \ds -> + let r = compositeReport (withData ds (initSysProg prog)) + in counterexample r (P.null r), + testProperty "a secret-free program leaks nothing about its data, behind the cache" $ + withMaxSuccess 300 $ + forAll genSecretFreeProg $ \prog -> + forAll genData $ \da -> + forAll genData $ \db -> + let s1 = withData da (initSysProg prog) + s2 = withData db (initSysProg prog) + in ctTrace 100 (isaStart s1) == ctTrace 100 (isaStart s2) + P.&& cachedObs 300 s1 == cachedObs 300 s2, + testProperty "a load through a loaded pointer leaks it, even to a timing attacker" $ + -- The control: @lw x5, 0(x0); lw x1, 0(x5); lw x2, 0(x0); ebreak@. The + -- second load's address is data. With the pointer at 0 the second load + -- hits the line the first one filled; with the pointer at 16, in the next + -- set, it misses. So even an attacker who sees only in which cycles a + -- request is made tells the two apart. + let prog = + map encode $ + unsafeFromList $ + [ IType (Load Types.Word Signed) 5 0 0, + IType (Load Types.Word Signed) 1 5 0, + IType (Load Types.Word Signed) 2 0 0 + ] + P.++ P.replicate 47 Core.Instruction.break + timing ptr = P.map (/= NoAccess) (cachedObs 100 (withData [(0, ptr)] (initSysProg prog))) + in once (timing 0 /= timing 16) + ] + +-- | The core behind the cache at start, for an ideal system at start: the same +-- core and input, and the cache at start in front of its memory. +cachedStart :: SysG r m -> CachedSysG r m +cachedStart (Sys core inp mem) = CachedSys core inp (initCacheSrv mem) + +-- | The cached system as an ideal one: its core and input, and the memory +-- behind the cache. +idealView :: CachedSysG r m -> SysG r m +idealView (CachedSys core inp srv) = Sys core inp (srvMem srv) + +-- | Has the core not halted yet? +running :: StateG r -> Bool +running = isNothing . stateHalt + +-- | The ISA state a program at start corresponds to: execution begins at +-- 'initPc', with the system's register file and memory. +isaStart :: Sys -> IsaState +isaStart (Sys core _ mem) = IsaState initPc (stateRegFile core) mem + +-- | The bus observations of the core behind the cache, cycle by cycle, until it +-- halts. +cachedObs :: Int -> Sys -> [Obs] +cachedObs n sys = go n (cachedStart sys) + where + go :: Int -> CachedSys -> [Obs] + go 0 _ = [] + go j csys + | P.not (running (cachedCore csys)) = [] + | otherwise = let (csys', o) = stepCachedOut csys in obsOf o : go (j - 1) csys' + +-- | The cycles in which the core behind the cache waits, until it halts. +stallCycles :: Sys -> Int +stallCycles sys = go (600 :: Int) (cachedStart sys) + where + go 0 _ = 0 + go j csys + | P.not (running (cachedCore csys)) = 0 + | otherwise = + (if isNothing (inputMem (cachedInput csys)) then 1 else 0) + + go (j - 1) (stepCached csys) + +-- | The core's bus observations computed from the leakage alone, hop by hop, +-- as behind ideal memory: the core's simulator +-- ('Proof.Core.Leakage.Simulator.simCircuit') run on the ISA's leakage trace. +-- +-- The hops are those of 'ProofSpec.leakReport': the first gets no leakage, +-- and every later one gets @'leakOf' isa@ on its first cycle, after which the +-- ISA steps. A halted ISA stands still. +simHops :: Sys -> [[Obs]] +simHops sys0 = go Nothing (isaStart sys0) simInit + where + go :: SimInput -> IsaState -> SimState -> [[Obs]] + go inp isa sim = + let (sim', os) = runSim (simDriver inp sim + 1) inp sim + isa' = case inp of + Nothing -> isa + Just _ -> isaNext isa + in os : go (Just (leakOf isa')) isa' sim' + -- The simulator for @n@ cycles; it gets @inp@ on the first only. + runSim :: Int -> SimInput -> SimState -> (SimState, [Obs]) + runSim 0 _ sim = (sim, []) + runSim n inp sim = + let (sim1, o) = simCircuit sim inp + (sim2, os) = runSim (n - 1) Nothing sim1 + in (sim2, o : os) + isaNext isa = case isaStep isa of + Next isa' -> isa' + IsaHalted -> isa + +-- | The bus trace of the core behind the cache, from the leakage alone: the +-- core's simulator gives each cycle of the core behind ideal memory +-- ('simHops'), and link 2's simulator +-- ("Proof.Cache.CachedCore.Leakage.Simulator") adds the cycles in which the +-- core waits for the cache. +compositeTrace :: Int -> Sys -> [Obs] +compositeTrace n sys0 = go (P.concat (P.take n (simHops sys0))) simInitCachedSys + where + go :: [Obs] -> SimCachedSys -> [Obs] + go [] _ = [] + go (obs : rest) sim = + let (sim', bus) = simStepCached sim (Just obs) + in bus : waiting rest sim' + waiting rest sim + | simCachedAnswered sim = go rest sim + | otherwise = + let (sim', bus) = simStepCached sim Nothing + in bus : waiting rest sim' + +compositeReport :: Sys -> String +compositeReport sys0 + | cached == P.take (P.length cached) composite = "" + | otherwise = + "first difference at cycle " P.++ show i P.++ ": " + P.++ show (P.take 6 (P.drop i cached)) P.++ " vs " + P.++ show (P.take 6 (P.drop i composite)) + where + cached = cachedObs 600 sys0 + composite = compositeTrace 600 sys0 + i = P.length (P.takeWhile id (P.zipWith (==) cached composite)) + +-- | Is the cache coherent with memory at every set the harness's memory can +-- fill? Memory is 'MEM_SIZE' words, 400 bytes, so only sets 0 to 24. +coherentLow :: MemBytes -> Cache4K -> Bool +coherentLow mem c = P.and [coherentAt s w mem c | s <- [0 .. 24], w <- [0 .. 3]] + +-- | Walk the cached system and the ideal one together for @n@ cycles of the +-- cached one, skipping the cached run's stall cycles -- those whose input is +-- 'Nothing' -- in the ideal one. Returns @\"\"@ if every stall cycle makes no +-- request and leaves the core alone, the cache stays coherent with memory, and +-- every other cycle makes the ideal run's request from the ideal run's state, +-- up to 'sameModuloCtrl'. +stutterReport :: Int -> Sys -> String +stutterReport n sys0 = go n (0 :: Int) (cachedStart sys0) sys0 + where + go :: Int -> Int -> CachedSys -> Sys -> String + go 0 _ _ _ = "" + go j c csys ideal + | P.not (running (cachedCore csys)) = "" + | P.not (coherentLow (srvMem srv) (srvCache srv)) = + failAt "the cache is not coherent with memory" "" + | isNothing (inputMem (cachedInput csys)) = + if obsOf oC /= NoAccess + then failAt "a stall cycle made a request: " (show (obsOf oC)) + else + if P.not (sameModuloCtrl (idealView csys) (withInput (idealView csys'))) + then + failAt "a stall cycle changed the core: " + (P.unwords (coreDiff (idealView csys) (withInput (idealView csys')))) + else go (j - 1) (c + 1) csys' ideal + | P.not (sameModuloCtrl (idealView csys) ideal) = + failAt "the cached core left the ideal run: " + (P.unwords (coreDiff ideal (idealView csys))) + | obsOf oC /= obsOf oI = failAt "different requests: " (show (obsOf oC, obsOf oI)) + | otherwise = go (j - 1) (c + 1) csys' ideal' + where + srv = cachedSrv csys + -- The answer may arrive in a stall cycle; only the core must stay. + withInput (Sys core _ mem) = Sys core (cachedInput csys) mem + (csys', oC) = stepCachedOut csys + (ideal', oI) = stepSysOut ideal + failAt what detail = "\ncycle " P.++ show c P.++ ": " P.++ what P.++ detail P.++ "\n" + +-- Comparing systems ---------------------------------------------------------------- + +-- | Two systems equal in everything but the control lines, which the core +-- resets in every cycle before any stage reads them. +sameModuloCtrl :: Sys -> Sys -> Bool +sameModuloCtrl (Sys a ia ma) (Sys b ib mb) = + a {stateCtrl = initCtrl} == b {stateCtrl = initCtrl} + P.&& ia == ib + P.&& ma == mb + +-- | The fields, other than the control lines, on which two systems differ, as +-- @field(first | second)@. +coreDiff :: Sys -> Sys -> [String] +coreDiff (Sys a ia ma) (Sys b ib mb) = + P.concat + [ f "fePc" stateFePc, + f "dePc" stateDePc, + f "deExpInstr" stateDeExpInstr, + f "exPc" stateExPc, + f "ex" stateExInstr, + f "me" stateMeInstr, + f "meAddr" stateMeAddr, + f "meRes" stateMeRes, + f "wb" stateWbInstr, + f "wbRes" stateWbRes, + f "halt" stateHalt, + ["input(" P.++ show (inputMem ia) P.++ " | " P.++ show (inputMem ib) P.++ ")" | ia /= ib], + ["registers" | stateRegFile a /= stateRegFile b], + ["memory" | ma /= mb] + ] + where + f :: (Eq v, Show v) => String -> (State -> v) -> [String] + f name sel + | sel a == sel b = [] + | otherwise = [name P.++ "(" P.++ show (sel a) P.++ " | " P.++ show (sel b) P.++ ")"] + +-- Programs ------------------------------------------------------------------------- + +-- | The ISA-level constant-time leakage trace of the first @n@ instructions. +ctTrace :: Int -> IsaState -> [Leak] +ctTrace 0 _ = [] +ctTrace n isa = leakOf isa : case isaStep isa of + Next isa' -> ctTrace (n - 1) isa' + IsaHalted -> [] + +-- | Load a data image (word-aligned addresses below the program) into a system. +withData :: [(Address, Word)] -> Sys -> Sys +withData ws (Sys s i m) = Sys s i (P.foldr (\(a, w) -> memWrite a Types.Word w) m ws) + +genData :: Gen [(Address, Word)] +genData = + P.mapM (\k -> (\w -> (4 * k, w)) <$> elements [0, 1, 4, 0x10, 0x40, 0xDEADBEEF]) [0 .. 49] + +-- | Random programs whose loads, stores and @jalr@s go through base registers. +-- +-- @x5@ and @x6@ are reserved as base registers: they are written only by +-- @addi@ from @x0@, with a word-aligned data address (below 'initPc') or the +-- address of an instruction of the program. Stores through them therefore also +-- hit the code, which raises store hazards; they store @x0@, so an overwritten +-- instruction decodes to @Nop DecodeFail@. Every access stays inside the +-- harness's memory. A @jalr@ off @x0@, whose target fits the immediate, is +-- generated as well. +genCTProg :: Gen (Vec PROG_SIZE Word) +genCTProg = do + n <- choose (2, 12) + body <- P.mapM (genCTInstr n) [0 .. n - 1] + let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break + pure (map encode (unsafeFromList instrs)) + +genCTInstr :: Int -> Int -> Gen Instruction +genCTInstr n i = + frequency + [ (2, RType <$> genArith <*> genDst <*> genSrc <*> genSrc), + (1, IType <$> (Arith <$> genArith) <*> genDst <*> genSrc <*> genSmallImm), + (3, (\b a -> IType (Arith ADD) b 0 (fromIntegral a)) <$> genBase <*> genAddrImm), + ( 3, + (\size sign rd b off -> IType (Load size sign) rd b off) + <$> genSize + <*> elements [Signed, Unsigned] + <*> genDst + <*> genBase + <*> genOff + ), + (3, (\size off b -> SType size off b 0) <$> genSize <*> genOff <*> genBase), + (1, (\t -> SType Types.Word (fromIntegral (codeAddr t)) 0 0) <$> choose (0, n)), + ( 2, + (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] + <*> choose (0, n) + <*> genSrc + <*> genSrc + ), + (1, (\rd t -> JType rd (fromIntegral ((t - i) * 4))) <$> genDst <*> choose (0, n)), + (1, (\b -> IType Jump 0 b 0) <$> genBase), + (1, (\t -> IType Jump 0 0 (fromIntegral (codeAddr t))) <$> choose (0, n)) + ] + where + genArith = elements [ADD, SUB, XOR, OR, AND, SLT, SLTU] + genSize = elements [Byte, Half, Types.Word] + genSmallImm = fromIntegral <$> choose (0 :: Int, 15) + -- Base registers, and everything else. + genBase = elements [5, 6] + genDst = elements [1, 2, 3, 4, 7] + genSrc = elements [0, 1, 2, 3, 4, 5, 6, 7] + genOff = (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 2) + codeAddr t = fromIntegral initPc + 4 * t :: Int + genAddrImm = + oneof + [ (\k -> 4 * k) <$> choose (0 :: Int, 40), + codeAddr <$> choose (0, n) + ] + +-- | Programs whose control flow and addresses never depend on loaded data. +-- +-- As 'genCTProg', with @x5@ and @x6@ the base registers, set only from +-- constants; loads write @x1@ to @x4@ and @x7@, and branches compare only +-- @x0@, @x5@ and @x6@, so no loaded value reaches a branch or an address. +-- Stores store @x0@, so no loaded value reaches memory either. +genSecretFreeProg :: Gen (Vec PROG_SIZE Word) +genSecretFreeProg = do + n <- choose (2, 12) + body <- P.mapM (genOne n) [0 .. n - 1] + let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break + pure (map encode (unsafeFromList instrs)) + where + genOne n i = + frequency + [ (2, RType <$> elements [ADD, SUB, XOR, OR, AND] <*> genDst <*> genAny <*> genAny), + (3, (\b a -> IType (Arith ADD) b 0 (fromIntegral a)) <$> genBase <*> genAddrImm n), + ( 3, + (\size sign rd b off -> IType (Load size sign) rd b off) + <$> elements [Byte, Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> genDst + <*> genBase + <*> genOff + ), + (2, (\size off b -> SType size off b 0) <$> elements [Byte, Half, Types.Word] <*> genOff <*> genBase), + ( 2, + (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] + <*> choose (0, n) + <*> genCtl + <*> genCtl + ), + (1, (\rd t -> JType rd (fromIntegral ((t - i) * 4))) <$> genDst <*> choose (0, n)) + ] + + genBase = elements [5, 6] + genCtl = elements [0, 5, 6] + genDst = elements [1, 2, 3, 4, 7] + genAny = elements [0, 1, 2, 3, 4, 5, 6, 7] + genOff = (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 2) + genAddrImm n = + oneof + [ (\k -> 4 * k) <$> choose (0 :: Int, 40), + (\t -> fromIntegral initPc + 4 * t) <$> choose (0, n) + ] + +-- | Programs whose loads and stores have every width and alignment, including +-- reads and writes that straddle two lines. +-- +-- Base registers @x5@ and @x6@ are set only from constants, to data addresses, +-- so no access reaches the program; offsets are any byte offset up to 11. +-- Stores store data registers, loads write them, and branches compare them, so +-- loaded values flow back into memory and into control flow. +genByteProg :: Gen (Vec PROG_SIZE Word) +genByteProg = do + n <- choose (2, 14) + body <- P.mapM (genOne n) [0 .. n - 1] + let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break + pure (map encode (unsafeFromList instrs)) + where + genOne n i = + frequency + [ (2, RType <$> elements [ADD, SUB, XOR, OR, AND] <*> genDst <*> genDst <*> genDst), + (3, (\b k -> IType (Arith ADD) b 0 (fromIntegral (4 * k :: Int))) <$> genBase <*> choose (0, 40)), + ( 4, + (\size sign rd b off -> IType (Load size sign) rd b off) + <$> elements [Byte, Half, Types.Word] + <*> elements [Signed, Unsigned] + <*> genDst + <*> genBase + <*> genOff + ), + (3, (\size off b rs2 -> SType size off b rs2) <$> elements [Byte, Half, Types.Word] <*> genOff <*> genBase <*> genDst), + ( 1, + (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) + <$> elements [EQ, NE, LT, GE, LTU, GEU] + <*> choose (i + 1, n) + <*> genDst + <*> genDst + ) + ] + + genBase = elements [5, 6] + genDst = elements [1, 2, 3, 4] + genOff = fromIntegral <$> choose (0 :: Int, 11) + +-- | An instruction that survives encoding, or @addi x0, x0, 0@. +roundTrips :: Instruction -> Instruction +roundTrips ir = case encode' ir of + Just w | decode' w == ir -> ir + _ -> IType (Arith ADD) 0 0 0 diff --git a/test/CompositionSpec.hs b/test/CompositionSpec.hs deleted file mode 100644 index 3ad5cb1..0000000 --- a/test/CompositionSpec.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE PackageImports #-} - --- | The core behind a cache: what holds for any cache, and the programs and --- traces the cache tests ("Cache4KSpec") are built from. --- --- The constant-time leakage proof ("Proof.Core.Leakage.Solver") is about the core --- attached to memory that answers every request in the next cycle. Behind a --- cache a load that misses is answered only after the miss penalty, and in the --- meantime the core stalls. The core's side of what lets the ideal-memory result --- carry over is checked here: after a data read the core waits --- ('Proof.CachedCore.Obligation.waitObligation'), and a stall cycle is a stutter step --- ('Proof.CachedCore.Obligation.stallObligation'). -module CompositionSpec - ( compositionTests, - sameModuloCtrl, - coreDiff, - ctTrace, - genByteProg, - genCTProg, - genData, - genSecretFreeProg, - genWord, - simHops, - withData, - ) -where - -import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Clash.Sized.Vector (unsafeFromList) -import Core -import Data.Functor.Identity (Identity (..)) -import Core.ISA (IsaState, StepG (..), isaStep) -import Core.Instruction -import Memory.Types -import Proof.CachedCore.Obligation (stallObligation, waitObligation) -import Proof.Core.Leakage.Model -import Proof.Core.Functional.Obligation (isaAt) -import Proof.Core.Leakage.Driver (simDriver) -import Proof.Core.Leakage.Simulator (SimInput, SimState, simCircuit, simInit) -import Proof.Core.Functional.Machine -import ProofSpec (genArbSys1) -import Core.RegFile (RegFileOps) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck -import "aimcore" Types -import Prelude hiding (Ordering (..), Word, init, log, map, not, undefined, (!!), (&&), (++), (||)) -import qualified Prelude as P - --- | Two systems equal in everything but the control lines, which --- 'Core.withCtrlReset' overwrites before any stage reads them. -sameModuloCtrl :: Sys -> Sys -> Bool -sameModuloCtrl (Sys a ia ma) (Sys b ib mb) = - a {stateCtrl = initCtrl} == b {stateCtrl = initCtrl} - P.&& runIdentity (inputMem ia) == runIdentity (inputMem ib) - P.&& inputMemReady ia == inputMemReady ib - P.&& ma == mb - --- | The fields, other than the control lines, on which two systems differ, as --- @field(first | second)@. -coreDiff :: Sys -> Sys -> [String] -coreDiff (Sys a ia ma) (Sys b ib mb) = - P.concat - [ f "fePc" stateFePc, - f "dePc" stateDePc, - f "deExpInstr" stateDeExpInstr, - f "exPc" stateExPc, - f "ex" stateExInstr, - f "me" stateMeInstr, - f "meAddr" stateMeAddr, - f "meRes" (runIdentity . stateMeRes), - f "wb" stateWbInstr, - f "wbRes" (runIdentity . stateWbRes), - f "halt" stateHalt, - f "loadInFlight" stateLoadInFlight, - g "bus" (runIdentity . inputMem), - g "ready" inputMemReady, - ["registers" | stateRegFile a /= stateRegFile b], - ["memory" | ma /= mb] - ] - where - f :: (Eq v, Show v) => String -> (State Identity -> v) -> [String] - f name sel - | sel a == sel b = [] - | otherwise = [name P.++ "(" P.++ show (sel a) P.++ " | " P.++ show (sel b) P.++ ")"] - g :: (Eq v, Show v) => String -> (Input Identity -> v) -> [String] - g name sel - | sel ia == sel ib = [] - | otherwise = [name P.++ "(" P.++ show (sel ia) P.++ " | " P.++ show (sel ib) P.++ ")"] - --- | The ISA-level constant-time leakage trace of the first @n@ instructions. -ctTrace :: Int -> IsaState -> [Leak] -ctTrace 0 _ = [] -ctTrace n a = leakOf a : case isaStep a of - Next a' -> ctTrace (n - 1) a' - IsaHalted -> [] - --- | Load a data image (word-aligned addresses below the program) into a system. -withData :: [(Address, Word)] -> Sys -> Sys -withData ws (Sys s i m) = Sys s i (P.foldr (\(a, w) -> memWrite a Types.Word w) m ws) - -genData :: Gen [(Address, Word)] -genData = - P.mapM (\k -> (\w -> (4 * k, w)) <$> elements [0, 1, 4, 0x10, 0x40, 0xDEADBEEF]) [0 .. 49] - --- | Random programs whose loads, stores and @jalr@s go through base registers. --- --- @x5@ and @x6@ are reserved as base registers: they are written only by --- @addi@ from @x0@, with a word-aligned data address (below 'initPc') or the --- address of an instruction of the program. Stores through them therefore also --- hit the code, which raises store hazards; they store @x0@, so an overwritten --- instruction decodes to @Nop DecodeFail@. Every access stays inside the --- harness's memory. A @jalr@ off @x0@, whose target fits the immediate, is --- generated as well. -genCTProg :: Gen (Vec PROG_SIZE Word) -genCTProg = do - n <- choose (2, 12) - body <- P.mapM (genCTInstr n) [0 .. n - 1] - let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break - pure (map encode (unsafeFromList instrs)) - where - roundTrips i = case encode' i of - Just w | decode' w == i -> i - _ -> IType (Arith ADD) 0 0 0 - -genCTInstr :: Int -> Int -> Gen Instruction -genCTInstr n i = - frequency - [ (2, RType <$> genArith <*> genDst <*> genSrc <*> genSrc), - (1, IType <$> (Arith <$> genArith) <*> genDst <*> genSrc <*> genSmallImm), - (3, (\b a -> IType (Arith ADD) b 0 (fromIntegral a)) <$> genBase <*> genAddr), - ( 3, - (\size sign rd b off -> IType (Load size sign) rd b off) - <$> genSize - <*> elements [Signed, Unsigned] - <*> genDst - <*> genBase - <*> genOff - ), - (3, (\size off b -> SType size off b 0) <$> genSize <*> genOff <*> genBase), - (1, (\t -> SType Word (fromIntegral (codeAddr t)) 0 0) <$> choose (0, n)), - ( 2, - (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) - <$> elements [EQ, NE, LT, GE, LTU, GEU] - <*> choose (0, n) - <*> genSrc - <*> genSrc - ), - (1, (\rd t -> JType rd (fromIntegral ((t - i) * 4))) <$> genDst <*> choose (0, n)), - (1, (\b -> IType Jump 0 b 0) <$> genBase), - (1, (\t -> IType Jump 0 0 (fromIntegral (codeAddr t))) <$> choose (0, n)) - ] - where - genArith = elements [ADD, SUB, XOR, OR, AND, SLT, SLTU] - genSize = elements [Byte, Half, Word] - genSmallImm = fromIntegral <$> choose (0 :: Int, 15) - -- Base registers, and everything else. - genBase = elements [5, 6] - genDst = elements [1, 2, 3, 4, 7] - genSrc = elements [0, 1, 2, 3, 4, 5, 6, 7] - genOff = (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 2) - codeAddr t = fromIntegral initPc + 4 * t :: Int - genAddr = - oneof - [ (\k -> 4 * k) <$> choose (0 :: Int, 40), - codeAddr <$> choose (0, n) - ] - --- | Programs whose control flow and addresses never depend on loaded data. --- --- As 'genCTProg', with @x5@ and @x6@ the base registers, set only --- from constants; loads write @x1@ to @x4@ and @x7@, and branches compare only --- @x0@, @x5@ and @x6@, so no loaded value reaches a branch or an address. Stores --- store @x0@, so no loaded value reaches memory either. -genSecretFreeProg :: Gen (Vec PROG_SIZE Word) -genSecretFreeProg = do - n <- choose (2, 12) - body <- P.mapM (genOne n) [0 .. n - 1] - let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break - pure (map encode (unsafeFromList instrs)) - where - roundTrips i = case encode' i of - Just w | decode' w == i -> i - _ -> IType (Arith ADD) 0 0 0 - - genOne n i = - frequency - [ (2, RType <$> elements [ADD, SUB, XOR, OR, AND] <*> genDst <*> genAny <*> genAny), - (3, (\b a -> IType (Arith ADD) b 0 (fromIntegral a)) <$> genBase <*> genAddr n), - ( 3, - (\size sign rd b off -> IType (Load size sign) rd b off) - <$> elements [Byte, Half, Types.Word] - <*> elements [Signed, Unsigned] - <*> genDst - <*> genBase - <*> genOff - ), - (2, (\size off b -> SType size off b 0) <$> elements [Byte, Half, Types.Word] <*> genOff <*> genBase), - ( 2, - (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) - <$> elements [EQ, NE, LT, GE, LTU, GEU] - <*> choose (0, n) - <*> genCtl - <*> genCtl - ), - (1, (\rd t -> JType rd (fromIntegral ((t - i) * 4))) <$> genDst <*> choose (0, n)) - ] - - genBase = elements [5, 6] - genCtl = elements [0, 5, 6] - genDst = elements [1, 2, 3, 4, 7] - genAny = elements [0, 1, 2, 3, 4, 5, 6, 7] - genOff = (\k -> fromIntegral (k * 4)) <$> choose (0 :: Int, 2) - genAddr n = - oneof - [ (\k -> 4 * k) <$> choose (0 :: Int, 40), - (\t -> fromIntegral initPc + 4 * t) <$> choose (0, n) - ] - --- | Programs whose loads and stores have every width and alignment, including --- reads and writes that straddle two blocks. --- --- Base registers @x5@ and @x6@ are set only from constants, to data addresses, --- so no access reaches the program; offsets are any byte offset up to 11. --- Stores store data registers, loads write them, and branches compare them, so --- loaded values flow back into memory and into control flow. -genByteProg :: Gen (Vec PROG_SIZE Word) -genByteProg = do - n <- choose (2, 14) - body <- P.mapM (genOne n) [0 .. n - 1] - let instrs = P.map roundTrips body P.++ P.replicate (50 - n) Core.Instruction.break - pure (map encode (unsafeFromList instrs)) - where - roundTrips i = case encode' i of - Just w | decode' w == i -> i - _ -> IType (Arith ADD) 0 0 0 - - genOne n i = - frequency - [ (2, RType <$> elements [ADD, SUB, XOR, OR, AND] <*> genDst <*> genDst <*> genDst), - (3, (\b k -> IType (Arith ADD) b 0 (fromIntegral (4 * k :: Int))) <$> genBase <*> choose (0, 40)), - ( 4, - (\size sign rd b off -> IType (Load size sign) rd b off) - <$> elements [Byte, Half, Types.Word] - <*> elements [Signed, Unsigned] - <*> genDst - <*> genBase - <*> genOff - ), - (3, (\size off b rs2 -> SType size off b rs2) <$> elements [Byte, Half, Types.Word] <*> genOff <*> genBase <*> genDst), - ( 1, - (\cmp t rs1 rs2 -> BType cmp (fromIntegral ((t - i) * 4)) rs1 rs2) - <$> elements [EQ, NE, LT, GE, LTU, GEU] - <*> choose (i + 1, n) - <*> genDst - <*> genDst - ) - ] - - genBase = elements [5, 6] - genDst = elements [1, 2, 3, 4] - genOff = fromIntegral <$> choose (0 :: Int, 11) - -genWord :: Gen Word -genWord = oneof [elements [0, 1, 0xFF, 0x1234, 0x80000000, 0xDEADBEEF], fromIntegral <$> (arbitrary :: Gen Int)] - --- | The core's bus observations computed from the leakage alone, hop by hop, as --- behind ideal memory: the leakage simulator ('Proof.Core.Leakage.Simulator.simCircuit') --- run on the ISA's leakage trace. --- --- The hops are those of 'ProofSpec.leakReport': the first gets no leakage, and --- every later one gets @'leakOf' isa@ on its first cycle, after which the ISA --- steps. A halted ISA stands still. -simHops :: Sys -> [[Obs]] -simHops sys0 = go Nothing (isaAt (stateFePc (sysCore sys0)) sys0) simInit - where - go :: SimInput -> IsaState -> SimState -> [[Obs]] - go inp a sim = - let (sim', os) = runSim (simDriver inp sim + 1) inp sim - a' = case inp of - Nothing -> a - Just _ -> isaNext a - in os : go (Just (leakOf a')) a' sim' - -- The simulator for @n@ cycles; it gets @inp@ on the first only. - runSim :: Int -> SimInput -> SimState -> (SimState, [Obs]) - runSim 0 _ sim = (sim, []) - runSim n inp sim = - let (sim1, o) = simCircuit sim inp - (sim2, os) = runSim (n - 1) Nothing sim1 - in (sim2, o : os) - isaNext a = case isaStep a of - Next a' -> a' - IsaHalted -> a - --- | A load to put into the memory stage, or none. -genMeLoad :: Gen (Maybe Instruction) -genMeLoad = - frequency - [ (1, pure Nothing), - ( 4, - (\size sign rd rs1 imm -> Just (IType (Load size sign) rd rs1 imm)) - <$> elements [Byte, Half, Types.Word] - <*> elements [Signed, Unsigned] - <*> (fromIntegral <$> choose (0 :: Int, 31)) - <*> (fromIntegral <$> choose (0 :: Int, 31)) - <*> (fromIntegral <$> choose (0 :: Int, 63)) - ) - ] - --- | Does a cycle of the core from this state issue a data read? -issuesDataRead :: (RegFileOps r) => StateG r Identity -> Input Identity -> Bool -issuesDataRead s inp = case outMem (snd (circuit s inp)) of - Just (MemAccess False _ _ Nothing) -> True - _ -> False - -compositionTests :: TestTree -compositionTests = - testGroup - "Core behind a cache" - [ testProperty "patience: after a data read the core waits" $ - -- Arbitrary states, mostly with a load in the memory stage and none in - -- flight, so that the cycle issues a data read. - withMaxSuccess 5000 $ checkCoverage $ - forAllShow genArbSys1 (const "") $ \(Sys s0 inp _, _, _) -> - forAll genMeLoad $ \me -> - let s = maybe s0 (\ir -> s0 {stateMeInstr = ir, stateLoadInFlight = False}) me - in cover 50 (issuesDataRead s inp) "the cycle issues a data read" (waitObligation s inp), - testProperty "a stall cycle is a stutter step, on arbitrary stalled states" $ - withMaxSuccess 5000 $ - forAllShow genArbSys1 (const "") $ \(Sys st inp _, wr, _) -> - isLoad (stateWbInstr st) ==> - stallObligation wr st {stateLoadInFlight = True} inp {inputMemReady = False} - ] diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index 475d990..d1bb76e 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PackageImports #-} -module ProofSpec (proofTests, progs, initSys, alignedWalk, invTrace, invReport, genProg, genArbSys, genArbSys1, genArbSys2, genArbSys3, genTakenTransfer) where +module ProofSpec (proofTests, progs, initSysProg, 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) @@ -10,7 +10,7 @@ import Core.ISA (IsaStateG (..), IsaState, StepG (..), isaStep, isaInstrAt) import Core.Instruction import Proof.Core.Functional.Invariant import Proof.Core.Functional.Machine -import Proof.Core.Functional.Obligation (indStep0, indStep1, indStep2, isaAt) +import Proof.Core.Functional.Obligation (indStep0, indStep1, indStep2) import Proof.Core.Leakage.Driver (simDriver) import Proof.Core.Leakage.Invariant (simInv) import Proof.Core.Leakage.Model (Obs, leakOf, obsOf) @@ -35,14 +35,14 @@ stepSysN n s -- | 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'. +-- see 'Proof.Core.Functional.Driver.isBubble'. aligned :: Sys -> Bool -aligned s = not (isBubble (stateExInstr (sysCore s))) || stateExInstr (sysCore s) == Nop FirstCycle +aligned s = not (isBubble s) || stateExInstr (sysCore 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) +alignedWalk k prog = go k 0 (initSysProg prog) where go 0 _ _ = [] go j i s = @@ -69,18 +69,14 @@ walkReport k prog = stateHalt (sysCore s') == Nothing ] --- | The system as it starts up, with @prog@ loaded at 'initPc'. -initSys :: Vec PROG_SIZE Word -> Sys -initSys prog = - Sys - { sysCore = Core.init, - sysInput = initInput, - sysMem = mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog - } +-- | The system as it starts up, with @prog@ loaded at 'initPc' and the +-- register file zeroed ('Proof.Core.Functional.Machine.initSys'). +initSysProg :: Vec PROG_SIZE Word -> Sys +initSysProg prog = initSys initPc initRFg (mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog) -- | The architectural state @prog@ starts in: execution begins at 'initPc', the -- register file is zeroed, and memory holds the program. The counterpart of --- 'initSys' on the ISA side. +-- 'initSysProg' on the ISA side. initIsa :: Vec PROG_SIZE Word -> IsaState initIsa prog = IsaState initPc initRF (mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog) @@ -90,18 +86,18 @@ initIsa prog = IsaState initPc initRF (mkRAM @PROG_SIZE @RAM_SIZE_BYTES prog) baseHolds :: Vec PROG_SIZE Word -> Bool baseHolds prog = driver sys0 P.== 1 - P.&& driverRef 12 sys0 P.== Just 2 + P.&& driverSpec 12 sys0 P.== Just 1 P.&& inv (initIsa prog) (stepSysN 2 sys0) where - sys0 = initSys prog + sys0 = initSysProg prog baseReport :: Vec PROG_SIZE Word -> String baseReport prog = "driver=" P.++ show (driver sys0) - P.++ " driverRef=" P.++ show (driverRef 12 sys0) + P.++ " driverSpec=" P.++ show (driverSpec 12 sys0) P.++ "\n" P.++ explain (initIsa prog) (stepSysN 2 sys0) where - sys0 = initSys prog + sys0 = initSysProg prog -- | The driver and the ISA walked in lockstep, at every state the invariant is -- meant to hold. @@ -115,7 +111,7 @@ invTrace :: Int -> Vec PROG_SIZE Word -> [(Int, IsaState, Sys)] invTrace k prog = go k 0 isa0 sys0 True where isa0 = initIsa prog - sys0 = initSys prog + sys0 = initSysProg prog go 0 _ _ _ _ = [] go j c isa sys firstHop = @@ -177,7 +173,7 @@ leakReport k prog = Just problem -> "first hop: " P.++ problem Nothing -> go k (driver sys0 + 1) (initIsa prog) sysAfter simAfter where - sys0 = initSys prog + sys0 = initSysProg prog firstHop@(sysAfter, simAfter, _, _) = runHop (driver sys0 + 1) sys0 simInit Nothing go :: Int -> Int -> IsaState -> Sys -> SimState -> String @@ -350,21 +346,16 @@ proofTests = ], -- 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. + -- stage stops being a bubble. Halted states and @ecall@ / @ebreak@ are + -- included: @Nop Halted@ is not a bubble ('isBubble'). testCase "driver agrees with its operational reading" $ let bad = [ (driver sys, ref, stateExInstr (sysCore sys)) | prog <- allProgs 500, (_, _, sys) <- invTrace 40 prog, - stateHalt (sysCore sys) == Nothing, aligned sys, - P.not (isEnvInstr (stateExInstr (sysCore sys))), - let ref = driverRef 12 sys, - ref /= Just (driver sys + 1) + let ref = driverSpec 12 sys, + ref /= Just (driver sys) ] in if P.null bad then pure () else assertFailure (show (P.take 10 bad)), -- The leakage simulator alongside the core: matching hop lengths and bus @@ -405,7 +396,7 @@ proofTests = -- 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.Core.Functional.Invariant.flushMeStage'. It fails if those clauses + -- 'Proof.Core.Functional.Invariant.applyMeStage'. 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)]] @@ -478,7 +469,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')))) ) - (indStep0 wr wa (stateExPc (sysCore sys)) sys), + (indStep0 wr wa sys), -- 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. @@ -498,14 +489,14 @@ 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)))) ) - (indStep1 wr wa (stateExPc (sysCore sys)) sys), + (indStep1 wr wa sys), testCase "k=1 generator satisfies the premise" $ let sample = [s | (s, _, _) <- unGen (vectorOf 4000 genArbSys1) (mkQCGen 7) 30] admitted = [ () | s <- sample, driver s P.== 1, - invAt 1 0 (isaAt (stateExPc (sysCore s)) s) s + invAt 1 0 (isaOf s) s ] 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 @@ -523,14 +514,14 @@ proofTests = P.++ "\nexPc=" P.++ show (stateExPc (sysCore sys)) P.++ " wr=" P.++ show wr P.++ " wa=" P.++ show wa ) - (indStep2 wr wa (stateExPc (sysCore sys)) sys), + (indStep2 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, - invAt wr wa (isaAt (stateExPc (sysCore s)) s) s + invAt wr wa (isaOf s) s ] has label = P.any ((P.== label) . P.fst) sample in do @@ -555,12 +546,12 @@ proofTests = -- 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 +-- | The architectural state that makes the pending-writes 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.Core.Functional.Solver.indStep0' via "Proof.Core.Functional.Obligation", so the two cannot drift. isaFromSys :: (RegFileOps r, MemOps m) => SysG r m -> IsaStateG r m -isaFromSys sys = isaAt (stateExPc (sysCore sys)) sys +isaFromSys sys = isaOf 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 @@ -641,7 +632,7 @@ wrapMem = MemFn bytes wrapCESys :: SysG RegFn MemFn wrapCESys = Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = 0x00000000, stateDePc = 0xFFFFFFFC, stateDeExpInstr = True, @@ -842,7 +833,7 @@ genArbSys = do wa <- unpack <$> genW let sys = Sys - ((sysCore (initSys (mkProg prog1))) + ((sysCore (initSysProg (mkProg prog1))) { stateFePc = base + 8, stateDePc = base + 4, stateDeExpInstr = True, @@ -925,7 +916,7 @@ genRunning2 label genEx = do wa <- unpack <$> genW let sys = Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = fePc, stateDePc = base + 4, stateDeExpInstr = P.not wbMem, @@ -985,7 +976,7 @@ genSteady2 = do wa <- unpack <$> genW let sys = Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = base + 4, stateDePc = base + 4, stateDeExpInstr = False, @@ -1029,7 +1020,7 @@ genSteady1 = do wa <- unpack <$> genW let sys = Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = base + 4, stateDePc = base + 4, stateDeExpInstr = False, @@ -1248,7 +1239,7 @@ genTakenTransfer useJalr = do mkSys w0 rfun = Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = fePc, stateDePc = base + 4, stateDeExpInstr = P.not wbMem, @@ -1362,7 +1353,7 @@ mk3 base exI meI wbI nextI wbMem = do | P.otherwise = 0 P.pure ( Sys - ( (sysCore (initSys (mkProg prog1))) + ( (sysCore (initSysProg (mkProg prog1))) { stateFePc = if wbMem then base + 4 else base + 8, stateDePc = base + 4, stateDeExpInstr = P.not wbMem, diff --git a/test/Spec.hs b/test/Spec.hs index 6b9bd58..afbe54f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,6 +7,8 @@ module Main (main) where import BenchmarkSpec (benchmarkTests) +import Cache4KSpec (cache4KTests) +import CacheProofSpec (cacheProofTests) import Clash.Prelude hiding (Log, Ordering (..), Word, break, def, init, lift, log, resize) import Clash.Sized.Vector (unsafeFromList) import Control.Monad @@ -23,7 +25,10 @@ import qualified Proof.SMT.Sanity as Sanity #endif import qualified Prelude #ifdef SMT_PROOF -import qualified Proof.Cache.Functional.Solver +import qualified Proof.Cache.Server.Functional.Solver +import qualified Proof.Cache.Server.Leakage.Solver +import qualified Proof.Cache.CachedCore.Functional.Solver +import qualified Proof.Cache.CachedCore.Leakage.Solver import qualified Proof.Core.Functional.Solver import qualified Proof.Core.Leakage.Solver #endif @@ -74,6 +79,12 @@ sanityTests = lookup "arrRoundTripP" Proof.Core.Functional.Solver.results @?= Just Nothing, testCase "shift embeddings are sane" $ lookup "shiftsSaneP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "on states in the invariant, the driver agrees with its reading" $ + lookup "driverMatchesSpecP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "on the initial system, the driver agrees with its reading" $ + lookup "driverMatchesSpecInitP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "the driver gives only the steps' hop lengths" $ + lookup "driverValuesP" Proof.Core.Functional.Solver.results @?= Just Nothing, testCase "base case: invariant holds after the reset hop" $ lookup "baseCaseP" Proof.Core.Functional.Solver.results @?= Just Nothing, testCase "k = 0 inductive step is valid" $ @@ -84,10 +95,18 @@ sanityTests = lookup "indStep2P" Proof.Core.Functional.Solver.results @?= Just Nothing, testCase "k = 3 inductive step is valid" $ lookup "indStep3P" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant implies the ISA's register file is the core's, flushed" $ + testCase "the invariant implies the ISA's PC is the core's architectural one" $ + lookup "pcUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "the invariant implies the ISA's register file is the core's architectural one" $ lookup "regFileUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, - testCase "the invariant implies the ISA's memory is the core's, flushed" $ + testCase "the invariant implies the ISA's memory is the core's architectural one" $ lookup "memUnderInvP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "the invariant is functional: it relates one ISA state to a system" $ + lookup "invFunctionalP" Proof.Core.Functional.Solver.results @?= Just Nothing, + testCase "the simulator's driver agrees with its operational reading" $ + lookup "simDriverMatchesSpecP" Proof.Core.Leakage.Solver.results @?= Just Nothing, + testCase "on the initial simulator, its driver agrees with its reading" $ + lookup "simDriverMatchesSpecInitP" Proof.Core.Leakage.Solver.results @?= Just Nothing, testCase "leakage base case: simulator matches the first hop" $ lookup "baseCaseLeakP" Proof.Core.Leakage.Solver.results @?= Just Nothing, testCase "k = 0 leakage step is valid" $ @@ -100,19 +119,66 @@ sanityTests = lookup "indStepLeak3P" Proof.Core.Leakage.Solver.results @?= Just Nothing, testGroup "the 4 KiB cache answers as ideal memory, with delay" - [ testCase name $ lookup name Proof.Cache.Functional.Solver.results @?= Just Nothing + [ testCase name $ + lookup name Proof.Cache.Server.Functional.Solver.results + @?= Just Nothing | name <- [ "cacheArraysP", "coherentDataP", "coherentWriteP", "coherentLayoutP", + "srvDriverMatchesSpecP", + "srvDriverValuesP", + "srvInvFunctionalP", "baseCaseP", "indStep0P", "indStep4P", + "indStepWaits4P", "indStep8P", - "readyUnderInvP", - "readyIdleNoWaitP", - "waitsAfterRequestP" + "indStepWaits8P", + "srvReadyIffAnsweredP", + "srvReadyUnderInvP", + "corePatientP" + ] + ], + testGroup + "the 4 KiB cache leaks only its requests' observations" + [ testCase name $ + lookup name Proof.Cache.Server.Leakage.Solver.results + @?= Just Nothing + | name <- + [ "simSrvReadyIffAnsweredP", + "simSrvDriverMatchesSpecP", + "baseCaseLeakP", + "indStepLeakP" + ] + ], + testGroup + "the core behind the cache refines the core behind ideal memory" + [ testCase name $ + lookup name Proof.Cache.CachedCore.Functional.Solver.results + @?= Just Nothing + | name <- + [ "cachedDriverMatchesSpecP", + "cachedDriverValuesP", + "cachedInvFunctionalP", + "baseCaseP", + "indStep0P", + "indStep4P", + "indStep8P" + ] + ], + testGroup + "the core behind the cache leaks only what it leaks behind ideal memory" + [ testCase name $ + lookup name Proof.Cache.CachedCore.Leakage.Solver.results + @?= Just Nothing + | name <- + [ "simCachedDriverMatchesSpecP", + "baseCaseLeakP", + "indStepLeak0P", + "indStepLeak4P", + "indStepLeak8P" ] ] ] @@ -132,6 +198,8 @@ tests = sanityTests, #endif proofTests, + cache4KTests, + cacheProofTests, isaConformanceTests, instructionTests, testGroup From b2d29b0f69c436e7cb8489860650ed5906298eff Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 10:52:59 +0100 Subject: [PATCH 5/6] Restructure the layout: Core.Pipeline, Core.Alu, Proof/Core/SMT, Proof/Memory/Cache4K The core's modules all live in src/Core now, as memory's live in src/Memory: Core, the pipeline, becomes Core.Pipeline. Files that write Core.x import it as Core, so only their import lines change. The ALU and branch semantics (alu, branch and the shift wrappers sllWord, srlWord, sraWord) move out of the pipeline into Core.Alu. The ISA imports them from there and no longer depends on the pipeline. The proofs follow the same layout. The cache's proof moves from Proof/Cache to Proof/Memory/Cache4K, after src/Memory/Cache4K. The SMT embeddings are split: memory's array, toInteger on Unsigned and the base axioms stay shared in Proof/SMT (axioms, memAxioms); the core's register file and shifts move to Proof/Core/SMT, whose arrayAxioms adds them on top. Comment references follow, rewrapped to 80 columns. stack test without the solver passes: 164 of 164; every solver module type-checks with the solver flag. The solver run is in progress. Co-Authored-By: Claude Opus 5.5 --- app/Main.hs | 2 +- package.yaml | 55 ++-- proof/Proof/Core/Functional/Driver.hs | 3 +- proof/Proof/Core/Functional/Invariant.hs | 2 +- proof/Proof/Core/Functional/Machine.hs | 2 +- proof/Proof/Core/Functional/Obligation.hs | 26 +- proof/Proof/Core/Functional/Solver.hs | 18 +- proof/Proof/Core/Functional/System.hs | 3 +- proof/Proof/Core/Leakage/Driver.hs | 10 +- proof/Proof/Core/Leakage/Invariant.hs | 2 +- proof/Proof/Core/Leakage/Model.hs | 3 +- proof/Proof/Core/Leakage/Simulator.hs | 6 +- proof/Proof/Core/Leakage/Solver.hs | 5 +- proof/Proof/Core/SMT/Array.hs | 198 ++++++++++++++ proof/Proof/Core/SMT/Axioms.hs | 50 ++++ .../Cache4K}/CachedCore/Functional/Driver.hs | 56 ++-- .../CachedCore/Functional/Invariant.hs | 18 +- .../Cache4K}/CachedCore/Functional/Machine.hs | 4 +- .../CachedCore/Functional/Obligation.hs | 70 ++--- .../Cache4K}/CachedCore/Functional/Solver.hs | 33 +-- .../Cache4K}/CachedCore/Leakage/Driver.hs | 34 +-- .../Cache4K}/CachedCore/Leakage/Invariant.hs | 19 +- .../Cache4K}/CachedCore/Leakage/Obligation.hs | 78 +++--- .../Cache4K}/CachedCore/Leakage/Simulator.hs | 28 +- .../Cache4K}/CachedCore/Leakage/Solver.hs | 30 ++- .../{Cache => Memory/Cache4K}/SMT/Array.hs | 6 +- .../{Cache => Memory/Cache4K}/SMT/Axioms.hs | 25 +- .../{Cache => Memory/Cache4K}/SMT/Coherent.hs | 14 +- .../{Cache => Memory/Cache4K}/SMT/Raw.hs | 7 +- .../Cache4K}/Server/Functional/Contract.hs | 21 +- .../Cache4K}/Server/Functional/Driver.hs | 22 +- .../Cache4K}/Server/Functional/Invariant.hs | 2 +- .../Cache4K}/Server/Functional/Obligation.hs | 30 +-- .../Cache4K}/Server/Functional/Solver.hs | 45 ++-- .../Cache4K}/Server/Leakage/Driver.hs | 27 +- .../Cache4K}/Server/Leakage/Invariant.hs | 6 +- .../Cache4K}/Server/Leakage/Model.hs | 4 +- .../Cache4K}/Server/Leakage/Obligation.hs | 14 +- .../Cache4K}/Server/Leakage/Simulator.hs | 19 +- .../Cache4K}/Server/Leakage/Solver.hs | 22 +- proof/Proof/SMT/Array.hs | 246 +++--------------- proof/Proof/SMT/Axioms.hs | 52 +--- src/Core/Alu.hs | 81 ++++++ src/Core/ISA.hs | 4 +- src/{Core.hs => Core/Pipeline.hs} | 69 +---- src/Core/RegFile.hs | 14 +- src/Elf/ElfLoader.hs | 2 +- src/Elf/Syscall.hs | 2 +- src/HardwareSim.hs | 2 +- src/Memory/Cache4K.hs | 5 +- src/Memory/Cache4KServer.hs | 2 +- src/Memory/Ideal.hs | 2 +- src/Memory/ST.hs | 2 +- src/Simulate.hs | 4 +- test/BenchmarkSpec.hs | 2 +- test/Cache4KSpec.hs | 6 +- test/CacheProofSpec.hs | 48 ++-- test/ProofSpec.hs | 2 +- test/Spec.hs | 18 +- 59 files changed, 834 insertions(+), 748 deletions(-) create mode 100644 proof/Proof/Core/SMT/Array.hs create mode 100644 proof/Proof/Core/SMT/Axioms.hs rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Functional/Driver.hs (56%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Functional/Invariant.hs (73%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Functional/Machine.hs (96%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Functional/Obligation.hs (66%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Functional/Solver.hs (84%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Leakage/Driver.hs (60%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Leakage/Invariant.hs (57%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Leakage/Obligation.hs (70%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Leakage/Simulator.hs (68%) rename proof/Proof/{Cache => Memory/Cache4K}/CachedCore/Leakage/Solver.hs (78%) rename proof/Proof/{Cache => Memory/Cache4K}/SMT/Array.hs (94%) rename proof/Proof/{Cache => Memory/Cache4K}/SMT/Axioms.hs (68%) rename proof/Proof/{Cache => Memory/Cache4K}/SMT/Coherent.hs (85%) rename proof/Proof/{Cache => Memory/Cache4K}/SMT/Raw.hs (79%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Functional/Contract.hs (86%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Functional/Driver.hs (71%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Functional/Invariant.hs (97%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Functional/Obligation.hs (88%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Functional/Solver.hs (86%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Driver.hs (69%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Invariant.hs (90%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Model.hs (90%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Obligation.hs (80%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Simulator.hs (87%) rename proof/Proof/{Cache => Memory/Cache4K}/Server/Leakage/Solver.hs (77%) create mode 100644 src/Core/Alu.hs rename src/{Core.hs => Core/Pipeline.hs} (88%) diff --git a/app/Main.hs b/app/Main.hs index c656b90..ff9e0c6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ import Clash.Prelude hiding (Log, Ordering (..), Word, break, def, init, lift, l import Control.Exception (catch) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Core as Core +import qualified Core.Pipeline as Core import Data.IORef import Elf.ElfLoader import Elf.Syscall (ProgramExitException (..), handleSyscall) diff --git a/package.yaml b/package.yaml index d722f44..4ef1ca0 100644 --- a/package.yaml +++ b/package.yaml @@ -108,16 +108,18 @@ library: when: - condition: flag(smt-proof) exposed-modules: - - Proof.Cache.Server.Functional.Solver - - Proof.Cache.Server.Leakage.Solver - - Proof.Cache.CachedCore.Functional.Solver - - Proof.Cache.CachedCore.Leakage.Solver + - Proof.Memory.Cache4K.Server.Functional.Solver + - Proof.Memory.Cache4K.Server.Leakage.Solver + - Proof.Memory.Cache4K.CachedCore.Functional.Solver + - Proof.Memory.Cache4K.CachedCore.Leakage.Solver - Proof.Core.Functional.Solver - Proof.Core.Leakage.Solver - Proof.SMT.Axioms - - Proof.Cache.SMT.Array - - Proof.Cache.SMT.Axioms - - Proof.Cache.SMT.Coherent + - Proof.Core.SMT.Array + - Proof.Core.SMT.Axioms + - Proof.Memory.Cache4K.SMT.Array + - Proof.Memory.Cache4K.SMT.Axioms + - Proof.Memory.Cache4K.SMT.Coherent - Proof.SMT.Logged - Proof.SMT.Sanity - Proof.Core.Functional.System @@ -126,24 +128,24 @@ library: # live in proof/ too, and must only be built with the smt-proof flag. other-modules: [] exposed-modules: - - Proof.Cache.Server.Functional.Contract - - Proof.Cache.Server.Functional.Driver - - Proof.Cache.Server.Functional.Invariant - - Proof.Cache.Server.Functional.Obligation - - Proof.Cache.Server.Leakage.Driver - - Proof.Cache.Server.Leakage.Invariant - - Proof.Cache.Server.Leakage.Model - - Proof.Cache.Server.Leakage.Obligation - - Proof.Cache.Server.Leakage.Simulator - - Proof.Cache.CachedCore.Functional.Driver - - Proof.Cache.CachedCore.Functional.Invariant - - Proof.Cache.CachedCore.Functional.Machine - - Proof.Cache.CachedCore.Functional.Obligation - - Proof.Cache.CachedCore.Leakage.Driver - - Proof.Cache.CachedCore.Leakage.Invariant - - Proof.Cache.CachedCore.Leakage.Obligation - - Proof.Cache.CachedCore.Leakage.Simulator - - Proof.Cache.SMT.Raw + - Proof.Memory.Cache4K.Server.Functional.Contract + - Proof.Memory.Cache4K.Server.Functional.Driver + - Proof.Memory.Cache4K.Server.Functional.Invariant + - Proof.Memory.Cache4K.Server.Functional.Obligation + - Proof.Memory.Cache4K.Server.Leakage.Driver + - Proof.Memory.Cache4K.Server.Leakage.Invariant + - Proof.Memory.Cache4K.Server.Leakage.Model + - Proof.Memory.Cache4K.Server.Leakage.Obligation + - Proof.Memory.Cache4K.Server.Leakage.Simulator + - Proof.Memory.Cache4K.CachedCore.Functional.Driver + - Proof.Memory.Cache4K.CachedCore.Functional.Invariant + - Proof.Memory.Cache4K.CachedCore.Functional.Machine + - Proof.Memory.Cache4K.CachedCore.Functional.Obligation + - Proof.Memory.Cache4K.CachedCore.Leakage.Driver + - Proof.Memory.Cache4K.CachedCore.Leakage.Invariant + - Proof.Memory.Cache4K.CachedCore.Leakage.Obligation + - Proof.Memory.Cache4K.CachedCore.Leakage.Simulator + - Proof.Memory.Cache4K.SMT.Raw - Proof.SMT.Array - Proof.Core.Functional.Machine - Proof.Core.Functional.Driver @@ -154,12 +156,13 @@ library: - Proof.Core.Leakage.Driver - Proof.Core.Leakage.Invariant - Proof.Core.Leakage.Obligation - - Core - Elf.ElfLoader - Elf.Syscall - HardwareSim + - Core.Alu - Core.Instruction - Core.ISA + - Core.Pipeline - Memory.Types - Memory.Ideal - Memory.Vec diff --git a/proof/Proof/Core/Functional/Driver.hs b/proof/Proof/Core/Functional/Driver.hs index 047ed68..c85bf04 100644 --- a/proof/Proof/Core/Functional/Driver.hs +++ b/proof/Proof/Core/Functional/Driver.hs @@ -29,7 +29,8 @@ module Proof.Core.Functional.Driver where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Alu (alu, branch) +import Core.Pipeline as Core import Data.Maybe (fromMaybe, isNothing) import Core.Instruction hiding (loadHazard, storeHazard) import qualified Core.Instruction diff --git a/proof/Proof/Core/Functional/Invariant.hs b/proof/Proof/Core/Functional/Invariant.hs index ed599b3..b09d6bf 100644 --- a/proof/Proof/Core/Functional/Invariant.hs +++ b/proof/Proof/Core/Functional/Invariant.hs @@ -45,7 +45,7 @@ module Proof.Core.Functional.Invariant where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Pipeline as Core import Data.Maybe (fromMaybe, isJust) import Core.Instruction import Memory.Types diff --git a/proof/Proof/Core/Functional/Machine.hs b/proof/Proof/Core/Functional/Machine.hs index 6b907c4..58ab3ba 100644 --- a/proof/Proof/Core/Functional/Machine.hs +++ b/proof/Proof/Core/Functional/Machine.hs @@ -20,7 +20,7 @@ module Proof.Core.Functional.Machine where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Pipeline as Core import Memory.Types import Memory.Ideal (idealServe) import Core.RegFile diff --git a/proof/Proof/Core/Functional/Obligation.hs b/proof/Proof/Core/Functional/Obligation.hs index d4e5e46..df02844 100644 --- a/proof/Proof/Core/Functional/Obligation.hs +++ b/proof/Proof/Core/Functional/Obligation.hs @@ -34,17 +34,17 @@ import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&& -- the invariant relates the core to the ISA at every state the driver lands on -- after the start. -- --- The initial 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. +-- The initial state itself is not a case of the invariant. 'Core.Pipeline.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. -- -- The start PC, the register file and memory are parameters, used for both the --- core and the ISA; every other field comes from 'Core.init' itself, so the --- initial pipeline shape cannot drift from the real one. Taking them as +-- core and the ISA; every other field comes from 'Core.Pipeline.init' itself, +-- so the initial pipeline shape cannot drift from the real one. Taking them as -- parameters makes the base case cover any loaded program and any initial PC -- and register contents, such as the ELF entry point and stack pointer the ELF -- runners start the core with. @@ -71,10 +71,10 @@ baseCase wr wa pc rf mem = -- -- > 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. +-- There is no side condition about aliasing stores: 'Core.Pipeline.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@ covers two shapes: a running state whose hop retires one -- instruction, and a halted one. The @IsaHalted@ branch is what says the halted diff --git a/proof/Proof/Core/Functional/Solver.hs b/proof/Proof/Core/Functional/Solver.hs index 6c7fa66..70b9774 100644 --- a/proof/Proof/Core/Functional/Solver.hs +++ b/proof/Proof/Core/Functional/Solver.hs @@ -38,7 +38,8 @@ module Proof.Core.Functional.Solver where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import qualified Core +import qualified Core.Alu +import qualified Core.Pipeline as Core import Core.ISA (IsaStateG (..)) import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime @@ -54,8 +55,9 @@ import Proof.Core.Functional.Invariant regFileUnderInv, ) import Proof.Core.Functional.Obligation +import Proof.Core.SMT.Array import Proof.SMT.Array -import Proof.SMT.Axioms (arrayAxioms) +import Proof.Core.SMT.Axioms (arrayAxioms) import Proof.SMT.Logged (pantomime) import Proof.Core.Functional.System import Types @@ -80,12 +82,12 @@ arrRoundTripP a i v = Pantomime.boolean $ loadRA (storeRA a i v) i == v shiftsSaneP :: Word -> Pantomime.Bool shiftsSaneP 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) + Core.Alu.sllWord x 0 == x + && Core.Alu.srlWord x 0 == x + && Core.Alu.sraWord x 0 == x + && Core.Alu.sllWord x 1 == x + x + && Core.Alu.srlWord x 31 == (if sign == 1 then 1 else 0) + && Core.Alu.sraWord x 31 == (if sign == 1 then 0xFFFFFFFF else 0) where sign = slice d31 d31 x diff --git a/proof/Proof/Core/Functional/System.hs b/proof/Proof/Core/Functional/System.hs index 5d35ac7..2eed781 100644 --- a/proof/Proof/Core/Functional/System.hs +++ b/proof/Proof/Core/Functional/System.hs @@ -20,9 +20,10 @@ module Proof.Core.Functional.System where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import qualified Core +import qualified Core.Pipeline as Core import Core.Instruction (Instruction) import Proof.Core.Functional.Machine +import Proof.Core.SMT.Array import Proof.SMT.Array import Types import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) diff --git a/proof/Proof/Core/Leakage/Driver.hs b/proof/Proof/Core/Leakage/Driver.hs index 0988612..7a9900f 100644 --- a/proof/Proof/Core/Leakage/Driver.hs +++ b/proof/Proof/Core/Leakage/Driver.hs @@ -25,9 +25,9 @@ import Proof.Core.Leakage.Simulator import Types (Address, RegIdx) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) --- | 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 store-hazard condition of 'Core.Pipeline.decode': the instruction word +-- at the decode-stage PC overlaps a store either in the execute stage or in the +-- memory stage. simStoreHazard :: SimInput -> SimState -> Bool simStoreHazard inp st = maybe False (Core.Instruction.storeHazard dePc) exStore @@ -41,8 +41,8 @@ simStoreHazard inp st = LStore size addr -> Just (addr, size) _ -> Nothing --- | The load-hazard condition of 'Core.decode', computed by the ISA as part of --- the leakage. +-- | The load-hazard condition of 'Core.Pipeline.decode', computed by the ISA as +-- part of the leakage. simLoadHazard :: SimInput -> SimState -> Bool simLoadHazard (Just (LLoad _ _ haz)) st = simStateDeExpInstr st && haz simLoadHazard _ _ = False diff --git a/proof/Proof/Core/Leakage/Invariant.hs b/proof/Proof/Core/Leakage/Invariant.hs index 4740b21..70481a4 100644 --- a/proof/Proof/Core/Leakage/Invariant.hs +++ b/proof/Proof/Core/Leakage/Invariant.hs @@ -6,7 +6,7 @@ module Proof.Core.Leakage.Invariant where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Pipeline as Core import Data.Maybe (isJust, isNothing) import Core.Instruction hiding (Halted) import Proof.Core.Leakage.Model diff --git a/proof/Proof/Core/Leakage/Model.hs b/proof/Proof/Core/Leakage/Model.hs index 9370ea9..c1c7c3f 100644 --- a/proof/Proof/Core/Leakage/Model.hs +++ b/proof/Proof/Core/Leakage/Model.hs @@ -43,7 +43,8 @@ module Proof.Core.Leakage.Model where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Alu (branch) +import Core.Pipeline as Core import Core.Instruction import Core.ISA (IsaStateG (..), isaInstrAt) import Memory.Types (MemOps (..)) diff --git a/proof/Proof/Core/Leakage/Simulator.hs b/proof/Proof/Core/Leakage/Simulator.hs index be3c703..2c337cf 100644 --- a/proof/Proof/Core/Leakage/Simulator.hs +++ b/proof/Proof/Core/Leakage/Simulator.hs @@ -1,6 +1,6 @@ -- | The leakage simulator: a pipeline with the same stage structure and timing --- as "Core", which sees only the leakage -- never the program, the register --- file or memory contents. +-- as "Core.Pipeline", which sees only the leakage -- never the program, the +-- register file or memory contents. -- -- Each cycle it may receive the 'Leak' of the instruction entering its execute -- stage ('SimInput'; 'Nothing' when there is none) and emits the bus @@ -140,7 +140,7 @@ simPipe = do simDecode simFetch -- The lines only carry values within a tick, so none of them survives it, - -- as in 'Core.pipe'. + -- as in 'Core.Pipeline.pipe'. modify $ \s -> s {simStateCtrl = simInitCtrl} simInit :: SimState diff --git a/proof/Proof/Core/Leakage/Solver.hs b/proof/Proof/Core/Leakage/Solver.hs index b4a341e..a705956 100644 --- a/proof/Proof/Core/Leakage/Solver.hs +++ b/proof/Proof/Core/Leakage/Solver.hs @@ -38,7 +38,7 @@ module Proof.Core.Leakage.Solver where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import qualified Core +import qualified Core.Pipeline as Core import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime import Proof.Core.Leakage.Driver @@ -48,8 +48,9 @@ import Proof.Core.Leakage.Driver import Proof.Core.Leakage.Model (Leak) import Proof.Core.Leakage.Obligation import Proof.Core.Leakage.Simulator +import Proof.Core.SMT.Array import Proof.SMT.Array -import Proof.SMT.Axioms (arrayAxioms) +import Proof.Core.SMT.Axioms (arrayAxioms) import Proof.SMT.Logged (pantomime) import Proof.Core.Functional.System import Types diff --git a/proof/Proof/Core/SMT/Array.hs b/proof/Proof/Core/SMT/Array.hs new file mode 100644 index 0000000..527df35 --- /dev/null +++ b/proof/Proof/Core/SMT/Array.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} + +-- | The core's register file embedded as an SMT array, in the pattern +-- "Proof.SMT.Array" describes for memory, and the ALU's shifts +-- ('Core.Alu.sllWord' and friends) as SMT bitvector shifts. +module Proof.Core.SMT.Array + ( RegArr (..), + RegArrF (..), + RegArrSMT (..), + loadRA, + storeRA, + zeroRA, + zeroRAE, + loadRAE, + storeRAE, + eqRA, + eqRAE, + sllWordE, + srlWordE, + sraWordE, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) +import Data.Coerce (Coercible, coerce) +import qualified Pantomime.BuiltIn as P +import qualified Pantomime.Clash as Clash +import Core.RegFile (RegFileOps (..)) +import Types +import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) + +-- The register file as an SMT array ------------------------------------------- + +-- | 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) + +-- | Equality, so that whole register files can be compared. Replaced by 'eqRAE' +-- under the term axiom; OPAQUE for the same reason as 'loadRA'. +{-# OPAQUE eqRA #-} +eqRA :: RegArr -> RegArr -> Bool +eqRA (RegArr v) (RegArr w) = v == w + +instance Eq RegArr where + (==) = eqRA + +-- | Embedding of 'eqRA' as array equality. +eqRAE :: forall arr. (Coercible RegArrSMT arr) => arr -> arr -> Bool +eqRAE = coerce go + where + go :: RegArrSMT -> RegArrSMT -> Bool + go (RegArrSMT a) (RegArrSMT b) = a == b + +-- | The all-zero register file. +-- +-- 'Proof.Core.Leakage.Simulator.censor' installs this on every state it builds, +-- so unlike 'Core.Pipeline.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'. A +-- verification-only representation. +newtype RegArrF = RegArrF RegArr + deriving (Eq) + +instance RegFileOps RegArrF where + lookupRFg idx (RegArrF a) = if idx == 0 then 0 else loadRA a idx + modifyRFg idx v rf@(RegArrF a) + | idx == 0 = rf + | otherwise = RegArrF (storeRA a idx v) + + -- On the symbolic path; see 'zeroRA'. + initRFg = RegArrF zeroRA + +-- Shifts as SMT bitvector shifts ---------------------------------------------- +-- +-- Embeddings for 'Core.Alu.sllWord', 'Core.Alu.srlWord' and +-- 'Core.Alu.sraWord'. See the note on those functions for why they exist: +-- without them each shift site converts its five-bit amount through 'Integer', +-- and the resulting +-- @ubv_to_int@ / @int_to_bv@ pair makes every query unreadable to the +-- bitvector-only solvers. +-- +-- The amount is zero-extended to the word width because SMT's shifts require +-- both operands to have the same sort. That is exact rather than a choice: the +-- amount is five bits, so it is always less than 32 and no shift saturates. + +-- | @shiftL@ on a 'Word' as @bvshl@. +sllWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + (Coercible Clash.BitVec bvX) => + (Coercible Clash.BitVec bvN) => + bvX 32 -> + bvN 5 -> + bvX 32 +sllWordE = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvshl x (P.bvzext n)) + +-- | @shiftR@ on a 'Word' as @bvlshr@. +srlWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + (Coercible Clash.BitVec bvX) => + (Coercible Clash.BitVec bvN) => + bvX 32 -> + bvN 5 -> + bvX 32 +srlWordE = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvlshr x (P.bvzext n)) + +-- | Arithmetic @shiftR@ on a 'Word' as @bvashr@. +sraWordE :: + forall (bvX :: Nat -> Type) (bvN :: Nat -> Type). + (Coercible Clash.BitVec bvX) => + (Coercible Clash.BitVec bvN) => + bvX 32 -> + bvN 5 -> + bvX 32 +sraWordE = coerce go + where + go :: Clash.BitVec 32 -> Clash.BitVec 5 -> Clash.BitVec 32 + go (Clash.BitVecP x) (Clash.BitVecP n) = + Clash.BitVecP (P.bvashr x (P.bvzext n)) diff --git a/proof/Proof/Core/SMT/Axioms.hs b/proof/Proof/Core/SMT/Axioms.hs new file mode 100644 index 0000000..4804451 --- /dev/null +++ b/proof/Proof/Core/SMT/Axioms.hs @@ -0,0 +1,50 @@ +-- | The axioms for the properties about the core: those every proof builds on +-- ("Proof.SMT.Axioms"), plus the core's shift wrappers and its register file as +-- an SMT array ("Proof.Core.SMT.Array"). +-- +-- This lives in its own module because GHC's stage restriction requires a value +-- mentioned in an @ANN@ pragma to be imported rather than defined locally. +module Proof.Core.SMT.Axioms (arrayAxioms) where + +import Core.Alu (sllWord, sraWord, srlWord) +import qualified Data.Map as Map +import Pantomime (PluginAxioms (..)) +import Proof.Core.SMT.Array +import Proof.SMT.Axioms (memAxioms) + +-- | The ALU shifts, mapped to the SMT bitvector shifts. +-- +-- They are part of the core's semantics, not of the container encoding: any +-- property that runs the ALU needs them. Without them 'Core.Alu.sllWord' and +-- friends are OPAQUE names with no unfolding, and symbolic execution stops +-- with \"Unbound variable in symbolise\". See 'Core.Alu.sllWord' for why the +-- wrappers exist: they keep the shift amount a bitvector, so a query stays in +-- the bitvector-and-array fragment that Bitwuzla and Yices can read. +shiftAxioms :: PluginAxioms +shiftAxioms = + PluginAxioms + { typeAxioms = Map.empty, + termAxioms = + [ ('sllWord, 'sllWordE), + ('srlWord, 'srlWordE), + ('sraWord, 'sraWordE) + ] + } + +-- | The register-file-as-SMT-array embedding and the shifts, on top of memory +-- and the base set. +-- +-- Monomorphic by necessity: an array needs concrete index and element sorts. +arrayAxioms :: PluginAxioms +arrayAxioms = + memAxioms + <> shiftAxioms + <> PluginAxioms + { typeAxioms = Map.fromList [(''RegArr, ''RegArrSMT)], + termAxioms = + [ ('loadRA, 'loadRAE), + ('zeroRA, 'zeroRAE), + ('storeRA, 'storeRAE), + ('eqRA, 'eqRAE) + ] + } diff --git a/proof/Proof/Cache/CachedCore/Functional/Driver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Driver.hs similarity index 56% rename from proof/Proof/Cache/CachedCore/Functional/Driver.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Functional/Driver.hs index 6c864e2..a65bf89 100644 --- a/proof/Proof/Cache/CachedCore/Functional/Driver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Driver.hs @@ -1,12 +1,12 @@ -- | The driver of link 2: how many cycles the core behind the cache --- ("Proof.Cache.CachedCore.Functional.Machine") takes beyond one cycle of the --- core behind ideal memory, before the two can be compared again -- the --- counterpart of "Proof.Cache.Server.Functional.Driver". +-- ("Proof.Memory.Cache4K.CachedCore.Functional.Machine") takes beyond one cycle +-- of the core behind ideal memory, before the two can be compared again -- the +-- counterpart of "Proof.Memory.Cache4K.Server.Functional.Driver". -- -- * 'cachedDriver', the server's driver on the request the core makes, and -- * 'cachedDriverSpec', the operational reading, obtained by actually -- stepping. -module Proof.Cache.CachedCore.Functional.Driver +module Proof.Memory.Cache4K.CachedCore.Functional.Driver ( cachedDriver, cachedDriverValues, cachedDriverSpec, @@ -14,36 +14,36 @@ module Proof.Cache.CachedCore.Functional.Driver ) where -import Core (Input (..), Output (..)) -import qualified Core +import Core.Pipeline as Core (Input (..), Output (..)) +import qualified Core.Pipeline as Core import Core.RegFile (RegFileOps) import Data.Maybe (isJust) import Memory.Cache4K (SetIdx, WordIdx) import Memory.Cache4KServer import Memory.Types (MemOps (..)) -import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) -import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..), stepCached) -import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Memory.Cache4K.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..), stepCached) +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriver) import Proof.Core.Functional.Machine (SysG) import Types --- | The cycles after this one until the cache has answered the request the --- core makes in this cycle: the server's driver --- ('Proof.Cache.Server.Functional.Driver.srvDriver') on that request. The --- driver is only ever run from systems that satisfy the invariant --- ('Proof.Cache.CachedCore.Functional.Invariant.cachedInvAt'), whose cache is --- ready; elsewhere it need not agree with 'cachedDriverSpec'. +-- | The cycles after this one until the cache has answered the request the core +-- makes in this cycle: the server's driver +-- ('Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver') on that request. +-- The driver is only ever run from systems that satisfy the invariant +-- ('Proof.Memory.Cache4K.CachedCore.Functional.Invariant.cachedInvAt'), whose +-- cache is ready; elsewhere it need not agree with 'cachedDriverSpec'. cachedDriver :: (RegFileOps r) => CachedSysG r m -> Int cachedDriver (CachedSys core inp srv) = let (_, Output req) = Core.circuit core inp in srvDriver srv req --- | The driver is 0, 'penalty' or twice 'penalty': the hop lengths of the --- steps ('Proof.Cache.CachedCore.Functional.Obligation.indStep0', --- 'Proof.Cache.CachedCore.Functional.Obligation.indStep4', --- 'Proof.Cache.CachedCore.Functional.Obligation.indStep8'), which so cover --- every hop. Follows from the server's --- ('Proof.Cache.Server.Functional.Driver.srvDriverValues'), since +-- | The driver is 0, 'penalty' or twice 'penalty': the hop lengths of the steps +-- ('Proof.Memory.Cache4K.CachedCore.Functional.Obligation.indStep0', +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Obligation.indStep4', +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Obligation.indStep8'), which so +-- cover every hop. Follows from the server's +-- ('Proof.Memory.Cache4K.Server.Functional.Driver.srvDriverValues'), since -- 'cachedDriver' is the server's driver on the core's request. cachedDriverValues :: (RegFileOps r) => CachedSysG r m -> Bool cachedDriverValues csys = @@ -68,13 +68,13 @@ cachedDriverSpec fuel csys0 = go 0 (stepCached csys0) -- for the core: the driver reads the core's request, which only matches the -- stepping on states the invariant covers. Eight cycles of fuel, 2 * 'penalty', -- cover the longest hop, two missed lines. Follows from the server's --- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec'): under the --- invariant the server is ready --- ('Proof.Cache.Server.Functional.Contract.srvReadyUnderInv'), and while it --- has not answered, the core makes no request --- ('Proof.Cache.Server.Functional.Contract.corePatient'), so the server is --- stepped exactly as 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' --- steps it. +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec'): +-- under the invariant the server is ready +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvReadyUnderInv'), and +-- while it has not answered, the core makes no request +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.corePatient'), so the +-- server is stepped exactly as +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverSpec' steps it. cachedDriverMatchesSpec :: (RegFileOps r, Eq r, MemOps m) => Address -> SetIdx -> WordIdx -> SysG r m -> CachedSysG r m -> Bool diff --git a/proof/Proof/Cache/CachedCore/Functional/Invariant.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Invariant.hs similarity index 73% rename from proof/Proof/Cache/CachedCore/Functional/Invariant.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Functional/Invariant.hs index 5b5f2cd..f52f5e9 100644 --- a/proof/Proof/Cache/CachedCore/Functional/Invariant.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Invariant.hs @@ -3,11 +3,11 @@ -- -- The two cores are the same, and so are their inputs; the cache relates to -- ideal memory as in the cache's own proof --- ('Proof.Cache.Server.Functional.Invariant.srvInvAt'): ready, holding ideal --- memory's byte @wa@, and coherent at word @wwi@ of set @wsi@. The cache holds --- 1024 words and memory many more bytes, so the invariant is stated at +-- ('Proof.Memory.Cache4K.Server.Functional.Invariant.srvInvAt'): ready, holding +-- ideal memory's byte @wa@, and coherent at word @wwi@ of set @wsi@. The cache +-- holds 1024 words and memory many more bytes, so the invariant is stated at -- witnesses, and the obligations quantify over them. -module Proof.Cache.CachedCore.Functional.Invariant +module Proof.Memory.Cache4K.CachedCore.Functional.Invariant ( cachedInvAt, cachedInvFunctional, ) @@ -16,8 +16,8 @@ where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Memory.Cache4K (SetIdx, WordIdx) import Memory.Types (MemOps (..)) -import Proof.Cache.Server.Functional.Invariant (srvInvAt) -import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Memory.Cache4K.Server.Functional.Invariant (srvInvAt) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..)) import Proof.Core.Functional.Machine (SysG (..)) import Types (Address) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) @@ -36,9 +36,9 @@ cachedInvAt wa wsi wwi (Sys core inp mem) (CachedSys ccore cinp srv) = -- | The invariant is functional: two ideal systems it relates to the same -- cached system are equal, at byte @wa@. Quantifying over @wa@ gives equality -- of the systems. Follows from the server's invariant being functional --- ('Proof.Cache.Server.Functional.Invariant.srvInvFunctional'): the cores and --- inputs are each equal to the cached system's, and the memories are the ones --- the server's invariant relates to the same server. +-- ('Proof.Memory.Cache4K.Server.Functional.Invariant.srvInvFunctional'): the +-- cores and inputs are each equal to the cached system's, and the memories are +-- the ones the server's invariant relates to the same server. cachedInvFunctional :: (Eq r, MemOps m) => Address -> SetIdx -> WordIdx -> SysG r m -> SysG r m -> CachedSysG r m -> Bool diff --git a/proof/Proof/Cache/CachedCore/Functional/Machine.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Machine.hs similarity index 96% rename from proof/Proof/Cache/CachedCore/Functional/Machine.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Functional/Machine.hs index 1bca6a8..0fcf64e 100644 --- a/proof/Proof/Cache/CachedCore/Functional/Machine.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Machine.hs @@ -10,7 +10,7 @@ -- answer, and the state the proofs reason about is the triple -- -- > (Core.State, Input, cache server) -module Proof.Cache.CachedCore.Functional.Machine +module Proof.Memory.Cache4K.CachedCore.Functional.Machine ( CachedSysG (..), CachedSys, initCachedSys, @@ -20,7 +20,7 @@ module Proof.Cache.CachedCore.Functional.Machine where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core +import Core.Pipeline as Core import Memory.Cache4KServer import Memory.Types import Core.RegFile diff --git a/proof/Proof/Cache/CachedCore/Functional/Obligation.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs similarity index 66% rename from proof/Proof/Cache/CachedCore/Functional/Obligation.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs index 866fd5b..ab6fc09 100644 --- a/proof/Proof/Cache/CachedCore/Functional/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Obligation.hs @@ -3,46 +3,49 @@ -- "Proof.Core.Functional.Obligation". -- -- One cycle of the core behind ideal memory ("Memory.Ideal") corresponds to --- 'Proof.Cache.CachedCore.Functional.Driver.cachedDriver' + 1 cycles of the --- core behind the cache. As the core's obligations build the ISA state from the --- system ('Proof.Core.Functional.Invariant.isaOf'), these build the cached --- system from the ideal one ('cachedOf'), with a cache that is coherent by --- construction; the conclusion compares the two after the hop. +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Driver.cachedDriver' + 1 cycles +-- of the core behind the cache. As the core's obligations build the ISA state +-- from the system ('Proof.Core.Functional.Invariant.isaOf'), these build the +-- cached system from the ideal one ('cachedOf'), with a cache that is coherent +-- by construction; the conclusion compares the two after the hop. -- -- From a system that satisfies the invariant the driver is 0, 'penalty' or -- twice 'penalty' (no, one or two lines missed; --- 'Proof.Cache.CachedCore.Functional.Driver.cachedDriverValues'), so there is --- one step per hop length, named after it for @'penalty' = 4@. Split by length --- because Pantomime unrolls recursion only when its count is concrete. +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Driver.cachedDriverValues'), so +-- there is one step per hop length, named after it for @'penalty' = 4@. Split +-- by length because Pantomime unrolls recursion only when its count is +-- concrete. -- -- == Why they hold -- -- The base case and the steps follow from the standalone cache's proof --- ("Proof.Cache.Server.Functional") and the contract between core and cache --- ("Proof.Cache.Server.Functional.Contract"); they are checked here only as a --- sanity check of that argument. +-- ("Proof.Memory.Cache4K.Server.Functional") and the contract between core and +-- cache ("Proof.Memory.Cache4K.Server.Functional.Contract"); they are checked +-- here only as a sanity check of that argument. -- -- * Base case: the server at start satisfies the cache's invariant against --- its memory ('Proof.Cache.Server.Functional.Obligation.baseCase'), and the +-- its memory +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.baseCase'), and the -- cores and inputs are the same by construction. -- -- * Step of length @k@: the invariant ('cachedInvAt') gives the same core, -- the same input, and the cache's invariant against ideal memory. In the -- first cycle both cores therefore make the same request. The server is --- ready ('Proof.Cache.Server.Functional.Contract.srvReadyUnderInv') and +-- ready +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvReadyUnderInv') and -- answers it @k@ cycles later --- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec'), with --- ideal memory's answer and its invariant again --- ('Proof.Cache.Server.Functional.Obligation.indStep0', --- 'Proof.Cache.Server.Functional.Obligation.indStep4', --- 'Proof.Cache.Server.Functional.Obligation.indStep8'). In the @k@ cycles --- in between it answers 'Nothing', and the core, given 'Nothing' after a --- request, makes no request and stays the same --- ('Proof.Cache.Server.Functional.Contract.corePatient', once per cycle), --- so the server is served no request, as its own steps assume. After the --- hop the cores and inputs are those of the ideal system after one step, --- and the cache's invariant holds: 'cachedInvAt' again. -module Proof.Cache.CachedCore.Functional.Obligation +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec'), +-- with ideal memory's answer and its invariant again +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.indStep0', +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.indStep4', +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.indStep8'). In the @k@ +-- cycles in between it answers 'Nothing', and the core, given 'Nothing' +-- after a request, makes no request and stays the same +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.corePatient', once per +-- cycle), so the server is served no request, as its own steps assume. +-- After the hop the cores and inputs are those of the ideal system after +-- one step, and the cache's invariant holds: 'cachedInvAt' again. +module Proof.Memory.Cache4K.CachedCore.Functional.Obligation ( cachedOf, baseCase, indStep0, @@ -56,11 +59,11 @@ import Core.RegFile (RegFileOps) import Memory.Cache4K import Memory.Cache4KServer import Memory.Types (MemOps (..)) -import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) -import Proof.Cache.SMT.Raw (RawData (..)) -import Proof.Cache.CachedCore.Functional.Driver (cachedDriver) -import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) -import Proof.Cache.CachedCore.Functional.Machine +import Proof.Memory.Cache4K.Server.Functional.Obligation (CoherentOps (..)) +import Proof.Memory.Cache4K.SMT.Raw (RawData (..)) +import Proof.Memory.Cache4K.CachedCore.Functional.Driver (cachedDriver) +import Proof.Memory.Cache4K.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine ( CachedSysG (..), initCachedSys, stepCached, @@ -75,9 +78,10 @@ import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&& -- in front of its memory a ready cache with the tag array @tags@ that is -- coherent by construction -- valid lines hold memory's words, invalid lines -- those of @raw@. The steps start from it, as the cache's own steps do --- ('Proof.Cache.Server.Functional.Obligation.indStep0'), so that coherence --- holds by construction instead of being assumed; it shows what the cache adds --- to the ideal system: its tags and the contents of its invalid lines. +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.indStep0'), so that +-- coherence holds by construction instead of being assumed; it shows what the +-- cache adds to the ideal system: its tags and the contents of its invalid +-- lines. cachedOf :: (CoherentOps m) => SysG r m -> TagArr -> RawData -> CachedSysG r m cachedOf (Sys core inp mem) tags raw = CachedSys core inp (CacheSrv cache mem CacheSrvReady) diff --git a/proof/Proof/Cache/CachedCore/Functional/Solver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs similarity index 84% rename from proof/Proof/Cache/CachedCore/Functional/Solver.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs index 31b126a..8a4493b 100644 --- a/proof/Proof/Cache/CachedCore/Functional/Solver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Functional/Solver.hs @@ -2,11 +2,11 @@ -- memory, checked symbolically: the counterpart of -- "Proof.Core.Functional.Solver". -- --- The statements live in "Proof.Cache.CachedCore.Functional.Driver" and --- "Proof.Cache.CachedCore.Functional.Obligation"; this module only instantiates --- them, over every core state, input, register file, memory, tag array, --- request and witness. --- Each property is named after the statement it checks, with a @P@: +-- The statements live in "Proof.Memory.Cache4K.CachedCore.Functional.Driver" +-- and "Proof.Memory.Cache4K.CachedCore.Functional.Obligation"; this module only +-- instantiates them, over every core state, input, register file, memory, tag +-- array, request and witness. Each property is named after the statement it +-- checks, with a @P@: -- -- * the driver against its operational reading -- ('cachedDriverMatchesSpecP'), and its values, the hop lengths of the @@ -14,17 +14,17 @@ -- * the invariant being functional ('cachedInvFunctionalP'); -- * the base case, and one step per hop length (0, 'penalty', -- 2 * 'penalty'), each starting from a cache coherent by construction --- ('Proof.Cache.Server.Functional.Obligation.mkData'). +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.mkData'). -- -- The array embeddings these rely on are checked in --- "Proof.Cache.Server.Functional.Solver". +-- "Proof.Memory.Cache4K.Server.Functional.Solver". -- -- == Running them -- -- Under Bitwuzla, not Z3: -- -- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build -module Proof.Cache.CachedCore.Functional.Solver +module Proof.Memory.Cache4K.CachedCore.Functional.Solver ( cachedDriverMatchesSpecP, cachedDriverValuesP, cachedInvFunctionalP, @@ -36,23 +36,24 @@ module Proof.Cache.CachedCore.Functional.Solver ) where -import qualified Core +import qualified Core.Pipeline as Core import Memory.Cache4K import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) -import Proof.Cache.SMT.Raw (RawData) -import Proof.Cache.CachedCore.Functional.Driver +import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Memory.Cache4K.SMT.Raw (RawData) +import Proof.Memory.Cache4K.CachedCore.Functional.Driver ( cachedDriverMatchesSpec, cachedDriverValues, ) -import Proof.Cache.CachedCore.Functional.Invariant (cachedInvFunctional) -import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) -import Proof.Cache.CachedCore.Functional.Obligation +import Proof.Memory.Cache4K.CachedCore.Functional.Invariant (cachedInvFunctional) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Memory.Cache4K.CachedCore.Functional.Obligation import Proof.Core.Functional.Machine (SysG (..)) import Proof.Core.Functional.System (KState, sysOf) -import Proof.SMT.Array (MemArr, RegArr, RegArrF (..)) +import Proof.Core.SMT.Array (RegArr, RegArrF (..)) +import Proof.SMT.Array (MemArr) import Proof.SMT.Logged (pantomime) import Types diff --git a/proof/Proof/Cache/CachedCore/Leakage/Driver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Driver.hs similarity index 60% rename from proof/Proof/Cache/CachedCore/Leakage/Driver.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Leakage/Driver.hs index 822042b..0540698 100644 --- a/proof/Proof/Cache/CachedCore/Leakage/Driver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Driver.hs @@ -1,7 +1,7 @@ -- | The driver of link 2's leakage half: how many cycles the core behind the -- cache waits after a request, computed from the request's observation alone --- -- the counterpart of "Proof.Cache.CachedCore.Functional.Driver". -module Proof.Cache.CachedCore.Leakage.Driver +-- -- the counterpart of "Proof.Memory.Cache4K.CachedCore.Functional.Driver". +module Proof.Memory.Cache4K.CachedCore.Leakage.Driver ( simCachedDriver, simCachedDriverSpec, simCachedDriverMatchesSpec, @@ -9,17 +9,18 @@ module Proof.Cache.CachedCore.Leakage.Driver where import Data.Maybe (fromMaybe) -import Proof.Cache.Server.Leakage.Driver (simSrvDriver) -import Proof.Cache.CachedCore.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Driver (simSrvDriver) +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator ( SimCachedInput, SimCachedSys (..), simStepCached, ) -import Proof.Cache.Server.Leakage.Simulator (simSrvReady) +import Proof.Memory.Cache4K.Server.Leakage.Simulator (simSrvReady) import Proof.Core.Leakage.Model (Obs (..)) -- | The cycles the core waits after a request observed as @inp@: the cache --- simulator's driver ('Proof.Cache.Server.Leakage.Driver.simSrvDriver') on that +-- simulator's driver +-- ('Proof.Memory.Cache4K.Server.Leakage.Driver.simSrvDriver') on that -- observation. Only ever run from a ready simulator, so whether the last cycle -- brought an answer is not consulted. simCachedDriver :: SimCachedSys -> SimCachedInput -> Int @@ -27,7 +28,7 @@ simCachedDriver (SimCachedSys sim _) inp = simSrvDriver sim (fromMaybe NoAccess inp) -- | The operational reading of 'simCachedDriver', as --- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverSpec' is of the cache +-- 'Proof.Memory.Cache4K.Server.Leakage.Driver.simSrvDriverSpec' is of the cache -- simulator's: step on the observed request, then with no input until the -- simulator answers, and count the cycles after the request's. 'Nothing' if -- more than @fuel@ cycles follow the request's. @@ -40,17 +41,18 @@ simCachedDriverSpec fuel sim0 inp = go 0 (fst (simStepCached sim0 inp)) | otherwise = go (n + 1) (fst (simStepCached sim Nothing)) -- | From a ready simulator -- its last cycle brought an answer, and the cache's --- simulator is ready ('Proof.Cache.Server.Leakage.Simulator.simSrvReady') -- --- its driver agrees with its operational reading, for the observation of any --- request: a hop starts with one, never in the middle of a driver hop. Eight --- cycles of fuel, 2 * 'penalty', cover the longest hop. +-- simulator is ready +-- ('Proof.Memory.Cache4K.Server.Leakage.Simulator.simSrvReady') -- its driver +-- agrees with its operational reading, for the observation of any request: a +-- hop starts with one, never in the middle of a driver hop. Eight cycles of +-- fuel, 2 * 'penalty', cover the longest hop. -- -- Follows from the cache simulator's --- ('Proof.Cache.Server.Leakage.Driver.simSrvDriverMatchesSpec'): since the last --- cycle brought an answer, 'simStepCached' passes the input on to the cache's --- simulator, and until it answers again passes it no input, so the cache's --- simulator is stepped exactly as --- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverSpec' steps it, and +-- ('Proof.Memory.Cache4K.Server.Leakage.Driver.simSrvDriverMatchesSpec'): since +-- the last cycle brought an answer, 'simStepCached' passes the input on to the +-- cache's simulator, and until it answers again passes it no input, so the +-- cache's simulator is stepped exactly as +-- 'Proof.Memory.Cache4K.Server.Leakage.Driver.simSrvDriverSpec' steps it, and -- 'simCachedDriver' is its driver. simCachedDriverMatchesSpec :: SimCachedSys -> Obs -> Bool simCachedDriverMatchesSpec sim@(SimCachedSys srvSim answered) obs = diff --git a/proof/Proof/Cache/CachedCore/Leakage/Invariant.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Invariant.hs similarity index 57% rename from proof/Proof/Cache/CachedCore/Leakage/Invariant.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Leakage/Invariant.hs index d386e3f..db27b78 100644 --- a/proof/Proof/Cache/CachedCore/Leakage/Invariant.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Invariant.hs @@ -1,24 +1,25 @@ -- | The invariant of link 2's leakage half: the cache's simulator agrees with -- the server of the core behind the cache -- the counterpart of --- "Proof.Cache.CachedCore.Functional.Invariant". +-- "Proof.Memory.Cache4K.CachedCore.Functional.Invariant". -- -- The steps assume link 2's functional invariant --- ('Proof.Cache.CachedCore.Functional.Invariant.cachedInvAt') as well, so this --- only adds the simulator ("Proof.Cache.CachedCore.Leakage.Simulator"). -module Proof.Cache.CachedCore.Leakage.Invariant +-- ('Proof.Memory.Cache4K.CachedCore.Functional.Invariant.cachedInvAt') as well, +-- so this only adds the simulator +-- ("Proof.Memory.Cache4K.CachedCore.Leakage.Simulator"). +module Proof.Memory.Cache4K.CachedCore.Leakage.Invariant ( cachedSimInvAt, simCachedOf, ) where import Memory.Cache4K (SetIdx) -import Proof.Cache.CachedCore.Functional.Machine (CachedSysG (..)) -import Proof.Cache.Server.Leakage.Invariant (simOf, srvSimInvAt) -import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..)) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine (CachedSysG (..)) +import Proof.Memory.Cache4K.Server.Leakage.Invariant (simOf, srvSimInvAt) +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator (SimCachedSys (..)) -- | The simulator agrees with the cached system at a hop boundary: the cache's -- simulator agrees with the server at set @wsi@, as in the cache's leakage --- proof ('Proof.Cache.Server.Leakage.Invariant.srvSimInvAt'), and the +-- proof ('Proof.Memory.Cache4K.Server.Leakage.Invariant.srvSimInvAt'), and the -- simulator records that an answer has just arrived. cachedSimInvAt :: SetIdx -> SimCachedSys -> CachedSysG r m -> Bool cachedSimInvAt wsi (SimCachedSys sim answered) (CachedSys _ _ srv) = @@ -26,7 +27,7 @@ cachedSimInvAt wsi (SimCachedSys sim answered) (CachedSys _ _ srv) = -- | The simulator a cached system determines at the start of a hop: the -- cache's simulator built from its server --- ('Proof.Cache.Server.Leakage.Invariant.simOf'), and an answer in the +-- ('Proof.Memory.Cache4K.Server.Leakage.Invariant.simOf'), and an answer in the -- previous cycle, as at every hop boundary. simCachedOf :: CachedSysG r m -> SimCachedSys simCachedOf (CachedSys _ _ srv) = SimCachedSys (simOf srv) True diff --git a/proof/Proof/Cache/CachedCore/Leakage/Obligation.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Obligation.hs similarity index 70% rename from proof/Proof/Cache/CachedCore/Leakage/Obligation.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Leakage/Obligation.hs index 63919ee..047923a 100644 --- a/proof/Proof/Cache/CachedCore/Leakage/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Obligation.hs @@ -1,49 +1,49 @@ -- | The obligations of link 2's leakage half, in one place: what the bus -- between the core and the cache shows follows from what the bus between the -- core and ideal memory shows -- the counterpart of --- "Proof.Cache.CachedCore.Functional.Obligation". +-- "Proof.Memory.Cache4K.CachedCore.Functional.Obligation". -- -- One cycle of the core behind ideal memory, with observation @o@, corresponds -- to @k + 1@ cycles of the core behind the cache: the first shows @o@ too, the -- other @k@ show no request. The cache's simulator, given @o@ alone, computes --- @k@ ('Proof.Cache.CachedCore.Leakage.Driver.simCachedDriver') and answers in --- the same cycles as the server. Together with the core's leakage proof, which --- gives the ideal observations from the ISA leakage, this gives the --- observations of the core behind the cache from the ISA leakage, with no +-- @k@ ('Proof.Memory.Cache4K.CachedCore.Leakage.Driver.simCachedDriver') and +-- answers in the same cycles as the server. Together with the core's leakage +-- proof, which gives the ideal observations from the ISA leakage, this gives +-- the observations of the core behind the cache from the ISA leakage, with no -- combination of stalls to consider: the stalls are inserted one ideal cycle -- at a time. -- -- The steps build the cached system from the ideal system, as the functional --- half does ('Proof.Cache.CachedCore.Functional.Obligation.cachedOf'), and the --- simulator from the cached system ('simCachedOf'), as the cache's leakage --- proof does from the server ('Proof.Cache.Server.Leakage.Invariant.simOf'). --- They assume link 2's functional invariant, which the functional half --- establishes, and add only the simulator's. One step per hop length, as in --- the functional half. +-- half does ('Proof.Memory.Cache4K.CachedCore.Functional.Obligation.cachedOf'), +-- and the simulator from the cached system ('simCachedOf'), as the cache's +-- leakage proof does from the server +-- ('Proof.Memory.Cache4K.Server.Leakage.Invariant.simOf'). They assume link 2's +-- functional invariant, which the functional half establishes, and add only the +-- simulator's. One step per hop length, as in the functional half. -- -- == Why they hold -- -- The base case and the steps follow from the cache's leakage proof --- ("Proof.Cache.Server.Leakage.Obligation"), the contract --- ("Proof.Cache.Server.Functional.Contract") and link 2's functional half; they --- are checked here only as a sanity check of that argument. +-- ("Proof.Memory.Cache4K.Server.Leakage.Obligation"), the contract +-- ("Proof.Memory.Cache4K.Server.Functional.Contract") and link 2's functional +-- half; they are checked here only as a sanity check of that argument. -- -- * Base case: the cache's simulator and the server at start agree --- ('Proof.Cache.Server.Leakage.Obligation.baseCaseLeak'), and the core's --- input at start holds an answer, as the simulator at start records. The --- functional invariant at start is the functional half's base case. +-- ('Proof.Memory.Cache4K.Server.Leakage.Obligation.baseCaseLeak'), and the +-- core's input at start holds an answer, as the simulator at start records. +-- The functional invariant at start is the functional half's base case. -- -- * Step of length @k@: by the functional half, the first cycle's request is -- the ideal one, and in the @k@ cycles after it the core makes no request --- ('Proof.Cache.Server.Functional.Contract.corePatient'). In every cycle, --- the simulator, given the observation of the request, answers exactly --- when the server does and agrees with it afterwards --- ('Proof.Cache.Server.Leakage.Obligation.indStepLeak', once per cycle). --- The simulator's wait is the functional driver's: both are the cache's --- drivers, which agree with their operational readings --- ('Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec', --- 'Proof.Cache.Server.Leakage.Driver.simSrvDriverMatchesSpec'). -module Proof.Cache.CachedCore.Leakage.Obligation +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.corePatient'). In every +-- cycle, the simulator, given the observation of the request, answers +-- exactly when the server does and agrees with it afterwards +-- ('Proof.Memory.Cache4K.Server.Leakage.Obligation.indStepLeak', once per +-- cycle). The simulator's wait is the functional driver's: both are the +-- cache's drivers, which agree with their operational readings +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec', +-- 'Proof.Memory.Cache4K.Server.Leakage.Driver.simSrvDriverMatchesSpec'). +module Proof.Memory.Cache4K.CachedCore.Leakage.Obligation ( baseCaseLeak, indStepLeak0, indStepLeak4, @@ -56,27 +56,27 @@ import Core.RegFile (RegFileOps) import Memory.Cache4K import Memory.Cache4KServer import Memory.Types (MemOps (..)) -import Proof.Cache.CachedCore.Functional.Driver (cachedDriver) -import Proof.Cache.CachedCore.Functional.Invariant (cachedInvAt) -import Proof.Cache.CachedCore.Functional.Machine +import Proof.Memory.Cache4K.CachedCore.Functional.Driver (cachedDriver) +import Proof.Memory.Cache4K.CachedCore.Functional.Invariant (cachedInvAt) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine ( CachedSysG (..), initCachedSys, stepCachedOut, ) -import Proof.Cache.CachedCore.Functional.Obligation (cachedOf) -import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriver) -import Proof.Cache.CachedCore.Leakage.Invariant +import Proof.Memory.Cache4K.CachedCore.Functional.Obligation (cachedOf) +import Proof.Memory.Cache4K.CachedCore.Leakage.Driver (simCachedDriver) +import Proof.Memory.Cache4K.CachedCore.Leakage.Invariant ( cachedSimInvAt, simCachedOf, ) -import Proof.Cache.CachedCore.Leakage.Simulator +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator ( SimCachedInput, SimCachedSys (..), simInitCachedSys, simStepCached, ) -import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) -import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.Memory.Cache4K.Server.Functional.Obligation (CoherentOps (..)) +import Proof.Memory.Cache4K.SMT.Raw (RawData (..)) import Proof.Core.Functional.Machine (SysG (..), stepSysOut) import Proof.Core.Leakage.Model (Obs, obsOf) import Types (Address) @@ -92,10 +92,10 @@ data Trace = TraceSingle Obs | TraceCons Obs Trace -- The base case ---------------------------------------------------------------- -- | The base case: the simulator at start agrees with the core at start behind --- the cache at start, in front of any memory. Link 2's functional invariant --- at start is its functional base case --- ('Proof.Cache.CachedCore.Functional.Obligation.baseCase'). A sanity check: --- it follows from the cache's leakage base case (see the module header). +-- the cache at start, in front of any memory. Link 2's functional invariant at +-- start is its functional base case +-- ('Proof.Memory.Cache4K.CachedCore.Functional.Obligation.baseCase'). A sanity +-- check: it follows from the cache's leakage base case (see the module header). baseCaseLeak :: SetIdx -> Address -> r -> m -> Bool baseCaseLeak wsi pc rf mem = cachedSimInvAt wsi simInitCachedSys (initCachedSys pc rf mem) diff --git a/proof/Proof/Cache/CachedCore/Leakage/Simulator.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Simulator.hs similarity index 68% rename from proof/Proof/Cache/CachedCore/Leakage/Simulator.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Leakage/Simulator.hs index 8c9383a..d532d11 100644 --- a/proof/Proof/Cache/CachedCore/Leakage/Simulator.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Simulator.hs @@ -1,14 +1,14 @@ -- | The simulator of link 2's leakage half: what the bus between the core and -- the cache shows, computed from what the bus between the core and ideal -- memory shows -- the counterpart of --- "Proof.Cache.CachedCore.Functional.Machine". +-- "Proof.Memory.Cache4K.CachedCore.Functional.Machine". -- -- It runs cycle by cycle, as the core behind the cache does. In a cycle in -- which the core does not wait, its input is the observation the core behind -- ideal memory makes; while the core waits, it has no input. It carries only --- the cache's simulator ("Proof.Cache.Server.Leakage.Simulator"), which --- decides from the observations alone in which cycles the answer comes. -module Proof.Cache.CachedCore.Leakage.Simulator +-- the cache's simulator ("Proof.Memory.Cache4K.Server.Leakage.Simulator"), +-- which decides from the observations alone in which cycles the answer comes. +module Proof.Memory.Cache4K.CachedCore.Leakage.Simulator ( SimCachedInput, SimCachedSys (..), simInitCachedSys, @@ -17,7 +17,7 @@ module Proof.Cache.CachedCore.Leakage.Simulator where import Data.Maybe (fromMaybe) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv, simInitCacheSrv, simServe, @@ -34,7 +34,7 @@ import Proof.Core.Leakage.Model (Obs (..)) type SimCachedInput = Maybe Obs -- | The simulator's counterpart of --- 'Proof.Cache.CachedCore.Functional.Machine.CachedSysG': the cache's +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Machine.CachedSysG': the cache's -- simulator, and what the core can see of its input -- whether the cache -- answered in the previous cycle, and so whether the core is no longer -- waiting. @@ -47,18 +47,18 @@ data SimCachedSys = SimCachedSys deriving (Show, Eq) -- | The simulator at start: the cache's simulator at start --- ('Proof.Cache.Server.Leakage.Simulator.simInitCacheSrv'), and an answer in --- the previous cycle, as the core's input at start holds one --- ('Core.initInput'). +-- ('Proof.Memory.Cache4K.Server.Leakage.Simulator.simInitCacheSrv'), and an +-- answer in the previous cycle, as the core's input at start holds one +-- ('Core.Pipeline.initInput'). simInitCachedSys :: SimCachedSys simInitCachedSys = SimCachedSys simInitCacheSrv True -- | One cycle of the core behind the cache, as --- 'Proof.Cache.CachedCore.Functional.Machine.stepCachedOut'. If the cache --- answered in the previous cycle, the core makes the ideal observation, and the --- cache's simulator is given it; otherwise the core waits, the bus shows no --- request and the simulator has no input. Returns the simulator afterwards and --- the bus's observation. +-- 'Proof.Memory.Cache4K.CachedCore.Functional.Machine.stepCachedOut'. If the +-- cache answered in the previous cycle, the core makes the ideal observation, +-- and the cache's simulator is given it; otherwise the core waits, the bus +-- shows no request and the simulator has no input. Returns the simulator +-- afterwards and the bus's observation. simStepCached :: SimCachedSys -> SimCachedInput -> (SimCachedSys, Obs) simStepCached (SimCachedSys sim answered) inp | answered = diff --git a/proof/Proof/Cache/CachedCore/Leakage/Solver.hs b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs similarity index 78% rename from proof/Proof/Cache/CachedCore/Leakage/Solver.hs rename to proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs index d75e41b..9c4d356 100644 --- a/proof/Proof/Cache/CachedCore/Leakage/Solver.hs +++ b/proof/Proof/Memory/Cache4K/CachedCore/Leakage/Solver.hs @@ -1,10 +1,11 @@ -- | Link 2's leakage half, checked symbolically: the counterpart of --- "Proof.Cache.CachedCore.Functional.Solver". +-- "Proof.Memory.Cache4K.CachedCore.Functional.Solver". -- --- The statements live in "Proof.Cache.CachedCore.Leakage.Driver" and --- "Proof.Cache.CachedCore.Leakage.Obligation"; this module only instantiates --- them, over every core state, input, register file, memory, tag array and --- witness. Each property is named after the statement it checks, with a @P@: +-- The statements live in "Proof.Memory.Cache4K.CachedCore.Leakage.Driver" and +-- "Proof.Memory.Cache4K.CachedCore.Leakage.Obligation"; this module only +-- instantiates them, over every core state, input, register file, memory, tag +-- array and witness. Each property is named after the statement it checks, with +-- a @P@: -- -- * the simulator's driver against its operational reading -- ('simCachedDriverMatchesSpecP'); @@ -16,7 +17,7 @@ -- Under Bitwuzla, not Z3: -- -- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build -module Proof.Cache.CachedCore.Leakage.Solver +module Proof.Memory.Cache4K.CachedCore.Leakage.Solver ( simCachedDriverMatchesSpecP, baseCaseLeakP, indStepLeak0P, @@ -26,22 +27,23 @@ module Proof.Cache.CachedCore.Leakage.Solver ) where -import qualified Core +import qualified Core.Pipeline as Core import Memory.Cache4K import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) -import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..)) +import Proof.Memory.Cache4K.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator (SimCachedSys (..)) import Proof.Core.Leakage.Model (Obs) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv (..), SimCacheSrvState, ) -import Proof.Cache.CachedCore.Leakage.Obligation -import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) -import Proof.Cache.SMT.Raw (RawData) +import Proof.Memory.Cache4K.CachedCore.Leakage.Obligation +import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Memory.Cache4K.SMT.Raw (RawData) import Proof.Core.Functional.System (KState, sysOf) -import Proof.SMT.Array (MemArr, RegArr, RegArrF (..)) +import Proof.Core.SMT.Array (RegArr, RegArrF (..)) +import Proof.SMT.Array (MemArr) import Proof.SMT.Logged (pantomime) import Types diff --git a/proof/Proof/Cache/SMT/Array.hs b/proof/Proof/Memory/Cache4K/SMT/Array.hs similarity index 94% rename from proof/Proof/Cache/SMT/Array.hs rename to proof/Proof/Memory/Cache4K/SMT/Array.hs index eb07aad..911a605 100644 --- a/proof/Proof/Cache/SMT/Array.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Array.hs @@ -2,9 +2,9 @@ -- | The arrays of "Memory.Cache4K" embedded as SMT arrays, as "Proof.SMT.Array" -- embeds the register file and memory: a monomorphic SMT newtype per array, and --- an embedding per wrapper, which the term axioms in "Proof.Cache.SMT.Axioms" --- put in place of the wrapper. -module Proof.Cache.SMT.Array +-- an embedding per wrapper, which the term axioms in +-- "Proof.Memory.Cache4K.SMT.Axioms" put in place of the wrapper. +module Proof.Memory.Cache4K.SMT.Array ( TagArrSMT (..), tagReadE, tagWriteE, diff --git a/proof/Proof/Cache/SMT/Axioms.hs b/proof/Proof/Memory/Cache4K/SMT/Axioms.hs similarity index 68% rename from proof/Proof/Cache/SMT/Axioms.hs rename to proof/Proof/Memory/Cache4K/SMT/Axioms.hs index 375c939..e116f9f 100644 --- a/proof/Proof/Cache/SMT/Axioms.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Axioms.hs @@ -1,7 +1,7 @@ -- | The axioms for the properties about "Memory.Cache4K": those of the register -- file and memory, and the two cache arrays. In its own module for the same -- reason as "Proof.SMT.Axioms". -module Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) where +module Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) where import qualified Data.Map as Map import Memory.Cache4K @@ -17,11 +17,11 @@ import Memory.Cache4K tagWrite, ) import Pantomime (PluginAxioms (..)) -import Proof.SMT.Axioms (arrayAxioms) -import Proof.Cache.SMT.Array -import Proof.Cache.Server.Functional.Obligation (mkDataMem) -import Proof.Cache.SMT.Coherent -import Proof.Cache.SMT.Raw +import Proof.Core.SMT.Axioms (arrayAxioms) +import Proof.Memory.Cache4K.SMT.Array +import Proof.Memory.Cache4K.Server.Functional.Obligation (mkDataMem) +import Proof.Memory.Cache4K.SMT.Coherent +import Proof.Memory.Cache4K.SMT.Raw cacheAxioms :: PluginAxioms cacheAxioms = @@ -45,12 +45,13 @@ cacheAxioms = } -- | The axioms for the cache's proof: as 'cacheAxioms', but the data array is --- embedded as 'Proof.Cache.SMT.Coherent.DataC', so that --- 'Proof.Cache.Server.Functional.Obligation.mkData' builds a cache coherent by --- construction (through its 'MemArr' instance, --- 'Proof.Cache.Server.Functional.Obligation.mkDataMem'). The raw-array and tag --- axioms come first: an embedding that calls another wrapper ('dataReadC' calls --- 'rawRead' and 'tagRead') only sees the axioms listed before its own. +-- embedded as 'Proof.Memory.Cache4K.SMT.Coherent.DataC', so that +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkData' builds a cache +-- coherent by construction (through its 'MemArr' instance, +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem'). The raw-array +-- and tag axioms come first: an embedding that calls another wrapper +-- ('dataReadC' calls 'rawRead' and 'tagRead') only sees the axioms listed +-- before its own. coherentAxioms :: PluginAxioms coherentAxioms = arrayAxioms diff --git a/proof/Proof/Cache/SMT/Coherent.hs b/proof/Proof/Memory/Cache4K/SMT/Coherent.hs similarity index 85% rename from proof/Proof/Cache/SMT/Coherent.hs rename to proof/Proof/Memory/Cache4K/SMT/Coherent.hs index bc60002..a89e244 100644 --- a/proof/Proof/Cache/SMT/Coherent.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Coherent.hs @@ -1,6 +1,7 @@ -- | The SMT side of a cache that is coherent by construction --- ('Proof.Cache.Server.Functional.Obligation.cachedOf'): the term axioms in --- "Proof.Cache.SMT.Axioms" ('Proof.Cache.SMT.Axioms.coherentAxioms') embed +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.cachedOf'): the term +-- axioms in "Proof.Memory.Cache4K.SMT.Axioms" +-- ('Proof.Memory.Cache4K.SMT.Axioms.coherentAxioms') embed -- 'Memory.Cache4K.DataArr' as 'DataC', which carries only arrays: -- -- * the words written since construction, and which slots were written; @@ -10,7 +11,7 @@ -- is valid, else the raw word. Everything stays an array, so the solver can -- share it across the cache's branches; a Haskell function in its place makes -- the longest hop exhaust memory before the query is even built. -module Proof.Cache.SMT.Coherent +module Proof.Memory.Cache4K.SMT.Coherent ( DataC (..), dataReadC, dataWriteC, @@ -22,7 +23,7 @@ import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Data.Coerce (Coercible, coerce) import Memory.Cache4K import Memory.Types (MemOps (..)) -import Proof.Cache.SMT.Raw +import Proof.Memory.Cache4K.SMT.Raw import Proof.SMT.Array (MemArr) import Types (Word) import Prelude hiding (Ordering (..), Word, init, log, not, repeat, undefined, (!!), (&&), (++), (||)) @@ -53,8 +54,9 @@ dataWriteC i v a = where DataC ws written mem tags raw = coerce a --- | The embedding of 'Proof.Cache.Server.Functional.Obligation.mkDataMem': --- nothing written yet. +-- | The embedding of +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem': nothing +-- written yet. mkDataC :: forall arr. (Coercible DataC arr) => MemArr -> TagArr -> RawData -> arr mkDataC mem t raw = coerce (DataC rawZero rawZero mem t raw) diff --git a/proof/Proof/Cache/SMT/Raw.hs b/proof/Proof/Memory/Cache4K/SMT/Raw.hs similarity index 79% rename from proof/Proof/Cache/SMT/Raw.hs rename to proof/Proof/Memory/Cache4K/SMT/Raw.hs index ee3a2ee..dfbe140 100644 --- a/proof/Proof/Cache/SMT/Raw.hs +++ b/proof/Proof/Memory/Cache4K/SMT/Raw.hs @@ -1,11 +1,12 @@ -- | A raw array of 1024 words, indexed like the cache's data array: the -- arbitrary contents of a coherent cache's invalid lines --- ('Proof.Cache.Server.Functional.Obligation.cachedOf'). The term axioms in --- "Proof.Cache.SMT.Axioms" embed it as 'Proof.Cache.SMT.Array.DataArrSMT'. +-- ('Proof.Memory.Cache4K.Server.Functional.Obligation.cachedOf'). The term +-- axioms in "Proof.Memory.Cache4K.SMT.Axioms" embed it as +-- 'Proof.Memory.Cache4K.SMT.Array.DataArrSMT'. -- -- In a module of its own, without the solver's types, so that the obligations -- can mention it and still build without the solver. -module Proof.Cache.SMT.Raw +module Proof.Memory.Cache4K.SMT.Raw ( RawData (..), rawRead, rawWrite, diff --git a/proof/Proof/Cache/Server/Functional/Contract.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs similarity index 86% rename from proof/Proof/Cache/Server/Functional/Contract.hs rename to proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs index 95cc561..7b76c44 100644 --- a/proof/Proof/Cache/Server/Functional/Contract.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Contract.hs @@ -1,7 +1,8 @@ -- | The contract between the core and the 4 KiB cache in front of memory: what -- each side promises beyond the cache's proof against ideal memory --- ("Proof.Cache.Server.Functional.Obligation"), so that the core runs behind --- the cache as it would behind ideal memory, with stutter steps inserted. +-- ("Proof.Memory.Cache4K.Server.Functional.Obligation"), so that the core runs +-- behind the cache as it would behind ideal memory, with stutter steps +-- inserted. -- -- The two sides are not symmetric: the core makes the requests and the cache -- answers them. @@ -22,8 +23,9 @@ -- Both sides are treated as opaque: states are compared whole, with '==', -- not field by field. -- --- The properties are checked in "Proof.Cache.Server.Functional.Solver". -module Proof.Cache.Server.Functional.Contract +-- The properties are checked in +-- "Proof.Memory.Cache4K.Server.Functional.Solver". +module Proof.Memory.Cache4K.Server.Functional.Contract ( srvReady, srvDriverSpec, srvReadyIffAnswered, @@ -34,12 +36,12 @@ module Proof.Cache.Server.Functional.Contract where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), Output (..), Request, StateG (..), circuit) +import Core.Pipeline (Input (..), Output (..), Request, StateG (..), circuit) import Data.Maybe (isJust, isNothing) import Memory.Cache4KServer (CacheSrv (..), serve) import Memory.Types (MemOps) -import Proof.Cache.Server.Functional.Driver (srvDriver) -import Proof.Cache.Server.Functional.Invariant (srvInvAt) +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriver) +import Proof.Memory.Cache4K.Server.Functional.Invariant (srvInvAt) import Core.RegFile (RegFileOps (..)) import Types (Address) import Memory.Cache4K (SetIdx, WordIdx) @@ -75,7 +77,8 @@ srvReadyUnderInv wa wsi wwi ideal srv = -- request, then serve without one until the server answers, and count the -- cycles after the request's. 'Nothing' if more than @fuel@ cycles follow the -- request's. The operational reading of a memory's driver, such as --- 'Proof.Cache.Server.Functional.Driver.srvDriver' ('srvDriverMatchesSpec'). +-- 'Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver' +-- ('srvDriverMatchesSpec'). srvDriverSpec :: (MemOps m) => Int -> CacheSrv m -> Request -> Maybe Int srvDriverSpec fuel srv0 req = let (srv', ans) = serve srv0 req @@ -89,7 +92,7 @@ srvDriverSpec fuel srv0 req = in go (n + 1) srv' (isJust (inputMem ans)) -- | From a ready server ('srvReady'), the driver --- ('Proof.Cache.Server.Functional.Driver.srvDriver') agrees with its +-- ('Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver') agrees with its -- operational reading ('srvDriverSpec'). -- Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two missed -- lines, and no more, since Pantomime unrolls all of them. Readiness suffices, diff --git a/proof/Proof/Cache/Server/Functional/Driver.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Driver.hs similarity index 71% rename from proof/Proof/Cache/Server/Functional/Driver.hs rename to proof/Proof/Memory/Cache4K/Server/Functional/Driver.hs index 7469e4d..1d4ce3d 100644 --- a/proof/Proof/Cache/Server/Functional/Driver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Driver.hs @@ -4,15 +4,15 @@ -- 'srvDriver' is a case table over the cache and the request. Its operational -- reading, obtained by actually serving, makes sense for any memory and so -- lives in the contract --- ('Proof.Cache.Server.Functional.Contract.srvDriverSpec'), together with the --- property that the two agree. -module Proof.Cache.Server.Functional.Driver +-- ('Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverSpec'), together +-- with the property that the two agree. +module Proof.Memory.Cache4K.Server.Functional.Driver ( srvDriver, srvDriverValues, ) where -import Core (MemAccess (..), Request) +import Core.Pipeline (MemAccess (..), Request) import Memory.Cache4K (cacheHit, setOf) import Memory.Cache4KServer import Types @@ -22,9 +22,9 @@ import Types -- the lines of its first and last byte; within four bytes those are different -- lines exactly when they are in different sets. The driver is only ever run -- from servers that satisfy the invariant --- ('Proof.Cache.Server.Functional.Invariant.srvInvAt'), which are ready, so the --- server's state is not consulted; elsewhere it need not agree with --- 'srvDriverSpec'. +-- ('Proof.Memory.Cache4K.Server.Functional.Invariant.srvInvAt'), which are +-- ready, so the server's state is not consulted; elsewhere it need not agree +-- with 'srvDriverSpec'. srvDriver :: CacheSrv m -> Request -> Int srvDriver (CacheSrv c _ _) req = case req of Just (MemRead addr size) -> @@ -43,10 +43,10 @@ srvDriver (CacheSrv c _ _) req = case req of _ -> 0 -- | The driver is 0, 'penalty' or twice 'penalty': the hop lengths of the --- cache's steps ('Proof.Cache.Server.Functional.Obligation.indStep0', --- 'Proof.Cache.Server.Functional.Obligation.indStep4', --- 'Proof.Cache.Server.Functional.Obligation.indStep8'), which so cover every --- hop. +-- cache's steps ('Proof.Memory.Cache4K.Server.Functional.Obligation.indStep0', +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.indStep4', +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.indStep8'), which so cover +-- every hop. srvDriverValues :: CacheSrv m -> Request -> Bool srvDriverValues srv req = k == 0 || k == fromIntegral penalty || k == 2 * fromIntegral penalty diff --git a/proof/Proof/Cache/Server/Functional/Invariant.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Invariant.hs similarity index 97% rename from proof/Proof/Cache/Server/Functional/Invariant.hs rename to proof/Proof/Memory/Cache4K/Server/Functional/Invariant.hs index 497a8ff..1c8a72b 100644 --- a/proof/Proof/Cache/Server/Functional/Invariant.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Invariant.hs @@ -3,7 +3,7 @@ -- many more bytes, so the invariant is stated at a witness byte and a witness -- word, and the obligations quantify over them, as the core's invariant does -- over a register and a byte. -module Proof.Cache.Server.Functional.Invariant +module Proof.Memory.Cache4K.Server.Functional.Invariant ( coherentAt, srvInvAt, srvInvFunctional, diff --git a/proof/Proof/Cache/Server/Functional/Obligation.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs similarity index 88% rename from proof/Proof/Cache/Server/Functional/Obligation.hs rename to proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs index 3dd305c..e61c213 100644 --- a/proof/Proof/Cache/Server/Functional/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Obligation.hs @@ -4,8 +4,8 @@ -- -- They relate the cached memory to ideal memory ("Memory.Ideal") one request at -- a time: ideal memory answers in one cycle, the cached memory in --- 'Proof.Cache.Server.Functional.Driver.srvDriver' + 1 cycles. As the core's --- obligations build the ISA state from the system +-- 'Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver' + 1 cycles. As the +-- core's obligations build the ISA state from the system -- ('Proof.Core.Functional.Invariant.isaOf'), these take ideal memory to be the -- server's memory before the hop; the conclusion compares the memory ideal -- memory steps to with the server's after the hop. @@ -23,7 +23,7 @@ -- answers before the last are 'Nothing' is stated apart, as a sanity check -- ('indStepWaits4', 'indStepWaits8'), since it follows from the driver's -- agreement with its operational reading. -module Proof.Cache.Server.Functional.Obligation +module Proof.Memory.Cache4K.Server.Functional.Obligation ( CoherentOps (..), mkDataMem, baseCase, @@ -36,14 +36,14 @@ module Proof.Cache.Server.Functional.Obligation where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), Request) +import Core.Pipeline (Input (..), Request) import Memory.Cache4K import Memory.Cache4KServer import Memory.Ideal (idealServe) import Memory.Types (MemOps (..)) -import Proof.Cache.Server.Functional.Driver (srvDriver) -import Proof.Cache.Server.Functional.Invariant (srvInvAt) -import Proof.Cache.SMT.Raw (RawData (..)) +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriver) +import Proof.Memory.Cache4K.Server.Functional.Invariant (srvInvAt) +import Proof.Memory.Cache4K.SMT.Raw (RawData (..)) import Proof.SMT.Array (MemArr) import Types (Address, Word) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) @@ -64,8 +64,8 @@ instance CoherentOps MemArr where mkData = mkDataMem -- | 'mkData' on the solver's memory. The solver does not run this body: --- 'Proof.Cache.SMT.Axioms.coherentAxioms' replaces it by --- 'Proof.Cache.SMT.Coherent.mkDataC'. +-- 'Proof.Memory.Cache4K.SMT.Axioms.coherentAxioms' replaces it by +-- 'Proof.Memory.Cache4K.SMT.Coherent.mkDataC'. {-# OPAQUE mkDataMem #-} mkDataMem :: MemArr -> TagArr -> RawData -> DataArr mkDataMem mem tags (RawData raw) = DataArr (imap word raw) @@ -135,9 +135,9 @@ indStep4 wa wsi wwi mem tags raw req = -- | Sanity check for 'indStep4': during the hop, the first 'penalty' answers -- are 'Nothing'. Implied by --- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec': --- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' counts the cycles --- until the first answer. +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec': +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverSpec' counts the +-- cycles until the first answer. indStepWaits4 :: (CoherentOps m) => Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool @@ -175,9 +175,9 @@ indStep8 wa wsi wwi mem tags raw req = -- | Sanity check for 'indStep8': during the hop, the first 2 * 'penalty' -- answers are 'Nothing'. Implied by --- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec': --- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' counts the cycles --- until the first answer. +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec': +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverSpec' counts the +-- cycles until the first answer. indStepWaits8 :: (CoherentOps m) => Address -> SetIdx -> WordIdx -> m -> TagArr -> RawData -> Request -> Bool diff --git a/proof/Proof/Cache/Server/Functional/Solver.hs b/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs similarity index 86% rename from proof/Proof/Cache/Server/Functional/Solver.hs rename to proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs index daddf21..fe204d4 100644 --- a/proof/Proof/Cache/Server/Functional/Solver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Functional/Solver.hs @@ -1,11 +1,11 @@ -- | The cache's functional proof, checked symbolically: the cache's counterpart -- of "Proof.Core.Functional.Solver". -- --- The statements live in "Proof.Cache.Server.Functional.Obligation", --- "Proof.Cache.Server.Functional.Driver" and --- "Proof.Cache.Server.Functional.Contract"; this module only instantiates them, --- over every tag array, data array, memory, request and witness. Each property --- is named after the statement it checks, with a @P@: +-- The statements live in "Proof.Memory.Cache4K.Server.Functional.Obligation", +-- "Proof.Memory.Cache4K.Server.Functional.Driver" and +-- "Proof.Memory.Cache4K.Server.Functional.Contract"; this module only +-- instantiates them, over every tag array, data array, memory, request and +-- witness. Each property is named after the statement it checks, with a @P@: -- -- * sanity probes for the trusted array embeddings; -- * the driver against its operational reading ('srvDriverMatchesSpecP'), and @@ -21,7 +21,7 @@ -- Under Bitwuzla, not Z3: -- -- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build -module Proof.Cache.Server.Functional.Solver +module Proof.Memory.Cache4K.Server.Functional.Solver ( cacheArraysP, coherentDataP, coherentWriteP, @@ -43,28 +43,29 @@ module Proof.Cache.Server.Functional.Solver where import Clash.Prelude (BitVector, d0, d1, d2, d9, not, slice, (++#), (||)) -import Core (Request) -import qualified Core +import Core.Pipeline as Core (Request) +import qualified Core.Pipeline as Core import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) import Memory.Cache4K import Memory.Types (MemOps (..)) import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.SMT.Axioms (cacheAxioms, coherentAxioms) -import Proof.Cache.SMT.Raw (RawData, rawRead) -import Proof.Cache.Server.Functional.Contract +import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms, coherentAxioms) +import Proof.Memory.Cache4K.SMT.Raw (RawData, rawRead) +import Proof.Memory.Cache4K.Server.Functional.Contract ( srvReadyIffAnswered, srvReadyUnderInv, corePatient, srvDriverMatchesSpec, ) -import Proof.Cache.Server.Functional.Driver (srvDriverValues) -import Proof.Cache.Server.Functional.Invariant (srvInvFunctional) -import Proof.Cache.Server.Functional.Obligation +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriverValues) +import Proof.Memory.Cache4K.Server.Functional.Invariant (srvInvFunctional) +import Proof.Memory.Cache4K.Server.Functional.Obligation import Proof.Core.Functional.Machine (SysG (..)) import Proof.Core.Functional.System (KState, sysOf) -import Proof.SMT.Array (MemArr, RegArr) -import Proof.SMT.Axioms (arrayAxioms) +import Proof.Core.SMT.Array (RegArr) +import Proof.SMT.Array (MemArr) +import Proof.Core.SMT.Axioms (arrayAxioms) import Proof.SMT.Logged (pantomime) import Types import Prelude hiding (Word, not, (||)) @@ -85,9 +86,9 @@ cacheArraysP tags dat s e i w = && dataRead i dataZero == 0 -- | The embedding of the coherent cache ('mkData' as --- 'Proof.Cache.SMT.Coherent.DataC'), which is trusted, against what 'mkData' --- defines: a read of the constructed array is memory's word if the line is --- valid, else the raw word. Writes are checked by 'coherentWriteP'. +-- 'Proof.Memory.Cache4K.SMT.Coherent.DataC'), which is trusted, against what +-- 'mkData' defines: a read of the constructed array is memory's word if the +-- line is valid, else the raw word. Writes are checked by 'coherentWriteP'. {-# ANN coherentDataP (Theory coherentAxioms) #-} coherentDataP :: MemArr -> TagArr -> RawData -> BitVector 10 -> Pantomime.Bool coherentDataP ma tags raw i = @@ -211,9 +212,9 @@ indStepWaits8P wa wsi wwi ma tags raw req = -- The contract ----------------------------------------------------------------- -- --- The properties of "Proof.Cache.Server.Functional.Contract": the cache's over --- a server with arbitrary tags, data, memory and state, the core's over a core --- state built from symbolic parts as in the core's proof +-- The properties of "Proof.Memory.Cache4K.Server.Functional.Contract": the +-- cache's over a server with arbitrary tags, data, memory and state, the core's +-- over a core state built from symbolic parts as in the core's proof -- ('Proof.Core.Functional.System.sysOf'). -- | After a step, the server is ready exactly when it has answered. diff --git a/proof/Proof/Cache/Server/Leakage/Driver.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Driver.hs similarity index 69% rename from proof/Proof/Cache/Server/Leakage/Driver.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Driver.hs index abebd9d..454ac56 100644 --- a/proof/Proof/Cache/Server/Leakage/Driver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Driver.hs @@ -1,12 +1,12 @@ -- | The cache simulator's driver: how many cycles after an observed request the -- simulator answers -- the counterpart of --- "Proof.Cache.Server.Functional.Driver" for --- "Proof.Cache.Server.Leakage.Simulator". +-- "Proof.Memory.Cache4K.Server.Functional.Driver" for +-- "Proof.Memory.Cache4K.Server.Leakage.Simulator". -- -- The cache's leakage proof does not need it: the simulator runs cycle by -- cycle. The proof of the core behind the cache does, to know how long a hop -- takes from the simulators alone. -module Proof.Cache.Server.Leakage.Driver +module Proof.Memory.Cache4K.Server.Leakage.Driver ( simSrvDriver, simSrvDriverSpec, simSrvDriverMatchesSpec, @@ -15,7 +15,7 @@ where import Memory.Cache4K (setOf) import Memory.Cache4KServer (penalty) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv (..), simServe, simSrvReady, @@ -26,8 +26,8 @@ import Types -- | The cycles after the observed request until the simulator answers: -- 'penalty' for every line a data read misses, nothing for anything else, as --- 'Proof.Cache.Server.Functional.Driver.srvDriver' computes for the server. --- Only ever run from a ready simulator, so its state is not consulted. +-- 'Proof.Memory.Cache4K.Server.Functional.Driver.srvDriver' computes for the +-- server. Only ever run from a ready simulator, so its state is not consulted. simSrvDriver :: SimCacheSrv -> Obs -> Int simSrvDriver (SimCacheSrv t _) obs = case obs of DataRead addr size -> @@ -46,9 +46,10 @@ simSrvDriver (SimCacheSrv t _) obs = case obs of _ -> 0 -- | The operational reading of 'simSrvDriver', as --- 'Proof.Cache.Server.Functional.Contract.srvDriverSpec' is of the server's: --- step on the observed request, then with no input until the simulator --- answers, and count the cycles after the request's. 'Nothing' if more than +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverSpec' is of the +-- server's: step on the observed request, then with no input until the +-- simulator answers, and count the cycles after the request's. 'Nothing' if +-- more than -- @fuel@ cycles follow the request's. simSrvDriverSpec :: Int -> SimCacheSrv -> Obs -> Maybe Int simSrvDriverSpec fuel sim0 obs = @@ -64,10 +65,10 @@ simSrvDriverSpec fuel sim0 obs = -- | From a ready simulator ('simSrvReady'), its driver agrees with its -- operational reading, as --- 'Proof.Cache.Server.Functional.Contract.srvDriverMatchesSpec' for the server. --- Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two missed --- lines. Readiness suffices, as for the server: the driver only asks which --- lines hit. +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvDriverMatchesSpec' for +-- the server. Eight cycles of fuel, 2 * 'penalty', cover the longest hop, two +-- missed lines. Readiness suffices, as for the server: the driver only asks +-- which lines hit. simSrvDriverMatchesSpec :: SimCacheSrv -> Obs -> Bool simSrvDriverMatchesSpec sim obs = not premises || conclusion diff --git a/proof/Proof/Cache/Server/Leakage/Invariant.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Invariant.hs similarity index 90% rename from proof/Proof/Cache/Server/Leakage/Invariant.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Invariant.hs index f1da6e4..c9953df 100644 --- a/proof/Proof/Cache/Server/Leakage/Invariant.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Invariant.hs @@ -1,7 +1,7 @@ -- | The invariant of the cache's leakage proof: the simulator's tags are the -- server's, at a witness set, and both wait for memory alike -- the leakage --- counterpart of "Proof.Cache.Server.Functional.Invariant". -module Proof.Cache.Server.Leakage.Invariant +-- counterpart of "Proof.Memory.Cache4K.Server.Functional.Invariant". +module Proof.Memory.Cache4K.Server.Leakage.Invariant ( srvSimInvAt, simOf, ) @@ -10,7 +10,7 @@ where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Memory.Cache4K import Memory.Cache4KServer (CacheSrv (..), CacheSrvState (..)) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv (..), SimCacheSrvState (..), ) diff --git a/proof/Proof/Cache/Server/Leakage/Model.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Model.hs similarity index 90% rename from proof/Proof/Cache/Server/Leakage/Model.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Model.hs index 1b87c6b..1178c83 100644 --- a/proof/Proof/Cache/Server/Leakage/Model.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Model.hs @@ -11,14 +11,14 @@ -- The server's internals -- the cache's contents, line fills, write-through to -- memory, the stall counter -- are hidden. What the cache adds to the bus is -- timing: the cycles in which it does not answer. -module Proof.Cache.Server.Leakage.Model +module Proof.Memory.Cache4K.Server.Leakage.Model ( Obs (..), obsReq, obsAns, ) where -import Core (Input (..)) +import Core.Pipeline as Core (Input (..)) import Data.Maybe (isJust) import Proof.Core.Leakage.Model (Obs (..), obsReq) diff --git a/proof/Proof/Cache/Server/Leakage/Obligation.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Obligation.hs similarity index 80% rename from proof/Proof/Cache/Server/Leakage/Obligation.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Obligation.hs index b094010..f1303fa 100644 --- a/proof/Proof/Cache/Server/Leakage/Obligation.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Obligation.hs @@ -1,6 +1,6 @@ -- | The cache's leakage obligations: the simulator --- ("Proof.Cache.Server.Leakage.Simulator"), which sees only the observations of --- the requests, answers in the same cycles as the server. +-- ("Proof.Memory.Cache4K.Server.Leakage.Simulator"), which sees only the +-- observations of the requests, answers in the same cycles as the server. -- -- The simulator runs cycle by cycle, as the server does, so there is no driver -- and one step obligation, for one cycle, from any state of the server: ready @@ -11,20 +11,20 @@ -- ('Proof.Core.Functional.Invariant.isaOf'): a simulator that satisfies the -- invariant at every set is the one built from the server. The conclusion -- compares the two after the cycle, at a witness set. -module Proof.Cache.Server.Leakage.Obligation +module Proof.Memory.Cache4K.Server.Leakage.Obligation ( baseCaseLeak, indStepLeak, ) where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Request) +import Core.Pipeline (Request) import Memory.Cache4K import Memory.Cache4KServer import Memory.Types (MemOps) -import Proof.Cache.Server.Leakage.Invariant (simOf, srvSimInvAt) -import Proof.Cache.Server.Leakage.Model (obsAns, obsReq) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Invariant (simOf, srvSimInvAt) +import Proof.Memory.Cache4K.Server.Leakage.Model (obsAns, obsReq) +import Proof.Memory.Cache4K.Server.Leakage.Simulator import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) -- The base case ---------------------------------------------------------------- diff --git a/proof/Proof/Cache/Server/Leakage/Simulator.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Simulator.hs similarity index 87% rename from proof/Proof/Cache/Server/Leakage/Simulator.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Simulator.hs index b2a0af6..de1c1ab 100644 --- a/proof/Proof/Cache/Server/Leakage/Simulator.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Simulator.hs @@ -7,13 +7,13 @@ -- 'Memory.Cache4KServer.serve'): from the tags and the observation of a cycle's -- request it computes whether the server answers in that cycle, and the tags -- and stall counter afterwards. The leakage proof --- ("Proof.Cache.Server.Leakage.Obligation") shows that the server agrees, so --- the stalls -- the only thing the cache adds to the bus trace -- depend on the --- observations alone. +-- ("Proof.Memory.Cache4K.Server.Leakage.Obligation") shows that the server +-- agrees, so the stalls -- the only thing the cache adds to the bus trace -- +-- depend on the observations alone. -- -- Readiness is defined by behaviour, as for the server ('simSrvReady'), with -- its property ('simSrvReadyIffAnswered'). -module Proof.Cache.Server.Leakage.Simulator +module Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrvState (..), SimCacheSrv (..), simInitCacheSrv, @@ -53,8 +53,8 @@ simInitCacheSrv :: SimCacheSrv simInitCacheSrv = SimCacheSrv tagEmpty SimCacheSrvReady -- | One cycle, as 'Memory.Cache4KServer.serve', from the observation of the --- cycle's request ('Nothing' for no input): whether the server answers in --- this cycle ('Proof.Cache.Server.Leakage.Model.obsAns'), and the simulator +-- cycle's request ('Nothing' for no input): whether the server answers in this +-- cycle ('Proof.Memory.Cache4K.Server.Leakage.Model.obsAns'), and the simulator -- afterwards. A read that misses fills the line's tag and stalls 'penalty' -- cycles per missed line; everything else is answered at once. simServe :: SimCacheSrv -> Obs -> (SimCacheSrv, Bool) @@ -98,15 +98,16 @@ tagFill :: Address -> TagArr -> TagArr tagFill addr t = tagWrite (setOf addr) ((1 :: BitVector 1) ++# tagOf addr) t -- | Is the simulator ready for a request? As --- 'Proof.Cache.Server.Functional.Contract.srvReady', defined by its behaviour: --- given no input, it answers within the cycle and stays the same. +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvReady', defined by its +-- behaviour: given no input, it answers within the cycle and stays the same. simSrvReady :: SimCacheSrv -> Bool simSrvReady sim = let (sim', ans) = simServe sim NoAccess in sim' == sim && ans -- | After a step, the simulator is ready exactly when it has answered: the --- counterpart of 'Proof.Cache.Server.Functional.Contract.srvReadyIffAnswered'. +-- counterpart of +-- 'Proof.Memory.Cache4K.Server.Functional.Contract.srvReadyIffAnswered'. simSrvReadyIffAnswered :: SimCacheSrv -> Obs -> Bool simSrvReadyIffAnswered sim obs = let (sim', ans) = simServe sim obs diff --git a/proof/Proof/Cache/Server/Leakage/Solver.hs b/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs similarity index 77% rename from proof/Proof/Cache/Server/Leakage/Solver.hs rename to proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs index 2d372cc..b39014b 100644 --- a/proof/Proof/Cache/Server/Leakage/Solver.hs +++ b/proof/Proof/Memory/Cache4K/Server/Leakage/Solver.hs @@ -1,17 +1,17 @@ -- | The cache's leakage proof, checked symbolically: the cache's counterpart of -- "Proof.Core.Leakage.Solver". -- --- The statements live in "Proof.Cache.Server.Leakage.Obligation"; this module --- only instantiates them, over every memory, request and witness set, and for --- the step over a server with arbitrary tags, data, memory and state. Each --- property is named after the statement it checks, with a @P@. +-- The statements live in "Proof.Memory.Cache4K.Server.Leakage.Obligation"; this +-- module only instantiates them, over every memory, request and witness set, +-- and for the step over a server with arbitrary tags, data, memory and state. +-- Each property is named after the statement it checks, with a @P@. -- -- == Running them -- -- Under Bitwuzla, not Z3: -- -- > SBV_Z3=/usr/local/bin/bitwuzla SBV_Z3_OPTIONS="--produce-models" stack build -module Proof.Cache.Server.Leakage.Solver +module Proof.Memory.Cache4K.Server.Leakage.Solver ( simSrvReadyIffAnsweredP, simSrvDriverMatchesSpecP, baseCaseLeakP, @@ -20,20 +20,20 @@ module Proof.Cache.Server.Leakage.Solver ) where -import Core (Request) +import Core.Pipeline (Request) import Memory.Cache4K import Memory.Cache4KServer (CacheSrv (..), CacheSrvState) -import Proof.Cache.Server.Leakage.Simulator +import Proof.Memory.Cache4K.Server.Leakage.Simulator ( SimCacheSrv (..), SimCacheSrvState (..), simSrvReadyIffAnswered, ) import Pantomime (Theory (..)) import qualified Pantomime.BuiltIn as Pantomime -import Proof.Cache.Server.Leakage.Driver (simSrvDriverMatchesSpec) -import Proof.Cache.Server.Leakage.Obligation -import Proof.Cache.Server.Leakage.Model (Obs) -import Proof.Cache.SMT.Axioms (cacheAxioms) +import Proof.Memory.Cache4K.Server.Leakage.Driver (simSrvDriverMatchesSpec) +import Proof.Memory.Cache4K.Server.Leakage.Obligation +import Proof.Memory.Cache4K.Server.Leakage.Model (Obs) +import Proof.Memory.Cache4K.SMT.Axioms (cacheAxioms) import Proof.SMT.Array (MemArr) import Proof.SMT.Logged (pantomime) diff --git a/proof/Proof/SMT/Array.hs b/proof/Proof/SMT/Array.hs index 741d4a9..571ee8a 100644 --- a/proof/Proof/SMT/Array.hs +++ b/proof/Proof/SMT/Array.hs @@ -1,17 +1,18 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MagicHash #-} --- | A register file embedded as an SMT array. +-- | Memory embedded as an SMT array, shared by every proof, and the +-- conversion of 'Unsigned' to 'Integer' that pantomime-clash leaves out. The +-- core's register file is embedded the same way in "Proof.Core.SMT.Array". -- -- The embedding has to be /monomorphic/: an SMT array needs concrete index and -- 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 monomorphic newtype ('MemArr') for the Haskell side, +-- * a matching newtype ('MemArrSMT') wrapping the SMT array, -- * a type axiom relating the two, --- * monomorphic wrappers ('loadRA', 'storeRA') that the verified code calls +-- * monomorphic wrappers ('loadM', 'storeM') that the verified code calls -- instead of Clash's polymorphic @(!!)@ and @replace@, each with a term -- axiom pointing at an embedding written with 'coerce'. -- @@ -20,9 +21,7 @@ -- Haskell implementations, which the axioms replace before symbolic execution -- ever sees them. module Proof.SMT.Array - ( RegArr (..), - RegArrF (..), - MemArr (..), + ( MemArr (..), MemArrSMT (..), loadM, storeM, @@ -30,18 +29,6 @@ module Proof.SMT.Array storeME, eqM, eqME, - RegArrSMT (..), - loadRA, - storeRA, - zeroRA, - zeroRAE, - loadRAE, - storeRAE, - eqRA, - eqRAE, - sllWordE, - srlWordE, - sraWordE, unsignedToIntegerE, ) where @@ -51,205 +38,19 @@ import Data.Coerce (Coercible, coerce) import qualified Pantomime.BuiltIn as P import qualified Pantomime.Clash as Clash import Memory.Types (MEM_SIZE_BYTES, MemOps (..)) -import Core.RegFile (RegFileOps (..)) import 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) - --- | Equality, so that whole register files can be compared. Replaced by 'eqRAE' --- under the term axiom; OPAQUE for the same reason as 'loadRA'. -{-# OPAQUE eqRA #-} -eqRA :: RegArr -> RegArr -> Bool -eqRA (RegArr v) (RegArr w) = v == w - -instance Eq RegArr where - (==) = eqRA - --- | Embedding of 'eqRA' as array equality. -eqRAE :: forall arr. (Coercible RegArrSMT arr) => arr -> arr -> Bool -eqRAE = coerce go - where - go :: RegArrSMT -> RegArrSMT -> Bool - go (RegArrSMT a) (RegArrSMT b) = a == b - --- | The all-zero register file. --- --- 'Proof.Core.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'. A --- verification-only representation. -newtype RegArrF = RegArrF RegArr - deriving (Eq) - -instance RegFileOps RegArrF where - lookupRFg idx (RegArrF a) = if idx == 0 then 0 else loadRA a idx - modifyRFg idx v rf@(RegArrF a) - | idx == 0 = rf - | otherwise = RegArrF (storeRA a idx 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)) - --- Unsigned to Integer --------------------------------------------------------- --- --- pantomime-clash embeds @toInteger@ on 'BitVector' but not on 'Unsigned', and --- Clash's primitive is @OPAQUE@, so even a literal such as --- 'Memory.Cache4KServer.penalty' converted with 'fromIntegral' stops symbolic --- execution. Both types are embedded as 'Clash.BitVec', so the embedding is --- the same. On a constant, the solver library folds the conversion away, so --- the query stays in the bitvector fragment. - --- | @toInteger@ on an 'Unsigned' as @ubv_to_int@. -unsignedToIntegerE :: - forall (bv :: Nat -> Type) (n :: Nat). - (Coercible Clash.BitVec bv) => - bv n -> - Integer -unsignedToIntegerE = coerce go - where - go :: Clash.BitVec n -> Integer - go Clash.BitVecZ = 0 - go (Clash.BitVecP x) = P.toInteger (P.bvu2i x) - -- 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. +-- A 'Vec', mirroring 'Proof.Core.SMT.Array.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. @@ -328,3 +129,24 @@ instance MemOps MemArr where b2 = slice d23 d16 w b3 = slice d31 d24 w put i v mm = storeM mm i v + +-- Unsigned to Integer --------------------------------------------------------- +-- +-- pantomime-clash embeds @toInteger@ on 'BitVector' but not on 'Unsigned', and +-- Clash's primitive is @OPAQUE@, so even a literal such as +-- 'Memory.Cache4KServer.penalty' converted with 'fromIntegral' stops symbolic +-- execution. Both types are embedded as 'Clash.BitVec', so the embedding is +-- the same. On a constant, the solver library folds the conversion away, so +-- the query stays in the bitvector fragment. + +-- | @toInteger@ on an 'Unsigned' as @ubv_to_int@. +unsignedToIntegerE :: + forall (bv :: Nat -> Type) (n :: Nat). + (Coercible Clash.BitVec bv) => + bv n -> + Integer +unsignedToIntegerE = coerce go + where + go :: Clash.BitVec n -> Integer + go Clash.BitVecZ = 0 + go (Clash.BitVecP x) = P.toInteger (P.bvu2i x) diff --git a/proof/Proof/SMT/Axioms.hs b/proof/Proof/SMT/Axioms.hs index b60bc4d..b4a59b8 100644 --- a/proof/Proof/SMT/Axioms.hs +++ b/proof/Proof/SMT/Axioms.hs @@ -1,13 +1,14 @@ {-# LANGUAGE MagicHash #-} --- | The axiom set used by the proof properties. +-- | The axiom sets every proof builds on: the embeddings of 'base' and of the +-- Clash numeric types, and memory as an SMT array ("Proof.SMT.Array"). The +-- core's register file and shifts add theirs in "Proof.Core.SMT.Axioms". -- -- 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 +module Proof.SMT.Axioms (axioms, memAxioms) 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 @@ -15,16 +16,9 @@ import qualified Pantomime.Clash as Clash import qualified Clash.Sized.Internal.Unsigned as Unsigned -- | '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\". +-- 'Signed', 'Bit'), which is what this core's types are built from. axioms :: PluginAxioms -axioms = Base.axioms <> Clash.axioms <> unsignedAxioms <> shiftAxioms +axioms = Base.axioms <> Clash.axioms <> unsignedAxioms -- | What pantomime-clash leaves out for 'Unsigned': its conversion to -- 'Integer', which 'fromIntegral' goes through. @@ -35,40 +29,16 @@ unsignedAxioms = termAxioms = [('Unsigned.toInteger#, 'unsignedToIntegerE)] } --- | 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. +-- | The memory-as-SMT-array embedding, on top of the base set. -- -- Monomorphic by necessity: an array needs concrete index and element sorts. -arrayAxioms :: PluginAxioms -arrayAxioms = +memAxioms :: PluginAxioms +memAxioms = axioms <> PluginAxioms - { typeAxioms = - Map.fromList - [ (''RegArr, ''RegArrSMT), - (''MemArr, ''MemArrSMT) - ], + { typeAxioms = Map.fromList [(''MemArr, ''MemArrSMT)], termAxioms = - [ ('loadRA, 'loadRAE), - ('zeroRA, 'zeroRAE), - ('storeRA, 'storeRAE), - ('eqRA, 'eqRAE), - ('loadM, 'loadME), + [ ('loadM, 'loadME), ('storeM, 'storeME), ('eqM, 'eqME) ] diff --git a/src/Core/Alu.hs b/src/Core/Alu.hs new file mode 100644 index 0000000..4f5bced --- /dev/null +++ b/src/Core/Alu.hs @@ -0,0 +1,81 @@ +-- | The arithmetic and comparison semantics of instructions: what the ALU +-- computes for an operation, and whether a branch's comparison holds. Shared +-- by the pipeline ("Core.Pipeline") and the ISA ("Core.ISA"), so that neither +-- depends on the other. +module Core.Alu + ( alu, + branch, + sllWord, + srlWord, + sraWord, + ) +where + +import Clash.Prelude hiding (Ordering (..), Word, def, init, lift) +import Core.Instruction (Arith (..), Comparison (..)) +import Types (Word) +import Prelude hiding (Ordering (..), Word, init, not, undefined, (&&), (||)) + +-- | What the ALU computes for an arithmetic operation on two words. +alu :: Arith -> Word -> Word -> Word +alu op lhs rhs = case op of + ADD -> lhs + rhs + SUB -> lhs - rhs + XOR -> lhs .^. rhs + OR -> lhs .|. rhs + AND -> lhs .&. 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 = slice d4 d0 + 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 "Proof.SMT.Axioms" map each shift to its SMT +-- counterpart; see 'Proof.SMT.Array.sllWordE'. +-- +-- OPAQUE is essential, for the same reason as 'Proof.SMT.Array.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)) + +-- | Does a branch's comparison hold of two words? +branch :: Comparison -> Word -> Word -> Bool +branch op lhs rhs = case op of + EQ -> lhs == rhs + NE -> lhs /= rhs + LT -> sign lhs < sign rhs + GE -> sign lhs >= sign rhs + LTU -> lhs < rhs + GEU -> lhs >= rhs + where + sign = unpack @(Signed 32) diff --git a/src/Core/ISA.hs b/src/Core/ISA.hs index 9339f3a..071aa12 100644 --- a/src/Core/ISA.hs +++ b/src/Core/ISA.hs @@ -40,7 +40,7 @@ where import Clash.Prelude hiding (Const, Log, Ordering (..), Word, def, init, lift, log) -import Core hiding (Syscall) +import Core.Alu (alu, branch) import Core.Instruction (Instruction, Sign, decode', loadExtend) import qualified Core.Instruction import Memory.Types (MemBytes, MemOps (..)) @@ -202,7 +202,7 @@ deriving instance (Show r, Show m) => Show (IsaStateG r m) deriving instance (Eq r, 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'. +-- @ecall@, which is where "Core.Pipeline" parks in a 'Core.Pipeline.HaltState'. data StepG r m = Next (IsaStateG r m) | IsaHalted diff --git a/src/Core.hs b/src/Core/Pipeline.hs similarity index 88% rename from src/Core.hs rename to src/Core/Pipeline.hs index b7cfda9..3ac7ff0 100644 --- a/src/Core.hs +++ b/src/Core/Pipeline.hs @@ -6,7 +6,7 @@ {-# LANGUAGE InstanceSigs #-} {- HLINT ignore "Functor law" -} -module Core +module Core.Pipeline ( initInput, initAt, init, @@ -26,11 +26,6 @@ module Core MemAccess (..), Request, Control (..), - alu, - branch, - sllWord, - srlWord, - sraWord, topEntity, ) where @@ -39,6 +34,7 @@ import Clash.Prelude hiding (Ordering (..), Word, def, init, lift) import Control.Monad import Control.Monad.RWS import Data.Maybe (fromMaybe, isJust, isNothing) +import Core.Alu (alu, branch) import Core.Instruction hiding (decode) import Memory.Types import Core.RegFile @@ -443,67 +439,6 @@ executeFresh = do pure fwdVal pure $ fromMaybe def (pick ctrlMeRegFwd <|> pick ctrlWbRegFwd) -alu :: Arith -> Word -> Word -> Word -alu op lhs rhs = case op of - ADD -> lhs + rhs - SUB -> lhs - rhs - XOR -> lhs .^. rhs - OR -> lhs .|. rhs - AND -> lhs .&. 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 = slice d4 d0 - 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 :: Comparison -> Word -> Word -> Bool -branch op lhs rhs = case op of - EQ -> lhs == rhs - NE -> lhs /= rhs - LT -> sign lhs < sign rhs - GE -> sign lhs >= sign rhs - LTU -> lhs < rhs - GEU -> lhs >= rhs - where - sign = unpack @(Signed 32) - -- | Memory stage. Holds while memory has not answered (see 'writeback'). memory :: CPUM r () memory = do diff --git a/src/Core/RegFile.hs b/src/Core/RegFile.hs index c887ac9..20a97e7 100644 --- a/src/Core/RegFile.hs +++ b/src/Core/RegFile.hs @@ -64,10 +64,10 @@ 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. +-- 'Core.Pipeline.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 :: RegIdx -> r -> Word modifyRFg :: RegIdx -> Word -> r -> r @@ -81,9 +81,9 @@ instance RegFileOps RegFile where -- | 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. +-- must never reach 'Core.Pipeline.topEntity'. It exists purely so that reads +-- become applications and writes become lambdas, both of which the symbolic +-- executor handles natively. newtype RegFn = RegFn (RegIdx -> Word) instance RegFileOps RegFn where diff --git a/src/Elf/ElfLoader.hs b/src/Elf/ElfLoader.hs index 70de775..3d82cb0 100644 --- a/src/Elf/ElfLoader.hs +++ b/src/Elf/ElfLoader.hs @@ -13,7 +13,7 @@ import Clash.Explicit.Prelude (Unsigned, bitCoerce, zeroExtend) import Clash.Explicit.Prelude.Safe ((.&.)) import Control.Monad (forM_, forM) import Control.Monad.Catch -import qualified Core +import qualified Core.Pipeline as Core import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS import Data.Char (chr) diff --git a/src/Elf/Syscall.hs b/src/Elf/Syscall.hs index 09049da..2c0ba46 100644 --- a/src/Elf/Syscall.hs +++ b/src/Elf/Syscall.hs @@ -27,7 +27,7 @@ import System.Entropy import qualified Data.ByteString as BS import Types -import qualified Core +import qualified Core.Pipeline as Core import Core.RegFile -- Custom exception type for non-zero program exit codes diff --git a/src/HardwareSim.hs b/src/HardwareSim.hs index 6bb03d8..3de508a 100644 --- a/src/HardwareSim.hs +++ b/src/HardwareSim.hs @@ -5,7 +5,7 @@ module HardwareSim (topEntity) where import Clash.Prelude hiding (Log, Ordering (..), Word, def, init, lift, log) -import Core hiding (topEntity) +import Core.Pipeline hiding (topEntity) import Data.Maybe (fromMaybe) import qualified GHC.TypeNats import Core.Instruction hiding (decode) diff --git a/src/Memory/Cache4K.hs b/src/Memory/Cache4K.hs index f6bb2bb..642748c 100644 --- a/src/Memory/Cache4K.hs +++ b/src/Memory/Cache4K.hs @@ -8,8 +8,9 @@ -- -- The arrays are 'Vec's, read and written only through the wrappers below. -- Those are @OPAQUE@ so that the proof can replace them by SMT array operations --- ("Proof.Cache.SMT.Array"), as it does for the register file and memory: the --- Clash 'Vec' operations themselves cannot be symbolically executed. +-- ("Proof.Memory.Cache4K.SMT.Array"), as it does for the register file and +-- memory: the Clash 'Vec' operations themselves cannot be symbolically +-- executed. module Memory.Cache4K ( -- * Arrays TagArr (..), diff --git a/src/Memory/Cache4KServer.hs b/src/Memory/Cache4KServer.hs index a59dfed..b2474dc 100644 --- a/src/Memory/Cache4KServer.hs +++ b/src/Memory/Cache4KServer.hs @@ -21,7 +21,7 @@ module Memory.Cache4KServer where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), MemAccess (..), Request) +import Core.Pipeline (Input (..), MemAccess (..), Request) import Memory.Cache4K import Memory.Types (MemOps (..)) import Types diff --git a/src/Memory/Ideal.hs b/src/Memory/Ideal.hs index 79276db..befe7ce 100644 --- a/src/Memory/Ideal.hs +++ b/src/Memory/Ideal.hs @@ -7,7 +7,7 @@ module Memory.Ideal where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), MemAccess (..)) +import Core.Pipeline (Input (..), MemAccess (..)) import Memory.Types (MemOps (..)) import Types (Address, Size (..), Word) import Prelude hiding (Ordering (..), Word, init, log, not, undefined, (!!), (&&), (++), (||)) diff --git a/src/Memory/ST.hs b/src/Memory/ST.hs index b4185a5..f0eafe2 100644 --- a/src/Memory/ST.hs +++ b/src/Memory/ST.hs @@ -16,7 +16,7 @@ import Clash.Prelude hiding (Ordering (..), Word, init, lift) import Control.Monad (when) import Control.Monad.Reader import Control.Monad.ST (RealWorld, ST, stToIO) -import Core +import Core.Pipeline as Core import Data.Array.ST (STUArray, newArray, readArray, writeArray) import Data.Word (Word8) import Memory.Types diff --git a/src/Simulate.hs b/src/Simulate.hs index 358a6a7..38f29b5 100644 --- a/src/Simulate.hs +++ b/src/Simulate.hs @@ -16,8 +16,8 @@ where import Clash.Prelude hiding (Log, Ordering (..), Word, def, init, lift, log) import Control.Monad.RWS import Control.Monad.State -import Core hiding (State) -import qualified Core +import Core.Pipeline as Core hiding (State) +import qualified Core.Pipeline as Core import Data.Maybe (isJust) import Memory.Types import Memory.Vec diff --git a/test/BenchmarkSpec.hs b/test/BenchmarkSpec.hs index 611f6a4..83c4076 100644 --- a/test/BenchmarkSpec.hs +++ b/test/BenchmarkSpec.hs @@ -11,7 +11,7 @@ import Control.Exception (throwIO) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.ST (stToIO, RealWorld) -import qualified Core as Core +import qualified Core.Pipeline as Core import Elf.ElfLoader import Elf.Syscall (handleSyscall) import Numeric (showHex) diff --git a/test/Cache4KSpec.hs b/test/Cache4KSpec.hs index 8e1ca91..d34fd47 100644 --- a/test/Cache4KSpec.hs +++ b/test/Cache4KSpec.hs @@ -14,12 +14,12 @@ module Cache4KSpec where import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) -import Core (Input (..), MemAccess (..), Request) +import Core.Pipeline (Input (..), MemAccess (..), Request) import Memory.Cache4K import Memory.Cache4KServer import Memory.Ideal (idealServe) import Memory.Types -import Proof.Cache.Server.Functional.Driver (srvDriver) +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriver) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck @@ -44,7 +44,7 @@ cache4KTests = -- | A memory for the tests: bytes that are a function of their address and two -- seeds, and the bytes written since, newest first. Unlike 'MemFn' it has --- equality, which 'Proof.Cache.Server.Functional.Contract.srvReady' needs, and +-- equality, which 'Proof.Memory.Cache4K.Server.Functional.Contract.srvReady' needs, and -- it shows. Equality compares the representation, so two memories that agree -- byte for byte may still differ; a server that leaves memory alone leaves it -- equal. diff --git a/test/CacheProofSpec.hs b/test/CacheProofSpec.hs index 783e641..ee0dcd4 100644 --- a/test/CacheProofSpec.hs +++ b/test/CacheProofSpec.hs @@ -4,10 +4,10 @@ -- | The cache's proof and link 2 on random states, and the core behind the -- cache end to end: the cache's counterpart of "ProofSpec". -- --- The statements are the ones "Proof.Cache.Server.Functional.Solver", --- "Proof.Cache.Server.Leakage.Solver", --- "Proof.Cache.CachedCore.Functional.Solver" and --- "Proof.Cache.CachedCore.Leakage.Solver" prove. Here they run on concrete +-- The statements are the ones "Proof.Memory.Cache4K.Server.Functional.Solver", +-- "Proof.Memory.Cache4K.Server.Leakage.Solver", +-- "Proof.Memory.Cache4K.CachedCore.Functional.Solver" and +-- "Proof.Memory.Cache4K.CachedCore.Leakage.Solver" prove. Here they run on concrete -- states, without the trusted array embeddings the solver relies on. -- -- The end-to-end runs check what no single proof states: that link 1 (the @@ -21,7 +21,7 @@ where import Cache4KSpec (TestMem (..), genAddr, genMem, genTag, genWord) import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Clash.Sized.Vector (unsafeFromList) -import Core +import Core.Pipeline as Core import Core.ISA (IsaState, IsaStateG (..), StepG (..), isaStep) import Core.Instruction import Core.RegFile (RegFile, RegFileOps (..), RegFn (..)) @@ -29,28 +29,28 @@ import Data.Maybe (isJust, isNothing) import Memory.Cache4K import Memory.Cache4KServer import Memory.Types -import Proof.Cache.CachedCore.Functional.Driver (cachedDriver, cachedDriverMatchesSpec) -import Proof.Cache.CachedCore.Functional.Machine -import qualified Proof.Cache.CachedCore.Functional.Obligation as Cached -import Proof.Cache.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) -import Proof.Cache.CachedCore.Leakage.Invariant (simCachedOf) -import qualified Proof.Cache.CachedCore.Leakage.Obligation as CachedLeak -import Proof.Cache.CachedCore.Leakage.Simulator (SimCachedSys (..), simInitCachedSys, simStepCached) -import Proof.Cache.SMT.Raw (RawData (..)) -import Proof.Cache.Server.Functional.Contract +import Proof.Memory.Cache4K.CachedCore.Functional.Driver (cachedDriver, cachedDriverMatchesSpec) +import Proof.Memory.Cache4K.CachedCore.Functional.Machine +import qualified Proof.Memory.Cache4K.CachedCore.Functional.Obligation as Cached +import Proof.Memory.Cache4K.CachedCore.Leakage.Driver (simCachedDriverMatchesSpec) +import Proof.Memory.Cache4K.CachedCore.Leakage.Invariant (simCachedOf) +import qualified Proof.Memory.Cache4K.CachedCore.Leakage.Obligation as CachedLeak +import Proof.Memory.Cache4K.CachedCore.Leakage.Simulator (SimCachedSys (..), simInitCachedSys, simStepCached) +import Proof.Memory.Cache4K.SMT.Raw (RawData (..)) +import Proof.Memory.Cache4K.Server.Functional.Contract ( corePatient, srvDriverMatchesSpec, srvReadyIffAnswered, srvReadyUnderInv, ) -import Proof.Cache.Server.Functional.Driver (srvDriver) -import Proof.Cache.Server.Functional.Invariant (coherentAt) -import Proof.Cache.Server.Functional.Obligation (CoherentOps (..)) -import qualified Proof.Cache.Server.Functional.Obligation as Srv -import Proof.Cache.Server.Leakage.Driver (simSrvDriverMatchesSpec) -import Proof.Cache.Server.Leakage.Invariant (simOf) -import Proof.Cache.Server.Leakage.Model (obsReq) -import qualified Proof.Cache.Server.Leakage.Obligation as SrvLeak +import Proof.Memory.Cache4K.Server.Functional.Driver (srvDriver) +import Proof.Memory.Cache4K.Server.Functional.Invariant (coherentAt) +import Proof.Memory.Cache4K.Server.Functional.Obligation (CoherentOps (..)) +import qualified Proof.Memory.Cache4K.Server.Functional.Obligation as Srv +import Proof.Memory.Cache4K.Server.Leakage.Driver (simSrvDriverMatchesSpec) +import Proof.Memory.Cache4K.Server.Leakage.Invariant (simOf) +import Proof.Memory.Cache4K.Server.Leakage.Model (obsReq) +import qualified Proof.Memory.Cache4K.Server.Leakage.Obligation as SrvLeak import Proof.Core.Functional.Machine import Proof.Core.Leakage.Driver (simDriver) import Proof.Core.Leakage.Model (Leak, Obs (..), leakOf, obsOf) @@ -74,7 +74,7 @@ cacheProofTests = -- The coherent cache --------------------------------------------------------------- -- | A coherent cache in front of the tests' memories, as --- 'Proof.Cache.Server.Functional.Obligation.mkDataMem' builds one in front of +-- 'Proof.Memory.Cache4K.Server.Functional.Obligation.mkDataMem' builds one in front of -- the solver's: a valid line holds memory's words, an invalid line raw ones. coherentData :: (MemOps m) => m -> TagArr -> RawData -> DataArr coherentData mem tags (RawData raw) = DataArr (imap word raw) @@ -407,7 +407,7 @@ simHops sys0 = go Nothing (isaStart sys0) simInit -- | The bus trace of the core behind the cache, from the leakage alone: the -- core's simulator gives each cycle of the core behind ideal memory -- ('simHops'), and link 2's simulator --- ("Proof.Cache.CachedCore.Leakage.Simulator") adds the cycles in which the +-- ("Proof.Memory.Cache4K.CachedCore.Leakage.Simulator") adds the cycles in which the -- core waits for the cache. compositeTrace :: Int -> Sys -> [Obs] compositeTrace n sys0 = go (P.concat (P.take n (simHops sys0))) simInitCachedSys diff --git a/test/ProofSpec.hs b/test/ProofSpec.hs index d1bb76e..cdf6df7 100644 --- a/test/ProofSpec.hs +++ b/test/ProofSpec.hs @@ -4,7 +4,7 @@ module ProofSpec (proofTests, progs, initSysProg, alignedWalk, invTrace, invRepo import Clash.Prelude hiding (Ordering (..), Word, def, init, lift, log) import Clash.Sized.Vector (unsafeFromList) -import Core +import Core.Pipeline as Core import Proof.Core.Functional.Driver hiding (loadHazard, storeHazard) import Core.ISA (IsaStateG (..), IsaState, StepG (..), isaStep, isaInstrAt) import Core.Instruction diff --git a/test/Spec.hs b/test/Spec.hs index afbe54f..f7876c9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,7 +12,7 @@ import CacheProofSpec (cacheProofTests) import Clash.Prelude hiding (Log, Ordering (..), Word, break, def, init, lift, log, resize) import Clash.Sized.Vector (unsafeFromList) import Control.Monad -import Core +import Core.Pipeline as Core import Data.Maybe (fromJust, isJust) import Core.Instruction import InstructionSpec (instructionTests) @@ -25,10 +25,10 @@ import qualified Proof.SMT.Sanity as Sanity #endif import qualified Prelude #ifdef SMT_PROOF -import qualified Proof.Cache.Server.Functional.Solver -import qualified Proof.Cache.Server.Leakage.Solver -import qualified Proof.Cache.CachedCore.Functional.Solver -import qualified Proof.Cache.CachedCore.Leakage.Solver +import qualified Proof.Memory.Cache4K.Server.Functional.Solver +import qualified Proof.Memory.Cache4K.Server.Leakage.Solver +import qualified Proof.Memory.Cache4K.CachedCore.Functional.Solver +import qualified Proof.Memory.Cache4K.CachedCore.Leakage.Solver import qualified Proof.Core.Functional.Solver import qualified Proof.Core.Leakage.Solver #endif @@ -120,7 +120,7 @@ sanityTests = testGroup "the 4 KiB cache answers as ideal memory, with delay" [ testCase name $ - lookup name Proof.Cache.Server.Functional.Solver.results + lookup name Proof.Memory.Cache4K.Server.Functional.Solver.results @?= Just Nothing | name <- [ "cacheArraysP", @@ -144,7 +144,7 @@ sanityTests = testGroup "the 4 KiB cache leaks only its requests' observations" [ testCase name $ - lookup name Proof.Cache.Server.Leakage.Solver.results + lookup name Proof.Memory.Cache4K.Server.Leakage.Solver.results @?= Just Nothing | name <- [ "simSrvReadyIffAnsweredP", @@ -156,7 +156,7 @@ sanityTests = testGroup "the core behind the cache refines the core behind ideal memory" [ testCase name $ - lookup name Proof.Cache.CachedCore.Functional.Solver.results + lookup name Proof.Memory.Cache4K.CachedCore.Functional.Solver.results @?= Just Nothing | name <- [ "cachedDriverMatchesSpecP", @@ -171,7 +171,7 @@ sanityTests = testGroup "the core behind the cache leaks only what it leaks behind ideal memory" [ testCase name $ - lookup name Proof.Cache.CachedCore.Leakage.Solver.results + lookup name Proof.Memory.Cache4K.CachedCore.Leakage.Solver.results @?= Just Nothing | name <- [ "simCachedDriverMatchesSpecP", From 6fba37785e4b8d19a213ef2ffef57089e5669e03 Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 3 Nov 2026 10:55:34 +0100 Subject: [PATCH 6/6] Add a note on the layout of the proofs proof/README.md: what each folder under proof/Proof proves (link 1 under Core, the standalone cache and link 2 under Memory/Cache4K, the shared SMT embeddings), the kinds of module a proof folder is split into, and that only the Solver modules run the solver, one module at a time. Co-Authored-By: Claude Opus 5.5 --- proof/README.md | 54 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 proof/README.md diff --git a/proof/README.md b/proof/README.md new file mode 100644 index 0000000..71d3cf0 --- /dev/null +++ b/proof/README.md @@ -0,0 +1,54 @@ +# The proofs + +Everything here is checked at compile time by Pantomime and Bitwuzla. The +statements are ordinary Haskell over the code in `src/`. `proof/` may import +`src/`, never the reverse: the ISA (`Core.ISA`) and ideal memory +(`Memory.Ideal`), which the proofs are checked against, live in `src/`. + +## Layout + +`proof/Proof/` mirrors `src/`: + +``` +Proof/ + Core/ the core (src/Core): the pipeline behind ideal memory + Functional/ link 1: the core behind ideal memory refines the ISA + Leakage/ link 1: and leaks only what the ISA-level leakage says + SMT/ the register file and ALU shifts as SMT terms + Memory/Cache4K/ the 4 KiB cache (src/Memory/Cache4K*) + Server/Functional/ the cache on its own refines ideal memory, with delay; + Contract.hs: what the core and any memory promise each other + Server/Leakage/ the cache leaks only its requests' observations + CachedCore/Functional/ link 2: the core behind the cache refines the core + behind ideal memory + CachedCore/Leakage/ link 2: and leaks only what that core leaks + SMT/ the cache's tag and data arrays as SMT arrays + SMT/ shared: memory as an SMT array, the base axioms, + Logged (marks each query in the build log, so a + timeout can be traced to its property), Sanity + (checks that the plugin runs) +``` + +Link 1 and link 2 are composed on paper, not in code. `test/CacheProofSpec.hs` checks the +composition on real programs. + +## Inside a proof folder + +Each `Functional/` or `Leakage/` folder splits a proof into modules of the same +kinds, using the ones it needs: + +| Module | Holds | +|---------------|-------| +| `Machine` | the system being proved, where `src/` does not already define it: the core with memory, or the core behind the cache | +| `Model` | (leakage) what the attacker observes | +| `Simulator` | (leakage) the machine that predicts the observations from leakage alone | +| `Driver` | how many cycles one step of the spec takes, and its operational reading | +| `Invariant` | the relation between the implementation and its spec | +| `Obligation` | the base case and one inductive step per hop length | +| `Solver` | the properties as Pantomime queries, collected in `results` | +| `System` | (core) how a system state is passed to the solver: SMT arrays for the register file and memory | + +Only the `Solver` modules (and the `SMT` axioms they use) run the solver. They +are built only with the `smt-proof` flag, and `test/Spec.hs` checks that every +entry in each `results` list is valid. Load or build them one module at a +time: a single module needs about 2 GB.