diff --git a/bittide/src/Bittide/DoubleBufferedRAM.hs b/bittide/src/Bittide/DoubleBufferedRAM.hs index ec0aee74f..e2f510d04 100644 --- a/bittide/src/Bittide/DoubleBufferedRAM.hs +++ b/bittide/src/Bittide/DoubleBufferedRAM.hs @@ -92,6 +92,23 @@ blockRamByteAddressable initRAM readAddr newEntry byteSelect = writeBytes = unbundle $ splitWriteInBytes <$> newEntry <*> byteSelect readBytes = bundle $ (`blockRam` readAddr) <$> initBytes <*> writeBytes +registerByteAddressable :: + forall dom a . + (HiddenClockResetEnable dom, Paddable a) => + a -> + Signal dom a -> + Signal dom (ByteEnable (Regs a 8)) -> + Signal dom a +registerByteAddressable initVal newVal byteEnables = + registersToData @_ @8 . RegisterBank <$> bundle regsOut + where + initBytes = getRegs initVal + newBytes = unbundle $ getRegs <$> newVal + regsOut = (`andEnable` register) <$> unbundle (unpack <$> byteEnables) <*> initBytes <*> newBytes + getRegs x = + case paddedToRegisters @8 $ Padded x of + RegisterBank vec -> vec + splitWriteInBytes :: forall maxIndex writeData . (Paddable writeData) => WriteAny maxIndex writeData -> diff --git a/bittide/tests/Tests/DoubleBufferedRAM.hs b/bittide/tests/Tests/DoubleBufferedRAM.hs index 9cb03f199..2a01e8d76 100644 --- a/bittide/tests/Tests/DoubleBufferedRAM.hs +++ b/bittide/tests/Tests/DoubleBufferedRAM.hs @@ -10,6 +10,9 @@ Maintainer: devops@qbaylogic.com {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleContexts #-} module Tests.DoubleBufferedRAM(ramGroup) where import Clash.Prelude @@ -28,15 +31,18 @@ import qualified Data.List as L import qualified Data.Set as Set import qualified GHC.TypeNats as TN import qualified Prelude as P +import Data.Proxy +import Data.Type.Equality (type (:~:)(Refl)) deriving instance (Show a) => Show (SomeVec 1 a) ramGroup :: TestTree ramGroup = testGroup "DoubleBufferedRAM group" [ testPropertyNamed "Reading the buffer." "readDoubleBufferedRAM" readDoubleBufferedRAM - , testPropertyNamed "Wriing and reading back buffers." "readWriteDoubleBufferedRAM" readWriteDoubleBufferedRAM + , testPropertyNamed "Writing and reading back buffers." "readWriteDoubleBufferedRAM" readWriteDoubleBufferedRAM , testPropertyNamed "Byte addressable blockram matches behavorial model." "readWriteByteAddressableBlockram" readWriteByteAddressableBlockram - , testPropertyNamed "Byte addressable double buffered RAM matches behavorial model." "readWriteByteAddressableDoubleBufferedRAM" readWriteByteAddressableDoubleBufferedRAM] + , testPropertyNamed "Byte addressable double buffered RAM matches behavorial model." "readWriteByteAddressableDoubleBufferedRAM" readWriteByteAddressableDoubleBufferedRAM + , testPropertyNamed "Byte addressable register can be written to and read from with byte enables." "readWriteRegisterByteAddressable" readWriteRegisterByteAddressable] genRamContents :: (MonadGen m, Integral i) => i -> m a -> m (SomeVec 1 a) genRamContents depth = genSomeVec (Range.singleton $ fromIntegral (depth - 1)) @@ -148,6 +154,35 @@ readWriteByteAddressableDoubleBufferedRAM = property $ do (_,expectedOut) = L.mapAccumL byteAddressableDoubleBufferedRAMBehaviour (L.head topEntityInput, contents, contents) $ L.tail topEntityInput L.drop 2 simOut === L.tail expectedOut +readWriteRegisterByteAddressable :: Property +readWriteRegisterByteAddressable = property $ do + bytes <- forAll $ Gen.enum 1 10 + case TN.someNatVal bytes of + SomeNat p -> case compareSNat d1 (snatProxy p) of + SNatLE -> go p + _ -> error "readWriteRegisterByteAddressable: Amount of bytes == 0." + where + go :: forall bytes m . (AtLeastOne bytes, AtLeastOne (bytes*8), Monad m) => Proxy bytes -> PropertyT m () + go Proxy = + case sameNat (Proxy @bytes) (Proxy @(Regs (Vec bytes Byte) 8)) of + Just Refl -> do + simLength <- forAll $ Gen.enum 1 100 + let + writeGen = genNonEmptyVec @_ @bytes $ genDefinedBitVector @_ @8 + initVal <- forAll writeGen + writes <- forAll $ Gen.list (Range.singleton simLength) writeGen + byteEnables <- forAll $ Gen.list (Range.singleton simLength) $ genDefinedBitVector @_ @(Regs (Vec bytes Byte) 8) + let + topEntity (unbundle -> (newVal, byteEnable))= + withClockResetEnable @System clockGen resetGen enableGen $ + registerByteAddressable initVal newVal byteEnable + expectedOut = P.scanl simFunc initVal $ P.zip writes byteEnables + simFunc olds (news,unpack -> bools) = (\(bool,old,new) -> if bool then new else old) <$> zip3 bools olds news + simOut = simulateN simLength topEntity $ P.zip writes byteEnables + simOut === P.take simLength expectedOut + _ -> error "readWriteRegisterByteAddressable: Amount of bytes not equal to registers required." + + byteAddressableRAMBehaviour :: forall bits depth bytes . (AtLeastOne depth, AtLeastOne bytes, bytes ~ Regs (BitVector bits) 8, AtLeastOne bits) => ((Index depth, WriteBits depth bits, ByteEnable bytes), Vec depth (BitVector bits))->