Merge pull request #12 from GiPHouse/5-define-a-streaming-protocol

5 define a streaming protocol

clash-eth.cabal

@@ -33,6 +33,7 @@ common common-options
     TypeFamilies
     TypeOperators
     ViewPatterns
+    ImportQualifiedPost
 
     -- TemplateHaskell is used to support convenience functions such as
     -- 'listToVecTH' and 'bLit'.
@@ -84,12 +85,15 @@ library
   exposed-modules:
     Clash.Lattice.ECP5.Colorlight.TopEntity
     Clash.Cores.Ethernet.RGMII
+    Clash.Cores.Ethernet.PacketStream
     Clash.Lattice.ECP5.Prims
     Clash.Lattice.ECP5.Colorlight.CRG
   default-language: Haskell2010
   build-depends:
     interpolate,
-    clash-cores
+    clash-cores,
+    deepseq,
+    hashable
 
 test-suite doctests
   type:             exitcode-stdio-1.0
@@ -110,11 +114,13 @@ test-suite test-library
   ghc-options: -threaded
   main-is: unittests.hs
   other-modules:
-    Test.Cores.Ethernet.Ethernet
+    Test.Cores.Ethernet.PacketStream
   build-depends:
     clash-eth,
     QuickCheck,
     hedgehog,
+    hashable,
+    unordered-containers,
     tasty >= 1.2 && < 1.5,
     tasty-hedgehog,
     tasty-th

src/Clash/Cores/Ethernet/PacketStream.hs

@@ -0,0 +1,136 @@
+{-# language FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Orphhan Hashable instances
+
+module Clash.Cores.Ethernet.PacketStream
+  ( PacketStreamM2S(..)
+  , PacketStreamS2M(..)
+  , PacketStream
+  ) where
+
+import Clash.Prelude hiding ( sample )
+import Prelude qualified as P
+
+import Data.Hashable ( Hashable, hashWithSalt )
+import Data.Maybe qualified as Maybe
+import Data.Proxy
+
+import Control.DeepSeq ( NFData )
+
+import Protocols.Df qualified as Df
+import Protocols.DfConv hiding ( pure )
+import Protocols.Hedgehog.Internal
+import Protocols.Internal
+
+-- | Data sent from manager to subordinate, a simplified AXI4-Stream like interface
+--   with metadata that can only change on packet delineation.
+--   We bundled _tdest, _tuser and _tid into one big _meta field which holds metadata.
+--   We don't have null or position bytes so _tstrb is replaced by a last indicator
+--   that includes how many bytes are valid from the front of the vector.
+--   _tvalid is modeled via wrapping this in a `Maybe`
+data PacketStreamM2S (dataWidth :: Nat) (metaType :: Type)
+  = PacketStreamM2S {
+  _data :: Vec dataWidth (BitVector 8),
+  -- ^ The bytes to be transmitted
+  _last :: Maybe (Index dataWidth),
+  -- ^ If Nothing, we are not yet at the last byte, otherwise signifies how many bytes of _data are valid
+  _meta :: metaType,
+  -- ^ the metaData of a packet, `_meta` must be constant during a packet.
+  _abort :: Bool
+  -- ^ If True, the current transfer is aborted and the slave should ignore the current transfer
+} deriving (Generic, ShowX, Show, NFData, Bundle)
+
+-- | Data sent from the subordinate to the manager
+-- The only information transmitted is whether the slave is ready to receive data
+newtype PacketStreamS2M = PacketStreamS2M {
+  _ready :: Bool
+  -- ^ Iff True, the slave is ready to receive data
+} deriving (Generic, ShowX, Show, NFData, Bundle, Eq, NFDataX)
+
+-- This data type is used for communication between components
+data PacketStream (dom :: Domain) (dataWidth :: Nat) (metaType :: Type)
+
+deriving instance
+  ( KnownNat dataWidth, NFDataX metaType)
+  => NFDataX (PacketStreamM2S dataWidth metaType)
+
+deriving instance
+  ( KnownNat dataWidth, Eq metaType)
+  => Eq (PacketStreamM2S dataWidth metaType)
+
+-- Orphan hashable instances
+deriving instance (KnownNat n) => Hashable (BitVector n)
+deriving instance (KnownNat n) => Hashable (Index n)
+instance (KnownNat n, Hashable a) => Hashable (Vec n a) where
+  hashWithSalt s v = hashWithSalt s (toList v)
+
+deriving instance
+  (KnownNat dataWidth, Hashable metaType)
+  => Hashable (PacketStreamM2S dataWidth metaType)
+
+instance Protocol (PacketStream dom dataWidth metaType) where
+  type Fwd (PacketStream dom dataWidth metaType) = Signal dom (Maybe (PacketStreamM2S dataWidth metaType))
+  type Bwd (PacketStream dom dataWidth metaType) = Signal dom PacketStreamS2M
+
+instance Backpressure (PacketStream dom dataWidth metaType) where
+  boolsToBwd _ = fromList_lazy . fmap PacketStreamS2M
+
+instance DfConv (PacketStream dom dataWidth metaType) where
+  type Dom (PacketStream dom dataWidth metaType) = dom
+  type FwdPayload (PacketStream dom dataWidth metaType) = PacketStreamM2S dataWidth metaType
+
+  toDfCircuit proxy = toDfCircuitHelper proxy s0 blankOtp stateFn where
+    s0 = ()
+    blankOtp = Nothing
+    stateFn ack _ optItem
+      = pure (optItem, Nothing, Maybe.isJust optItem && _ready ack)
+
+  fromDfCircuit proxy =  fromDfCircuitHelper proxy s0 blankOtp stateFn where
+    s0 = ()
+    blankOtp = PacketStreamS2M { _ready = False }
+    stateFn m2s ack _
+      = pure (PacketStreamS2M {_ready = ack }, m2s, False)
+
+instance (KnownDomain dom) =>
+  Simulate (PacketStream dom dataWidth metaType) where
+  type SimulateFwdType (PacketStream dom dataWidth metaType) = [Maybe (PacketStreamM2S dataWidth metaType)]
+  type SimulateBwdType (PacketStream dom dataWidth metaType) = [PacketStreamS2M]
+  type SimulateChannels (PacketStream dom dataWidth metaType) = 1
+
+  simToSigFwd _ = fromList_lazy
+  simToSigBwd _ = fromList_lazy
+  sigToSimFwd _ s = sample_lazy s
+  sigToSimBwd _ s = sample_lazy s
+
+  stallC conf (head -> (stallAck, stalls))
+    = withClockResetEnable clockGen resetGen enableGen
+    $ stall Proxy Proxy conf stallAck stalls
+
+instance (KnownDomain dom) =>
+  Drivable (PacketStream dom dataWidth metaType) where
+  type ExpectType (PacketStream dom dataWidth metaType) =
+    [PacketStreamM2S dataWidth metaType]
+
+  toSimulateType Proxy = fmap Just
+  fromSimulateType Proxy = Maybe.catMaybes
+
+  driveC conf vals
+    = withClockResetEnable clockGen resetGen enableGen
+    $ drive Proxy conf vals
+  sampleC conf ckt
+    = withClockResetEnable clockGen resetGen enableGen
+    $ sample Proxy conf ckt
+
+instance
+  ( KnownNat dataWidth
+  , NFDataX metaType
+  , NFData metaType
+  , ShowX metaType
+  , Show metaType
+  , Eq metaType
+  , KnownDomain dom ) =>
+  Test (PacketStream dom dataWidth metaType) where
+
+  expectToLengths Proxy = pure . P.length
+  expectN Proxy options nExpected sampled
+    = expectN (Proxy @(Df.Df dom _)) options nExpected
+    $ Df.maybeToData <$> sampled

tests/Test/Cores/Ethernet/PacketStream.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Test.Cores.Ethernet.PacketStream where
+
+-- base
+import Prelude
+import Data.Proxy
+
+-- clash-prelude
+import qualified Clash.Prelude as C
+import Clash.Prelude (type (<=))
+
+-- hedgehog
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+-- tasty
+import Test.Tasty
+import Test.Tasty.Hedgehog (HedgehogTestLimit(HedgehogTestLimit))
+import Test.Tasty.Hedgehog.Extra (testProperty)
+import Test.Tasty.TH (testGroupGenerator)
+
+-- clash-protocols
+import Protocols
+import Protocols.Hedgehog
+import qualified Protocols.DfConv as DfConv
+
+-- Me
+import Clash.Cores.Ethernet.PacketStream
+
+genVec :: (C.KnownNat n, 1 <= n) => Gen a -> Gen (C.Vec n a)
+genVec gen = sequence (C.repeat gen)
+
+-- | Test the packet stream instance
+--   TODO: Use the fifo given by `DfConv`
+prop_packetstream_fifo_id :: Property
+prop_packetstream_fifo_id =
+  propWithModelSingleDomain
+    @C.System
+    defExpectOptions
+    (Gen.list (Range.linear 0 100) genPackets)
+    (C.exposeClockResetEnable id)
+    (C.exposeClockResetEnable @C.System ckt)
+    (\a b -> a === b)
+ where
+  ckt :: (C.HiddenClockResetEnable dom) =>
+    Circuit
+      (PacketStream dom 1 Int)
+      (PacketStream dom 1 Int)
+  ckt = DfConv.fifo Proxy Proxy (C.SNat @10)
+
+  -- This is used to generate
+  genPackets =
+    PacketStreamM2S <$>
+    (genVec Gen.enumBounded) <*>
+    (Gen.maybe Gen.enumBounded) <*>
+    Gen.enumBounded <*>
+    Gen.enumBounded
+
+tests :: TestTree
+tests =
+    localOption (mkTimeout 12_000_000 {- 12 seconds -})
+  $ localOption (HedgehogTestLimit (Just 1000))
+  $(testGroupGenerator)

tests/unittests.hs

@@ -2,9 +2,9 @@ import Prelude
 
 import Test.Tasty
 
-import qualified Test.Cores.Ethernet.Ethernet
+import qualified Test.Cores.Ethernet.PacketStream
 
 main :: IO ()
 main = defaultMain $ testGroup "."
-  [ Test.Cores.Ethernet.Ethernet.tests
+  [ Test.Cores.Ethernet.PacketStream.tests
   ]