packages feed

clash-protocols (empty) → 0.1

raw patch · 69 files changed

+16159/−0 lines, 69 filesdep +Cabaldep +basedep +circuit-notationbuild-type:Customsetup-changed

Dependencies added: Cabal, base, circuit-notation, clash-prelude, clash-prelude-hedgehog, clash-protocols, clash-protocols-base, constraints, data-default, deepseq, doctest, extra, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, hashable, hedgehog, lifted-async, monad-control, mtl, pretty-show, process, strict-tuple, string-interpolate, tagged, tasty, tasty-hedgehog, tasty-hunit, tasty-th, template-haskell, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for `clash-protocols`++## 0.1 -- 28-04-2026++* First release
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2024, Martijn Bastiaan+              2024, QBayLogic B.V.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Extra.Doctest (defaultMainWithDoctests)+import Prelude++main :: IO ()+main = defaultMainWithDoctests "doctests"
+ clash-protocols.cabal view
@@ -0,0 +1,231 @@+cabal-version: 2.4+name: clash-protocols+synopsis: a battery-included library for (dataflow) protocols+homepage: https://github.com/clash-lang/clash-protocols+bug-reports: https://github.com/clash-lang/clash-protocols/issues+version: 0.1+category: Hardware+license: BSD-2-Clause+license-file: LICENSE+author: Martijn Bastiaan, QBayLogic B.V.+maintainer: QBayLogic B.V. <devops@qbaylogic.com>+extra-doc-files:+  CHANGELOG.md+description:+  Suggested reading order:+  .+  * 'Protocols' + https://github.com/clash-lang/clash-protocols/v0.1/main/README.md+  * 'Protocols.Df'+  * 'Protocols.Plugin'++data-files:+  src/Protocols/Experimental/Hedgehog.hs+  src/Protocols/Experimental/Hedgehog/*.hs++source-repository head+  type: git+  location: https://github.com/clash-lang/clash-protocols.git++flag large-tuples+  description:+    Generate instances for classes such as `Units` and `TaggedBundle` for tuples+    up to and including 62 elements - the GHC imposed maximum. Note that this+    greatly increases compile times for `clash-protocols`.++  default: False+  manual: True++common common-options+  default-extensions:+    -- TemplateHaskell is used to support convenience functions such as+    -- 'listToVecTH' and 'bLit'.+    CPP+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DerivingStrategies+    LambdaCase+    NoStarIsType+    OverloadedRecordDot+    PackageImports+    QuasiQuotes+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns++  -- Prelude isn't imported by default as Clash offers Clash.Prelude+  -- NoImplicitPrelude+  ghc-options:+    -- Plugins to support type-level constraint solving on naturals+    -- `-fexpose-all-unfoldings` is required because clash needs access to the+    -- source code in compiled modules+    -Wall+    -Wcompat+    -fplugin=GHC.TypeLits.Extra.Solver+    -fplugin=GHC.TypeLits.Normalise+    -fplugin=GHC.TypeLits.KnownNat.Solver+    -fexpose-all-unfoldings+    -fno-worker-wrapper++  default-language: GHC2021+  build-depends:+    Cabal >=3.12 && <3.17,+    base >=4.18 && <5,+    clash-prelude >=1.10 && <1.12,+    ghc-typelits-extra,+    ghc-typelits-knownnat,+    ghc-typelits-natnormalise,++custom-setup+  setup-depends:+    Cabal >=3.12 && <3.17,+    base >=4.18 && <5,+    cabal-doctest >=1.0.1 && <1.1,++library+  import: common-options+  hs-source-dirs: src++  if flag(large-tuples)+    cpp-options: -DLARGE_TUPLES+  build-depends:+    -- To be removed; we need 'Test.Tasty.Hedgehog.Extra' to fix upstream issues+    circuit-notation >=0.2 && <0.3,+    clash-prelude-hedgehog,+    clash-protocols-base,+    constraints >=0.9 && <1,+    data-default >=0.7 && <0.9,+    deepseq >=1.4.1 && <1.6,+    extra >=1.6.17 && <1.9,+    hashable >=1.4.1 && <1.6,+    hedgehog >=1.0.3 && <1.6,+    lifted-async <0.12,+    monad-control <1.1,+    mtl >=2.3.1 && <2.4,+    pretty-show >=1.9 && <2,+    strict-tuple <0.2,+    string-interpolate >=0.3 && <0.4,+    tagged >=0.8 && <0.9,+    tasty >=1.2 && <1.6,+    tasty-hedgehog >=1.2 && <1.5,+    template-haskell >=2.20 && <2.24,++  exposed-modules:+    -- 'testProperty' is broken upstream, it reports wrong test names+    -- TODO: test / upstream ^+    Data.List.Extra+    Protocols+    Protocols.Df+    Protocols.DfConv+    Protocols.Experimental.Avalon.MemMap+    Protocols.Experimental.Avalon.Stream+    Protocols.Experimental.Axi4.Common+    Protocols.Experimental.Axi4.ReadAddress+    Protocols.Experimental.Axi4.ReadData+    Protocols.Experimental.Axi4.Stream+    Protocols.Experimental.Axi4.WriteAddress+    Protocols.Experimental.Axi4.WriteData+    Protocols.Experimental.Axi4.WriteResponse+    Protocols.Experimental.Df+    Protocols.Experimental.DfConv+    Protocols.Experimental.Hedgehog+    Protocols.Experimental.PacketStream+    Protocols.Experimental.Simulate+    Protocols.Experimental.Wishbone+    Protocols.Experimental.Wishbone.Standard+    Protocols.Experimental.Wishbone.Standard.Hedgehog+    Protocols.Idle+    Protocols.Internal+    Protocols.Internal.TH+    Protocols.PacketStream+    Protocols.PacketStream.AsyncFifo+    Protocols.PacketStream.Base+    Protocols.PacketStream.Converters+    Protocols.PacketStream.Depacketizers+    Protocols.PacketStream.Hedgehog+    Protocols.PacketStream.PacketFifo+    Protocols.PacketStream.Packetizers+    Protocols.PacketStream.Padding+    Protocols.PacketStream.Routing+    Protocols.ToConst+    Protocols.Vec+    Test.Tasty.Hedgehog.Extra++  reexported-modules:+    Protocols.Plugin++  autogen-modules: Paths_clash_protocols+  other-modules:+    Clash.Sized.Vector.Extra+    Data.Constraint.Nat.Extra+    Data.Maybe.Extra+    Paths_clash_protocols+    Protocols.Experimental.Hedgehog.Internal+    Protocols.Experimental.Hedgehog.Types+    Protocols.Experimental.Simulate.Types+    Protocols.Internal.Types++  default-language: GHC2021++test-suite unittests+  import: common-options+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  ghc-options:+    -threaded+    -with-rtsopts=-N++  main-is: unittests.hs+  other-modules:+    Tests.Haxioms+    Tests.Protocols+    Tests.Protocols.Avalon+    Tests.Protocols.Axi4+    Tests.Protocols.Df+    Tests.Protocols.DfConv+    Tests.Protocols.PacketStream+    Tests.Protocols.PacketStream.AsyncFifo+    Tests.Protocols.PacketStream.Base+    Tests.Protocols.PacketStream.Converters+    Tests.Protocols.PacketStream.Depacketizers+    Tests.Protocols.PacketStream.PacketFifo+    Tests.Protocols.PacketStream.Packetizers+    Tests.Protocols.PacketStream.Padding+    Tests.Protocols.PacketStream.Routing+    Tests.Protocols.Plugin+    Tests.Protocols.Vec+    Tests.Protocols.Wishbone+    Util++  build-depends:+    clash-prelude-hedgehog,+    clash-protocols,+    clash-protocols-base,+    deepseq,+    extra,+    hashable,+    hedgehog,+    strict-tuple,+    string-interpolate,+    tasty >=1.2 && <1.6,+    tasty-hedgehog >=1.2,+    tasty-hunit,+    tasty-th,+    unordered-containers,++test-suite doctests+  import: common-options+  type: exitcode-stdio-1.0+  default-language: GHC2021+  main-is: doctests.hs+  hs-source-dirs: tests+  build-depends:+    base,+    clash-protocols,+    clash-protocols-base,+    doctest,+    process,
+ src/Clash/Sized/Vector/Extra.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Clash.Sized.Vector.Extra (+  dropLe,+  takeLe,+) where++import Clash.Prelude++-- | Like 'drop' but uses a 'Data.Type.Ord.<=' constraint+dropLe ::+  forall+    (n :: Nat)+    (m :: Nat)+    (a :: Type).+  (n <= m) =>+  -- | How many elements to take+  SNat n ->+  -- | input vector+  Vec m a ->+  Vec (m - n) a+dropLe SNat vs = leToPlus @n @m $ dropI vs++-- | Like 'take' but uses a 'Data.Type.Ord.<=' constraint+takeLe ::+  forall+    (n :: Nat)+    (m :: Nat)+    (a :: Type).+  (n <= m) =>+  -- | How many elements to take+  SNat n ->+  -- | input vector+  Vec m a ->+  Vec n a+takeLe SNat vs = leToPlus @n @m $ takeI vs
+ src/Data/Constraint/Nat/Extra.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-+NOTE [constraint solver addition]++The functions in this module enable us introduce trivial constraints that are not+solved by the constraint solver.+-}+module Data.Constraint.Nat.Extra where++import Clash.Prelude+import Data.Constraint+import Unsafe.Coerce (unsafeCoerce)++-- | if (1 <= b) then (Mod a b + 1 <= b)+leModulusDivisor :: forall a b. (1 <= b) => Dict (Mod a b + 1 <= b)+leModulusDivisor = unsafeCoerce (Dict :: Dict (0 <= 0))++-- | if (1 <= a) and (1 <= b) then (1 <= DivRU a b)+strictlyPositiveDivRu :: forall a b. (1 <= a, 1 <= b) => Dict (1 <= DivRU a b)+strictlyPositiveDivRu = unsafeCoerce (Dict :: Dict (0 <= 0))++-- | if (1 <= a) then (b <= ceil(b/a) * a)+leTimesDivRu :: forall a b. (1 <= a) => Dict (b <= a * DivRU b a)+leTimesDivRu = unsafeCoerce (Dict :: Dict (0 <= 0))++-- | if (1 <= a) then (a * ceil(b/a) ~ b + Mod (a - Mod b a) a)+eqTimesDivRu :: forall a b. (1 <= a) => Dict (a * DivRU b a ~ b + Mod (a - Mod b a) a)+eqTimesDivRu = unsafeCoerce (Dict :: Dict (0 ~ 0))
+ src/Data/List/Extra.hs view
@@ -0,0 +1,32 @@+{- |+Utility functions that operate on lists, but are not part of `Data.List`.+-}+module Data.List.Extra where++import "base" Data.List qualified as L++{- |+Takes elements from a list while the predicate holds, considers up to @window@ elements+since the last element that satisfied the predicate.++>>> takeWhileAnyInWindow 3 Prelude.odd [1, 2, 3, 6, 8, 10, 12]+[1,2,3]+-}+takeWhileAnyInWindow ::+  -- | Number of elements to consider since the last element that satisfied the predicate.+  Int ->+  -- | Function to test each element.+  (a -> Bool) ->+  -- | Input list+  [a] ->+  {- | List of elements that satisfied the predicate. Ends at an element that+  satisfies the predicate.+  -}+  [a]+takeWhileAnyInWindow wdw predicate = go wdw []+ where+  go 0 _ _ = []+  go cnt acc (x : xs)+    | predicate x = L.reverse (x : acc) <> go wdw [] xs+    | otherwise = go (pred cnt) (x : acc) xs+  go _ _ _ = []
+ src/Data/Maybe/Extra.hs view
@@ -0,0 +1,8 @@+module Data.Maybe.Extra (+  toMaybe,+) where++-- | Wrap a value in a @Just@ if @True@+toMaybe :: Bool -> a -> Maybe a+toMaybe True x = Just x+toMaybe False _ = Nothing
+ src/Protocols.hs view
@@ -0,0 +1,45 @@+{- |+See t'Circuit' for documentation. This module is designed to import unqualified,+i.e. using:++@+  import Protocols+@++Definitions of t'Circuit', 'Fwd', 'Bwd', and 'Protocols.Df.Df', inspired by+definitions in @circuit-notation@ at <https://github.com/cchalmers/circuit-notation>.+-}+module Protocols (+  -- * Circuit definition+  Circuit (Circuit),+  Protocol (Fwd, Bwd),+  Ack (..),+  Reverse,++  -- * Combinators & functions+  (|>),+  (<|),+  fromSignals,+  toSignals,++  -- * Protocol types+  CSignal,+  Df,+  ToConst,+  ToConstBwd,++  -- * Basic circuits+  idC,+  repeatC,+  applyC,+  prod2C,++  -- * Circuit notation plugin+  circuit,+  (-<),+  Units (..),+  TaggedBundle (..),+) where++import Protocols.Df (Df)+import Protocols.Internal
+ src/Protocols/Df.hs view
@@ -0,0 +1,963 @@+{-# LANGUAGE RecordWildCards #-}+-- TODO: Fix warnings introduced by GHC 9.2 w.r.t. incomplete lazy pattern matches+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fplugin Protocols.Plugin #-}++{- |+Defines data structures and operators to create a Dataflow protocol that only+carries data, no metadata. For documentation see:++  * 'Protocols.Circuit'+  * 'Protocols.Df.Df'+-}+module Protocols.Df (+  -- * Types+  Df,++  -- * Operations on Df protocol+  empty,+  const,+  consume,+  void,+  pure,+  map,+  mapS,+  bimap,+  bimapS,+  fst,+  snd,+  mapMaybe,+  catMaybes,+  coerce,+  compressor,+  expander,+  compander,+  filter,+  filterS,+  either,+  eitherS,+  first {-firstT,-},+  firstS,+  mapLeft,+  mapLeftS,+  second {-secondT,-},+  secondS,+  mapRight,+  mapRightS,+  zipWith,+  zipWithS,+  zip,+  partition,+  partitionEithers,+  partitionS,+  route,+  select,+  selectN,+  selectUntil,+  selectUntilS,+  fanin,+  faninS,+  mfanin,+  fanout,+  bundleVec,+  unbundleVec,+  roundrobin,+  CollectMode (..),+  roundrobinCollect,+  registerFwd,+  registerBwd,+  fifo,+  toMaybe,+  unsafeFromMaybe,++  -- * Internals+  forceResetSanity,+) where++-- base+#if !MIN_VERSION_base(4,18,0)+import           Control.Applicative (Applicative(liftA2))+#endif+import Control.Applicative (Alternative ((<|>)))+import GHC.Stack (HasCallStack)+import Prelude hiding (+  const,+  either,+  filter,+  fst,+  map,+  pure,+  snd,+  zip,+  zipWith,+  (!!),+ )++import Data.Bifunctor qualified as B+import Data.Bool (bool)+import Data.Coerce qualified as Coerce+import Data.Kind (Type)+import Data.Maybe qualified as Maybe+import Data.Maybe.Extra qualified as Maybe+import Prelude qualified as P++-- clash-prelude++import Clash.Prelude (type (<=))+import Clash.Prelude qualified as C+import Clash.Signal.Internal (Signal (..))++-- me+import Protocols.Idle+import Protocols.Internal++{-# ANN module "HLint: ignore Use const" #-}++{- $setup+>>> import Protocols+>>> import Protocols.Experimental.Df+>>> import Clash.Prelude (Vec(..))+>>> import qualified Prelude as P+>>> import qualified Data.Bifunctor as B+-}++-- | Simple unidirectional valid-ready protocol.+data Df (dom :: C.Domain) (a :: Type)++instance Protocol (Df dom a) where+  -- \| Forward part of simple dataflow: @Signal dom (Maybe a)@+  type Fwd (Df dom a) = Signal dom (Maybe a)++  -- \| Backward part of simple dataflow: @Signal dom Bool@+  type Bwd (Df dom a) = Signal dom Ack++instance IdleCircuit (Df dom a) where+  idleFwd _ = C.pure Nothing+  idleBwd _ = C.pure (Ack False)++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom a.+  ( C.KnownDomain dom+  , C.HiddenReset dom+  ) =>+  Circuit (Df dom a) (Df dom a)+forceResetSanity = forceResetSanityGeneric++-- | Coerce the payload of a Df stream.+coerce :: (Coerce.Coercible a b) => Circuit (Df dom a) (Df dom b)+coerce = fromSignals $ \(fwdA, bwdB) -> (Coerce.coerce bwdB, Coerce.coerce fwdA)++{- | Takes one or more values from the left and "compresses" it into a single+value that is occasionally sent to the right. Useful for taking small high-speed+inputs (like bits from a serial line) and turning them into slower wide outputs+(like 32-bit integers).++Example:++>>> accumulate xs x = let xs' = x:xs in if length xs' == 3 then ([], Just xs') else (xs', Nothing)+>>> circuit = C.exposeClockResetEnable (compressor @C.System [] accumulate)+>>> take 2 (simulateCSE circuit [(1::Int),2,3,4,5,6,7])+[[3,2,1],[6,5,4]]+-}+compressor ::+  forall dom s i o.+  (C.HiddenClockResetEnable dom, C.NFDataX s) =>+  s ->+  -- | Return `Just` when the compressed value is complete.+  (s -> i -> (s, Maybe o)) ->+  Circuit (Df dom i) (Df dom o)+compressor s0 f = compander s0 $+  \s i ->+    let (s', o) = f s i+     in (s', o, True)++{- | Takes a value from the left and "expands" it into one or more values that+are sent off to the right. Useful for taking wide, slow inputs (like a stream of+32-bit integers) and turning them into a fast, narrow output (like a stream of bits).++Example:++>>> step index = if index == maxBound then (0, True) else (index + 1, False)+>>> expandVector index vec = let (index', done) = step index in (index', vec C.!! index, done)+>>> circuit = C.exposeClockResetEnable (expander @C.System (0 :: C.Index 3) expandVector)+>>> take 6 (simulateCSE circuit [1 :> 2 :> 3 :> Nil, 4 :> 5 :> 6 :> Nil])+[1,2,3,4,5,6]+-}+expander ::+  forall dom i o s.+  (C.HiddenClockResetEnable dom, C.NFDataX s) =>+  s ->+  {- | Return `True` when you're finished with the current input value+  and are ready for the next one.+  -}+  (s -> i -> (s, o, Bool)) ->+  Circuit (Df dom i) (Df dom o)+expander s0 f = compander s0 $+  \s i ->+    let (s', o, done) = f s i+     in (s', Just o, done)++{- | Takes values from the left,+possibly holding them there for a while while working on them,+and occasionally sends values off to the right.+Used to implement both `expander` and `compressor`, so you can use it+when there's not a straightforward one-to-many or many-to-one relationship+between the input and output streams.+-}+compander ::+  forall dom i o s.+  (C.HiddenClockResetEnable dom, C.NFDataX s) =>+  s ->+  {- | Return `True` when you're finished with the current input value+  and are ready for the next one.+  Return `Just` to send the produced value off to the right.+  -}+  (s -> i -> (s, Maybe o, Bool)) ->+  Circuit (Df dom i) (Df dom o)+compander s0 f = forceResetSanity |> Circuit (C.unbundle . go . C.bundle)+ where+  go :: Signal dom (Maybe i, Ack) -> Signal dom (Ack, Maybe o)+  go = C.mealy f' s0+  f' :: s -> (Maybe i, Ack) -> (s, (Ack, Maybe o))+  f' s (Nothing, _) = (s, (C.deepErrorX "undefined ack", Nothing))+  f' s (Just i, Ack ack) = (s'', (Ack ackBack, o))+   where+    (s', o, doneWithInput) = f s i+    -- We only care about the downstream ack if we're sending them something+    mustWaitForAck = Maybe.isJust o+    (s'', ackBack) = if mustWaitForAck && not ack then (s, False) else (s', doneWithInput)++-- | Like 'P.map', but over payload (/a/) of a Df stream.+map :: (a -> b) -> Circuit (Df dom a) (Df dom b)+map f = mapS (C.pure f)++-- | Like 'map', but can reason over signals.+mapS :: Signal dom (a -> b) -> Circuit (Df dom a) (Df dom b)+mapS fS = Circuit (C.unbundle . liftA2 go fS . C.bundle)+ where+  go f (fwd, bwd) = (bwd, f <$> fwd)++-- | Like 'P.map', but over payload (/a/) of a Df stream.+bimap ::+  (B.Bifunctor p) =>+  (a -> b) ->+  (c -> d) ->+  Circuit (Df dom (p a c)) (Df dom (p b d))+bimap f g = bimapS (C.pure f) (C.pure g)++-- | Like 'bimap', but can reason over signals.+bimapS ::+  (B.Bifunctor p) =>+  Signal dom (a -> b) ->+  Signal dom (c -> d) ->+  Circuit (Df dom (p a c)) (Df dom (p b d))+bimapS fS gS = mapS (liftA2 B.bimap fS gS)++-- | Like 'P.fst', but over payload of a Df stream.+fst :: Circuit (Df dom (a, b)) (Df dom a)+fst = map P.fst++-- | Like 'P.snd', but over payload of a Df stream.+snd :: Circuit (Df dom (a, b)) (Df dom b)+snd = map P.snd++-- | Like 'Data.Bifunctor.first', but over payload of a Df stream.+first :: (B.Bifunctor p) => (a -> b) -> Circuit (Df dom (p a c)) (Df dom (p b c))+first f = firstS (C.pure f)++-- | Like 'first', but can reason over signals.+firstS ::+  (B.Bifunctor p) => Signal dom (a -> b) -> Circuit (Df dom (p a c)) (Df dom (p b c))+firstS fS = mapS (B.first <$> fS)++-- | Like 'Data.Bifunctor.second', but over payload of a Df stream.+second :: (B.Bifunctor p) => (b -> c) -> Circuit (Df dom (p a b)) (Df dom (p a c))+second f = secondS (C.pure f)++-- | Like 'second', but can reason over signals.+secondS ::+  (B.Bifunctor p) => Signal dom (b -> c) -> Circuit (Df dom (p a b)) (Df dom (p a c))+secondS fS = mapS (B.second <$> fS)++-- | Acknowledge but ignore data from LHS protocol. Send a static value /b/.+const :: (C.HiddenReset dom) => b -> Circuit (Df dom a) (Df dom b)+const b =+  Circuit+    ( P.const+        ( Ack+            <$> C.unsafeToActiveLow C.hasReset+        , P.pure (Just b)+        )+    )++-- | Never produce a value.+empty :: Circuit () (Df dom a)+empty = Circuit (P.const ((), P.pure Nothing))++-- | Drive a constant value composed of /a/.+pure :: a -> Circuit () (Df dom a)+pure a = Circuit (P.const ((), P.pure (Just a)))++-- | Always acknowledge and ignore values.+consume :: (C.HiddenReset dom) => Circuit (Df dom a) ()+consume = Circuit (P.const (P.pure (Ack True), ()))++-- | Never acknowledge values.+void :: (C.HiddenReset dom) => Circuit (Df dom a) ()+void =+  Circuit+    ( P.const+        ( Ack+            <$> C.unsafeToActiveLow C.hasReset+        , ()+        )+    )++{- | Like 'Data.Maybe.catMaybes', but over a Df stream.++Example:++>>> take 2 (simulateCS (catMaybes @C.System @Int) [Nothing, Just 1, Nothing, Just 3])+[1,3]+-}+catMaybes :: Circuit (Df dom (Maybe a)) (Df dom a)+catMaybes = Circuit (C.unbundle . fmap go . C.bundle)+ where+  go (Nothing, _) = (C.deepErrorX "undefined ack", Nothing)+  go (Just Nothing, _) = (Ack True, Nothing)+  go (Just (Just a), ack) = (ack, Just a)++-- | Like 'Data.Maybe.mapMaybe', but over payload (/a/) of a Df stream.+mapMaybe :: (a -> Maybe b) -> Circuit (Df dom a) (Df dom b)+mapMaybe f = map f |> catMaybes++{- | Like 'P.filter', but over a 'Df' stream.++Example:++>>> take 3 (simulateCS (filter @C.System @Int (>5)) [1, 5, 7, 10, 3, 11])+[7,10,11]+-}+filter :: forall dom a. (a -> Bool) -> Circuit (Df dom a) (Df dom a)+filter f = filterS (C.pure f)++-- | Like `filter`, but can reason over signals.+filterS :: forall dom a. Signal dom (a -> Bool) -> Circuit (Df dom a) (Df dom a)+filterS fS = Circuit (C.unbundle . liftA2 go fS . C.bundle)+ where+  go _ (Nothing, _) = (C.deepErrorX "undefined ack", Nothing)+  go f (Just d, ack)+    | f d = (ack, Just d)+    | otherwise = (Ack True, Nothing)++-- | Like 'Data.Either.Combinators.mapLeft', but over payload of a 'Df' stream.+mapLeft :: (a -> b) -> Circuit (Df dom (Either a c)) (Df dom (Either b c))+mapLeft f = mapLeftS (C.pure f)++-- | Like 'mapLeft', but can reason over signals.+mapLeftS :: Signal dom (a -> b) -> Circuit (Df dom (Either a c)) (Df dom (Either b c))+mapLeftS = firstS++-- | Like 'Data.Either.Combinators.mapRight', but over payload of a 'Df' stream.+mapRight :: (b -> c) -> Circuit (Df dom (Either a b)) (Df dom (Either a c))+mapRight = second++-- | Like 'mapRight', but can reason over signals.+mapRightS :: Signal dom (b -> c) -> Circuit (Df dom (Either a b)) (Df dom (Either a c))+mapRightS = secondS++-- | Like 'Data.Either.either', but over a 'Df' stream.+either :: (a -> c) -> (b -> c) -> Circuit (Df dom (Either a b)) (Df dom c)+either f g = eitherS (C.pure f) (C.pure g)++-- | Like 'either', but can reason over signals.+eitherS ::+  Signal dom (a -> c) -> Signal dom (b -> c) -> Circuit (Df dom (Either a b)) (Df dom c)+eitherS fS gS = mapS (liftA2 P.either fS gS)++{- | Like 'P.zipWith', but over two 'Df' streams.++Example:++>>> take 3 (simulateCS (zipWith @C.System @Int (+)) ([1, 3, 5], [2, 4, 7]))+[3,7,12]+-}+zipWith ::+  forall dom a b c.+  (a -> b -> c) ->+  Circuit+    (Df dom a, Df dom b)+    (Df dom c)+zipWith f = zipWithS (C.pure f)++-- | Like 'zipWith', but can reason over signals.+zipWithS ::+  forall dom a b c.+  Signal dom (a -> b -> c) ->+  Circuit+    (Df dom a, Df dom b)+    (Df dom c)+zipWithS fS =+  Circuit (B.first C.unbundle . C.unbundle . liftA2 go fS . C.bundle . B.first C.bundle)+ where+  go f ((Just a, Just b), ack) = ((ack, ack), Just (f a b))+  go _ _ = ((Ack False, Ack False), Nothing)++-- | Like 'P.zip', but over two 'Df' streams.+zip :: forall a b dom. Circuit (Df dom a, Df dom b) (Df dom (a, b))+zip = zipWith (,)++{- | Like 'P.partition', but over 'Df' streams++Example:++>>> let input = [1, 3, 5, 7, 9, 2, 11]+>>> let output = simulateCS (partition @C.System @Int (>5)) input+>>> B.bimap (take 3) (take 4) output+([7,9,11],[1,3,5,2])+-}+partition :: forall dom a. (a -> Bool) -> Circuit (Df dom a) (Df dom a, Df dom a)+partition f = partitionS (C.pure f)++{- | Like 'P.partitionEithers', but over 'Df' streams++Example:++>>> let input = [Left 1, Right 'a', Left 2, Right 'b']+>>> let output = simulateCS (partitionEithers @C.System @Int @Char) input+>>> B.bimap (take 2) (take 2) output+([1,2],"ab")+-}+partitionEithers :: forall dom a b. Circuit (Df dom (Either a b)) (Df dom a, Df dom b)+partitionEithers =+  Circuit (B.second C.unbundle . C.unbundle . C.liftA go . C.bundle . B.second C.bundle)+ where+  go (Nothing, _) = (C.deepErrorX "undefined ack", (Nothing, Nothing))+  go (Just (Left a), (ackA, _)) = (ackA, (Just a, Nothing))+  go (Just (Right b), (_, ackB)) = (ackB, (Nothing, Just b))++-- | Like `partition`, but can reason over signals.+partitionS ::+  forall dom a. Signal dom (a -> Bool) -> Circuit (Df dom a) (Df dom a, Df dom a)+partitionS fS =+  Circuit (B.second C.unbundle . C.unbundle . liftA2 go fS . C.bundle . B.second C.bundle)+ where+  go f (Just a, (ackT, ackF))+    | f a = (ackT, (Just a, Nothing))+    | otherwise = (ackF, (Nothing, Just a))+  go _ _ = (C.deepErrorX "undefined ack", (Nothing, Nothing))++{- | Route a 'Df' stream to another corresponding to the index++Example:++>>> let input = [(0, 3), (0, 5), (1, 7), (2, 13), (1, 11), (2, 1)]+>>> let output = simulateCS (route @3 @C.System @Int) input+>>> fmap (take 2) output+[3,5] :> [7,11] :> [13,1] :> Nil+-}+route ::+  forall n dom a.+  (C.KnownNat n) =>+  Circuit (Df dom (C.Index n, a)) (C.Vec n (Df dom a))+route =+  Circuit (B.second C.unbundle . C.unbundle . fmap go . C.bundle . B.second C.bundle)+ where+  -- go :: (Data (C.Index n, a), C.Vec n (Ack a)) -> (Ack (C.Index n, a), C.Vec n (Data a))+  go (Just (i, a), acks) =+    ( acks C.!! i+    , C.replace i (Just a) (C.repeat Nothing)+    )+  go _ =+    (C.deepErrorX "undefined ack", C.repeat Nothing)++{- | Select data from the channel indicated by the 'Df' stream carrying+@Index n@.++Example:++>>> let indices = [1, 1, 2, 0, 2]+>>> let dats = [8] :> [5, 7] :> [9, 1] :> Nil+>>> let output = simulateCS (select @3 @C.System @Int) (dats, indices)+>>> take 5 output+[5,7,9,8,1]+-}+select ::+  forall n dom a.+  (C.KnownNat n) =>+  Circuit (C.Vec n (Df dom a), Df dom (C.Index n)) (Df dom a)+select = selectUntil (P.const True)++{- | Select /selectN/ samples from channel /n/.++Example:++>>> let indices = [(0, 2), (1, 3), (0, 2)]+>>> let dats = [10, 20, 30, 40] :> [11, 22, 33] :> Nil+>>> let circuit = C.exposeClockResetEnable (selectN @2 @10 @C.System @Int)+>>> take 7 (simulateCSE circuit (dats, indices))+[10,20,11,22,33,30,40]+-}+selectN ::+  forall n selectN dom a.+  ( C.HiddenClockResetEnable dom+  , C.KnownNat selectN+  , C.KnownNat n+  ) =>+  Circuit+    (C.Vec n (Df dom a), Df dom (C.Index n, C.Index selectN))+    (Df dom a)+selectN =+  Circuit+    ( B.first (B.first C.unbundle . C.unbundle)+        . C.mealyB go (0 :: C.Index (selectN C.+ 1))+        . B.first (C.bundle . B.first C.bundle)+    )+ where+  go c0 ((dats, datI), Ack iAck)+    -- Select zero samples: don't send any data to RHS, acknowledge index stream+    -- but no data stream.+    | Just (_, 0) <- datI =+        (c0, ((nacks, Ack True), Nothing))+    -- Acknowledge data if RHS acknowledges ours. Acknowledge index stream if+    -- we're done.+    | Just (streamI, nSelect) <- datI+    , let dat = dats C.!! streamI+    , Just d <- dat =+        let+          c1 = if iAck then succ c0 else c0+          oAckIndex = c1 == C.extend nSelect+          c2 = if oAckIndex then 0 else c1+          datAcks = C.replace streamI (Ack iAck) nacks+         in+          ( c2+          ,+            ( (datAcks, Ack oAckIndex)+            , Just d+            )+          )+    -- No index from LHS, nothing to do+    | otherwise =+        (c0, ((nacks, Ack False), Nothing))+   where+    nacks = C.repeat (Ack False)++{- | Selects samples from channel /n/ until the predicate holds. The cycle in+which the predicate turns true is included.++Example:++>>> let indices = [0, 0, 1, 2]+>>> let channel1 = [(10, False), (20, False), (30, True), (40, True)]+>>> let channel2 = [(11, False), (21, True)]+>>> let channel3 = [(12, False), (22, False), (32, False), (42, True)]+>>> let dats = channel1 :> channel2 :> channel3 :> Nil+>>> take 10 (simulateCS (selectUntil @3 @C.System @(Int, Bool) P.snd) (dats, indices))+[(10,False),(20,False),(30,True),(40,True),(11,False),(21,True),(12,False),(22,False),(32,False),(42,True)]+-}+selectUntil ::+  forall n dom a.+  (C.KnownNat n) =>+  (a -> Bool) ->+  Circuit+    (C.Vec n (Df dom a), Df dom (C.Index n))+    (Df dom a)+selectUntil f = selectUntilS (C.pure f)++-- | Like 'selectUntil', but can reason over signals.+selectUntilS ::+  forall n dom a.+  (C.KnownNat n) =>+  Signal dom (a -> Bool) ->+  Circuit+    (C.Vec n (Df dom a), Df dom (C.Index n))+    (Df dom a)+selectUntilS fS =+  Circuit+    ( B.first (B.first C.unbundle . C.unbundle)+        . C.unbundle+        . liftA2 go fS+        . C.bundle+        . B.first (C.bundle . B.first C.bundle)+    )+ where+  nacks = C.repeat (Ack False)++  go f ((dats, dat), Ack ack)+    | Just i <- dat+    , Just d <- dats C.!! i =+        (+          ( C.replace i (Ack ack) nacks+          , Ack (f d && ack)+          )+        , Just d+        )+    | otherwise =+        ((nacks, Ack False), Nothing)++{- | Copy data of a single 'Df' stream to multiple. LHS will only receive+an acknowledgement when all RHS receivers have acknowledged data.+-}+fanout ::+  forall n dom a.+  (C.KnownNat n, C.HiddenClockResetEnable dom, 1 <= n) =>+  Circuit (Df dom a) (C.Vec n (Df dom a))+fanout = forceResetSanity |> goC+ where+  goC =+    Circuit $ \(s2r, r2s) ->+      B.second C.unbundle (C.mealyB f initState (s2r, C.bundle r2s))++  initState = C.repeat False++  f acked (dat, acks) =+    case dat of+      Nothing -> (acked, (C.deepErrorX "undefined ack", C.repeat Nothing))+      Just _ ->+        -- Data on input+        let+          -- Send data to "clients" that have not acked yet+          valids_ = C.map not acked+          dats = C.map (bool Nothing dat) valids_++          -- Store new acks, send ack if all "clients" have acked+          acked1 = C.zipWith (||) acked (C.map (\(Ack a) -> a) acks)+          ack = C.fold @(n C.- 1) (&&) acked1+         in+          ( if ack then initState else acked1+          , (Ack ack, dats)+          )++-- | Merge data of multiple 'Df' streams using a user supplied function+fanin ::+  forall n dom a.+  (C.KnownNat n, 1 <= n) =>+  (a -> a -> a) ->+  Circuit (C.Vec n (Df dom a)) (Df dom a)+fanin f = faninS (C.pure f)++-- | Like 'fanin', but can reason over signals.+faninS ::+  forall n dom a.+  (C.KnownNat n, 1 <= n) =>+  Signal dom (a -> a -> a) ->+  Circuit (C.Vec n (Df dom a)) (Df dom a)+faninS fS = bundleVec |> mapS (C.fold @(n C.- 1) <$> fS)++-- | Merge data of multiple 'Df' streams using Monoid's '<>'.+mfanin ::+  forall n dom a.+  (C.KnownNat n, Monoid a, 1 <= n) =>+  Circuit (C.Vec n (Df dom a)) (Df dom a)+mfanin = fanin (<>)++-- | Bundle a vector of 'Df' streams into one.+bundleVec ::+  forall n dom a.+  (C.KnownNat n, 1 <= n) =>+  Circuit (C.Vec n (Df dom a)) (Df dom (C.Vec n a))+bundleVec =+  Circuit (B.first C.unbundle . C.unbundle . fmap go . C.bundle . B.first C.bundle)+ where+  go (iDats0, iAck) = (C.repeat oAck, dat)+   where+    oAck = maybe (Ack False) (P.const iAck) dat+    dat = sequenceA iDats0++-- | Split up a 'Df' stream of a vector into multiple independent 'Df' streams.+unbundleVec ::+  forall n dom a.+  (C.KnownNat n, C.NFDataX a, C.HiddenClockResetEnable dom, 1 <= n) =>+  Circuit (Df dom (C.Vec n a)) (C.Vec n (Df dom a))+unbundleVec =+  Circuit (B.second C.unbundle . C.mealyB go initState . B.second C.bundle)+ where+  initState :: C.Vec n Bool+  initState = C.repeat False++  go _ (Nothing, _) = (initState, (C.deepErrorX "undefined ack", C.repeat Nothing))+  go acked (Just payloadVec, acks) =+    let+      -- Send data to "clients" that have not acked yet+      valids_ = C.map not acked+      dats = C.zipWith (bool Nothing . Just) payloadVec valids_++      -- Store new acks, send ack if all "clients" have acked+      acked1 = C.zipWith (||) acked (C.map (\(Ack a) -> a) acks)+      ack = C.fold @(n C.- 1) (&&) acked1+     in+      ( if ack then initState else acked1+      , (Ack ack, dats)+      )++{- | Distribute data across multiple components on the RHS. Useful if you want+to parallelize a workload across multiple (slow) workers. For optimal+throughput, you should make sure workers can accept data every /n/ cycles.+-}+roundrobin ::+  forall n dom a.+  (C.KnownNat n, C.HiddenClockResetEnable dom, 1 <= n) =>+  Circuit (Df dom a) (C.Vec n (Df dom a))+roundrobin =+  Circuit+    ( B.second C.unbundle+        . C.mealyB go (minBound :: C.Index n)+        . B.second C.bundle+    )+ where+  go i0 (Nothing, _) = (i0, (C.deepErrorX "undefined ack", C.repeat Nothing))+  go i0 (Just dat, acks) =+    let+      datOut = C.replace i0 (Just dat) (C.repeat Nothing)+      i1 = if ack then C.satSucc C.SatWrap i0 else i0+      Ack ack = acks C.!! i0+     in+      (i1, (Ack ack, datOut))++-- | Collect modes for dataflow arbiters.+data CollectMode+  = {- | Collect in a /round-robin/ fashion. If a source does not produce+    data, wait until it does. Use with care, as there is a risk of+    starvation if a selected source is idle for a long time.+    -}+    NoSkip+  | {- | Collect in a /round-robin/ fashion. If a source does not produce+    data, skip it and check the next source on the next cycle.+    -}+    Skip+  | {- | Check all sources in parallel. Biased towards the /first/ source.+    If the number of sources is high, this is more expensive than other+    modes.+    -}+    Parallel++{- | Opposite of 'roundrobin'. Useful to collect data from workers that only+produce a result with an interval of /n/ cycles.+-}+roundrobinCollect ::+  forall n dom a.+  (C.KnownNat n, C.HiddenClockResetEnable dom, 1 <= n) =>+  CollectMode ->+  Circuit (C.Vec n (Df dom a)) (Df dom a)+roundrobinCollect NoSkip =+  Circuit (B.first C.unbundle . C.mealyB go minBound . B.first C.bundle)+ where+  go (i :: C.Index n) (dats, Ack ack) =+    case dats C.!! i of+      Just d ->+        ( if ack then C.satSucc C.SatWrap i else i+        ,+          ( C.replace i (Ack ack) (C.repeat (Ack False))+          , Just d+          )+        )+      Nothing ->+        (i, (C.repeat (Ack False), Nothing))+roundrobinCollect Skip =+  Circuit (B.first C.unbundle . C.mealyB go minBound . B.first C.bundle)+ where+  go (i :: C.Index n) (dats, Ack ack) =+    case dats C.!! i of+      Just d ->+        ( if ack then C.satSucc C.SatWrap i else i+        ,+          ( C.replace i (Ack ack) (C.repeat (Ack False))+          , Just d+          )+        )+      Nothing ->+        (C.satSucc C.SatWrap i, (C.repeat (Ack False), Nothing))+roundrobinCollect Parallel =+  Circuit (B.first C.unbundle . C.mealyB go Nothing . B.first C.bundle)+ where+  go im (fwds, bwd@(Ack ack)) = (nextIm, (bwds, fwd))+   where+    nextSrc = C.fold @(n C.- 1) (<|>) (C.zipWith (<$) C.indicesI fwds)+    i = Maybe.fromMaybe (Maybe.fromMaybe maxBound nextSrc) im++    bwds = C.replace i bwd (C.repeat (Ack False))+    fwd = fwds C.!! i++    nextIm =+      if Maybe.isNothing fwd || ack+        then Nothing+        else im++-- | Place register on /forward/ part of a circuit. This adds combinational delay on the /backward/ path.+registerFwd ::+  forall dom a.+  (C.NFDataX a, C.HiddenClockResetEnable dom) =>+  Circuit (Df dom a) (Df dom a)+registerFwd =+  forceResetSanity |> Circuit (C.mealyB go Nothing)+ where+  go s0 (iDat, Ack iAck) = (s1, (Ack oAck, s0))+   where+    oAck = Maybe.isNothing s0 || iAck+    s1 = if oAck then iDat else s0++-- | Place register on /backward/ part of a circuit. This adds combinational delay on the /forward/ path.+registerBwd ::+  forall dom a.+  (C.NFDataX a, C.HiddenClockResetEnable dom) =>+  Circuit (Df dom a) (Df dom a)+registerBwd =+  forceResetSanity |> Circuit go+ where+  go (iDat, iAck) = (Ack <$> oAck, oDat)+   where+    oAck = C.regEn True valid (Coerce.coerce <$> iAck)+    valid = (Maybe.isJust <$> iDat) C..||. fmap not oAck+    iDatX0 = C.fromJustX <$> iDat+    iDatX1 = C.regEn (C.errorX "registerBwd") oAck iDatX0+    oDat = Maybe.toMaybe <$> valid <*> C.mux oAck iDatX0 iDatX1++-- Fourmolu only allows CPP conditions on complete top-level definitions. This+-- function is not exported.+blockRamUNoClear ::+  forall n dom a addr.+  ( HasCallStack+  , C.HiddenClockResetEnable dom+  , C.NFDataX a+  , Enum addr+  , C.NFDataX addr+  , 1 <= n+  ) =>+  C.SNat n ->+  Signal dom addr ->+  Signal dom (Maybe (addr, a)) ->+  Signal dom a+#if MIN_VERSION_clash_prelude(1,9,0)+blockRamUNoClear = C.blockRamU C.NoClearOnReset+#else+blockRamUNoClear n =+  C.blockRamU C.NoClearOnReset n (C.errorX "No reset function")+#endif++{- | A fifo buffer with user-provided depth. Uses blockram to store data. Can+handle simultaneous write and read (full throughput rate).+-}+fifo ::+  forall dom a depth.+  (C.HiddenClockResetEnable dom, C.KnownNat depth, C.NFDataX a, 1 C.<= depth) =>+  C.SNat depth ->+  Circuit (Df dom a) (Df dom a)+fifo fifoDepth = Circuit $ C.hideReset circuitFunction+ where+  -- implemented using a fixed-size array+  --   write location and read location are both stored+  --   to write, write to current location and move one to the right+  --   to read, read from current location and move one to the right+  --   loop around from the end to the beginning if necessary++  circuitFunction reset (inpA, inpB) = (otpA, otpB)+   where+    -- initialize bram+    brRead =+      C.readNew+        (blockRamUNoClear fifoDepth)+        brReadAddr+        brWrite+    -- run the state machine (a mealy machine)+    (brReadAddr, brWrite, otpA, otpB) =+      C.unbundle $+        C.mealy machineAsFunction s0 $+          C.bundle+            ( brRead+            , C.unsafeToActiveHigh reset+            , inpA+            , inpB+            )++  -- when reset is on, set state to initial state and output blank outputs+  machineAsFunction _ (_, True, _, _) = (s0, (0, Nothing, Ack False, Nothing))+  machineAsFunction (rAddr0, wAddr0, amtLeft0) (brRead0, False, pushData, Ack popped) =+    let+      -- potentially push an item onto blockram+      maybePush = if amtLeft0 > 0 then pushData else Nothing+      brWrite = (wAddr0,) <$> maybePush+      -- adjust write address and amount left+      --   (output state machine doesn't see amountLeft')+      (wAddr1, amtLeft1)+        | Just _ <- maybePush = (C.satSucc C.SatWrap wAddr0, amtLeft0 - 1)+        | otherwise = (wAddr0, amtLeft0)+      -- if we're about to push onto an empty queue, we can pop immediately instead+      (brRead1, amtLeft2)+        | Just push <- maybePush, amtLeft0 == maxBound = (push, amtLeft1)+        | otherwise = (brRead0, amtLeft0)+      -- adjust blockram read address and amount left+      (rAddr1, amtLeft3)+        | amtLeft2 < maxBound && popped = (C.satSucc C.SatWrap rAddr0, amtLeft1 + 1)+        | otherwise = (rAddr0, amtLeft1)+      brReadAddr = rAddr1+      -- return our new state and outputs+      otpAck = Maybe.isJust maybePush+      otpDat = if amtLeft2 < maxBound then Just brRead1 else Nothing+     in+      ((rAddr1, wAddr1, amtLeft3), (brReadAddr, brWrite, Ack otpAck, otpDat))++  -- initial state+  -- (next read address in bram, next write address in bram, space left in bram)+  -- Addresses only go from 0 to depth-1.+  -- Space left goes from 0 to depth because the fifo could be empty+  -- (space left = depth) or full (space left = 0).+  s0 :: (C.Index depth, C.Index depth, C.Index (depth C.+ 1))+  s0 = (0, 0, maxBound)++-- | Convert a 'Df' stream to a 'Maybe' stream. Never stalls LHS.+toMaybe :: Circuit (Df dom a) (CSignal dom (Maybe a))+toMaybe = Circuit $ \(maybes, _) -> (C.pure (Ack True), maybes)++{- | Convert a 'Maybe' stream to a 'Df' stream. Not every 'Just' is guaranteed to+be forwarded to the RHS because of potential backpressure. The number of dropped 'Just's+is exported as an unsigned number. Note that this circuit uses the clock supplied through+the 'Clash.Signal.HiddenClockResetEnable' constraint to latch the incoming 'Maybe' values in case of+backpressure from the RHS. This makes it adhere to the rules of the `Df` protocol.+-}+unsafeFromMaybe ::+  forall n a dom.+  ( C.HiddenClockResetEnable dom+  , C.NFDataX a+  , C.KnownNat n+  ) =>+  Circuit+    (CSignal dom (Maybe a))+    ( Df dom a+    , CSignal dom (C.Unsigned n)+    )+unsafeFromMaybe = circuit $ \maybes -> do+  (as0, droppeds) <- Circuit go2 -< maybes+  as1 <- forceResetSanity -< as0+  idC -< (as1, droppeds)+ where+  go2 ::+    (Signal dom (Maybe a), (Signal dom Ack, ())) ->+    ((), (Signal dom (Maybe a), Signal dom (C.Unsigned n)))+  go2 (fwdA, (ackB, _)) = ((), C.mealyB go1 (Nothing, 0) (fwdA, ackB))++  go1 ::+    (Maybe a, C.Unsigned n) ->+    (Maybe a, Ack) ->+    ( (Maybe a, C.Unsigned n)+    , (Maybe a, C.Unsigned n)+    )+  go1 (s0, !n0) ~(i, ~(Ack ack)) = ((s1, n1), (o, n1))+   where+    -- We're dropping a value if we have a stored value (s0), the LHS sends a+    -- new value (i), and the RHS does not acknowledge (not ack).+    n1+      | Maybe.isJust s0 && Maybe.isJust i && not ack = n0 + 1+      | otherwise = n0++    o = s0 <|> i++    s1+      | Maybe.isJust s0 && not ack = s0+      | Maybe.isJust s0 && ack = i+      | Maybe.isJust i && ack = Nothing+      | otherwise = i
+ src/Protocols/DfConv.hs view
@@ -0,0 +1,1129 @@+{-# LANGUAGE UndecidableInstances #-}++{- |+This module implements a type class 'DfConv' which serves as a generalization+of the 'Protocols.Df.Df' protocol. Similar protocols can provide an instance+for it and subsequently expose all the functionality implemented in this module.+-}+module Protocols.DfConv (+  -- * Typeclass and its associated types/fns+  DfConv,+  Dom,+  BwdPayload,+  FwdPayload,+  toDfCircuit,+  fromDfCircuit,++  -- * Helper functions+  toDfCircuitHelper,+  fromDfCircuitHelper,+  dfToDfConvInp,+  dfToDfConvOtp,+  vecToDfConv,+  vecFromDfConv,+  tupToDfConv,+  tupFromDfConv,++  -- * Df functions generalized to Dflike+  convert,+  const,+  void,+  pure,+  map,+  mapS,+  bimap,+  fst,+  snd,+  mapMaybe,+  catMaybes,+  filter,+  filterS,+  either,+  first {-firstT,-},+  mapLeft,+  second {-secondT,-},+  mapRight,+  zipWith,+  zip,+  partition,+  route,+  select,+  selectN,+  selectUntil,+  fanin,+  mfanin,+  fanout,+  bundleVec,+  unbundleVec,+  roundrobin,+  Df.CollectMode (..),+  roundrobinCollect,+  registerFwd,+  registerBwd,+  fifo,+) where++import Clash.Prelude hiding (+  const,+  either,+  filter,+  fst,+  map,+  pure,+  sample,+  select,+  simulate,+  snd,+  zip,+  zipWith,+ )+import Clash.Prelude qualified as C+import Control.Arrow ((***))+import Control.Monad.State (State, runState)+import Data.Bifunctor qualified as B+import Data.Proxy (Proxy (..))+import Data.Tuple (swap)+import Prelude qualified as P++-- me+import Protocols.Df (Df)+import Protocols.Df qualified as Df+import Protocols.Internal+import Protocols.Vec qualified as Vec++{- | Class for protocols that are "similar" to 'Df', i.e. they can be converted+to and from a pair of 'Df' ports (one going 'Fwd', one going 'Bwd'), using+a t'Circuit' (see 'toDfCircuit' and 'fromDfCircuit'). This is for protocols+that carry some "interesting" data, as well as some "uninteresting" data+(e.g. address, burst length). The t'Circuit' should abstract away the+complexities of each protocol, so that they can be dealt with uniformly+using 'Df'. For pipelined protocols, which can carry both in the same cycle,+the t'Circuit' should pass along the interesting parts but not the+uninteresting parts.+-}+class (Protocol df) => DfConv df where+  {- | Domain that messages are being sent over. In general, it should be true that+  @Fwd df ~ Signal dom [something]@ and that @Bwd df ~ Signal dom [something]@.+  -}+  type Dom df :: Domain++  {- | Information being sent in the 'Bwd' direction, along+  @Reverse (Df (Dom df) (BwdPayload df))@. This is the information being+  carried over the protocol, /not/ the messages being carried over the+  protocol, so it doesn't include auxiliary information like address or+  burst length. If no data is sent in this direction, set this to @()@.+  -}+  type BwdPayload df++  {- | Information being sent in the 'Fwd' direction, along+  @Df (Dom df) (FwdPayload df)@. This is the information being+  carried over the protocol, /not/ the messages being carried over the+  protocol, so it doesn't include auxiliary information like address or+  burst length. If no data is sent in this direction, set this to @()@.+  -}+  type FwdPayload df++  {- | Circuit which converts Df into this protocol's messages. This should+  deal with all the complexities of your protocol such as addresses, bursts,+  pipelining, etc. so that a circuit connected to the 'Df' end doesn't have+  to worry about all that. There are two Df channels, one for fwd data and+  one for bwd data, so data can be sent both ways at once. This circuit is+  expected to follow all of the conventions of 'Df'; for example, data on the+  fwd channel should stay the same between clock cycles unless acknowledged.+  -}+  toDfCircuit ::+    (HiddenClockResetEnable (Dom df)) =>+    Proxy df ->+    Circuit+      (Df (Dom df) (FwdPayload df), Reverse (Df (Dom df) (BwdPayload df)))+      df++  {- | 'toDfCircuit', but in reverse: the @df@ port is on the left side instead+  of the right side.+  -}+  fromDfCircuit ::+    (HiddenClockResetEnable (Dom df)) =>+    Proxy df ->+    Circuit+      df+      (Df (Dom df) (FwdPayload df), Reverse (Df (Dom df) (BwdPayload df)))++  -- defaults+  type BwdPayload df = ()+  type FwdPayload df = ()++{- | Helper function to make it easier to implement 'toDfCircuit' in 'DfConv'.+t'Protocols.Internal.Ack's are automatically converted to and from 'Bool's.+A default @otpMsg@ value is+given for if reset is currently on. The 'State' machine is run every clock cycle.+Parameters: initial state, default @otpMsg@, and 'State' machine function+-}+toDfCircuitHelper ::+  ( HiddenClockResetEnable dom+  , Protocol df+  , Bwd df ~ Unbundled dom inpMsg+  , Fwd df ~ Unbundled dom otpMsg+  , NFDataX state+  , Bundle inpMsg+  , Bundle otpMsg+  ) =>+  Proxy df ->+  state ->+  otpMsg ->+  ( inpMsg ->+    Bool ->+    Maybe fwdPayload ->+    State state (otpMsg, Maybe bwdPayload, Bool)+  ) ->+  Circuit+    ( Df dom fwdPayload+    , Reverse (Df dom bwdPayload)+    )+    df+toDfCircuitHelper _ s0 blankOtp stateFn =+  Circuit+    $ (unbundle *** unbundle)+    . unbundle+    . hideReset cktFn+    . bundle+    . (bundle *** bundle)+ where+  cktFn reset inp =+    let rstLow = unsafeToActiveHigh reset+     in mealy transFn s0 ((,) <$> rstLow <*> inp)++  transFn _ (True, _) = (s0, ((Ack False, Nothing), blankOtp))+  transFn s (False, ((toOtp, Ack inpAck), inp)) =+    let+      ((otp, inputted, otpAck), s') =+        runState+          (stateFn inp inpAck toOtp)+          s+     in+      (s', ((Ack otpAck, inputted), otp))++{- | Helper function to make it easier to implement 'fromDfCircuit' in 'DfConv'.+t'Protocols.Internal.Ack's are automatically converted to and from 'Bool's.+A default @otpMsg@ value is+given for if reset is currently on. The 'State' machine is run every clock cycle.+Parameters: initial state, default @otpMsg@, and 'State' machine function+-}+fromDfCircuitHelper ::+  ( HiddenClockResetEnable dom+  , Protocol df+  , Fwd df ~ Unbundled dom inpMsg+  , Bwd df ~ Unbundled dom otpMsg+  , NFDataX state+  , Bundle inpMsg+  , Bundle otpMsg+  ) =>+  Proxy df ->+  state ->+  otpMsg ->+  ( inpMsg ->+    Bool ->+    Maybe bwdPayload ->+    State state (otpMsg, Maybe fwdPayload, Bool)+  ) ->+  Circuit df (Df dom fwdPayload, Reverse (Df dom bwdPayload))+fromDfCircuitHelper df s0 blankOtp stateFn =+  mapCircuit id id swap swap+    $ reverseCircuit+    $ toDfCircuitHelper (reverseProxy df) s0 blankOtp stateFn+ where+  reverseProxy :: Proxy df -> Proxy (Reverse df)+  reverseProxy Proxy = Proxy++-- Trivial DfConv instance for (Df, Reverse Df)++instance DfConv (Df dom a, Reverse (Df dom b)) where+  type Dom (Df dom a, Reverse (Df dom b)) = dom+  type BwdPayload (Df dom a, Reverse (Df dom b)) = b+  type FwdPayload (Df dom a, Reverse (Df dom b)) = a+  toDfCircuit _ = idC+  fromDfCircuit _ = idC++-- DfConv instance for Reverse++instance (DfConv a) => DfConv (Reverse a) where+  type Dom (Reverse a) = Dom a+  type BwdPayload (Reverse a) = FwdPayload a+  type FwdPayload (Reverse a) = BwdPayload a+  toDfCircuit _ = mapCircuit swap swap id id $ reverseCircuit $ fromDfCircuit (Proxy @a)+  fromDfCircuit _ = mapCircuit id id swap swap $ reverseCircuit $ toDfCircuit (Proxy @a)++-- DfConv instances for Df++instance (NFDataX dat) => DfConv (Df dom dat) where+  type Dom (Df dom dat) = dom+  type FwdPayload (Df dom dat) = dat+  toDfCircuit _ = Circuit (uncurry f)+   where+    f ~(a, _) c = ((c, P.pure Nothing), a)+  fromDfCircuit _ = Circuit (uncurry f)+   where+    f a ~(b, _) = (b, (a, P.pure (Ack False)))++-- | Convert 'DfConv' into a /one-way/ 'Df' port, at the data input end+dfToDfConvInp ::+  ( DfConv df+  , HiddenClockResetEnable (Dom df)+  ) =>+  Proxy df ->+  Circuit df (Df (Dom df) (FwdPayload df))+dfToDfConvInp = mapCircuit id id P.fst (,P.pure Nothing) . fromDfCircuit++-- | Convert 'DfConv' into a /one-way/ 'Df' port, at the data output end+dfToDfConvOtp ::+  ( DfConv df+  , HiddenClockResetEnable (Dom df)+  ) =>+  Proxy df ->+  Circuit (Df (Dom df) (FwdPayload df)) df+dfToDfConvOtp = mapCircuit (,P.pure (Ack False)) P.fst id id . toDfCircuit++-- | 'toDfCircuit', but the 'DfConv' is inside a 'Vec'+vecToDfConv ::+  (DfConv df) =>+  (HiddenClockResetEnable (Dom df)) =>+  (KnownNat n) =>+  Proxy df ->+  Circuit+    ( Vec n (Df (Dom df) (FwdPayload df))+    , Vec n (Reverse (Df (Dom df) (BwdPayload df)))+    )+    (Vec n df)+vecToDfConv proxy =+  mapCircuit (uncurry C.zip) unzip id id+    $ Vec.vecCircuits+    $ repeat+    $ toDfCircuit proxy++-- | 'fromDfCircuit', but the 'DfConv' is inside a 'Vec'+vecFromDfConv ::+  (DfConv df) =>+  (HiddenClockResetEnable (Dom df)) =>+  (KnownNat n) =>+  Proxy df ->+  Circuit+    (Vec n df)+    ( Vec n (Df (Dom df) (FwdPayload df))+    , Vec n (Reverse (Df (Dom df) (BwdPayload df)))+    )+vecFromDfConv proxy =+  mapCircuit id id unzip (uncurry C.zip)+    $ Vec.vecCircuits+    $ repeat+    $ fromDfCircuit proxy++-- | 'toDfCircuit', but on a pair of 'DfConv's+tupToDfConv ::+  ( DfConv dfA+  , DfConv dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Circuit+    ( ( Df (Dom dfA) (FwdPayload dfA)+      , Df (Dom dfB) (FwdPayload dfB)+      )+    , ( Reverse (Df (Dom dfA) (BwdPayload dfA))+      , Reverse (Df (Dom dfB) (BwdPayload dfB))+      )+    )+    (dfA, dfB)+tupToDfConv (argsA, argsB) =+  mapCircuit f f id id+    $ tupCircuits (toDfCircuit argsA) (toDfCircuit argsB)+ where+  f ((a, b), (c, d)) = ((a, c), (b, d))++-- | 'fromDfCircuit', but on a pair of 'DfConv's+tupFromDfConv ::+  ( DfConv dfA+  , DfConv dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Circuit+    (dfA, dfB)+    ( ( Df (Dom dfA) (FwdPayload dfA)+      , Df (Dom dfB) (FwdPayload dfB)+      )+    , ( Reverse (Df (Dom dfA) (BwdPayload dfA))+      , Reverse (Df (Dom dfB) (BwdPayload dfB))+      )+    )+tupFromDfConv (argsA, argsB) =+  mapCircuit id id f f+    $ tupCircuits (fromDfCircuit argsA) (fromDfCircuit argsB)+ where+  f ((a, b), (c, d)) = ((a, c), (b, d))++-- | Circuit converting a pair of items into a @Vec 2@+tupToVec :: Circuit (a, a) (Vec 2 a)+tupToVec = Circuit ((f *** g) . swap)+ where+  f :: Vec 2 p -> (p, p)+  f v = (C.head v, C.last v)+  g (x, y) = x :> y :> Nil++-- | Circuit converting a @Vec 2@ into a pair of items+vecToTup :: Circuit (Vec 2 a) (a, a)+vecToTup = Circuit ((g *** f) . swap)+ where+  f :: Vec 2 p -> (p, p)+  f v = (C.head v, C.last v)+  g (x, y) = x :> y :> Nil++{- | Preserves 'Df' data unmodified. Potentially useful for converting between+protocols.+-}+convert ::+  ( DfConv dfA+  , DfConv dfB+  , FwdPayload dfA ~ FwdPayload dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+convert dfA dfB =+  fromDfCircuit dfA+    |> toDfCircuit dfB++-- | Like 'P.map'+map ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (FwdPayload dfA -> FwdPayload dfB) ->+  Circuit dfA dfB+map dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.map f) idC+    |> toDfCircuit dfB++-- | Like 'Df.mapS'+mapS ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Signal (Dom dfA) (FwdPayload dfA -> FwdPayload dfB) ->+  Circuit dfA dfB+mapS dfA dfB fS =+  fromDfCircuit dfA+    |> tupCircuits (Df.mapS fS) idC+    |> toDfCircuit dfB++-- | Like 'P.fst'+fst ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ (a, b)+  , FwdPayload dfB ~ a+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+fst dfA dfB =+  fromDfCircuit dfA+    |> tupCircuits Df.fst idC+    |> toDfCircuit dfB++-- | Like 'P.fst'+snd ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ (a, b)+  , FwdPayload dfB ~ b+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+snd dfA dfB =+  fromDfCircuit dfA+    |> tupCircuits Df.snd idC+    |> toDfCircuit dfB++-- | Like 'Data.Bifunctor.bimap'+bimap ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , B.Bifunctor p+  , FwdPayload dfA ~ p a c+  , FwdPayload dfB ~ p b d+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (a -> b) ->+  (c -> d) ->+  Circuit dfA dfB+bimap dfA dfB f g =+  fromDfCircuit dfA+    |> tupCircuits (Df.bimap f g) idC+    |> toDfCircuit dfB++-- | Like 'Data.Bifunctor.first'+first ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , B.Bifunctor p+  , FwdPayload dfA ~ p a c+  , FwdPayload dfB ~ p b c+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (a -> b) ->+  Circuit dfA dfB+first dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.first f) idC+    |> toDfCircuit dfB++-- | Like 'Data.Bifunctor.second'+second ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , B.Bifunctor p+  , FwdPayload dfA ~ p a b+  , FwdPayload dfB ~ p a c+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (b -> c) ->+  Circuit dfA dfB+second dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.second f) idC+    |> toDfCircuit dfB++-- | Acknowledge but ignore data from LHS protocol. Send a static value /b/.+const ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  FwdPayload dfB ->+  Circuit dfA dfB+const dfA dfB b =+  fromDfCircuit dfA+    |> tupCircuits (Df.const b) idC+    |> toDfCircuit dfB++-- | Drive a constant value composed of /a/.+pure ::+  ( DfConv df+  , HiddenClockResetEnable (Dom df)+  ) =>+  Proxy df ->+  FwdPayload df ->+  Circuit () df+pure df a =+  Df.pure a+    |> dfToDfConvOtp df++-- | Ignore incoming data+void ::+  ( DfConv df+  , HiddenClockResetEnable (Dom df)+  ) =>+  Proxy df ->+  Circuit df ()+void df =+  dfToDfConvInp df+    |> Df.void++-- | Like 'Data.Maybe.catMaybes'+catMaybes ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ Maybe (FwdPayload dfB)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+catMaybes dfA dfB =+  fromDfCircuit dfA+    |> tupCircuits Df.catMaybes idC+    |> toDfCircuit dfB++-- | Like 'Data.Maybe.mapMaybe'+mapMaybe ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , NFDataX (FwdPayload dfB)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (FwdPayload dfA -> Maybe (FwdPayload dfB)) ->+  Circuit dfA dfB+mapMaybe dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.mapMaybe f) idC+    |> toDfCircuit dfB++-- | Like 'P.filter'+filter ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (FwdPayload dfA -> Bool) ->+  Circuit dfA dfB+filter dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.filter f) idC+    |> toDfCircuit dfB++-- | Like 'Df.filterS'+filterS ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Signal (Dom dfA) (FwdPayload dfA -> Bool) ->+  Circuit dfA dfB+filterS dfA dfB fS =+  fromDfCircuit dfA+    |> tupCircuits (Df.filterS fS) idC+    |> toDfCircuit dfB++-- | Like 'Data.Either.Combinators.mapLeft'+mapLeft ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ Either a c+  , FwdPayload dfB ~ Either b c+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (a -> b) ->+  Circuit dfA dfB+mapLeft dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.mapLeft f) idC+    |> toDfCircuit dfB++-- | Like 'Data.Either.Combinators.mapRight'+mapRight ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ Either a b+  , FwdPayload dfB ~ Either a c+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (b -> c) ->+  Circuit dfA dfB+mapRight dfA dfB f =+  fromDfCircuit dfA+    |> tupCircuits (Df.mapRight f) idC+    |> toDfCircuit dfB++-- | Like 'Data.Either.either'+either ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ Either a b+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (a -> FwdPayload dfB) ->+  (b -> FwdPayload dfB) ->+  Circuit dfA dfB+either dfA dfB f g =+  fromDfCircuit dfA+    |> tupCircuits (Df.either f g) idC+    |> toDfCircuit dfB++-- | Like 'P.zipWith'. Any data not in /Payload/ is copied from stream A.+zipWith ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfC+  , BwdPayload dfB ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Proxy dfC ->+  (FwdPayload dfA -> FwdPayload dfB -> FwdPayload dfC) ->+  Circuit (dfA, dfB) dfC+zipWith dfAB dfC f =+  tupFromDfConv dfAB+    |> coerceCircuit+      ( tupCircuits+          (Df.zipWith f)+          (reverseCircuit $ Df.roundrobin |> vecToTup)+      )+    |> toDfCircuit dfC++-- | Like 'P.zip'+zip ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfC+  , BwdPayload dfB ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfC ~ (FwdPayload dfA, FwdPayload dfB)+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Proxy dfC ->+  Circuit (dfA, dfB) dfC+zip dfAB dfC =+  tupFromDfConv dfAB+    |> coerceCircuit+      ( tupCircuits+          Df.zip+          (reverseCircuit $ Df.roundrobin |> vecToTup)+      )+    |> toDfCircuit dfC++-- | Like 'P.partition'+partition ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfB+  , BwdPayload dfA ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , FwdPayload dfA ~ FwdPayload dfC+  ) =>+  Proxy dfA ->+  (Proxy dfB, Proxy dfC) ->+  (FwdPayload dfA -> Bool) ->+  Circuit dfA (dfB, dfC)+partition dfA dfBC f =+  fromDfCircuit dfA+    |> coerceCircuit+      ( tupCircuits+          (Df.partition f)+          (reverseCircuit $ tupToVec |> Df.roundrobinCollect Df.Parallel)+      )+    |> tupToDfConv dfBC++-- | Route a DfConv stream to another corresponding to the index+route ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ (Index n, FwdPayload dfB)+  , KnownNat n+  , 1 <= n+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA (Vec n dfB)+route dfA dfB =+  fromDfCircuit dfA+    |> coerceCircuit+      ( tupCircuits+          Df.route+          (reverseCircuit (Df.roundrobinCollect Df.Parallel))+      )+    |> vecToDfConv dfB++selectHelperA :: Circuit ((a, b), (c, d)) ((a, c), (b, d))+selectHelperA = Circuit ((f *** f) . swap)+ where+  f ((a, b), (c, d)) = ((a, c), (b, d))++selectHelperB :: Circuit (Vec (n + 1) a) (Vec n a, a)+selectHelperB = Circuit ((f *** g) . swap)+ where+  f :: (Vec n q, q) -> Vec (n + 1) q+  f (t, h) = h :> t+  g :: Vec (n + 1) q -> (Vec n q, q)+  g v = (C.tail v, C.head v)++{- | Select data from the channel indicated by the DfConv stream carrying+@Index n@.+-}+select ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfC+  , BwdPayload dfB ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfC+  , FwdPayload dfB ~ Index n+  , KnownNat n+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Proxy dfC ->+  Circuit (Vec n dfA, dfB) dfC+select (dfA, dfB) dfC =+  tupCircuits (vecFromDfConv dfA) (fromDfCircuit dfB)+    |> selectHelperA+    |> coerceCircuit+      ( tupCircuits+          Df.select+          (reverseCircuit $ Df.roundrobin |> selectHelperB)+      )+    |> toDfCircuit dfC++-- | Select /selectN/ samples from channel /n/.+selectN ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfC+  , BwdPayload dfB ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfC+  , FwdPayload dfB ~ (Index n, Index selectN)+  , KnownNat n+  , KnownNat selectN+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Proxy dfC ->+  Circuit (Vec n dfA, dfB) dfC+selectN (dfA, dfB) dfC =+  tupCircuits (vecFromDfConv dfA) (fromDfCircuit dfB)+    |> selectHelperA+    |> coerceCircuit+      ( tupCircuits+          Df.selectN+          (reverseCircuit $ Df.roundrobin |> selectHelperB)+      )+    |> toDfCircuit dfC++{- | Selects samples from channel /n/ until the predicate holds. The cycle in+which the predicate turns true is included.+-}+selectUntil ::+  ( DfConv dfA+  , DfConv dfB+  , DfConv dfC+  , BwdPayload dfA ~ BwdPayload dfC+  , BwdPayload dfB ~ BwdPayload dfC+  , Dom dfA ~ Dom dfB+  , Dom dfA ~ Dom dfC+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfC+  , FwdPayload dfB ~ Index n+  , KnownNat n+  ) =>+  (Proxy dfA, Proxy dfB) ->+  Proxy dfC ->+  (FwdPayload dfA -> Bool) ->+  Circuit (Vec n dfA, dfB) dfC+selectUntil (dfA, dfB) dfC f =+  tupCircuits (vecFromDfConv dfA) (fromDfCircuit dfB)+    |> selectHelperA+    |> coerceCircuit+      ( tupCircuits+          (Df.selectUntil f)+          (reverseCircuit $ Df.roundrobin |> selectHelperB)+      )+    |> toDfCircuit dfC++{- | Copy data of a single DfConv stream to multiple. LHS will only receive an+acknowledgement when all RHS receivers have acknowledged data.+-}+fanout ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  , KnownNat numB+  , 1 <= numB+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA (Vec numB dfB)+fanout dfA dfB =+  fromDfCircuit dfA+    |> coerceCircuit+      ( tupCircuits+          Df.fanout+          (reverseCircuit (Df.roundrobinCollect Df.Parallel))+      )+    |> vecToDfConv dfB++-- | Merge data of multiple streams using a user supplied function+fanin ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  , KnownNat numA+  , numA ~ (decNumA + 1)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  (FwdPayload dfA -> FwdPayload dfA -> FwdPayload dfA) ->+  Circuit (Vec numA dfA) dfB+fanin dfA dfB f =+  vecFromDfConv dfA+    |> coerceCircuit+      ( tupCircuits+          (Df.fanin f)+          (reverseCircuit Df.roundrobin)+      )+    |> toDfCircuit dfB++-- | Merge data of multiple streams using Monoid's '<>'.+mfanin ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  , Monoid (FwdPayload dfA)+  , KnownNat numA+  , numA ~ (decNumA + 1)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit (Vec numA dfA) dfB+mfanin dfA dfB =+  vecFromDfConv dfA+    |> coerceCircuit+      ( tupCircuits+          Df.mfanin+          (reverseCircuit Df.roundrobin)+      )+    |> toDfCircuit dfB++-- | Bundle a vector of DfConv streams into one.+bundleVec ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , Vec n (FwdPayload dfA) ~ FwdPayload dfB+  , KnownNat n+  , n ~ (decN + 1)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit (Vec n dfA) dfB+bundleVec dfA dfB =+  vecFromDfConv dfA+    |> coerceCircuit+      ( tupCircuits+          Df.bundleVec+          (reverseCircuit Df.roundrobin)+      )+    |> toDfCircuit dfB++{- | Split up a DfConv stream of a vector into multiple independent DfConv+streams.+-}+unbundleVec ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ Vec n (FwdPayload dfB)+  , NFDataX (FwdPayload dfB)+  , KnownNat n+  , 1 <= n+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA (Vec n dfB)+unbundleVec dfA dfB =+  fromDfCircuit dfA+    |> coerceCircuit+      ( tupCircuits+          Df.unbundleVec+          (reverseCircuit (Df.roundrobinCollect Df.Parallel))+      )+    |> vecToDfConv dfB++{- | Distribute data across multiple components on the RHS. Useful if you want+to parallelize a workload across multiple (slow) workers. For optimal+throughput, you should make sure workers can accept data every /n/ cycles.+-}+roundrobin ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , KnownNat n+  , n ~ (decN + 1)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA (Vec n dfB)+roundrobin dfA dfB =+  fromDfCircuit dfA+    |> coerceCircuit+      ( tupCircuits+          Df.roundrobin+          (reverseCircuit (Df.roundrobinCollect Df.Parallel))+      )+    |> vecToDfConv dfB++{- | Opposite of 'roundrobin'. Useful to collect data from workers that only+produce a result with an interval of /n/ cycles.+-}+roundrobinCollect ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , KnownNat n+  , n ~ (decN + 1)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Df.CollectMode ->+  Circuit (Vec n dfA) dfB+roundrobinCollect dfA dfB mode =+  vecFromDfConv dfA+    |> coerceCircuit+      ( tupCircuits+          (Df.roundrobinCollect mode)+          (reverseCircuit Df.roundrobin)+      )+    |> toDfCircuit dfB++-- | Place register on /forward/ part of a circuit.+registerFwd ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+registerFwd dfA dfB =+  fromDfCircuit dfA+    |> tupCircuits Df.registerFwd idC+    |> toDfCircuit dfB++{- | Place register on /backward/ part of a circuit. This is implemented using+a in-logic two-element shift register.+-}+registerBwd ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  Circuit dfA dfB+registerBwd dfA dfB =+  fromDfCircuit dfA+    |> tupCircuits Df.registerBwd idC+    |> toDfCircuit dfB++-- | A fifo buffer with user-provided depth. Uses blockram to store data+fifo ::+  ( DfConv dfA+  , DfConv dfB+  , BwdPayload dfA ~ BwdPayload dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , KnownNat depth+  , 1 <= depth+  , FwdPayload dfA ~ FwdPayload dfB+  , NFDataX (FwdPayload dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  SNat depth ->+  Circuit dfA dfB+fifo dfA dfB fifoDepth =+  fromDfCircuit dfA+    |> tupCircuits (Df.fifo fifoDepth) idC+    |> toDfCircuit dfB
+ src/Protocols/Experimental/Avalon/MemMap.hs view
@@ -0,0 +1,1484 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Types and instance declarations for the Avalon memory mapped protocol+(http://www1.cs.columbia.edu/~sedwards/classes/2009/4840/mnl_avalon_spec.pdf).+Non-required fields can be easily toggled by the user. The @data@ and+@outputenable@ fields are not supported since we would need bidirectional data+ports. The @resetrequest@ field is also not supported since this does not get+transferred around, but rather gets send "outwards" to whoever is controlling+the reset signal of the circuit.+-}+module Protocols.Experimental.Avalon.MemMap (+  -- * Configuration types+  AvalonMmSharedConfig (..),+  AvalonMmSubordinateConfig (..),+  AvalonMmManagerConfig (..),++  -- * Grab members from AvalonMmSharedConfig at the type level+  DataWidth,+  KeepReadData,+  KeepWriteData,+  AddrWidth,+  KeepRead,+  KeepWrite,+  ByteEnableWidth,+  KeepByteEnable,+  BurstCountWidth,+  KeepBurstCount,+  KeepReadDataValid,+  KeepEndOfPacket,++  -- * Grab members from AvalonMmSubordinateConfig at the type level+  KeepAddr,+  KeepWriteByteEnable,+  KeepChipSelect,+  KeepBeginTransfer,+  KeepWaitRequest,+  KeepBeginBurstTransfer,+  KeepReadyForData,+  KeepDataAvailable,+  KeepIrq,+  SShared,++  -- * Grab members from AvalonMmManagerConfig at the type level+  KeepFlush,+  KeepIrqList,+  KeepIrqNumber,+  MShared,++  -- * Remove DfConv-incompatible fields from configs+  RemoveNonDfSubordinate,+  RemoveNonDfManager,++  -- * Constraints on configs+  KnownSharedConfig,+  KnownSubordinateConfig,+  KnownManagerConfig,++  -- * Avalon MM signals+  AvalonManagerOut (..),+  AvalonManagerIn (..),+  AvalonSubordinateOut (..),+  AvalonSubordinateIn (..),++  -- * Important parts of signals, used as payload in DfConv+  AvalonWriteImpt (..),+  AvalonReadReqImpt (..),+  AvalonReadImpt (..),++  -- * Helper functions+  managerOutAddNonDf,+  managerOutRemoveNonDf,+  managerInAddNonDf,+  managerInRemoveNonDf,+  subordinateOutAddNonDf,+  subordinateOutRemoveNonDf,+  subordinateInAddNonDf,+  subordinateInRemoveNonDf,+  forceResetSanity,++  -- * Protocols+  AvalonMmManager (..),+  AvalonMmSubordinate (..),+) where++-- base+import Prelude ()++import Control.DeepSeq (NFData)+import Control.Monad.State (get, put)+import Data.Maybe qualified as Maybe+import Data.Proxy++-- clash-prelude+import Clash.Prelude hiding (concat, length, take)+import Clash.Prelude qualified as C++-- me++import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++{- | Config needed for both manager and subordinate interfaces.+@Bool@ values represent whether to keep a boolean field or not.+@Nat@ values represent the width of a variable-sized numeric field.+-}+data AvalonMmSharedConfig = AvalonMmSharedConfig+  { dataWidth :: Nat+  , keepReadData :: Bool+  , keepWriteData :: Bool+  , addrWidth :: Nat+  , keepRead :: Bool+  , keepWrite :: Bool+  , byteEnableWidth :: Nat+  , keepByteEnable :: Bool+  , burstCountWidth :: Nat+  , keepBurstCount :: Bool+  , keepReadDataValid :: Bool+  , keepEndOfPacket :: Bool+  }++{- | Config specific to Avalon MM subordinate interfaces.+@Bool@ values represent whether to keep a boolean field or not.+@Nat@ values represent the width of a variable-sized numeric field.+An t'AvalonMmSharedConfig' is also included for the rest of the fields.+-}+data AvalonMmSubordinateConfig = AvalonMmSubordinateConfig+  { keepAddr :: Bool+  , keepWriteByteEnable :: Bool+  , keepChipSelect :: Bool+  , keepBeginTransfer :: Bool+  , keepWaitRequest :: Bool+  , keepBeginBurstTransfer :: Bool+  , keepReadyForData :: Bool+  , keepDataAvailable :: Bool+  , keepIrq :: Bool+  , sShared :: AvalonMmSharedConfig+  }++{- | Config specific to Avalon MM manager interfaces.+@Bool@ values represent whether to keep a boolean field or not.+@Nat@ values represent the width of a variable-sized numeric field.+An t'AvalonMmSharedConfig' is also included for the rest of the fields.+-}+data AvalonMmManagerConfig = AvalonMmManagerConfig+  { keepFlush :: Bool+  , keepIrqList :: Bool+  , keepIrqNumber :: Bool+  , mShared :: AvalonMmSharedConfig+  }++-- Grab record fields at the type level:++-- | Grab 'dataWidth' from t'AvalonMmSharedConfig' at the type level+type family DataWidth (c :: AvalonMmSharedConfig) where+  DataWidth ('AvalonMmSharedConfig a _ _ _ _ _ _ _ _ _ _ _) = a++-- | Grab 'keepReadData' from t'AvalonMmSharedConfig' at the type level+type family KeepReadData (c :: AvalonMmSharedConfig) where+  KeepReadData ('AvalonMmSharedConfig _ a _ _ _ _ _ _ _ _ _ _) = a++-- | Grab 'keepWriteData' from t'AvalonMmSharedConfig' at the type level+type family KeepWriteData (c :: AvalonMmSharedConfig) where+  KeepWriteData ('AvalonMmSharedConfig _ _ a _ _ _ _ _ _ _ _ _) = a++-- | Grab 'addrWidth' from t'AvalonMmSharedConfig' at the type level+type family AddrWidth (c :: AvalonMmSharedConfig) where+  AddrWidth ('AvalonMmSharedConfig _ _ _ a _ _ _ _ _ _ _ _) = a++-- | Grab 'keepRead' from t'AvalonMmSharedConfig' at the type level+type family KeepRead (c :: AvalonMmSharedConfig) where+  KeepRead ('AvalonMmSharedConfig _ _ _ _ a _ _ _ _ _ _ _) = a++-- | Grab 'keepWrite' from t'AvalonMmSharedConfig' at the type level+type family KeepWrite (c :: AvalonMmSharedConfig) where+  KeepWrite ('AvalonMmSharedConfig _ _ _ _ _ a _ _ _ _ _ _) = a++-- | Grab 'byteEnableWidth' from t'AvalonMmSharedConfig' at the type level+type family ByteEnableWidth (c :: AvalonMmSharedConfig) where+  ByteEnableWidth ('AvalonMmSharedConfig _ _ _ _ _ _ a _ _ _ _ _) = a++-- | Grab 'keepByteEnable' from t'AvalonMmSharedConfig' at the type level+type family KeepByteEnable (c :: AvalonMmSharedConfig) where+  KeepByteEnable ('AvalonMmSharedConfig _ _ _ _ _ _ _ a _ _ _ _) = a++-- | Grab 'burstCountWidth' from t'AvalonMmSharedConfig' at the type level+type family BurstCountWidth (c :: AvalonMmSharedConfig) where+  BurstCountWidth ('AvalonMmSharedConfig _ _ _ _ _ _ _ _ a _ _ _) = a++-- | Grab 'keepBurstCount' from t'AvalonMmSharedConfig' at the type level+type family KeepBurstCount (c :: AvalonMmSharedConfig) where+  KeepBurstCount ('AvalonMmSharedConfig _ _ _ _ _ _ _ _ _ a _ _) = a++-- | Grab 'keepReadDataValid' from t'AvalonMmSharedConfig' at the type level+type family KeepReadDataValid (c :: AvalonMmSharedConfig) where+  KeepReadDataValid ('AvalonMmSharedConfig _ _ _ _ _ _ _ _ _ _ a _) = a++-- | Grab 'keepEndOfPacket' from t'AvalonMmSharedConfig' at the type level+type family KeepEndOfPacket (c :: AvalonMmSharedConfig) where+  KeepEndOfPacket ('AvalonMmSharedConfig _ _ _ _ _ _ _ _ _ _ _ a) = a++-- | Grab 'keepAddr' from t'AvalonMmSubordinateConfig' at the type level+type family KeepAddr (c :: AvalonMmSubordinateConfig) where+  KeepAddr ('AvalonMmSubordinateConfig a _ _ _ _ _ _ _ _ _) = a++-- | Grab 'keepWriteByteEnable' from t'AvalonMmSubordinateConfig' at the type level+type family KeepWriteByteEnable (c :: AvalonMmSubordinateConfig) where+  KeepWriteByteEnable ('AvalonMmSubordinateConfig _ a _ _ _ _ _ _ _ _) = a++-- | Grab 'keepChipSelect' from t'AvalonMmSubordinateConfig' at the type level+type family KeepChipSelect (c :: AvalonMmSubordinateConfig) where+  KeepChipSelect ('AvalonMmSubordinateConfig _ _ a _ _ _ _ _ _ _) = a++-- | Grab 'keepBeginTransfer' from t'AvalonMmSubordinateConfig' at the type level+type family KeepBeginTransfer (c :: AvalonMmSubordinateConfig) where+  KeepBeginTransfer ('AvalonMmSubordinateConfig _ _ _ a _ _ _ _ _ _) = a++-- | Grab 'keepWaitRequest' from t'AvalonMmSubordinateConfig' at the type level+type family KeepWaitRequest (c :: AvalonMmSubordinateConfig) where+  KeepWaitRequest ('AvalonMmSubordinateConfig _ _ _ _ a _ _ _ _ _) = a++-- | Grab 'keepBeginBurstTransfer' from t'AvalonMmSubordinateConfig' at the type level+type family KeepBeginBurstTransfer (c :: AvalonMmSubordinateConfig) where+  KeepBeginBurstTransfer ('AvalonMmSubordinateConfig _ _ _ _ _ a _ _ _ _) = a++-- | Grab 'keepReadyForData' from t'AvalonMmSubordinateConfig' at the type level+type family KeepReadyForData (c :: AvalonMmSubordinateConfig) where+  KeepReadyForData ('AvalonMmSubordinateConfig _ _ _ _ _ _ a _ _ _) = a++-- | Grab 'keepDataAvailable' from t'AvalonMmSubordinateConfig' at the type level+type family KeepDataAvailable (c :: AvalonMmSubordinateConfig) where+  KeepDataAvailable ('AvalonMmSubordinateConfig _ _ _ _ _ _ _ a _ _) = a++-- | Grab 'keepIrq' from t'AvalonMmSubordinateConfig' at the type level+type family KeepIrq (c :: AvalonMmSubordinateConfig) where+  KeepIrq ('AvalonMmSubordinateConfig _ _ _ _ _ _ _ _ a _) = a++-- | Grab 'sShared' from t'AvalonMmSubordinateConfig' at the type level+type family SShared (c :: AvalonMmSubordinateConfig) where+  SShared ('AvalonMmSubordinateConfig _ _ _ _ _ _ _ _ _ a) = a++-- | Grab 'keepFlush' from t'AvalonMmManagerConfig' at the type level+type family KeepFlush (c :: AvalonMmManagerConfig) where+  KeepFlush ('AvalonMmManagerConfig a _ _ _) = a++-- | Grab 'keepIrqList' from t'AvalonMmManagerConfig' at the type level+type family KeepIrqList (c :: AvalonMmManagerConfig) where+  KeepIrqList ('AvalonMmManagerConfig _ a _ _) = a++-- | Grab 'keepIrqNumber' from t'AvalonMmManagerConfig' at the type level+type family KeepIrqNumber (c :: AvalonMmManagerConfig) where+  KeepIrqNumber ('AvalonMmManagerConfig _ _ a _) = a++-- | Grab 'mShared' from t'AvalonMmManagerConfig' at the type level+type family MShared (c :: AvalonMmManagerConfig) where+  MShared ('AvalonMmManagerConfig _ _ _ a) = a++{- | Disable fields of t'AvalonMmSubordinateConfig' that are not allowed in the+'DfConv.DfConv' instance+-}+type family RemoveNonDfSubordinate (cfg :: AvalonMmSubordinateConfig) where+  RemoveNonDfSubordinate cfg =+    'AvalonMmSubordinateConfig+      (KeepAddr cfg)+      (KeepWriteByteEnable cfg)+      (KeepChipSelect cfg)+      'False+      (KeepWaitRequest cfg)+      'False+      'False+      'False+      'False+      (SShared cfg)++{- | Disable fields of t'AvalonMmManagerConfig' that are not allowed in the+'DfConv.DfConv' instance+-}+type family RemoveNonDfManager (cfg :: AvalonMmManagerConfig) where+  RemoveNonDfManager cfg =+    'AvalonMmManagerConfig+      'False+      'False+      'False+      (MShared cfg)++{- | Constraint representing a well-behaved shared config.+This class holds for every possible t'AvalonMmSharedConfig',+but we need to write out the class anyway so that GHC holds.+-}+type KnownSharedConfig config =+  ( KnownNat (DataWidth config)+  , KeepTypeClass (KeepReadData config)+  , KeepTypeClass (KeepWriteData config)+  , KnownNat (AddrWidth config)+  , KeepTypeClass (KeepRead config)+  , KeepTypeClass (KeepWrite config)+  , KnownNat (ByteEnableWidth config)+  , KeepTypeClass (KeepByteEnable config)+  , KnownNat (BurstCountWidth config)+  , KeepTypeClass (KeepBurstCount config)+  , KeepTypeClass (KeepReadDataValid config)+  , KeepTypeClass (KeepEndOfPacket config)+  , NFDataX (KeepType (KeepReadData config) (Unsigned (DataWidth config)))+  , NFData (KeepType (KeepReadData config) (Unsigned (DataWidth config)))+  , ShowX (KeepType (KeepReadData config) (Unsigned (DataWidth config)))+  , Show (KeepType (KeepReadData config) (Unsigned (DataWidth config)))+  , Eq (KeepType (KeepReadData config) (Unsigned (DataWidth config)))+  , NFDataX (KeepType (KeepWriteData config) (Unsigned (DataWidth config)))+  , NFData (KeepType (KeepWriteData config) (Unsigned (DataWidth config)))+  , ShowX (KeepType (KeepWriteData config) (Unsigned (DataWidth config)))+  , Show (KeepType (KeepWriteData config) (Unsigned (DataWidth config)))+  , Eq (KeepType (KeepWriteData config) (Unsigned (DataWidth config)))+  , NFDataX (KeepType (KeepByteEnable config) (Unsigned (ByteEnableWidth config)))+  , NFData (KeepType (KeepByteEnable config) (Unsigned (ByteEnableWidth config)))+  , ShowX (KeepType (KeepByteEnable config) (Unsigned (ByteEnableWidth config)))+  , Show (KeepType (KeepByteEnable config) (Unsigned (ByteEnableWidth config)))+  , Eq (KeepType (KeepByteEnable config) (Unsigned (ByteEnableWidth config)))+  , NFDataX (KeepType (KeepBurstCount config) (Unsigned (BurstCountWidth config)))+  , NFData (KeepType (KeepBurstCount config) (Unsigned (BurstCountWidth config)))+  , ShowX (KeepType (KeepBurstCount config) (Unsigned (BurstCountWidth config)))+  , Show (KeepType (KeepBurstCount config) (Unsigned (BurstCountWidth config)))+  , Eq (KeepType (KeepBurstCount config) (Unsigned (BurstCountWidth config)))+  )++{- | Constraint representing a well-behaved subordinate config.+This class holds for every possible t'AvalonMmSubordinateConfig',+but we need to write out the class anyway so that GHC holds.+-}+type KnownSubordinateConfig config =+  ( KeepTypeClass (KeepAddr config)+  , KeepTypeClass (KeepWriteByteEnable config)+  , KeepTypeClass (KeepChipSelect config)+  , KeepTypeClass (KeepBeginTransfer config)+  , KeepTypeClass (KeepWaitRequest config)+  , KeepTypeClass (KeepBeginBurstTransfer config)+  , KeepTypeClass (KeepReadyForData config)+  , KeepTypeClass (KeepDataAvailable config)+  , KeepTypeClass (KeepIrq config)+  , KnownSharedConfig (SShared config)+  , NFDataX (KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config))))+  , NFData (KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config))))+  , ShowX (KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config))))+  , Show (KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config))))+  , Eq (KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config))))+  , NFDataX+      (KeepType (KeepWriteByteEnable config) (Unsigned (ByteEnableWidth (SShared config))))+  , NFData+      (KeepType (KeepWriteByteEnable config) (Unsigned (ByteEnableWidth (SShared config))))+  , ShowX+      (KeepType (KeepWriteByteEnable config) (Unsigned (ByteEnableWidth (SShared config))))+  , Show+      (KeepType (KeepWriteByteEnable config) (Unsigned (ByteEnableWidth (SShared config))))+  , Eq+      (KeepType (KeepWriteByteEnable config) (Unsigned (ByteEnableWidth (SShared config))))+  )++{- | Constraint representing a well-behaved manager config.+This class holds for every possible t'AvalonMmManagerConfig',+but we need to write out the class anyway so that GHC holds.+-}+type KnownManagerConfig config =+  ( KeepTypeClass (KeepFlush config)+  , KeepTypeClass (KeepIrqList config)+  , KeepTypeClass (KeepIrqNumber config)+  , KnownSharedConfig (MShared config)+  , NFDataX (KeepType (KeepIrqList config) (Unsigned 32))+  , NFData (KeepType (KeepIrqList config) (Unsigned 32))+  , ShowX (KeepType (KeepIrqList config) (Unsigned 32))+  , Show (KeepType (KeepIrqList config) (Unsigned 32))+  , Eq (KeepType (KeepIrqList config) (Unsigned 32))+  , NFDataX (KeepType (KeepIrqNumber config) (Maybe (Unsigned 6)))+  , NFData (KeepType (KeepIrqNumber config) (Maybe (Unsigned 6)))+  , ShowX (KeepType (KeepIrqNumber config) (Maybe (Unsigned 6)))+  , Show (KeepType (KeepIrqNumber config) (Maybe (Unsigned 6)))+  , Eq (KeepType (KeepIrqNumber config) (Maybe (Unsigned 6)))+  )++{- | Data coming out of an Avalon MM manager port.+All fields are optional and can be toggled using the config.+-}+data AvalonManagerOut config = AvalonManagerOut+  { mo_writeData ::+      KeepType+        (KeepWriteData (MShared config))+        (Unsigned (DataWidth (MShared config)))+  , mo_addr :: Unsigned (AddrWidth (MShared config))+  , mo_read :: KeepType (KeepRead (MShared config)) Bool+  , mo_write :: KeepType (KeepWrite (MShared config)) Bool+  , mo_byteEnable ::+      KeepType+        (KeepByteEnable (MShared config))+        (Unsigned (ByteEnableWidth (MShared config)))+  , mo_burstCount ::+      KeepType+        (KeepBurstCount (MShared config))+        (Unsigned (BurstCountWidth (MShared config)))+  , mo_flush :: KeepType (KeepFlush config) Bool+  }+  deriving (Generic, Bundle)++deriving instance+  (KnownManagerConfig config) =>+  NFDataX (AvalonManagerOut config)+deriving instance+  (KnownManagerConfig config) =>+  NFData (AvalonManagerOut config)+deriving instance+  (KnownManagerConfig config) =>+  ShowX (AvalonManagerOut config)+deriving instance+  (KnownManagerConfig config) =>+  Show (AvalonManagerOut config)+deriving instance+  (KnownManagerConfig config) =>+  Eq (AvalonManagerOut config)++{- | Data coming into an Avalon MM manager port.+Almost all fields are optional and can be toggled using the config.+WaitRequest is mandatory.+-}+data AvalonManagerIn config = AvalonManagerIn+  { mi_readData ::+      KeepType+        (KeepReadData (MShared config))+        (Unsigned (DataWidth (MShared config)))+  , mi_waitRequest :: Bool+  , mi_readDataValid :: KeepType (KeepReadDataValid (MShared config)) Bool+  , mi_endOfPacket :: KeepType (KeepEndOfPacket (MShared config)) Bool+  , mi_irqList :: KeepType (KeepIrqList config) (Unsigned 32)+  , mi_irqNumber :: KeepType (KeepIrqNumber config) (Maybe (Unsigned 6))+  }+  deriving (Generic, Bundle)++deriving instance+  (KnownManagerConfig config) =>+  NFDataX (AvalonManagerIn config)+deriving instance+  (KnownManagerConfig config) =>+  NFData (AvalonManagerIn config)+deriving instance+  (KnownManagerConfig config) =>+  ShowX (AvalonManagerIn config)+deriving instance+  (KnownManagerConfig config) =>+  Show (AvalonManagerIn config)+deriving instance+  (KnownManagerConfig config) =>+  Eq (AvalonManagerIn config)++{- | Data coming out of an Avalon MM subordinate port.+All fields are optional and can be toggled using the config.+-}+data AvalonSubordinateOut config = AvalonSubordinateOut+  { so_readData ::+      KeepType+        (KeepReadData (SShared config))+        (Unsigned (DataWidth (SShared config)))+  , so_readDataValid :: KeepType (KeepReadDataValid (SShared config)) Bool+  , so_endOfPacket :: KeepType (KeepEndOfPacket (SShared config)) Bool+  , so_waitRequest :: KeepType (KeepWaitRequest config) Bool+  , so_readyForData :: KeepType (KeepReadyForData config) Bool+  , so_dataAvailable :: KeepType (KeepDataAvailable config) Bool+  , so_irq :: KeepType (KeepIrq config) Bool+  }+  deriving (Generic, Bundle)++deriving instance+  (KnownSubordinateConfig config) =>+  NFDataX (AvalonSubordinateOut config)+deriving instance+  (KnownSubordinateConfig config) =>+  NFData (AvalonSubordinateOut config)+deriving instance+  (KnownSubordinateConfig config) =>+  ShowX (AvalonSubordinateOut config)+deriving instance+  (KnownSubordinateConfig config) =>+  Show (AvalonSubordinateOut config)+deriving instance+  (KnownSubordinateConfig config) =>+  Eq (AvalonSubordinateOut config)++{- | Data coming into an Avalon MM subordinate port.+All fields are optional and can be toggled using the config.+-}+data AvalonSubordinateIn config = AvalonSubordinateIn+  { si_writeData ::+      KeepType+        (KeepWriteData (SShared config))+        (Unsigned (DataWidth (SShared config)))+  , si_addr :: KeepType (KeepAddr config) (Unsigned (AddrWidth (SShared config)))+  , si_read :: KeepType (KeepRead (SShared config)) Bool+  , si_write :: KeepType (KeepWrite (SShared config)) Bool+  , si_byteEnable ::+      KeepType+        (KeepByteEnable (SShared config))+        (Unsigned (ByteEnableWidth (SShared config)))+  , si_burstCount ::+      KeepType+        (KeepBurstCount (SShared config))+        (Unsigned (BurstCountWidth (SShared config)))+  , si_writeByteEnable ::+      KeepType+        (KeepWriteByteEnable config)+        (Unsigned (ByteEnableWidth (SShared config)))+  , si_chipSelect :: KeepType (KeepChipSelect config) Bool+  , si_beginTransfer :: KeepType (KeepBeginTransfer config) Bool+  , si_beginBurstTransfer :: KeepType (KeepBeginBurstTransfer config) Bool+  }+  deriving (Generic, Bundle)++deriving instance+  (KnownSubordinateConfig config) =>+  NFDataX (AvalonSubordinateIn config)+deriving instance+  (KnownSubordinateConfig config) =>+  NFData (AvalonSubordinateIn config)+deriving instance+  (KnownSubordinateConfig config) =>+  ShowX (AvalonSubordinateIn config)+deriving instance+  (KnownSubordinateConfig config) =>+  Show (AvalonSubordinateIn config)+deriving instance+  (KnownSubordinateConfig config) =>+  Eq (AvalonSubordinateIn config)++{- | "Important" data pertaining to write transfers.+Can be grabbed from t'AvalonManagerOut' or t'AvalonSubordinateIn'.+-}+data AvalonWriteImpt keepAddr config = AvalonWriteImpt+  { wi_writeData ::+      KeepType+        (KeepWriteData config)+        (Unsigned (DataWidth config))+  , wi_addr :: KeepType keepAddr (Unsigned (AddrWidth config))+  , wi_byteEnable ::+      KeepType+        (KeepByteEnable config)+        (Unsigned (ByteEnableWidth config))+  , wi_burstCount ::+      KeepType+        (KeepBurstCount config)+        (Unsigned (BurstCountWidth config))+  }+  deriving (Generic, Bundle)++deriving instance+  ( KnownSharedConfig config+  , NFDataX (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  NFDataX (AvalonWriteImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , NFData (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  NFData (AvalonWriteImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , ShowX (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  ShowX (AvalonWriteImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , Show (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  Show (AvalonWriteImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , Eq (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  Eq (AvalonWriteImpt keepAddr config)++{- | "Important" data pertaining to read requests.+Can be grabbed from t'AvalonManagerOut' or t'AvalonSubordinateIn'.+-}+data AvalonReadReqImpt keepAddr config = AvalonReadReqImpt+  { rri_addr :: KeepType keepAddr (Unsigned (AddrWidth config))+  , rri_byteEnable ::+      KeepType+        (KeepByteEnable config)+        (Unsigned (ByteEnableWidth config))+  , rri_burstCount ::+      KeepType+        (KeepBurstCount config)+        (Unsigned (BurstCountWidth config))+  }+  deriving (Generic, Bundle)++deriving instance+  ( KnownSharedConfig config+  , NFDataX (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  NFDataX (AvalonReadReqImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , NFData (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  NFData (AvalonReadReqImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , ShowX (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  ShowX (AvalonReadReqImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , Show (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  Show (AvalonReadReqImpt keepAddr config)+deriving instance+  ( KnownSharedConfig config+  , Eq (KeepType keepAddr (Unsigned (AddrWidth config)))+  , KeepTypeClass keepAddr+  ) =>+  Eq (AvalonReadReqImpt keepAddr config)++{- | "Important" data pertaining to subordinate-to-master read data.+Can be grabbed from t'AvalonManagerIn' or t'AvalonSubordinateOut'.+-}+data AvalonReadImpt config = AvalonReadImpt+  { ri_readData ::+      KeepType+        (KeepReadData config)+        (Unsigned (DataWidth config))+  , ri_endOfPacket :: KeepType (KeepEndOfPacket config) Bool+  }+  deriving (Generic, Bundle)++deriving instance+  (KnownSharedConfig config) =>+  NFDataX (AvalonReadImpt config)+deriving instance+  (KnownSharedConfig config) =>+  NFData (AvalonReadImpt config)+deriving instance+  (KnownSharedConfig config) =>+  ShowX (AvalonReadImpt config)+deriving instance+  (KnownSharedConfig config) =>+  Show (AvalonReadImpt config)+deriving instance+  (KnownSharedConfig config) =>+  Eq (AvalonReadImpt config)++{- | Given an t'AvalonManagerOut', separate out the parts which are not+compatible with 'DfConv.DfConv'.+-}+managerOutRemoveNonDf ::+  (KnownManagerConfig cfg) =>+  AvalonManagerOut cfg ->+  ( AvalonManagerOut (RemoveNonDfManager cfg)+  , KeepType (KeepFlush cfg) Bool+  )+managerOutRemoveNonDf AvalonManagerOut{..} =+  ( AvalonManagerOut+      { mo_addr+      , mo_read+      , mo_write+      , mo_byteEnable+      , mo_burstCount+      , mo_writeData+      , mo_flush = keepTypeFalse+      }+  , mo_flush+  )++{- | Given an t'AvalonManagerOut' which is compatible with 'DfConv.DfConv', add+back in the parts which are not compatible with 'DfConv.DfConv'.+-}+managerOutAddNonDf ::+  (KnownManagerConfig cfg) =>+  KeepType (KeepFlush cfg) Bool ->+  AvalonManagerOut (RemoveNonDfManager cfg) ->+  AvalonManagerOut cfg+managerOutAddNonDf flush AvalonManagerOut{..} =+  AvalonManagerOut+    { mo_addr+    , mo_read+    , mo_write+    , mo_byteEnable+    , mo_burstCount+    , mo_writeData+    , mo_flush = flush+    }++{- | Given an t'AvalonManagerIn', separate out the parts which are not+compatible with 'DfConv.DfConv'.+-}+managerInRemoveNonDf ::+  (KnownManagerConfig cfg) =>+  AvalonManagerIn cfg ->+  ( AvalonManagerIn (RemoveNonDfManager cfg)+  , ( KeepType (KeepIrqList cfg) (Unsigned 32)+    , KeepType (KeepIrqNumber cfg) (Maybe (Unsigned 6))+    )+  )+managerInRemoveNonDf AvalonManagerIn{..} =+  ( AvalonManagerIn+      { mi_readData+      , mi_waitRequest+      , mi_readDataValid+      , mi_endOfPacket+      , mi_irqList = keepTypeFalse+      , mi_irqNumber = keepTypeFalse+      }+  , (mi_irqList, mi_irqNumber)+  )++{- | Given an t'AvalonManagerIn' which is compatible with 'DfConv.DfConv', add+back in the parts which are not compatible with 'DfConv.DfConv'.+-}+managerInAddNonDf ::+  (KnownManagerConfig cfg) =>+  ( KeepType (KeepIrqList cfg) (Unsigned 32)+  , KeepType (KeepIrqNumber cfg) (Maybe (Unsigned 6))+  ) ->+  AvalonManagerIn (RemoveNonDfManager cfg) ->+  AvalonManagerIn cfg+managerInAddNonDf (irqList, irqNumber) AvalonManagerIn{..} =+  AvalonManagerIn+    { mi_readData+    , mi_waitRequest+    , mi_readDataValid+    , mi_endOfPacket+    , mi_irqList = irqList+    , mi_irqNumber = irqNumber+    }++{- | Given an t'AvalonSubordinateOut', separate out the parts which are not+compatible with 'DfConv.DfConv'.+-}+subordinateOutRemoveNonDf ::+  (KnownSubordinateConfig cfg) =>+  AvalonSubordinateOut cfg ->+  ( AvalonSubordinateOut (RemoveNonDfSubordinate cfg)+  , ( KeepType (KeepReadyForData cfg) Bool+    , KeepType (KeepDataAvailable cfg) Bool+    , KeepType (KeepIrq cfg) Bool+    )+  )+subordinateOutRemoveNonDf AvalonSubordinateOut{..} =+  ( AvalonSubordinateOut+      { so_waitRequest+      , so_readDataValid+      , so_endOfPacket+      , so_readData+      , so_readyForData = keepTypeFalse+      , so_dataAvailable = keepTypeFalse+      , so_irq = keepTypeFalse+      }+  , (so_readyForData, so_dataAvailable, so_irq)+  )++{- | Given an t'AvalonSubordinateOut' which is compatible with 'DfConv.DfConv',+add back in the parts which are not compatible with 'DfConv.DfConv'.+-}+subordinateOutAddNonDf ::+  (KnownSubordinateConfig cfg) =>+  ( KeepType (KeepReadyForData cfg) Bool+  , KeepType (KeepDataAvailable cfg) Bool+  , KeepType (KeepIrq cfg) Bool+  ) ->+  AvalonSubordinateOut (RemoveNonDfSubordinate cfg) ->+  AvalonSubordinateOut cfg+subordinateOutAddNonDf (readyForData, dataAvailable, irq) AvalonSubordinateOut{..} =+  AvalonSubordinateOut+    { so_waitRequest+    , so_readDataValid+    , so_endOfPacket+    , so_readData+    , so_readyForData = readyForData+    , so_dataAvailable = dataAvailable+    , so_irq = irq+    }++{- | Given an t'AvalonSubordinateIn', separate out the parts which are not+compatible with 'DfConv.DfConv'.+-}+subordinateInRemoveNonDf ::+  (KnownSubordinateConfig cfg) =>+  AvalonSubordinateIn cfg ->+  ( AvalonSubordinateIn (RemoveNonDfSubordinate cfg)+  , ( KeepType (KeepBeginBurstTransfer cfg) Bool+    , KeepType (KeepBeginTransfer cfg) Bool+    )+  )+subordinateInRemoveNonDf AvalonSubordinateIn{..} =+  ( AvalonSubordinateIn+      { si_chipSelect+      , si_addr+      , si_read+      , si_write+      , si_byteEnable+      , si_writeByteEnable+      , si_burstCount+      , si_writeData+      , si_beginBurstTransfer = keepTypeFalse+      , si_beginTransfer = keepTypeFalse+      }+  , (si_beginBurstTransfer, si_beginTransfer)+  )++{- | Given an t'AvalonSubordinateIn' which is compatible with 'DfConv.DfConv',+add back in the parts which are not compatible with 'DfConv.DfConv'.+-}+subordinateInAddNonDf ::+  (KnownSubordinateConfig cfg) =>+  ( KeepType (KeepBeginBurstTransfer cfg) Bool+  , KeepType (KeepBeginTransfer cfg) Bool+  ) ->+  AvalonSubordinateIn (RemoveNonDfSubordinate cfg) ->+  AvalonSubordinateIn cfg+subordinateInAddNonDf (beginBurstTransfer, beginTransfer) AvalonSubordinateIn{..} =+  AvalonSubordinateIn+    { si_chipSelect+    , si_addr+    , si_read+    , si_write+    , si_byteEnable+    , si_writeByteEnable+    , si_burstCount+    , si_writeData+    , si_beginBurstTransfer = beginBurstTransfer+    , si_beginTransfer = beginTransfer+    }++{- | Convert a boolean value to an t'AvalonSubordinateOut' structure.+The structure gives no read data, no IRQ, etc. Fields relating to+"acknowledging" a write, or a read request, are controlled by the bool input.+-}+boolToMmSubordinateAck ::+  (KnownSubordinateConfig config) => Bool -> AvalonSubordinateOut config+boolToMmSubordinateAck ack =+  AvalonSubordinateOut+    { so_waitRequest = toKeepType (not ack)+    , so_readDataValid = toKeepType False+    , so_readyForData = toKeepType ack+    , so_dataAvailable = toKeepType False+    , so_endOfPacket = toKeepType False+    , so_irq = toKeepType False+    , so_readData = errorX "No readData for boolToAck"+    }++{- | Convert a boolean value to an t'AvalonManagerIn' structure.+The structure gives no read data, no IRQ, etc. The @waitRequest@ field is+controlled by the (negated) boolean input.+-}+boolToMmManagerAck ::+  (KnownManagerConfig config) => Bool -> AvalonManagerIn config+boolToMmManagerAck ack =+  AvalonManagerIn+    { mi_waitRequest = not ack+    , mi_readDataValid = toKeepType False+    , mi_endOfPacket = toKeepType False+    , mi_irqList = toKeepType 0+    , mi_irqNumber = toKeepType Nothing+    , mi_readData = errorX "No readData for boolToAck"+    }++{- | Convert an t'AvalonReadImpt' into an t'AvalonSubordinateOut' containing that+read data.+-}+mmReadImptToSubordinateOut ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonReadImpt (SShared config) ->+  AvalonSubordinateOut config+mmReadImptToSubordinateOut dat =+  AvalonSubordinateOut+    { so_waitRequest = toKeepType False+    , so_readDataValid = toKeepType True+    , so_readyForData = keepTypeFalse+    , so_dataAvailable = keepTypeFalse+    , so_endOfPacket = ri_endOfPacket dat+    , so_irq = keepTypeFalse+    , so_readData = ri_readData dat+    }++{- | Grab the important read information from an t'AvalonSubordinateOut', putting+it into an t'AvalonReadImpt'. Only works if fixed wait time is 0.+-}+mmSubordinateOutToReadImpt ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonSubordinateOut config ->+  Maybe (AvalonReadImpt (SShared config))+mmSubordinateOutToReadImpt (AvalonSubordinateOut{..})+  | cond =+      Just+        AvalonReadImpt+          { ri_endOfPacket = so_endOfPacket+          , ri_readData = so_readData+          }+  | otherwise = Nothing+ where+  cond =+    fromKeepTypeDef True so_readDataValid+      && not (fromKeepTypeDef False so_waitRequest)++{- | Convert an t'AvalonReadImpt' into an t'AvalonManagerIn' containing that+read data.+-}+mmReadImptToManagerIn ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonReadImpt (MShared config) ->+  AvalonManagerIn config+mmReadImptToManagerIn dat =+  AvalonManagerIn+    { mi_waitRequest = False+    , mi_readDataValid = toKeepType True+    , mi_endOfPacket = ri_endOfPacket dat+    , mi_irqList = keepTypeFalse+    , mi_irqNumber = keepTypeFalse+    , mi_readData = ri_readData dat+    }++{- | Grab the important read information from an t'AvalonManagerIn', putting it+into an t'AvalonReadImpt'. Only works if fixed wait time is 0.+-}+mmManagerInToReadImpt ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonManagerIn config ->+  Maybe (AvalonReadImpt (MShared config))+mmManagerInToReadImpt (AvalonManagerIn{..})+  | cond =+      Just+        AvalonReadImpt+          { ri_endOfPacket = mi_endOfPacket+          , ri_readData = mi_readData+          }+  | otherwise = Nothing+ where+  cond = fromKeepTypeDef True mi_readDataValid++{- | Convert an t'AvalonWriteImpt' into an t'AvalonSubordinateIn' containing+that write data.+-}+mmWriteImptToSubordinateIn ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonWriteImpt (KeepAddr config) (SShared config) ->+  AvalonSubordinateIn config+mmWriteImptToSubordinateIn (AvalonWriteImpt{..}) =+  AvalonSubordinateIn+    { si_chipSelect = toKeepType True+    , si_addr = wi_addr+    , si_read = toKeepType False+    , si_write = toKeepType True+    , si_byteEnable = wi_byteEnable+    , si_writeByteEnable =+        convKeepType+          (bitCoerce $ repeat True)+          wi_byteEnable+    , si_beginTransfer = keepTypeFalse+    , si_burstCount = wi_burstCount+    , si_beginBurstTransfer = keepTypeFalse+    , si_writeData = wi_writeData+    }++{- | Grab the important write information from an t'AvalonSubordinateIn',+putting it into an t'AvalonWriteImpt'.+-}+mmSubordinateInToWriteImpt ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonSubordinateIn config ->+  Maybe (AvalonWriteImpt (KeepAddr config) (SShared config))+mmSubordinateInToWriteImpt (AvalonSubordinateIn{..})+  | cond =+      Just+        AvalonWriteImpt+          { wi_addr = si_addr+          , wi_byteEnable = si_byteEnable+          , wi_burstCount = si_burstCount+          , wi_writeData = si_writeData+          }+  | otherwise = Nothing+ where+  cond =+    fromKeepTypeDef True si_chipSelect+      && fromKeepTypeDef True si_write+      && not (fromKeepTypeDef False si_read)++{- | Convert an t'AvalonWriteImpt' into an t'AvalonManagerOut' containing that+write data.+-}+mmWriteImptToManagerOut ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonWriteImpt 'True (MShared config) ->+  AvalonManagerOut config+mmWriteImptToManagerOut (AvalonWriteImpt{..}) =+  AvalonManagerOut+    { mo_addr = fromKeepTypeTrue wi_addr+    , mo_read = toKeepType False+    , mo_write = toKeepType True+    , mo_byteEnable = wi_byteEnable+    , mo_burstCount = wi_burstCount+    , mo_flush = keepTypeFalse+    , mo_writeData = wi_writeData+    }++{- | Grab the important write information from an t'AvalonManagerOut', putting+it into an t'AvalonWriteImpt'.+-}+mmManagerOutToWriteImpt ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonManagerOut config ->+  Maybe (AvalonWriteImpt 'True (MShared config))+mmManagerOutToWriteImpt (AvalonManagerOut{..})+  | cond =+      Just+        AvalonWriteImpt+          { wi_addr = toKeepType mo_addr+          , wi_byteEnable = mo_byteEnable+          , wi_burstCount = mo_burstCount+          , wi_writeData = mo_writeData+          }+  | otherwise = Nothing+ where+  cond =+    fromKeepTypeDef True mo_write+      && not (fromKeepTypeDef False mo_read)++{- | Convert an t'AvalonReadReqImpt' into an t'AvalonSubordinateIn' containing+that read request data.+-}+mmReadReqImptToSubordinateIn ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonReadReqImpt (KeepAddr config) (SShared config) ->+  AvalonSubordinateIn config+mmReadReqImptToSubordinateIn (AvalonReadReqImpt{..}) =+  AvalonSubordinateIn+    { si_chipSelect = toKeepType True+    , si_addr = rri_addr+    , si_read = toKeepType True+    , si_write = toKeepType False+    , si_byteEnable = rri_byteEnable+    , si_writeByteEnable = toKeepType 0+    , si_beginTransfer = keepTypeFalse+    , si_burstCount = rri_burstCount+    , si_beginBurstTransfer = keepTypeFalse+    , si_writeData = errorX "No writeData for read req"+    }++{- | Grab the important read request information from an t'AvalonSubordinateIn',+putting it into an t'AvalonReadReqImpt'.+-}+mmSubordinateInToReadReqImpt ::+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  AvalonSubordinateIn config ->+  Maybe (AvalonReadReqImpt (KeepAddr config) (SShared config))+mmSubordinateInToReadReqImpt (AvalonSubordinateIn{..})+  | cond =+      Just+        AvalonReadReqImpt+          { rri_addr = si_addr+          , rri_byteEnable = si_byteEnable+          , rri_burstCount = si_burstCount+          }+  | otherwise = Nothing+ where+  cond =+    fromKeepTypeDef True si_chipSelect+      && fromKeepTypeDef True si_read+      && not (fromKeepTypeDef False si_write)++{- | Convert an t'AvalonReadReqImpt' into an t'AvalonManagerOut' containing that+read request data.+-}+mmReadReqImptToManagerOut ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonReadReqImpt 'True (MShared config) ->+  AvalonManagerOut config+mmReadReqImptToManagerOut (AvalonReadReqImpt{..}) =+  AvalonManagerOut+    { mo_addr = fromKeepTypeTrue rri_addr+    , mo_read = toKeepType True+    , mo_write = toKeepType False+    , mo_byteEnable = rri_byteEnable+    , mo_burstCount = rri_burstCount+    , mo_flush = keepTypeFalse+    , mo_writeData = errorX "No writeData for read req"+    }++{- | Grab the important read request information from an t'AvalonManagerOut',+putting it into an t'AvalonReadReqImpt'.+-}+mmManagerOutToReadReqImpt ::+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  AvalonManagerOut config ->+  Maybe (AvalonReadReqImpt 'True (MShared config))+mmManagerOutToReadReqImpt (AvalonManagerOut{..})+  | cond =+      Just+        AvalonReadReqImpt+          { rri_addr = toKeepType mo_addr+          , rri_byteEnable = mo_byteEnable+          , rri_burstCount = mo_burstCount+          }+  | otherwise = Nothing+ where+  cond =+    fromKeepTypeDef True mo_read+      && not (fromKeepTypeDef False mo_write)++{- | An t'AvalonSubordinateIn' containing no write data, and indicating that no+transmission is currently occurring.+-}+mmSubordinateInNoData ::+  (KnownSubordinateConfig config) =>+  AvalonSubordinateIn config+mmSubordinateInNoData =+  AvalonSubordinateIn+    { si_chipSelect = toKeepType False+    , si_addr = toKeepType 0+    , si_read = toKeepType False+    , si_write = toKeepType False+    , si_byteEnable = toKeepType 0+    , si_writeByteEnable = toKeepType 0+    , si_beginTransfer = toKeepType False+    , si_burstCount = toKeepType 0+    , si_beginBurstTransfer = toKeepType False+    , si_writeData = errorX "No writeData for noData"+    }++{- | An t'AvalonManagerOut' containing no write data, and indicating that no+transmission is currently occurring.+-}+mmManagerOutNoData :: (KnownManagerConfig config) => AvalonManagerOut config+mmManagerOutNoData =+  AvalonManagerOut+    { mo_addr = 0+    , mo_read = toKeepType False+    , mo_write = toKeepType False+    , mo_byteEnable = toKeepType 0+    , mo_burstCount = toKeepType 0+    , mo_flush = toKeepType False+    , mo_writeData = errorX "No writeData for noData"+    }++{- | Grab the "acknowledgement" value from an t'AvalonSubordinateOut'.+Reasonable defaults are provided for optional fields.+-}+mmSubordinateOutToBool ::+  (KnownSubordinateConfig config) =>+  AvalonSubordinateOut config ->+  Bool+mmSubordinateOutToBool so =+  fromKeepTypeDef True (so_readyForData so)+    && not (fromKeepTypeDef False (so_waitRequest so))++{- | Grab the "acknowledgement" value from an t'AvalonManagerIn'.+Reasonable defaults are provided for optional fields.+-}+mmManagerInToBool ::+  (KnownManagerConfig config) => AvalonManagerIn config -> Bool+mmManagerInToBool = not . mi_waitRequest++-- | Datatype for the manager end of the Avalon memory-mapped protocol.+data AvalonMmManager (dom :: Domain) (config :: AvalonMmManagerConfig)+  = AvalonMmManager++-- | Datatype for the subordinate end of the Avalon memory-mapped protocol.+data+  AvalonMmSubordinate+    (dom :: Domain)+    (fixedWaitTime :: Nat)+    (config :: AvalonMmSubordinateConfig)+  = AvalonMmSubordinate++instance Protocol (AvalonMmManager dom config) where+  type Fwd (AvalonMmManager dom config) = Signal dom (AvalonManagerOut config)+  type Bwd (AvalonMmManager dom config) = Signal dom (AvalonManagerIn config)++instance Protocol (AvalonMmSubordinate dom fixedWaitTime config) where+  type+    Fwd (AvalonMmSubordinate dom fixedWaitTime config) =+      Signal dom (AvalonSubordinateIn config)+  type+    Bwd (AvalonMmSubordinate dom fixedWaitTime config) =+      Signal dom (AvalonSubordinateOut config)++instance+  (KnownSubordinateConfig config, KeepWaitRequest config ~ 'True) =>+  Backpressure (AvalonMmSubordinate dom 0 config)+  where+  boolsToBwd _ = C.fromList_lazy . fmap boolToMmSubordinateAck++instance+  (KnownManagerConfig config) =>+  Backpressure (AvalonMmManager dom config)+  where+  boolsToBwd _ = C.fromList_lazy . fmap boolToMmManagerAck++-- 'toDfLike' and 'fromDfLike' here are very similar to their implementations+-- in @instance DfConv.DfConv (AvalonMmManager ...)@. 'toDfCircuit' forces+-- burstCount to be 1, will overwrite whatever value you specify in your+-- WriteImpt and ReadReqImpt. In the case of write, this is because the user+-- could otherwise send in a write with burst size of 2, but then send a read+-- request along the same channel, which would either have to get dropped, or+-- the write burst would have to be left unfinished. In the case of read+-- request, this is because read data only comes in for one clock cycle, while+-- a Df acknowledge can take a while to come in, so we need to store incoming+-- read data; if we were allowed to have arbitrarily large burst sizes, we+-- would need to store incoming read data in an arbitrarily-large buffer.+instance+  (KnownSubordinateConfig config, config ~ RemoveNonDfSubordinate config) =>+  DfConv.DfConv (AvalonMmSubordinate dom 0 config)+  where+  type Dom (AvalonMmSubordinate dom 0 config) = dom+  type+    BwdPayload (AvalonMmSubordinate dom 0 config) =+      AvalonReadImpt (SShared config)+  type+    FwdPayload (AvalonMmSubordinate dom 0 config) =+      Either+        (AvalonReadReqImpt (KeepAddr config) (SShared config))+        (AvalonWriteImpt (KeepAddr config) (SShared config))++  toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = (Nothing, False)+    -- Nothing: readDatStored:+    --   reads only get sent for one clock cycle, so we have to store it+    --   until it's acked+    -- False: readReqAcked:+    --   when our read request is acknowledged, we should stop sending the+    --   read request forwards+    blankOtp = mmSubordinateInNoData+    stateFn so dfAck dfDat = do+      (readDatStored0, readReqAcked0) <- get+      let+        readDatIn = mmSubordinateOutToReadImpt so+        soBool = mmSubordinateOutToBool so+        (readDatStored1, readReqAcked1, si, dfAckOut) =+          genOutputs dfDat readDatStored0 readReqAcked0 readDatIn soBool+      put+        ( if ( Maybe.isNothing readDatStored1 -- to avoid looking at dfAck when not needed+                 || dfAck+             )+            then Nothing+            else readDatStored1+        , readReqAcked1+        )+      pure (si, readDatStored1, dfAckOut)+     where+      genOutputs (Just (Right wi)) readDatStored0 _ _ soBool =+        ( readDatStored0+        , False+        , mmWriteImptToSubordinateIn+            (wi{wi_burstCount = toKeepType 1})+        , soBool+        )+      genOutputs _ readDatStored0@(Just _) _ _ soBool =+        ( readDatStored0+        , False+        , mmSubordinateInNoData+        , soBool+        )+      genOutputs (Just (Left ri)) Nothing readReqAcked0 readDatIn soBool =+        ( readDatIn+        , soBool+        , if readReqAcked0+            then mmSubordinateInNoData+            else+              mmReadReqImptToSubordinateIn+                (ri{rri_burstCount = toKeepType 1})+        , soBool+        )+      genOutputs Nothing Nothing _ _ _ =+        ( Nothing+        , False+        , mmSubordinateInNoData+        , False+        )++  fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = False -- dfAckSt -- read request might be acked before read is sent back+    blankOtp = boolToMmSubordinateAck False+    stateFn si dfAck dfDat = do+      dfAckSt <- get+      let+        writeImpt = mmSubordinateInToWriteImpt si+        readReqImpt+          | Nothing <- writeImpt = mmSubordinateInToReadReqImpt si+          | otherwise = Nothing+        sendingReadDat+          | Just _ <- readReqImpt, dfAckSt = dfDat+          | otherwise = Nothing+        dfAckSt' = Maybe.isJust readReqImpt && (dfAckSt || dfAck)+        so = case (writeImpt, sendingReadDat) of+          (Just _, _) -> boolToMmSubordinateAck dfAck+          (_, Just rdat) -> mmReadImptToSubordinateOut rdat+          _ -> boolToMmSubordinateAck False+        dfDatOut = case (writeImpt, readReqImpt, dfAckSt) of+          (Just wi, _, _) -> Just (Right wi)+          (_, Just ri, False) -> Just (Left ri)+          _ -> Nothing+      let dfAckOut = Maybe.isJust sendingReadDat+      put dfAckSt'+      pure (so, dfDatOut, dfAckOut)++-- See comments for @instance DfConv.DfConv (AvalonMmSubordinate ...)@, as the+-- instance is very similar and the comments there apply here as well.+instance+  (KnownManagerConfig config, config ~ RemoveNonDfManager config) =>+  DfConv.DfConv (AvalonMmManager dom config)+  where+  type Dom (AvalonMmManager dom config) = dom+  type BwdPayload (AvalonMmManager dom config) = AvalonReadImpt (MShared config)+  type+    FwdPayload (AvalonMmManager dom config) =+      Either+        (AvalonReadReqImpt 'True (MShared config))+        (AvalonWriteImpt 'True (MShared config))++  toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = (Nothing, False)+    -- Nothing: readDatStored:+    --   reads only get sent for one clock cycle, so we have to store it+    --   until it's acked+    -- False: readReqAcked:+    --   when our read request is acknowledged, we should stop sending the+    --   read request forwards+    blankOtp = mmManagerOutNoData+    stateFn mi dfAck dfDat = do+      (readDatStored0, readReqAcked0) <- get+      let+        readDatIn = mmManagerInToReadImpt mi+        miBool = mmManagerInToBool mi+        (readDatStored1, readReqAcked1, mo, dfAckOut) =+          genOutputs dfDat readDatStored0 readReqAcked0 readDatIn miBool+      put+        ( if ( Maybe.isNothing readDatStored1 -- to avoid looking at dfAck when not needed+                 || dfAck+             )+            then Nothing+            else readDatStored1+        , readReqAcked1+        )+      pure (mo, readDatStored1, dfAckOut)+     where+      genOutputs (Just (Right wi)) readDatStored0 _ _ miBool =+        ( readDatStored0+        , False+        , mmWriteImptToManagerOut+            (wi{wi_burstCount = toKeepType 1})+        , miBool+        )+      genOutputs _ readDatStored0@(Just _) _ _ miBool =+        ( readDatStored0+        , False+        , mmManagerOutNoData+        , miBool+        )+      genOutputs (Just (Left ri)) Nothing readReqAcked0 readDatIn miBool =+        ( readDatIn+        , miBool+        , if readReqAcked0+            then mmManagerOutNoData+            else+              mmReadReqImptToManagerOut+                (ri{rri_burstCount = toKeepType 1})+        , miBool+        )+      genOutputs Nothing Nothing _ _ _ =+        ( Nothing+        , False+        , mmManagerOutNoData+        , False+        )++  fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = False -- dfAckSt -- read request might be acked before read is sent back+    blankOtp = boolToMmManagerAck False+    stateFn mo dfAck dfDat = do+      dfAckSt <- get+      let+        writeImpt = mmManagerOutToWriteImpt mo+        readReqImpt+          | Nothing <- writeImpt = mmManagerOutToReadReqImpt mo+          | otherwise = Nothing+        sendingReadDat+          | Just _ <- readReqImpt, dfAckSt = dfDat+          | otherwise = Nothing+        dfAckSt' = Maybe.isJust readReqImpt && (dfAckSt || dfAck)+        mi = case (writeImpt, sendingReadDat) of+          (Just _, _) -> boolToMmManagerAck dfAck+          (_, Just rdat) -> mmReadImptToManagerIn rdat+          _ -> boolToMmManagerAck False+        dfDatOut = case (writeImpt, readReqImpt, dfAckSt) of+          (Just wi, _, _) -> Just (Right wi)+          (_, Just ri, False) -> Just (Left ri)+          _ -> Nothing+      let dfAckOut = Maybe.isJust sendingReadDat+      put dfAckSt'+      pure (mi, dfDatOut, dfAckOut)++instance+  ( KnownManagerConfig config+  , KnownDomain dom+  , config ~ RemoveNonDfManager config+  ) =>+  Simulate (AvalonMmManager dom config)+  where+  type SimulateFwdType (AvalonMmManager dom config) = [AvalonManagerOut config]+  type SimulateBwdType (AvalonMmManager dom config) = [AvalonManagerIn config]+  type SimulateChannels (AvalonMmManager dom config) = 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+      $ DfConv.stall Proxy Proxy conf stallAck stalls++instance+  ( KnownSubordinateConfig config+  , KnownDomain dom+  , config ~ RemoveNonDfSubordinate config+  ) =>+  Simulate (AvalonMmSubordinate dom 0 config)+  where+  type+    SimulateFwdType (AvalonMmSubordinate dom 0 config) =+      [AvalonSubordinateIn config]+  type+    SimulateBwdType (AvalonMmSubordinate dom 0 config) =+      [AvalonSubordinateOut config]+  type SimulateChannels (AvalonMmSubordinate dom 0 config) = 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+      $ DfConv.stall Proxy Proxy conf stallAck stalls++-- NOTE: Unfortunately, we can't write a 'Drivable' instance (and, by extension,+-- a 'Test' instance) for 'AvalonMmManager' or 'AvalonMmSubordinate'.  This is+-- because they have both write data sent one way and read data sent the other.+-- By writing a 'Drivable' instance (meant for protocols with unidirectional+-- data), we would have to ignore one or the other.+--+-- Tests can still be made for Avalon MM circuits, using 'DfConv.dfConvTestBench'.+-- See 'Tests.Protocols.AvalonMemMap' for examples.++instance+  (KnownManagerConfig config) =>+  IdleCircuit (AvalonMmManager dom config)+  where+  idleFwd _ = pure mmManagerOutNoData+  idleBwd _ = pure $ boolToMmManagerAck False++instance+  (KnownSubordinateConfig config) =>+  IdleCircuit (AvalonMmSubordinate dom fixedWaitTime config)+  where+  idleFwd _ = pure mmSubordinateInNoData+  idleBwd _ = pure $ boolToMmSubordinateAck False++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  (KnownDomain dom, HiddenReset dom, KnownManagerConfig config) =>+  Circuit (AvalonMmManager dom config) (AvalonMmManager dom config)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Avalon/Stream.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+-- Hashable (Unsigned n)+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Types and instance declarations for the Avalon Stream protocol.+-}+module Protocols.Experimental.Avalon.Stream where++-- base+import Control.DeepSeq (NFData)+import Control.Monad (when)+import Control.Monad.State (get, gets, modify, put)+import Data.Hashable (Hashable)+import Data.Maybe qualified as Maybe+import Data.Proxy+import Prelude qualified as P++-- clash-prelude+import Clash.Prelude hiding (concat, length, take)+import Clash.Prelude qualified as C++-- me++import Protocols.Df qualified as Df+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++instance Hashable (C.Unsigned n)++{- | Configuration for the Avalon Stream protocol. Determines the width of some+fields in t'AvalonStreamM2S', and toggles some others. Also sets the ready+latency (see specs for more info on this).+-}+data AvalonStreamConfig = AvalonStreamConfig+  { _channelWidth :: Nat+  , _errorWidth :: Nat+  , _keepStartOfPacket :: Bool+  , _keepEndOfPacket :: Bool+  , _emptyWidth :: Nat+  , _readyLatency :: Nat+  }++-- | Grab '_channelWidth' at the type level.+type family ChannelWidth (conf :: AvalonStreamConfig) where+  ChannelWidth ('AvalonStreamConfig a _ _ _ _ _) = a++-- | Grab '_errorWidth' at the type level.+type family ErrorWidth (conf :: AvalonStreamConfig) where+  ErrorWidth ('AvalonStreamConfig _ a _ _ _ _) = a++-- | Grab '_keepStartOfPacket' at the type level.+type family KeepStartOfPacket (conf :: AvalonStreamConfig) where+  KeepStartOfPacket ('AvalonStreamConfig _ _ a _ _ _) = a++-- | Grab '_keepEndOfPacket' at the type level.+type family KeepEndOfPacket (conf :: AvalonStreamConfig) where+  KeepEndOfPacket ('AvalonStreamConfig _ _ _ a _ _) = a++-- | Grab '_emptyWidth' at the type level.+type family EmptyWidth (conf :: AvalonStreamConfig) where+  EmptyWidth ('AvalonStreamConfig _ _ _ _ a _) = a++-- | Grab '_readyLatency' at the type level.+type family ReadyLatency (conf :: AvalonStreamConfig) where+  ReadyLatency ('AvalonStreamConfig _ _ _ _ _ a) = a++{- | Shorthand for a "well-behaved" config, so that we don't need to write out+a bunch of type constraints later. Holds for every configuration; don't worry+about implementing this class.+-}+type KnownAvalonStreamConfig conf =+  ( KnownNat (ChannelWidth conf)+  , KnownNat (ErrorWidth conf)+  , KeepTypeClass (KeepStartOfPacket conf)+  , KeepTypeClass (KeepEndOfPacket conf)+  , KnownNat (EmptyWidth conf)+  , KnownNat (ReadyLatency conf)+  )++{- | Data sent from manager to subordinate.+The @tvalid@ field is left out: messages with+@tvalid = False@ should be sent as a @Nothing@.+-}+data AvalonStreamM2S (conf :: AvalonStreamConfig) (dataType :: Type) = AvalonStreamM2S+  { _data :: dataType+  , _channel :: Unsigned (ChannelWidth conf)+  , _error :: Unsigned (ErrorWidth conf)+  , _startofpacket :: KeepType (KeepStartOfPacket conf) Bool+  , _endofpacket :: KeepType (KeepEndOfPacket conf) Bool+  , _empty :: Unsigned (EmptyWidth conf)+  }+  deriving (Generic, Bundle)++deriving instance+  ( KnownAvalonStreamConfig conf+  , C.NFDataX dataType+  ) =>+  C.NFDataX (AvalonStreamM2S conf dataType)++deriving instance+  ( KnownAvalonStreamConfig conf+  , NFData dataType+  ) =>+  NFData (AvalonStreamM2S conf dataType)++deriving instance+  ( KnownAvalonStreamConfig conf+  , C.ShowX dataType+  ) =>+  C.ShowX (AvalonStreamM2S conf dataType)++deriving instance+  ( KnownAvalonStreamConfig conf+  , Show dataType+  ) =>+  Show (AvalonStreamM2S conf dataType)++deriving instance+  ( KnownAvalonStreamConfig conf+  , Eq dataType+  ) =>+  Eq (AvalonStreamM2S conf dataType)++deriving instance+  ( KnownAvalonStreamConfig conf+  , Hashable dataType+  ) =>+  Hashable (AvalonStreamM2S conf dataType)++{- | Data sent from subordinate to manager. A simple acknowledge message.+Manager can only send t'AvalonStreamM2S' when '_ready' was true+@readyLatency@ clock cycles ago.+-}+newtype AvalonStreamS2M (readyLatency :: Nat) = AvalonStreamS2M {_ready :: Bool}+  deriving stock (Generic, Show, Eq)+  deriving anyclass (C.NFDataX, C.ShowX, NFData, Bundle)++-- | Type for Avalon Stream protocol.+data AvalonStream (dom :: Domain) (conf :: AvalonStreamConfig) (dataType :: Type)++instance Protocol (AvalonStream dom conf dataType) where+  type+    Fwd (AvalonStream dom conf dataType) =+      Signal dom (Maybe (AvalonStreamM2S conf dataType))+  type+    Bwd (AvalonStream dom conf dataType) =+      Signal dom (AvalonStreamS2M (ReadyLatency conf))++instance+  (ReadyLatency conf ~ 0) =>+  Backpressure (AvalonStream dom conf dataType)+  where+  boolsToBwd _ = C.fromList_lazy . fmap AvalonStreamS2M++instance+  (KnownAvalonStreamConfig conf, NFDataX dataType) =>+  DfConv.DfConv (AvalonStream dom conf dataType)+  where+  type Dom (AvalonStream dom conf dataType) = dom+  type+    FwdPayload (AvalonStream dom conf dataType) =+      AvalonStreamM2S conf dataType++  toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = C.repeat @(ReadyLatency conf + 1) False+    blankOtp = Nothing+    stateFn (AvalonStreamS2M thisAck) _ otpItem = do+      modify (thisAck +>>)+      ackQueue <- get+      pure+        ( if Maybe.isJust otpItem && C.last ackQueue then otpItem else Nothing+        , Nothing+        , C.last ackQueue+        )++  fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = Nothing+    blankOtp = AvalonStreamS2M{_ready = False}+    stateFn m2s ack _ = do+      noCurrentVal <- gets Maybe.isNothing+      let msgOtp = AvalonStreamS2M{_ready = noCurrentVal}+      when noCurrentVal $ put m2s+      dfOtp <- get+      when (Maybe.isJust dfOtp && ack) $ put Nothing+      pure (msgOtp, dfOtp, False)++instance+  ( ReadyLatency conf ~ 0+  , KnownAvalonStreamConfig conf+  , NFDataX dataType+  , KnownDomain dom+  ) =>+  Simulate (AvalonStream dom conf dataType)+  where+  type+    SimulateFwdType (AvalonStream dom conf dataType) =+      [Maybe (AvalonStreamM2S conf dataType)]+  type SimulateBwdType (AvalonStream dom conf dataType) = [AvalonStreamS2M 0]+  type SimulateChannels (AvalonStream dom conf dataType) = 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+      $ DfConv.stall Proxy Proxy conf stallAck stalls++instance+  ( ReadyLatency conf ~ 0+  , KnownAvalonStreamConfig conf+  , NFDataX dataType+  , KnownDomain dom+  ) =>+  Drivable (AvalonStream dom conf dataType)+  where+  type+    ExpectType (AvalonStream dom conf dataType) =+      [AvalonStreamM2S conf dataType]++  toSimulateType Proxy = P.map Just+  fromSimulateType Proxy = Maybe.catMaybes++  driveC conf vals =+    withClockResetEnable clockGen resetGen enableGen+      $ DfConv.drive Proxy conf vals+  sampleC conf ckt =+    withClockResetEnable clockGen resetGen enableGen+      $ DfConv.sample Proxy conf ckt++instance+  ( ReadyLatency conf ~ 0+  , KnownAvalonStreamConfig conf+  , NFDataX dataType+  , NFData dataType+  , ShowX dataType+  , Show dataType+  , Eq dataType+  , KnownDomain dom+  ) =>+  Test (AvalonStream dom conf dataType)+  where+  expectN Proxy = expectN (Proxy @(Df.Df dom _))++instance IdleCircuit (AvalonStream dom conf dataType) where+  idleFwd _ = pure Nothing+  idleBwd _ = pure AvalonStreamS2M{_ready = False}++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom conf dataType.+  (KnownDomain dom, HiddenReset dom) =>+  Circuit (AvalonStream dom conf dataType) (AvalonStream dom conf dataType)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Axi4/Common.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE TypeFamilyDependencies #-}++{- |+Shared types and helpers for the experimental AXI4-family channel definitions.+-}+module Protocols.Experimental.Axi4.Common where++-- base++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import GHC.TypeNats (Nat)++-- clash-prelude++import Clash.Prelude (type (-), type (^))+import Clash.Prelude qualified as C++import Protocols.Internal++-- | Enables or disables 'BurstMode'+type BurstType (keep :: Bool) = KeepType keep BurstMode++-- | Enables or disables burst length+type BurstLengthType (keep :: Bool) = KeepType keep (C.Index (2 ^ 8))++-- | Enables or disables the 'AwCache' for Write Address operations+type AwCacheType (keep :: Bool) = KeepType keep AwCache++-- | Enables or disables the 'ArCache' for Read Address operations+type ArCacheType (keep :: Bool) = KeepType keep ArCache++-- | Enables or disables a boolean indicating whether a transaction is done+type LastType (keep :: Bool) = KeepType keep Bool++-- | Enables or disables 'AtomicAccess'+type LockType (keep :: Bool) = KeepType keep AtomicAccess++-- | Enables or disables 'Permissions'+type PermissionsType (keep :: Bool) = KeepType keep Permissions++-- | Enables or disables 'Qos'+type QosType (keep :: Bool) = KeepType keep Qos++-- | Enables or disables region type+type RegionType (keep :: Bool) = KeepType keep (C.BitVector 4)++-- | Enables or disables 'Resp'+type ResponseType (keep :: Bool) = KeepType keep Resp++-- | Enables or disables 'BurstSize'+type SizeType (keep :: Bool) = KeepType keep BurstSize++{- | @byteSize@ bytes of data,+with @keepStrobe@ determining whether to include a strobe value or not.+-}+type StrictStrobeType (byteSize :: Nat) (keepStrobe :: Bool) =+  C.Vec byteSize (StrobeDataType keepStrobe)++-- | Enable or disable a strobe value.+type family StrobeDataType (keepStrobe :: Bool) = t | t -> keepStrobe where+  StrobeDataType 'True = Maybe (C.BitVector 8)+  StrobeDataType 'False = C.BitVector 8++{- | We want to define operations on 'StrobeDataType' that work for both possibilities+(@keepStrobe = 'True@ and @keepStrobe = 'False@), but we can't pattern match directly.+Instead we need to define a class and instantiate+the class for both @'True@ and @'False@.+-}+class KeepStrobeClass (keepStrobe :: Bool) where+  -- | Get the value of @keepStrobe@ at the term level.+  getKeepStrobe :: StrobeDataType keepStrobe -> Bool++  {- | Convert a byte into a possibly-strobed byte.+  The 'Bool' value determines the strobe value+  if strobe is enabled.+  -}+  toStrobeDataType :: Bool -> C.BitVector 8 -> StrobeDataType keepStrobe++  {- | Convert a possibly-strobed byte into a byte,+  or 'Nothing' if strobe is enabled and strobe = false.+  -}+  fromStrobeDataType :: StrobeDataType keepStrobe -> Maybe (C.BitVector 8)++instance KeepStrobeClass 'True where+  getKeepStrobe _ = True+  toStrobeDataType True d = Just d+  toStrobeDataType False _ = Nothing+  fromStrobeDataType v = v++instance KeepStrobeClass 'False where+  getKeepStrobe _ = False+  toStrobeDataType _ d = d+  fromStrobeDataType v = Just v++{- | The protocol does not specify the exact use of the QoS identifier. This+AXI specification recommends that AxQOS is used as a priority indicator for the+associated write or read transaction. A higher value indicates a higher+priority transaction.++A default value of 0 indicates that the interface is not participating in any+QoS scheme.+-}+type Qos = C.Index ((2 ^ 4) - 1)++{- | The burst type and the size information, determine how the address for+each transfer within the burst is calculated.+-}+data BurstMode+  = {- | In a fixed burst, the address is the same for every transfer in the+    burst. This burst type is used for repeated accesses to the same location+    such as when loading or emptying a FIFO+    -}+    BmFixed+  | {- | Incrementing. In an incrementing burst, the address for each transfer in+    the burst is an increment of the address for the previous transfer. The+    increment value depends on the size of the transfer. For example, the+    address for each transfer in a burst with a size of four bytes is the+    previous address plus four. This burst type is used for accesses to normal+    sequential memory.+    -}+    BmIncr+  | {- | A wrapping burst is similar to an incrementing burst, except that the+    address wraps around to a lower address if an upper address limit is+    reached. The following restrictions apply to wrapping bursts:++    * the start address must be aligned to the size of each transfer+    * the length of the burst must be 2, 4, 8, or 16 transfers.++    The behavior of a wrapping burst is:++    * The lowest address used by the burst is aligned to the total size of+    the data to be transferred, that is, to ((size of each transfer in the+    burst) × (number of transfers in the burst)). This address is defined+    as the _wrap boundary_.++    * After each transfer, the address increments in the same way as for an+    INCR burst. However, if this incremented address is ((wrap boundary) ++    (total size of data to be transferred)) then the address wraps round to+    the wrap boundary.++    * The first transfer in the burst can use an address that is higher than+    the wrap boundary, subject to the restrictions that apply to wrapping+    bursts. This means that the address wraps for any WRAP burst for which+    the first address is higher than the wrap boundary.++    This burst type is used for cache line accesses.+    -}+    BmWrap+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | The maximum number of bytes to transfer in each data transfer, or beat,+in a burst.+-}+data BurstSize+  = Bs1+  | Bs2+  | Bs4+  | Bs8+  | Bs16+  | Bs32+  | Bs64+  | Bs128+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++-- | Convert burst size to a numeric value+burstSizeToNum :: (Num a) => BurstSize -> a+burstSizeToNum = \case+  Bs1 -> 1+  Bs2 -> 2+  Bs4 -> 4+  Bs8 -> 8+  Bs16 -> 16+  Bs32 -> 32+  Bs64 -> 64+  Bs128 -> 128++-- | Whether a transaction is bufferable+data Bufferable = NonBufferable | Bufferable+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | When set to "LookupCache", it is recommended that this transaction is+allocated in the cache for performance reasons.+-}+data Allocate = NoLookupCache | LookupCache+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | When set to "OtherLookupCache", it is recommended that this transaction is+allocated in the cache for performance reasons.+-}+data OtherAllocate = OtherNoLookupCache | OtherLookupCache+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | Memory attributes. Note that the 'Allocate' and 'OtherAllocate' bits are+in different positions for read and write requests.+-}+type AwCache = (Bufferable, Modifiable, OtherAllocate, Allocate)++{- | Memory attributes. Note that the 'Allocate' and 'OtherAllocate' bits are+in different positions for read and write requests.+-}+type ArCache = (Bufferable, Modifiable, Allocate, OtherAllocate)++-- | Status of the write transaction.+data Resp+  = {- | Normal access success. Indicates that a normal access has been+    successful. Can also indicate an exclusive access has failed.+    -}+    ROkay+  | {- | Exclusive access okay. Indicates that either the read or write portion+    of an exclusive access has been successful.+    -}+    RExclusiveOkay+  | {- | Slave error. Used when the access has reached the slave successfully, but+    the slave wishes to return an error condition to the originating master.+    -}+    RSlaveError+  | {- | Decode error. Generated, typically by an interconnect component, to+    indicate that there is no slave at the transaction address.+    -}+    RDecodeError+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++-- | Whether a resource is accessed with exclusive access or not+data AtomicAccess+  = NonExclusiveAccess+  | ExclusiveAccess+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++-- | Whether transaction can be modified+data Modifiable+  = Modifiable+  | NonModifiable+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | An AXI master might support Secure and Non-secure operating states, and+extend this concept of security to memory access.+-}+data Secure+  = Secure+  | NonSecure+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | An AXI master might support more than one level of operating privilege,+and extend this concept of privilege to memory access.+-}+data Privileged+  = NotPrivileged+  | Privileged+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++{- | Whether the transaction is an instruction access or a data access. The AXI+protocol defines this indication as a hint. It is not accurate in all cases,+for example, where a transaction contains a mix of instruction and data+items. This specification recommends that a master sets it to "Data", to+indicate a data access unless the access is specifically known to be an+instruction access.+-}+data InstructionOrData+  = Data+  | Instruction+  deriving (Show, C.ShowX, Generic, C.NFDataX, NFData, Eq, C.BitPack)++-- | Enables or disables t'Privileged', t'Secure', and 'InstructionOrData'+type Permissions = (Privileged, Secure, InstructionOrData)
+ src/Protocols/Experimental/Axi4/ReadAddress.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Defines ReadAddress channel of full AXI4 protocol with port names corresponding+to the AXI4 specification.+-}+module Protocols.Experimental.Axi4.ReadAddress (+  M2S_ReadAddress (..),+  S2M_ReadAddress (..),+  Axi4ReadAddress,++  -- * configuration+  Axi4ReadAddressConfig (..),+  KnownAxi4ReadAddressConfig,+  ARKeepBurst,+  ARKeepSize,+  ARIdWidth,+  ARAddrWidth,+  ARKeepRegion,+  ARKeepBurstLength,+  ARKeepLock,+  ARKeepCache,+  ARKeepPermissions,+  ARKeepQos,++  -- * read address info+  Axi4ReadAddressInfo (..),+  axi4ReadAddrMsgToReadAddrInfo,+  axi4ReadAddrMsgFromReadAddrInfo,++  -- * helpers+  forceResetSanity,+) where++-- base+import Control.DeepSeq (NFData)+import Data.Coerce+import Data.Kind (Type)+import GHC.Generics (Generic)++-- clash-prelude+import Clash.Prelude qualified as C++-- me+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++-- | Configuration options for 'Axi4ReadAddress'.+data Axi4ReadAddressConfig = Axi4ReadAddressConfig+  { _arKeepBurst :: Bool+  , _arKeepSize :: Bool+  , _arIdWidth :: C.Nat+  , _arAddrWidth :: C.Nat+  , _arKeepRegion :: Bool+  , _arKeepBurstLength :: Bool+  , _arKeepLock :: Bool+  , _arKeepCache :: Bool+  , _arKeepPermissions :: Bool+  , _arKeepQos :: Bool+  }++{- | Grab '_arKeepBurst' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arburst' field+in t'M2S_ReadAddress'.+-}+type family ARKeepBurst (conf :: Axi4ReadAddressConfig) where+  ARKeepBurst ('Axi4ReadAddressConfig a _ _ _ _ _ _ _ _ _) = a++{- | Grab '_arKeepSize' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arsize' field+in t'M2S_ReadAddress'.+-}+type family ARKeepSize (conf :: Axi4ReadAddressConfig) where+  ARKeepSize ('Axi4ReadAddressConfig _ a _ _ _ _ _ _ _ _) = a++{- | Grab '_arIdWidth' from t'Axi4ReadAddressConfig' at the type level.+This nat value determines the size of the '_arid' field+in t'M2S_ReadAddress'.+-}+type family ARIdWidth (conf :: Axi4ReadAddressConfig) where+  ARIdWidth ('Axi4ReadAddressConfig _ _ a _ _ _ _ _ _ _) = a++{- | Grab '_arAddrWidth' from t'Axi4ReadAddressConfig' at the type level.+This nat value determines the size of the '_araddr' field+in t'M2S_ReadAddress'.+-}+type family ARAddrWidth (conf :: Axi4ReadAddressConfig) where+  ARAddrWidth ('Axi4ReadAddressConfig _ _ _ a _ _ _ _ _ _) = a++{- | Grab '_arKeepRegion' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arregion' field+in t'M2S_ReadAddress'.+-}+type family ARKeepRegion (conf :: Axi4ReadAddressConfig) where+  ARKeepRegion ('Axi4ReadAddressConfig _ _ _ _ a _ _ _ _ _) = a++{- | Grab '_arKeepBurstLength' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arlen' field+in t'M2S_ReadAddress'.+-}+type family ARKeepBurstLength (conf :: Axi4ReadAddressConfig) where+  ARKeepBurstLength ('Axi4ReadAddressConfig _ _ _ _ _ a _ _ _ _) = a++{- | Grab '_arKeepLock' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arlock' field+in t'M2S_ReadAddress'.+-}+type family ARKeepLock (conf :: Axi4ReadAddressConfig) where+  ARKeepLock ('Axi4ReadAddressConfig _ _ _ _ _ _ a _ _ _) = a++{- | Grab '_arKeepCache' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arcache' field+in t'M2S_ReadAddress'.+-}+type family ARKeepCache (conf :: Axi4ReadAddressConfig) where+  ARKeepCache ('Axi4ReadAddressConfig _ _ _ _ _ _ _ a _ _) = a++{- | Grab '_arKeepPermissions' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arprot' field+in t'M2S_ReadAddress'.+-}+type family ARKeepPermissions (conf :: Axi4ReadAddressConfig) where+  ARKeepPermissions ('Axi4ReadAddressConfig _ _ _ _ _ _ _ _ a _) = a++{- | Grab '_arKeepQos' from t'Axi4ReadAddressConfig' at the type level.+This boolean value determines whether to keep the '_arqos' field+in t'M2S_ReadAddress'.+-}+type family ARKeepQos (conf :: Axi4ReadAddressConfig) where+  ARKeepQos ('Axi4ReadAddressConfig _ _ _ _ _ _ _ _ _ a) = a++-- | AXI4 Read Address channel protocol+data+  Axi4ReadAddress+    (dom :: C.Domain)+    (conf :: Axi4ReadAddressConfig)+    (userType :: Type)++instance Protocol (Axi4ReadAddress dom conf userType) where+  type+    Fwd (Axi4ReadAddress dom conf userType) =+      C.Signal dom (M2S_ReadAddress conf userType)+  type+    Bwd (Axi4ReadAddress dom conf userType) =+      C.Signal dom S2M_ReadAddress++instance Backpressure (Axi4ReadAddress dom conf userType) where+  boolsToBwd _ = C.fromList_lazy . coerce++-- | See Table A2-5 "Read address channel signals"+data+  M2S_ReadAddress+    (conf :: Axi4ReadAddressConfig)+    (userType :: Type)+  = M2S_NoReadAddress+  | M2S_ReadAddress+      { _arid :: C.BitVector (ARIdWidth conf)+      -- ^ Read address id*+      , _araddr :: C.BitVector (ARAddrWidth conf)+      -- ^ Read address+      , _arregion :: RegionType (ARKeepRegion conf)+      -- ^ Read region*+      , _arlen :: BurstLengthType (ARKeepBurstLength conf)+      -- ^ Burst length*+      , _arsize :: SizeType (ARKeepSize conf)+      -- ^ Burst size*+      , _arburst :: BurstType (ARKeepBurst conf)+      -- ^ Burst type*+      , _arlock :: LockType (ARKeepLock conf)+      -- ^ Lock type*+      , _arcache :: ArCacheType (ARKeepCache conf)+      -- ^ Cache type* (has been renamed to modifiable in AXI spec)+      , _arprot :: PermissionsType (ARKeepPermissions conf)+      -- ^ Protection type+      , _arqos :: QosType (ARKeepQos conf)+      -- ^ QoS value+      , _aruser :: userType+      -- ^ User data+      }+  deriving (Generic)++deriving instance+  (KnownAxi4ReadAddressConfig conf, C.NFDataX user) => C.NFDataX (M2S_ReadAddress conf user)+deriving instance+  (KnownAxi4ReadAddressConfig conf, C.BitPack user) => C.BitPack (M2S_ReadAddress conf user)+deriving instance+  (KnownAxi4ReadAddressConfig conf, Show userType) => Show (M2S_ReadAddress conf userType)+deriving instance+  (KnownAxi4ReadAddressConfig conf, C.ShowX userType) =>+  C.ShowX (M2S_ReadAddress conf userType)+deriving instance+  (KnownAxi4ReadAddressConfig conf, Eq userType) => Eq (M2S_ReadAddress conf userType)++-- | See Table A2-5 "Read address channel signals"+newtype S2M_ReadAddress = S2M_ReadAddress+  {_arready :: Bool}+  deriving stock (Show, Generic, Eq)+  deriving anyclass (C.ShowX, C.NFDataX, C.BitPack)++{- | Shorthand for a "well-behaved" read address config,+so that we don't need to write out a bunch of type constraints later.+Holds for every configuration; don't worry about implementing this class.+-}+type KnownAxi4ReadAddressConfig conf =+  ( KeepTypeClass (ARKeepBurst conf)+  , KeepTypeClass (ARKeepSize conf)+  , KeepTypeClass (ARKeepRegion conf)+  , KeepTypeClass (ARKeepBurstLength conf)+  , KeepTypeClass (ARKeepLock conf)+  , KeepTypeClass (ARKeepCache conf)+  , KeepTypeClass (ARKeepPermissions conf)+  , KeepTypeClass (ARKeepQos conf)+  , C.KnownNat (ARIdWidth conf)+  , C.KnownNat (ARAddrWidth conf)+  , C.ShowX (RegionType (ARKeepRegion conf))+  , C.ShowX (BurstLengthType (ARKeepBurstLength conf))+  , C.ShowX (SizeType (ARKeepSize conf))+  , C.ShowX (BurstType (ARKeepBurst conf))+  , C.ShowX (LockType (ARKeepLock conf))+  , C.ShowX (ArCacheType (ARKeepCache conf))+  , C.ShowX (PermissionsType (ARKeepPermissions conf))+  , C.ShowX (QosType (ARKeepQos conf))+  , Show (RegionType (ARKeepRegion conf))+  , Show (BurstLengthType (ARKeepBurstLength conf))+  , Show (SizeType (ARKeepSize conf))+  , Show (BurstType (ARKeepBurst conf))+  , Show (LockType (ARKeepLock conf))+  , Show (ArCacheType (ARKeepCache conf))+  , Show (PermissionsType (ARKeepPermissions conf))+  , Show (QosType (ARKeepQos conf))+  , C.NFDataX (RegionType (ARKeepRegion conf))+  , C.NFDataX (BurstLengthType (ARKeepBurstLength conf))+  , C.NFDataX (SizeType (ARKeepSize conf))+  , C.NFDataX (BurstType (ARKeepBurst conf))+  , C.NFDataX (LockType (ARKeepLock conf))+  , C.NFDataX (ArCacheType (ARKeepCache conf))+  , C.NFDataX (PermissionsType (ARKeepPermissions conf))+  , C.NFDataX (QosType (ARKeepQos conf))+  , C.BitPack (RegionType (ARKeepRegion conf))+  , C.BitPack (BurstLengthType (ARKeepBurstLength conf))+  , C.BitPack (SizeType (ARKeepSize conf))+  , C.BitPack (BurstType (ARKeepBurst conf))+  , C.BitPack (LockType (ARKeepLock conf))+  , C.BitPack (ArCacheType (ARKeepCache conf))+  , C.BitPack (PermissionsType (ARKeepPermissions conf))+  , C.BitPack (QosType (ARKeepQos conf))+  , NFData (RegionType (ARKeepRegion conf))+  , NFData (BurstLengthType (ARKeepBurstLength conf))+  , NFData (SizeType (ARKeepSize conf))+  , NFData (BurstType (ARKeepBurst conf))+  , NFData (LockType (ARKeepLock conf))+  , NFData (ArCacheType (ARKeepCache conf))+  , NFData (PermissionsType (ARKeepPermissions conf))+  , NFData (QosType (ARKeepQos conf))+  , Eq (RegionType (ARKeepRegion conf))+  , Eq (BurstLengthType (ARKeepBurstLength conf))+  , Eq (SizeType (ARKeepSize conf))+  , Eq (BurstType (ARKeepBurst conf))+  , Eq (LockType (ARKeepLock conf))+  , Eq (ArCacheType (ARKeepCache conf))+  , Eq (PermissionsType (ARKeepPermissions conf))+  , Eq (QosType (ARKeepQos conf))+  )++{- | Mainly for use in 'Protocols.DfConv.DfConv'.++Data carried along 'Axi4ReadAddress' channel which is put in control of+the user, rather than being managed by the 'Protocols.DfConv.DfConv' instances.+Matches up+one-to-one with the fields of t'M2S_ReadAddress' except for '_arlen',+'_arsize', and '_arburst'.+-}+data Axi4ReadAddressInfo (conf :: Axi4ReadAddressConfig) (userType :: Type) = Axi4ReadAddressInfo+  { _ariid :: C.BitVector (ARIdWidth conf)+  -- ^ Id+  , _ariaddr :: C.BitVector (ARAddrWidth conf)+  -- ^ Address+  , _ariregion :: RegionType (ARKeepRegion conf)+  -- ^ Region+  , _arilen :: BurstLengthType (ARKeepBurstLength conf)+  -- ^ Burst length+  , _arisize :: SizeType (ARKeepSize conf)+  -- ^ Burst size+  , _ariburst :: BurstType (ARKeepBurst conf)+  -- ^ Burst type+  , _arilock :: LockType (ARKeepLock conf)+  -- ^ Lock type+  , _aricache :: ArCacheType (ARKeepCache conf)+  -- ^ Cache type+  , _ariprot :: PermissionsType (ARKeepPermissions conf)+  -- ^ Protection type+  , _ariqos :: QosType (ARKeepQos conf)+  -- ^ QoS value+  , _ariuser :: userType+  -- ^ User data+  }+  deriving (Generic)++deriving instance+  ( KnownAxi4ReadAddressConfig conf+  , Show userType+  ) =>+  Show (Axi4ReadAddressInfo conf userType)++deriving instance+  ( KnownAxi4ReadAddressConfig conf+  , C.ShowX userType+  ) =>+  C.ShowX (Axi4ReadAddressInfo conf userType)++deriving instance+  ( KnownAxi4ReadAddressConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (Axi4ReadAddressInfo conf userType)++deriving instance+  ( KnownAxi4ReadAddressConfig conf+  , NFData userType+  ) =>+  NFData (Axi4ReadAddressInfo conf userType)++deriving instance+  ( KnownAxi4ReadAddressConfig conf+  , Eq userType+  ) =>+  Eq (Axi4ReadAddressInfo conf userType)++-- | Convert t'M2S_ReadAddress' to t'Axi4ReadAddressInfo', dropping some info+axi4ReadAddrMsgToReadAddrInfo ::+  M2S_ReadAddress conf userType ->+  Axi4ReadAddressInfo conf userType+axi4ReadAddrMsgToReadAddrInfo M2S_NoReadAddress = C.errorX "Expected ReadAddress"+axi4ReadAddrMsgToReadAddrInfo M2S_ReadAddress{..} =+  Axi4ReadAddressInfo+    { _ariid = _arid+    , _ariaddr = _araddr+    , _ariregion = _arregion+    , _arilen = _arlen+    , _arisize = _arsize+    , _ariburst = _arburst+    , _arilock = _arlock+    , _aricache = _arcache+    , _ariprot = _arprot+    , _ariqos = _arqos+    , _ariuser = _aruser+    }++-- | Convert t'Axi4ReadAddressInfo' to t'M2S_ReadAddress', adding some info+axi4ReadAddrMsgFromReadAddrInfo ::+  Axi4ReadAddressInfo conf userType -> M2S_ReadAddress conf userType+axi4ReadAddrMsgFromReadAddrInfo Axi4ReadAddressInfo{..} =+  M2S_ReadAddress+    { _arid = _ariid+    , _araddr = _ariaddr+    , _arregion = _ariregion+    , _arlen = _arilen+    , _arsize = _arisize+    , _arburst = _ariburst+    , _arlock = _arilock+    , _arcache = _aricache+    , _arprot = _ariprot+    , _arqos = _ariqos+    , _aruser = _ariuser+    }++instance IdleCircuit (Axi4ReadAddress dom conf userType) where+  idleFwd _ = pure M2S_NoReadAddress+  idleBwd _ = pure S2M_ReadAddress{_arready = False}++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom conf userType.+  (C.KnownDomain dom, C.HiddenReset dom) =>+  Circuit (Axi4ReadAddress dom conf userType) (Axi4ReadAddress dom conf userType)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Axi4/ReadData.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}++{- |+Defines ReadData channel of full AXI4 protocol with port names corresponding+to the AXI4 specification.+-}+module Protocols.Experimental.Axi4.ReadData (+  M2S_ReadData (..),+  S2M_ReadData (..),+  Axi4ReadData,++  -- * configuration+  Axi4ReadDataConfig (..),+  KnownAxi4ReadDataConfig,+  RKeepResponse,+  RIdWidth,++  -- * helpers+  forceResetSanity,+) where++-- base+import Data.Coerce (coerce)+import Data.Kind (Type)+import GHC.Generics (Generic)+import Prelude hiding (+  const,+  either,+  filter,+  fst,+  map,+  pure,+  snd,+  zip,+  zipWith,+  (!!),+ )++-- clash-prelude+import Clash.Prelude qualified as C++-- me+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++-- | Configuration options for 'Axi4ReadData'.+data Axi4ReadDataConfig = Axi4ReadDataConfig+  { _rKeepResponse :: Bool+  , _rIdWidth :: C.Nat+  }++{- | Grab '_rKeepResponse' from t'Axi4ReadDataConfig' at the type level.+This boolean value determines whether to keep the '_rresp' field+in t'S2M_ReadData'.+-}+type family RKeepResponse (conf :: Axi4ReadDataConfig) where+  RKeepResponse ('Axi4ReadDataConfig a _) = a++{- | Grab '_rIdWidth' from t'Axi4ReadDataConfig' at the type level.+This nat value determines the size of the '_rid' field+in t'S2M_ReadData'.+-}+type family RIdWidth (conf :: Axi4ReadDataConfig) where+  RIdWidth ('Axi4ReadDataConfig _ a) = a++-- | AXI4 Read Data channel protocol+data+  Axi4ReadData+    (dom :: C.Domain)+    (conf :: Axi4ReadDataConfig)+    (userType :: Type)+    (dataType :: Type)++instance Protocol (Axi4ReadData dom conf userType dataType) where+  type+    Fwd (Axi4ReadData dom conf userType dataType) =+      C.Signal dom (S2M_ReadData conf userType dataType)+  type+    Bwd (Axi4ReadData dom conf userType dataType) =+      C.Signal dom M2S_ReadData++instance Backpressure (Axi4ReadData dom conf userType dataType) where+  boolsToBwd _ = C.fromList_lazy . coerce++-- | See Table A2-6 "Read data channel signals"+data+  S2M_ReadData+    (conf :: Axi4ReadDataConfig)+    (userType :: Type)+    (dataType :: Type)+  = S2M_NoReadData+  | S2M_ReadData+      { _rid :: C.BitVector (RIdWidth conf)+      -- ^ Read address id*+      , _rdata :: dataType+      -- ^ Read data+      , _rresp :: ResponseType (RKeepResponse conf)+      -- ^ Read response+      , _rlast :: Bool+      -- ^ Read last+      , _ruser :: userType+      -- ^ User data+      }+  deriving (Generic)++-- | See Table A2-6 "Read data channel signals"+newtype M2S_ReadData = M2S_ReadData {_rready :: Bool}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (C.ShowX, C.NFDataX, C.BitPack)++{- | Shorthand for a "well-behaved" read data config,+so that we don't need to write out a bunch of type constraints later.+Holds for every configuration; don't worry about implementing this class.+-}+type KnownAxi4ReadDataConfig conf =+  ( KeepTypeClass (RKeepResponse conf)+  , C.KnownNat (RIdWidth conf)+  , Show (ResponseType (RKeepResponse conf))+  , C.ShowX (ResponseType (RKeepResponse conf))+  , Eq (ResponseType (RKeepResponse conf))+  , C.NFDataX (ResponseType (RKeepResponse conf))+  , C.BitPack (ResponseType (RKeepResponse conf))+  )++deriving instance+  ( KnownAxi4ReadDataConfig conf+  , Show userType+  , Show dataType+  ) =>+  Show (S2M_ReadData conf userType dataType)++deriving instance+  ( KnownAxi4ReadDataConfig conf+  , C.ShowX userType+  , C.ShowX dataType+  ) =>+  C.ShowX (S2M_ReadData conf userType dataType)++deriving instance+  ( KnownAxi4ReadDataConfig conf+  , Eq userType+  , Eq dataType+  ) =>+  Eq (S2M_ReadData conf userType dataType)++deriving instance+  ( KnownAxi4ReadDataConfig conf+  , C.NFDataX userType+  , C.NFDataX dataType+  ) =>+  C.NFDataX (S2M_ReadData conf userType dataType)++instance IdleCircuit (Axi4ReadData dom conf userType dataType) where+  idleFwd _ = C.pure S2M_NoReadData+  idleBwd _ = C.pure $ M2S_ReadData False++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom conf userType dataType.+  (C.KnownDomain dom, C.HiddenReset dom) =>+  Circuit+    (Axi4ReadData dom conf userType dataType)+    (Axi4ReadData dom conf userType dataType)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Axi4/Stream.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+-- Hashable (Unsigned n)+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Types and instance declarations for the AXI4-stream protocol.+-}+module Protocols.Experimental.Axi4.Stream where++-- base+import Control.DeepSeq (NFData)+import Data.Hashable (Hashable, hashWithSalt)+import Data.Maybe qualified as Maybe+import Data.Proxy++-- clash-prelude+import Clash.Prelude hiding (concat, length, take)+import Clash.Prelude qualified as C++-- me++import Protocols.Df qualified as Df+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++instance (KnownNat n) => Hashable (Unsigned n)+instance (KnownNat n, Hashable a) => Hashable (Vec n a) where+  hashWithSalt s v = hashWithSalt s (toList v)++{- | Configuration for AXI4 Stream protocol. Determines the width of some+fields in t'Axi4StreamM2S'.+-}+data Axi4StreamConfig = Axi4StreamConfig+  { _dataWidth :: Nat+  , _idWidth :: Nat+  , _destWidth :: Nat+  }++-- | Grab '_dataWidth' at the type level.+type family DataWidth (conf :: Axi4StreamConfig) where+  DataWidth ('Axi4StreamConfig a _ _) = a++-- | Grab '_idWidth' at the type level.+type family IdWidth (conf :: Axi4StreamConfig) where+  IdWidth ('Axi4StreamConfig _ a _) = a++-- | Grab '_destWidth' at the type level.+type family DestWidth (conf :: Axi4StreamConfig) where+  DestWidth ('Axi4StreamConfig _ _ a) = a++{- | Shorthand for a "well-behaved" config, so that we don't need to write out+a bunch of type constraints later. Holds for every configuration; don't worry+about implementing this class.+-}+type KnownAxi4StreamConfig conf =+  ( KnownNat (DataWidth conf)+  , KnownNat (IdWidth conf)+  , KnownNat (DestWidth conf)+  )++{- | Data sent from manager to subordinate. The tvalid field is left out: messages with @tvalid = False@+should be sent as a @Nothing@.+-}+data Axi4StreamM2S (conf :: Axi4StreamConfig) (userType :: Type) = Axi4StreamM2S+  { _tdata :: Vec (DataWidth conf) (Unsigned 8)+  , _tkeep :: Vec (DataWidth conf) Bool+  , _tstrb :: Vec (DataWidth conf) Bool+  , _tlast :: Bool+  , _tid :: Unsigned (IdWidth conf)+  , _tdest :: Unsigned (DestWidth conf)+  , _tuser :: userType+  }+  deriving (Generic, C.ShowX, Show, NFData, Bundle)++deriving instance+  ( KnownAxi4StreamConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (Axi4StreamM2S conf userType)++deriving instance+  ( KnownAxi4StreamConfig conf+  , Eq userType+  ) =>+  Eq (Axi4StreamM2S conf userType)++deriving instance+  ( KnownAxi4StreamConfig conf+  , Hashable userType+  ) =>+  Hashable (Axi4StreamM2S conf userType)++{- | Data sent from subordinate to manager. A simple acknowledge message.+'_tready' may be on even when manager is sending 'Nothing'.+Manager may not decide whether or not to send 'Nothing' based on+the '_tready' signal.+-}+newtype Axi4StreamS2M = Axi4StreamS2M {_tready :: Bool}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (C.NFDataX, C.ShowX, NFData, Bundle)++-- | Type for AXI4 Stream protocol.+data Axi4Stream (dom :: Domain) (conf :: Axi4StreamConfig) (userType :: Type)++instance Protocol (Axi4Stream dom conf userType) where+  type Fwd (Axi4Stream dom conf userType) = Signal dom (Maybe (Axi4StreamM2S conf userType))+  type Bwd (Axi4Stream dom conf userType) = Signal dom Axi4StreamS2M++instance Backpressure (Axi4Stream dom conf userType) where+  boolsToBwd _ = C.fromList_lazy . fmap Axi4StreamS2M++instance+  (KnownAxi4StreamConfig conf, NFDataX userType) =>+  DfConv.DfConv (Axi4Stream dom conf userType)+  where+  type Dom (Axi4Stream dom conf userType) = dom+  type+    FwdPayload (Axi4Stream dom conf userType) =+      Axi4StreamM2S conf userType++  toDfCircuit proxy = DfConv.toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = ()+    blankOtp = Nothing+    stateFn ack _ otpItem =+      pure (otpItem, Nothing, Maybe.isJust otpItem C.&& _tready ack)++  fromDfCircuit proxy = DfConv.fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = ()+    blankOtp = Axi4StreamS2M{_tready = False}+    stateFn m2s ack _ =+      pure (Axi4StreamS2M{_tready = ack}, m2s, False)++instance+  (KnownAxi4StreamConfig conf, NFDataX userType, KnownDomain dom) =>+  Simulate (Axi4Stream dom conf userType)+  where+  type+    SimulateFwdType (Axi4Stream dom conf userType) =+      [Maybe (Axi4StreamM2S conf userType)]+  type SimulateBwdType (Axi4Stream dom conf userType) = [Axi4StreamS2M]+  type SimulateChannels (Axi4Stream dom conf userType) = 1++  simToSigFwd _ = fromList_lazy+  simToSigBwd _ = fromList_lazy+  sigToSimFwd _ s = sample_lazy s+  sigToSimBwd _ s = sample_lazy s++  stallC conf (C.head -> (stallAck, stalls)) =+    withClockResetEnable clockGen resetGen enableGen $+      DfConv.stall Proxy Proxy conf stallAck stalls++instance+  (KnownAxi4StreamConfig conf, NFDataX userType, KnownDomain dom) =>+  Drivable (Axi4Stream dom conf userType)+  where+  type+    ExpectType (Axi4Stream dom conf userType) =+      [Axi4StreamM2S conf userType]++  toSimulateType Proxy = fmap Just+  fromSimulateType Proxy = Maybe.catMaybes++  driveC conf vals =+    withClockResetEnable clockGen resetGen enableGen $+      DfConv.drive Proxy conf vals+  sampleC conf ckt =+    withClockResetEnable clockGen resetGen enableGen $+      DfConv.sample Proxy conf ckt++instance+  ( KnownAxi4StreamConfig conf+  , NFDataX userType+  , NFData userType+  , ShowX userType+  , Show userType+  , Eq userType+  , KnownDomain dom+  ) =>+  Test (Axi4Stream dom conf userType)+  where+  expectN Proxy = expectN (Proxy @(Df.Df dom _))++instance IdleCircuit (Axi4Stream dom conf userType) where+  idleFwd Proxy = C.pure Nothing+  idleBwd Proxy = C.pure $ Axi4StreamS2M False++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  (KnownDomain dom, HiddenReset dom) =>+  Circuit (Axi4Stream dom conf userType) (Axi4Stream dom conf userType)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Axi4/WriteAddress.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Defines WriteAddress channel of full AXI4 protocol with port names corresponding+to the AXI4 specification.+-}+module Protocols.Experimental.Axi4.WriteAddress (+  M2S_WriteAddress (..),+  S2M_WriteAddress (..),+  Axi4WriteAddress,++  -- * configuration+  Axi4WriteAddressConfig (..),+  KnownAxi4WriteAddressConfig,+  AWKeepBurst,+  AWKeepSize,+  AWIdWidth,+  AWAddrWidth,+  AWKeepRegion,+  AWKeepBurstLength,+  AWKeepLock,+  AWKeepCache,+  AWKeepPermissions,+  AWKeepQos,++  -- * write address info+  Axi4WriteAddressInfo (..),+  axi4WriteAddrMsgToWriteAddrInfo,+  axi4WriteAddrMsgFromWriteAddrInfo,+  forceResetSanity,+) where++-- base+import Control.DeepSeq (NFData)+import Data.Coerce (coerce)+import Data.Kind (Type)+import GHC.Generics (Generic)++-- clash-prelude+import Clash.Prelude qualified as C++-- me+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++-- | Configuration options for 'Axi4WriteAddress'.+data Axi4WriteAddressConfig = Axi4WriteAddressConfig+  { _awKeepBurst :: Bool+  , _awKeepSize :: Bool+  , _awIdWidth :: C.Nat+  , _awAddrWidth :: C.Nat+  , _awKeepRegion :: Bool+  , _awKeepBurstLength :: Bool+  , _awKeepLock :: Bool+  , _awKeepCache :: Bool+  , _awKeepPermissions :: Bool+  , _awKeepQos :: Bool+  }++{- | Grab '_awKeepBurst' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awburst' field+in t'M2S_WriteAddress'.+-}+type family AWKeepBurst (c :: Axi4WriteAddressConfig) where+  AWKeepBurst ('Axi4WriteAddressConfig a _ _ _ _ _ _ _ _ _) = a++{- | Grab '_awKeepSize' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awsize' field+in t'M2S_WriteAddress'.+-}+type family AWKeepSize (c :: Axi4WriteAddressConfig) where+  AWKeepSize ('Axi4WriteAddressConfig _ a _ _ _ _ _ _ _ _) = a++{- | Grab '_awIdWidth' from t'Axi4WriteAddressConfig' at the type level.+This nat value determines the size of the '_awid' field+in t'M2S_WriteAddress'.+-}+type family AWIdWidth (c :: Axi4WriteAddressConfig) where+  AWIdWidth ('Axi4WriteAddressConfig _ _ a _ _ _ _ _ _ _) = a++{- | Grab '_awAddrWidth' from t'Axi4WriteAddressConfig' at the type level.+This nat value determines the size of the '_awaddr' field+in t'M2S_WriteAddress'.+-}+type family AWAddrWidth (c :: Axi4WriteAddressConfig) where+  AWAddrWidth ('Axi4WriteAddressConfig _ _ _ a _ _ _ _ _ _) = a++{- | Grab '_awKeepRegion' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awregion' field+in t'M2S_WriteAddress'.+-}+type family AWKeepRegion (c :: Axi4WriteAddressConfig) where+  AWKeepRegion ('Axi4WriteAddressConfig _ _ _ _ a _ _ _ _ _) = a++{- | Grab '_awKeepBurstLength' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awlen' field+in t'M2S_WriteAddress'.+-}+type family AWKeepBurstLength (c :: Axi4WriteAddressConfig) where+  AWKeepBurstLength ('Axi4WriteAddressConfig _ _ _ _ _ a _ _ _ _) = a++{- | Grab '_awKeepLock' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awlock' field+in t'M2S_WriteAddress'.+-}+type family AWKeepLock (c :: Axi4WriteAddressConfig) where+  AWKeepLock ('Axi4WriteAddressConfig _ _ _ _ _ _ a _ _ _) = a++{- | Grab '_awKeepCache' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awcache' field+in t'M2S_WriteAddress'.+-}+type family AWKeepCache (c :: Axi4WriteAddressConfig) where+  AWKeepCache ('Axi4WriteAddressConfig _ _ _ _ _ _ _ a _ _) = a++{- | Grab '_awKeepPermissions' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awprot' field+in t'M2S_WriteAddress'.+-}+type family AWKeepPermissions (c :: Axi4WriteAddressConfig) where+  AWKeepPermissions ('Axi4WriteAddressConfig _ _ _ _ _ _ _ _ a _) = a++{- | Grab '_awKeepQos' from t'Axi4WriteAddressConfig' at the type level.+This boolean value determines whether to keep the '_awqos' field+in t'M2S_WriteAddress'.+-}+type family AWKeepQos (c :: Axi4WriteAddressConfig) where+  AWKeepQos ('Axi4WriteAddressConfig _ _ _ _ _ _ _ _ _ a) = a++-- | AXI4 Write Address channel protocol+data+  Axi4WriteAddress+    (dom :: C.Domain)+    (conf :: Axi4WriteAddressConfig)+    (userType :: Type)++instance Protocol (Axi4WriteAddress dom conf userType) where+  type+    Fwd (Axi4WriteAddress dom conf userType) =+      C.Signal dom (M2S_WriteAddress conf userType)+  type+    Bwd (Axi4WriteAddress dom conf userType) =+      C.Signal dom S2M_WriteAddress++instance Backpressure (Axi4WriteAddress dom conf userType) where+  boolsToBwd _ = C.fromList_lazy . coerce++-- | See Table A2-2 "Write address channel signals"+data+  M2S_WriteAddress+    (conf :: Axi4WriteAddressConfig)+    (userType :: Type)+  = M2S_NoWriteAddress+  | M2S_WriteAddress+      { _awid :: C.BitVector (AWIdWidth conf)+      -- ^ Write address id*+      , _awaddr :: C.BitVector (AWAddrWidth conf)+      -- ^ Write address+      , _awregion :: RegionType (AWKeepRegion conf)+      -- ^ Write region*+      , _awlen :: BurstLengthType (AWKeepBurstLength conf)+      -- ^ Burst length*+      , _awsize :: SizeType (AWKeepSize conf)+      -- ^ Burst size*+      , _awburst :: BurstType (AWKeepBurst conf)+      -- ^ Burst type*+      , _awlock :: LockType (AWKeepLock conf)+      -- ^ Lock type*+      , _awcache :: AwCacheType (AWKeepCache conf)+      -- ^ Cache type*+      , _awprot :: PermissionsType (AWKeepPermissions conf)+      -- ^ Protection type+      , _awqos :: QosType (AWKeepQos conf)+      -- ^ QoS value+      , _awuser :: userType+      -- ^ User data+      }+  deriving (Generic)++-- | See Table A2-2 "Write address channel signals"+newtype S2M_WriteAddress = S2M_WriteAddress {_awready :: Bool}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (C.ShowX, C.NFDataX, C.BitPack)++{- | Shorthand for a "well-behaved" write address config,+so that we don't need to write out a bunch of type constraints later.+Holds for every configuration; don't worry about implementing this class.+-}+type KnownAxi4WriteAddressConfig conf =+  ( KeepTypeClass (AWKeepBurst conf)+  , KeepTypeClass (AWKeepSize conf)+  , KeepTypeClass (AWKeepRegion conf)+  , KeepTypeClass (AWKeepBurstLength conf)+  , KeepTypeClass (AWKeepLock conf)+  , KeepTypeClass (AWKeepCache conf)+  , KeepTypeClass (AWKeepPermissions conf)+  , KeepTypeClass (AWKeepQos conf)+  , C.KnownNat (AWIdWidth conf)+  , C.KnownNat (AWAddrWidth conf)+  , C.ShowX (RegionType (AWKeepRegion conf))+  , C.ShowX (BurstLengthType (AWKeepBurstLength conf))+  , C.ShowX (SizeType (AWKeepSize conf))+  , C.ShowX (BurstType (AWKeepBurst conf))+  , C.ShowX (LockType (AWKeepLock conf))+  , C.ShowX (AwCacheType (AWKeepCache conf))+  , C.ShowX (PermissionsType (AWKeepPermissions conf))+  , C.ShowX (QosType (AWKeepQos conf))+  , Show (RegionType (AWKeepRegion conf))+  , Show (BurstLengthType (AWKeepBurstLength conf))+  , Show (SizeType (AWKeepSize conf))+  , Show (BurstType (AWKeepBurst conf))+  , Show (LockType (AWKeepLock conf))+  , Show (AwCacheType (AWKeepCache conf))+  , Show (PermissionsType (AWKeepPermissions conf))+  , Show (QosType (AWKeepQos conf))+  , C.NFDataX (RegionType (AWKeepRegion conf))+  , C.NFDataX (BurstLengthType (AWKeepBurstLength conf))+  , C.NFDataX (SizeType (AWKeepSize conf))+  , C.NFDataX (BurstType (AWKeepBurst conf))+  , C.NFDataX (LockType (AWKeepLock conf))+  , C.NFDataX (AwCacheType (AWKeepCache conf))+  , C.NFDataX (PermissionsType (AWKeepPermissions conf))+  , C.NFDataX (QosType (AWKeepQos conf))+  , C.BitPack (RegionType (AWKeepRegion conf))+  , C.BitPack (BurstLengthType (AWKeepBurstLength conf))+  , C.BitPack (SizeType (AWKeepSize conf))+  , C.BitPack (BurstType (AWKeepBurst conf))+  , C.BitPack (LockType (AWKeepLock conf))+  , C.BitPack (AwCacheType (AWKeepCache conf))+  , C.BitPack (PermissionsType (AWKeepPermissions conf))+  , C.BitPack (QosType (AWKeepQos conf))+  , NFData (RegionType (AWKeepRegion conf))+  , NFData (BurstLengthType (AWKeepBurstLength conf))+  , NFData (SizeType (AWKeepSize conf))+  , NFData (BurstType (AWKeepBurst conf))+  , NFData (LockType (AWKeepLock conf))+  , NFData (AwCacheType (AWKeepCache conf))+  , NFData (PermissionsType (AWKeepPermissions conf))+  , NFData (QosType (AWKeepQos conf))+  , Eq (RegionType (AWKeepRegion conf))+  , Eq (BurstLengthType (AWKeepBurstLength conf))+  , Eq (SizeType (AWKeepSize conf))+  , Eq (BurstType (AWKeepBurst conf))+  , Eq (LockType (AWKeepLock conf))+  , Eq (AwCacheType (AWKeepCache conf))+  , Eq (PermissionsType (AWKeepPermissions conf))+  , Eq (QosType (AWKeepQos conf))+  )++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , Show userType+  ) =>+  Show (M2S_WriteAddress conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , C.ShowX userType+  ) =>+  C.ShowX (M2S_WriteAddress conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (M2S_WriteAddress conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , Eq userType+  ) =>+  Eq (M2S_WriteAddress conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , C.BitPack userType+  ) =>+  C.BitPack (M2S_WriteAddress conf userType)++{- | Mainly for use in 'Protocols.DfConv.DfConv'.++Data carried along 'Axi4WriteAddress' channel which is put in control of+the user, rather than being managed by the 'Protocols.DfConv.DfConv' instances.+Matches up+one-to-one with the fields of t'M2S_WriteAddress' except for '_awlen',+'_awsize', and '_awburst'.+-}+data Axi4WriteAddressInfo (conf :: Axi4WriteAddressConfig) (userType :: Type) = Axi4WriteAddressInfo+  { _awiid :: C.BitVector (AWIdWidth conf)+  -- ^ Id+  , _awiaddr :: C.BitVector (AWAddrWidth conf)+  -- ^ Address+  , _awiregion :: RegionType (AWKeepRegion conf)+  -- ^ Region+  , _awisize :: SizeType (AWKeepSize conf)+  -- ^ Burst size+  , _awilock :: LockType (AWKeepLock conf)+  -- ^ Lock type+  , _awicache :: AwCacheType (AWKeepCache conf)+  -- ^ Cache type+  , _awiprot :: PermissionsType (AWKeepPermissions conf)+  -- ^ Protection type+  , _awiqos :: QosType (AWKeepQos conf)+  -- ^ QoS value+  , _awiuser :: userType+  -- ^ User data+  }+  deriving (Generic)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , Show userType+  ) =>+  Show (Axi4WriteAddressInfo conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , C.ShowX userType+  ) =>+  C.ShowX (Axi4WriteAddressInfo conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (Axi4WriteAddressInfo conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , NFData userType+  ) =>+  NFData (Axi4WriteAddressInfo conf userType)++deriving instance+  ( KnownAxi4WriteAddressConfig conf+  , Eq userType+  ) =>+  Eq (Axi4WriteAddressInfo conf userType)++-- | Convert t'M2S_WriteAddress' to t'Axi4WriteAddressInfo', dropping some info+axi4WriteAddrMsgToWriteAddrInfo ::+  M2S_WriteAddress conf userType ->+  Axi4WriteAddressInfo conf userType+axi4WriteAddrMsgToWriteAddrInfo M2S_NoWriteAddress = C.errorX "Expected WriteAddress"+axi4WriteAddrMsgToWriteAddrInfo M2S_WriteAddress{..} =+  Axi4WriteAddressInfo+    { _awiid = _awid+    , _awiaddr = _awaddr+    , _awiregion = _awregion+    , _awisize = _awsize+    , _awilock = _awlock+    , _awicache = _awcache+    , _awiprot = _awprot+    , _awiqos = _awqos+    , _awiuser = _awuser+    }++-- | Convert t'Axi4WriteAddressInfo' to t'M2S_WriteAddress', adding some info+axi4WriteAddrMsgFromWriteAddrInfo ::+  BurstLengthType (AWKeepBurstLength conf) ->+  BurstType (AWKeepBurst conf) ->+  Axi4WriteAddressInfo conf userType ->+  M2S_WriteAddress conf userType+axi4WriteAddrMsgFromWriteAddrInfo _awlen _awburst Axi4WriteAddressInfo{..} =+  M2S_WriteAddress+    { _awid = _awiid+    , _awaddr = _awiaddr+    , _awregion = _awiregion+    , _awsize = _awisize+    , _awlock = _awilock+    , _awcache = _awicache+    , _awprot = _awiprot+    , _awqos = _awiqos+    , _awuser = _awiuser+    , _awlen+    , _awburst+    }++instance IdleCircuit (Axi4WriteAddress dom conf userType) where+  idleFwd _ = C.pure M2S_NoWriteAddress+  idleBwd _ = C.pure $ S2M_WriteAddress False++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  (C.KnownDomain dom, C.HiddenReset dom) =>+  Circuit (Axi4WriteAddress dom conf userType) (Axi4WriteAddress dom conf userType)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Axi4/WriteData.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Defines WriteData channel of full AXI4 protocol with port names corresponding+to the AXI4 specification.+-}+module Protocols.Experimental.Axi4.WriteData (+  M2S_WriteData (..),+  S2M_WriteData (..),+  Axi4WriteData,++  -- * configuration+  Axi4WriteDataConfig (..),+  KnownAxi4WriteDataConfig,+  WKeepStrobe,+  WNBytes,+) where++-- base+import Data.Coerce (coerce)+import Data.Kind (Type)+import GHC.Generics (Generic)+import Prelude hiding (+  const,+  either,+  filter,+  fst,+  map,+  pure,+  snd,+  zip,+  zipWith,+  (!!),+ )++-- clash-prelude+import Clash.Prelude qualified as C++-- me+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++-- | Configuration options for 'Axi4WriteData'.+data Axi4WriteDataConfig = Axi4WriteDataConfig+  { _wKeepStrobe :: Bool+  , _wNBytes :: C.Nat+  }++{- | Grab '_wKeepStrobe' from t'Axi4WriteDataConfig' at the type level.+This boolean value determines whether to keep strobe values in the '_wdata' field+in t'M2S_WriteData'.+-}+type family WKeepStrobe (conf :: Axi4WriteDataConfig) where+  WKeepStrobe ('Axi4WriteDataConfig a _) = a++{- | Grab '_wNBytes' from t'Axi4WriteDataConfig' at the type level.+This nat value determines the size of the '_wdata' field+in t'M2S_WriteData'.+-}+type family WNBytes (conf :: Axi4WriteDataConfig) where+  WNBytes ('Axi4WriteDataConfig _ a) = a++-- | AXI4 Write Data channel protocol+data+  Axi4WriteData+    (dom :: C.Domain)+    (conf :: Axi4WriteDataConfig)+    (userType :: Type)++instance Protocol (Axi4WriteData dom conf userType) where+  type+    Fwd (Axi4WriteData dom conf userType) =+      C.Signal dom (M2S_WriteData conf userType)+  type+    Bwd (Axi4WriteData dom conf userType) =+      C.Signal dom S2M_WriteData++instance Backpressure (Axi4WriteData dom conf userType) where+  boolsToBwd _ = C.fromList_lazy . coerce++{- | See Table A2-3 "Write data channel signals". If strobing is kept, the data+will be a vector of 'Maybe' bytes. If strobing is not kept, data will be a+'C.BitVector'.+-}+data+  M2S_WriteData+    (conf :: Axi4WriteDataConfig)+    (userType :: Type)+  = M2S_NoWriteData+  | M2S_WriteData+      { _wdata :: StrictStrobeType (WNBytes conf) (WKeepStrobe conf)+      -- ^ Write data+      , _wlast :: Bool+      -- ^ Write last+      , _wuser :: userType+      -- ^ User data+      }+  deriving (Generic)++-- | See Table A2-3 "Write data channel signals"+newtype S2M_WriteData = S2M_WriteData {_wready :: Bool}+  deriving stock (Show, Generic)+  deriving anyclass (C.NFDataX, C.BitPack)++{- | Shorthand for a "well-behaved" write data config,+so that we don't need to write out a bunch of type constraints later.+Holds for every configuration; don't worry about implementing this class.+-}+type KnownAxi4WriteDataConfig conf =+  ( KeepStrobeClass (WKeepStrobe conf)+  , C.KnownNat (WNBytes conf)+  , Eq (StrobeDataType (WKeepStrobe conf))+  , Show (StrobeDataType (WKeepStrobe conf))+  , C.ShowX (StrobeDataType (WKeepStrobe conf))+  , C.NFDataX (StrobeDataType (WKeepStrobe conf))+  , C.BitPack (StrobeDataType (WKeepStrobe conf))+  )++deriving instance+  ( KnownAxi4WriteDataConfig conf+  , Show userType+  ) =>+  Show (M2S_WriteData conf userType)++deriving instance+  ( KnownAxi4WriteDataConfig conf+  , C.ShowX userType+  ) =>+  C.ShowX (M2S_WriteData conf userType)++deriving instance+  ( KnownAxi4WriteDataConfig conf+  , Eq userType+  ) =>+  Eq (M2S_WriteData conf userType)++deriving instance+  ( KnownAxi4WriteDataConfig conf+  , C.BitPack userType+  ) =>+  C.BitPack (M2S_WriteData conf userType)++deriving instance+  ( KnownAxi4WriteDataConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (M2S_WriteData conf userType)++instance IdleCircuit (Axi4WriteData dom conf userType) where+  idleFwd _ = C.pure M2S_NoWriteData+  idleBwd _ = C.pure S2M_WriteData{_wready = False}
+ src/Protocols/Experimental/Axi4/WriteResponse.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}++{- |+Defines WriteResponse channel of full AXI4 protocol with port names corresponding+to the AXI4 specification.+-}+module Protocols.Experimental.Axi4.WriteResponse (+  M2S_WriteResponse (..),+  S2M_WriteResponse (..),+  Axi4WriteResponse,++  -- * configuration+  Axi4WriteResponseConfig (..),+  KnownAxi4WriteResponseConfig,+  BKeepResponse,+  BIdWidth,+) where++-- base+import Data.Coerce (coerce)+import Data.Kind (Type)+import GHC.Generics (Generic)++-- clash-prelude+import Clash.Prelude qualified as C++-- me+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Simulate+import Protocols.Idle+import Protocols.Internal++-- | Configuration options for 'Axi4WriteResponse'.+data Axi4WriteResponseConfig = Axi4WriteResponseConfig+  { _bKeepResponse :: Bool+  , _bIdWidth :: C.Nat+  }++{- | Grab '_bKeepResponse' from t'Axi4WriteResponseConfig' at the type level.+This boolean value determines whether to keep the '_bresp' field+in t'S2M_WriteResponse'.+-}+type family BKeepResponse (conf :: Axi4WriteResponseConfig) where+  BKeepResponse ('Axi4WriteResponseConfig a _) = a++{- | Grab '_bIdWidth' from t'Axi4WriteResponseConfig' at the type level.+This nat value determines the size of the '_bid' field+in t'S2M_WriteResponse'.+-}+type family BIdWidth (conf :: Axi4WriteResponseConfig) where+  BIdWidth ('Axi4WriteResponseConfig _ a) = a++-- | AXI4 write response channel protocol+data+  Axi4WriteResponse+    (dom :: C.Domain)+    (conf :: Axi4WriteResponseConfig)+    (userType :: Type)++instance Protocol (Axi4WriteResponse dom conf userType) where+  type+    Fwd (Axi4WriteResponse dom conf userType) =+      C.Signal dom (S2M_WriteResponse conf userType)+  type+    Bwd (Axi4WriteResponse dom conf userType) =+      C.Signal dom M2S_WriteResponse++instance Backpressure (Axi4WriteResponse dom conf userType) where+  boolsToBwd _ = C.fromList_lazy . coerce++-- | See Table A2-4 "Write response channel signals"+data+  S2M_WriteResponse+    (conf :: Axi4WriteResponseConfig)+    (userType :: Type)+  = S2M_NoWriteResponse+  | S2M_WriteResponse+      { _bid :: C.BitVector (BIdWidth conf)+      -- ^ Response ID+      , _bresp :: ResponseType (BKeepResponse conf)+      -- ^ Write response+      , _buser :: userType+      -- ^ User data+      }+  deriving (Generic)++-- | See Table A2-4 "Write response channel signals"+newtype M2S_WriteResponse = M2S_WriteResponse {_bready :: Bool}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (C.ShowX, C.NFDataX, C.BitPack)++{- | Shorthand for a "well-behaved" write response config,+so that we don't need to write out a bunch of type constraints later.+Holds for every configuration; don't worry about implementing this class.+-}+type KnownAxi4WriteResponseConfig conf =+  ( KeepTypeClass (BKeepResponse conf)+  , C.KnownNat (BIdWidth conf)+  , Eq (ResponseType (BKeepResponse conf))+  , Show (ResponseType (BKeepResponse conf))+  , C.ShowX (ResponseType (BKeepResponse conf))+  , C.NFDataX (ResponseType (BKeepResponse conf))+  , C.BitPack (ResponseType (BKeepResponse conf))+  )++deriving instance+  ( KnownAxi4WriteResponseConfig conf+  , Eq userType+  ) =>+  Eq (S2M_WriteResponse conf userType)++deriving instance+  ( KnownAxi4WriteResponseConfig conf+  , Show userType+  ) =>+  Show (S2M_WriteResponse conf userType)++deriving instance+  ( KnownAxi4WriteResponseConfig conf+  , C.BitPack userType+  ) =>+  C.BitPack (S2M_WriteResponse conf userType)++deriving instance+  ( KnownAxi4WriteResponseConfig conf+  , C.ShowX userType+  ) =>+  C.ShowX (S2M_WriteResponse conf userType)++deriving instance+  ( KnownAxi4WriteResponseConfig conf+  , C.NFDataX userType+  ) =>+  C.NFDataX (S2M_WriteResponse conf userType)++instance IdleCircuit (Axi4WriteResponse dom conf userType) where+  idleFwd _ = pure S2M_NoWriteResponse+  idleBwd _ = pure $ M2S_WriteResponse False
+ src/Protocols/Experimental/Df.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Experimental simulation support for "Protocols.Df".+-}+module Protocols.Experimental.Df (+  module Protocols.Df,+  module Protocols.Experimental.Simulate,++  -- * Simulation functions+  drive,+  stall,+  sample,+  simulate,+) where++import Clash.Explicit.Prelude qualified as CE+import Clash.Prelude qualified as C+import Clash.Signal.Internal (Signal (..))+import Data.Bifunctor qualified as B+import Data.Bool (bool)+import Data.Coerce qualified as Coerce+import Data.List ((\\))+import Data.Maybe qualified as Maybe+import Data.Proxy+import GHC.Stack (HasCallStack)+import Prelude+import Prelude qualified as P++import Protocols+import Protocols.Df+import Protocols.Experimental.Simulate++{- $setup+>>> import Protocols+>>> import Protocols.Experimental.Df+-}++instance Backpressure (Df dom a) where+  boolsToBwd _ = C.fromList_lazy . Coerce.coerce++instance (C.KnownDomain dom, C.NFDataX a, C.ShowX a, Show a) => Simulate (Df dom a) where+  type SimulateFwdType (Df dom a) = [Maybe a]+  type SimulateBwdType (Df dom a) = [Ack]+  type SimulateChannels (Df dom a) = 1++  simToSigFwd _ = C.fromList_lazy+  simToSigBwd _ = C.fromList_lazy+  sigToSimFwd _ s = C.sample_lazy s+  sigToSimBwd _ s = C.sample_lazy s++  stallC conf (C.head -> (stallAck, stalls)) = stall conf stallAck stalls++instance (C.KnownDomain dom, C.NFDataX a, C.ShowX a, Show a) => Drivable (Df dom a) where+  type ExpectType (Df dom a) = [a]++  toSimulateType Proxy = P.map Just+  fromSimulateType Proxy = Maybe.catMaybes++  driveC = drive+  sampleC = sample++{- | Emit values given in list. Emits no data while reset is asserted. Not+synthesizable.+-}+drive ::+  forall dom a.+  (C.KnownDomain dom) =>+  SimulationConfig ->+  [Maybe a] ->+  Circuit () (Df dom a)+drive SimulationConfig{resetCycles} s0 =+  Circuit $+    ((),)+      . C.fromList_lazy+      . go s0 resetCycles+      . CE.sample_lazy+      . P.snd+ where+  go _ resetN ~(ack : acks)+    | resetN > 0 =+        Nothing : (ack `C.seqX` go s0 (resetN - 1) acks)+  go [] _ ~(ack : acks) =+    Nothing : (ack `C.seqX` go [] 0 acks)+  go (Nothing : is) _ ~(ack : acks) =+    Nothing : (ack `C.seqX` go is 0 acks)+  go (Just dat : is) _ ~(Ack ack : acks) =+    Just dat : go (if ack then is else Just dat : is) 0 acks++{- | Sample protocol to a list of values. Drops values while reset is asserted.+Not synthesizable.++For a generalized version of 'sample', check out 'sampleC'.+-}+sample ::+  forall dom b.+  (C.KnownDomain dom) =>+  SimulationConfig ->+  Circuit () (Df dom b) ->+  [Maybe b]+sample SimulationConfig{..} c =+  CE.sampleN_lazy timeoutAfter $+    ignoreWhileInReset $+      P.snd $+        toSignals c ((), Ack <$> rst_n)+ where+  ignoreWhileInReset s =+    uncurry (bool Nothing)+      <$> C.bundle (s, rst_n)++  rst_n = C.fromList (replicate resetCycles False <> repeat True)++{- | Stall every valid Df packet with a given number of cycles. If there are+more valid packets than given numbers, passthrough all valid packets without+stalling. Not synthesizable.++For a generalized version of 'stall', check out 'stallC'.+-}+stall ::+  forall dom a.+  ( C.KnownDomain dom+  , HasCallStack+  ) =>+  SimulationConfig ->+  {- | Acknowledgement to send when LHS does not send data. Stall will act+  transparently when reset is asserted.+  -}+  StallAck ->+  -- Number of cycles to stall for every valid Df packet+  [Int] ->+  Circuit (Df dom a) (Df dom a)+stall SimulationConfig{..} stallAck stalls =+  Circuit $+    uncurry (go stallAcks stalls resetCycles)+ where+  stallAcks+    | stallAck == StallCycle = [minBound .. maxBound] \\ [StallCycle]+    | otherwise = [stallAck]++  toStallAck :: Maybe a -> Ack -> StallAck -> Ack+  toStallAck (Just _) ack = P.const ack+  toStallAck Nothing ack = \case+    StallWithNack -> Ack False+    StallWithAck -> Ack True+    StallWithErrorX -> C.errorX "No defined ack"+    StallTransparently -> ack+    StallCycle -> Ack False -- shouldn't happen..+  go ::+    [StallAck] ->+    [Int] ->+    Int ->+    Signal dom (Maybe a) ->+    Signal dom Ack ->+    ( Signal dom Ack+    , Signal dom (Maybe a)+    )+  go [] ss rs fwd bwd =+    go stallAcks ss rs fwd bwd+  go (_ : sas) _ resetN (f :- fwd) ~(b :- bwd)+    | resetN > 0 =+        B.bimap (b :-) (f :-) (go sas stalls (resetN - 1) fwd bwd)+  go (sa : sas) [] _ (f :- fwd) ~(b :- bwd) =+    B.bimap (toStallAck f b sa :-) (f :-) (go sas [] 0 fwd bwd)+  go (sa : sas) ss _ (Nothing :- fwd) ~(b :- bwd) =+    -- Left hand side does not send data, simply replicate that behavior. Right+    -- hand side might send an arbitrary acknowledgement, so we simply pass it+    -- through.+    B.bimap (toStallAck Nothing b sa :-) (Nothing :-) (go sas ss 0 fwd bwd)+  go (_sa : sas) (s : ss) _ (f0 :- fwd) ~(Ack b0 :- bwd) =+    let+      -- Stall as long as s > 0. If s ~ 0, we wait for the RHS to acknowledge+      -- the data. As long as RHS does not acknowledge the data, we keep sending+      -- the same data.+      (f1, b1, s1) = case compare 0 s of+        LT -> (Nothing, Ack False, pred s : ss) -- s > 0+        EQ -> (f0, Ack b0, if b0 then ss else s : ss) -- s ~ 0+        GT -> error ("Unexpected negative stall: " <> show s) -- s < 0+     in+      B.bimap (b1 :-) (f1 :-) (go sas s1 0 fwd bwd)++{- | Simulate a single domain protocol. Not synthesizable.++For a generalized version of 'simulate', check out+'Protocols.Experimental.Simulate.simulateC'.+-}+simulate ::+  forall dom a b.+  (C.KnownDomain dom) =>+  -- | Simulation configuration. Use 'Data.Default.def' for sensible defaults.+  SimulationConfig ->+  -- | Circuit to simulate.+  ( C.Clock dom ->+    C.Reset dom ->+    C.Enable dom ->+    Circuit (Df dom a) (Df dom b)+  ) ->+  -- | Inputs+  [Maybe a] ->+  -- | Outputs+  [Maybe b]+simulate conf@SimulationConfig{..} circ inputs =+  sample conf (drive conf inputs |> circ clk rst ena)+ where+  (clk, rst, ena) = (C.clockGen, resetGen resetCycles, C.enableGen)++{- | Like 'C.resetGenN', but works on 'Int' instead of 'C.SNat'. Not+synthesizable.+-}+resetGen :: (C.KnownDomain dom) => Int -> C.Reset dom+resetGen n =+  C.unsafeFromActiveHigh $+    C.fromList (replicate n True <> repeat False)
+ src/Protocols/Experimental/DfConv.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Experimental 'DfConv' support.++Import this module instead of 'Protocols.DfConv' when working with+experimental protocols that rely on experimental 'DfConv' instances.+-}+module Protocols.Experimental.DfConv (+  module Protocols.DfConv,++  -- * Simulation functions+  drive,+  sample,+  stall,+  simulate,+  dfConvTestBench,+  dfConvTestBenchRev,+) where++import Clash.Prelude hiding (sample, simulate)+import Control.Monad (when)+import Control.Monad.State (get, put, runState)+import Data.Maybe (isJust)+import Data.Proxy (Proxy (..))+import GHC.Stack (HasCallStack)+import Prelude qualified as P++import Protocols+import Protocols.DfConv+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Axi4.ReadAddress+import Protocols.Experimental.Axi4.ReadData+import Protocols.Experimental.Axi4.WriteAddress+import Protocols.Experimental.Axi4.WriteData+import Protocols.Experimental.Axi4.WriteResponse+import Protocols.Experimental.Df qualified as Df+import Protocols.Experimental.Simulate+import Protocols.Internal++-- Manager end (toDfCircuit) only allows for burst length of 1, will ignore the+-- burst length you input. Subordinate end (fromDfCircuit) allows for any burst+-- length.+instance+  ( KnownAxi4WriteAddressConfig confAW+  , KnownAxi4WriteDataConfig confW+  , KnownAxi4WriteResponseConfig confB+  , NFDataX userAW+  , NFDataX userB+  , AWIdWidth confAW ~ BIdWidth confB+  ) =>+  DfConv+    ( Axi4WriteAddress dom confAW userAW+    , Axi4WriteData dom confW userW+    , Reverse (Axi4WriteResponse dom confB userB)+    )+  where+  type+    Dom+      ( Axi4WriteAddress dom confAW userAW+      , Axi4WriteData dom confW userW+      , Reverse (Axi4WriteResponse dom confB userB)+      ) =+      dom++  type+    FwdPayload+      ( Axi4WriteAddress dom confAW userAW+      , Axi4WriteData dom confW userW+      , Reverse (Axi4WriteResponse dom confB userB)+      ) =+      ( Axi4WriteAddressInfo confAW userAW+      , BurstLengthType (AWKeepBurstLength confAW)+      , BurstType (AWKeepBurst confAW)+      , StrictStrobeType (WNBytes confW) (WKeepStrobe confW)+      , userW+      )++  type+    BwdPayload+      ( Axi4WriteAddress dom confAW userAW+      , Axi4WriteData dom confW userW+      , Reverse (Axi4WriteResponse dom confB userB)+      ) =+      (ResponseType (BKeepResponse confB), userB)++  toDfCircuit proxy = toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = (False, False)+    blankOtp =+      ( M2S_NoWriteAddress+      , M2S_NoWriteData+      , M2S_WriteResponse{_bready = False}+      )++    stateFn (addrAck, dataAck, respVal) dfAckIn dfDatIn = do+      st0 <- get+      let+        (addrMsg, st1) = runState (sendAddr addrAck dfDatIn) st0+        ((dataMsg, dfAckOut), st2) = runState (sendData dataAck dfDatIn) st1+        ((respAck, dfDatOut), st3) = runState (receiveResp respVal dfAckIn) st2+      put st3+      P.pure ((addrMsg, dataMsg, respAck), dfDatOut, dfAckOut)++    sendAddr _ Nothing = P.pure M2S_NoWriteAddress+    sendAddr addrAck (Just (info, _, burst, _, _)) = do+      (addrReceived, b) <- get+      put (addrReceived || _awready addrAck, b)+      P.pure+        $ if addrReceived+          then M2S_NoWriteAddress+          else+            axi4WriteAddrMsgFromWriteAddrInfo+              (toKeepType 0)+              burst+              info++    sendData _ Nothing = P.pure (M2S_NoWriteData, False)+    sendData dataAck (Just (_, _, _, dat, user)) = do+      (addrReceived, dataReceived) <- get+      put (addrReceived, dataReceived || _wready dataAck)+      P.pure+        $ if not addrReceived || dataReceived+          then (M2S_NoWriteData, False)+          else+            ( M2S_WriteData+                { _wdata = dat+                , _wlast = True+                , _wuser = user+                }+            , _wready dataAck+            )++    receiveResp S2M_NoWriteResponse _ =+      P.pure (M2S_WriteResponse{_bready = False}, Nothing)+    receiveResp S2M_WriteResponse{_bresp, _buser} dfAckIn = do+      (_, dataReceived) <- get+      let shouldAckResponse = dataReceived && dfAckIn+      when shouldAckResponse $ put (False, False)+      P.pure+        ( M2S_WriteResponse{_bready = shouldAckResponse}+        , Just (_bresp, _buser)+        )++  fromDfCircuit proxy = fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = (Nothing, Nothing)+    blankOtp =+      ( S2M_WriteAddress{_awready = False}+      , S2M_WriteData{_wready = False}+      , S2M_NoWriteResponse+      )++    stateFn (addrVal, dataVal, respAck) dfAckIn dfDatIn = do+      st0 <- get+      let+        (addrAck, st1) = runState (processWAddr addrVal) st0+        ((dataAck, dfDatOut), st2) = runState (processWData dataVal dfAckIn) st1+        ((respVal, dfAckOut), st3) = runState (sendWResp respAck dfDatIn) st2+      put st3+      P.pure ((addrAck, dataAck, respVal), dfDatOut, dfAckOut)++    processWAddr M2S_NoWriteAddress = P.pure (S2M_WriteAddress{_awready = False})+    processWAddr msg = do+      (writingInfo, b) <- get+      put+        ( writingInfo+            <|> Just (axi4WriteAddrMsgToWriteAddrInfo msg, _awlen msg, _awburst msg)+        , b+        )+      P.pure (S2M_WriteAddress{_awready = True})++    processWData M2S_NoWriteData _ = P.pure (S2M_WriteData{_wready = False}, Nothing)+    processWData M2S_WriteData{_wlast, _wdata, _wuser} dfAckIn = do+      (writingInfo, respID) <- get+      case writingInfo of+        Nothing -> P.pure (S2M_WriteData{_wready = False}, Nothing)+        Just (info, len, burst) -> do+          when dfAckIn+            $ put+              ( Nothing+              , if _wlast+                  then Just (_awiid info)+                  else respID+              )+          P.pure+            ( S2M_WriteData{_wready = dfAckIn}+            , Just (info, len, burst, _wdata, _wuser)+            )++    sendWResp respAck dfDatIn = do+      (a, respID) <- get+      let (respVal, dfAckOut) = case (respID, dfDatIn) of+            (Just _bid, Just (_bresp, _buser)) ->+              (S2M_WriteResponse{..}, _bready respAck)+            _ -> (S2M_NoWriteResponse, False)+      when dfAckOut $ put (a, Nothing)+      P.pure (respVal, dfAckOut)++instance+  ( KnownAxi4ReadAddressConfig confAR+  , KnownAxi4ReadDataConfig confR+  , NFDataX userR+  , NFDataX dat+  , ARIdWidth confAR ~ RIdWidth confR+  ) =>+  DfConv+    ( Axi4ReadAddress dom confAR dataAR+    , Reverse (Axi4ReadData dom confR userR dat)+    )+  where+  type+    Dom+      ( Axi4ReadAddress dom confAR dataAR+      , Reverse (Axi4ReadData dom confR userR dat)+      ) =+      dom++  type+    BwdPayload+      ( Axi4ReadAddress dom confAR dataAR+      , Reverse (Axi4ReadData dom confR userR dat)+      ) =+      (dat, userR, ResponseType (RKeepResponse confR))++  type+    FwdPayload+      ( Axi4ReadAddress dom confAR dataAR+      , Reverse (Axi4ReadData dom confR userR dat)+      ) =+      Axi4ReadAddressInfo confAR dataAR++  toDfCircuit proxy = toDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = ()+    blankOtp =+      ( M2S_NoReadAddress+      , M2S_ReadData{_rready = False}+      )++    stateFn (addrAck, readVal) dfAckIn dfDatIn =+      let readAddrMsg = processAddrInfo dfDatIn+       in P.pure+            ( (readAddrMsg, M2S_ReadData{_rready = dfAckIn})+            , processReadVal readVal+            , isJust dfDatIn && getDfAckOut addrAck readAddrMsg+            )++    processAddrInfo = maybe M2S_NoReadAddress axi4ReadAddrMsgFromReadAddrInfo++    processReadVal S2M_NoReadData = Nothing+    processReadVal S2M_ReadData{..} = Just (_rdata, _ruser, _rresp)++    getDfAckOut _ M2S_NoReadAddress = False+    getDfAckOut addrAck _ = _arready addrAck++  fromDfCircuit proxy = fromDfCircuitHelper proxy s0 blankOtp stateFn+   where+    s0 = (0, errorX "DfConv for Axi4: No initial value for read id")+    blankOtp = (S2M_ReadAddress{_arready = False}, S2M_NoReadData)++    stateFn (addrVal, dataAck) dfAckIn dfDatIn = do+      st0 <- get+      let+        ((addrAck, dfDatOut), st1) = runState (processAddr addrVal dfAckIn) st0+        ((dataVal, dfAckOut), st2) = runState (sendData dfDatIn dataAck) st1+      put st2+      P.pure ((addrAck, dataVal), dfDatOut, dfAckOut)++    processAddr M2S_NoReadAddress _ =+      P.pure (S2M_ReadAddress{_arready = False}, Nothing)+    processAddr msg dfAckIn = do+      (burstLenLeft, _) <- get+      case burstLenLeft of+        0 -> do+          put (succResizing $ fromKeepTypeDef 0 $ _arlen msg, _arid msg)+          P.pure+            ( S2M_ReadAddress{_arready = dfAckIn}+            , Just (axi4ReadAddrMsgToReadAddrInfo msg)+            )+        _ ->+          P.pure+            ( S2M_ReadAddress{_arready = False}+            , Nothing+            )++    succResizing :: (KnownNat n) => Index n -> Index (n + 1)+    succResizing n = resize n + 1++    sendData dfDatIn dataAck = do+      (burstLenLeft, readId) <- get+      case (burstLenLeft == 0, dfDatIn) of+        (False, Just (_rdata, _ruser, _rresp)) -> do+          put (burstLenLeft - 1, readId)+          P.pure+            ( S2M_ReadData+                { _rid = readId+                , _rlast = burstLenLeft == 1+                , _rdata+                , _ruser+                , _rresp+                }+            , _rready dataAck+            )+        _ -> P.pure (S2M_NoReadData, False)++{- | Emit values given in list. Emits no data while reset is asserted. Not+synthesizable.+-}+drive ::+  ( DfConv dfA+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  SimulationConfig ->+  [Maybe (FwdPayload dfA)] ->+  Circuit () dfA+drive dfA conf s0 = Df.drive conf s0 |> dfToDfConvOtp dfA++{- | Sample protocol to a list of values. Drops values while reset is asserted.+Not synthesizable.++For a generalized version of 'sample', check out 'sampleC'.+-}+sample ::+  ( DfConv dfB+  , HiddenClockResetEnable (Dom dfB)+  ) =>+  Proxy dfB ->+  SimulationConfig ->+  Circuit () dfB ->+  [Maybe (FwdPayload dfB)]+sample dfB conf c = Df.sample conf (c |> dfToDfConvInp dfB)++{- | Stall every valid Df packet with a given number of cycles. If there are+more valid packets than given numbers, passthrough all valid packets+without stalling. Not synthesizable.++For a generalized version of 'stall', check out 'stallC'.+-}+stall ::+  ( DfConv dfA+  , DfConv dfB+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  , FwdPayload dfA ~ FwdPayload dfB+  , HasCallStack+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  SimulationConfig ->+  {- | Acknowledgement to send when LHS does not send data. Stall will act+  transparently when reset is asserted.+  -}+  StallAck ->+  -- Number of cycles to stall for every valid Df packet+  [Int] ->+  Circuit dfA dfB+stall dfA dfB conf stallAck stalls =+  dfToDfConvInp dfA+    |> Df.stall conf stallAck stalls+    |> dfToDfConvOtp dfB++{- | Simulate a single domain protocol. Not synthesizable.++For a generalized version of 'simulate', check out+'Protocols.Experimental.Simulate.simulateC'.++You may notice that things seem to be "switched around" in this function+compared to others (the t'Circuit' has @Reverse@ applied to its right side,+rather than its left, and we take the @FwdPayload@ of @dfA@ rather than+@dfB@). This is because we are taking a t'Circuit' as a parameter, rather+than returning a t'Circuit' like most other functions do.+-}+simulate ::+  ( DfConv dfA+  , DfConv dfB+  , Dom dfA ~ Dom dfB+  , KnownDomain (Dom dfA)+  , HasCallStack+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  -- | Simulation configuration. Use 'Data.Default.def' for sensible defaults.+  SimulationConfig ->+  -- | Circuit to simulate.+  ( Clock (Dom dfA) ->+    Reset (Dom dfA) ->+    Enable (Dom dfA) ->+    Circuit dfA dfB+  ) ->+  -- | Inputs+  [Maybe (FwdPayload dfA)] ->+  -- | Outputs+  [Maybe (FwdPayload dfB)]+simulate dfA dfB conf circ = Df.simulate conf circ'+ where+  circ' clk rst en =+    withClockResetEnable clk rst en (dfToDfConvOtp dfA)+      |> circ clk rst en+      |> withClockResetEnable clk rst en (dfToDfConvInp dfB)++{- | Given behavior along the backward channel, turn an arbitrary 'DfConv'+circuit into an easily-testable 'Df' circuit representing the forward+channel. Behavior along the backward channel is specified by a @[Bool]@+(a list of acknowledges to provide), and a @[Maybe (BwdPayload dfB)]@ (a list+of data values to feed in).+-}+dfConvTestBench ::+  ( DfConv dfA+  , DfConv dfB+  , NFDataX (BwdPayload dfB)+  , ShowX (BwdPayload dfB)+  , Show (BwdPayload dfB)+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  [Bool] ->+  [Maybe (BwdPayload dfB)] ->+  Circuit dfA dfB ->+  Circuit+    (Df.Df (Dom dfA) (FwdPayload dfA))+    (Df.Df (Dom dfB) (FwdPayload dfB))+dfConvTestBench dfA dfB bwdAcks bwdPayload circ =+  mapCircuit (,()) P.fst P.fst (,())+    $ tupCircuits idC (ackCircuit dfA)+    |> toDfCircuit dfA+    |> circ+    |> fromDfCircuit dfB+    |> tupCircuits idC driveCircuit+ where+  ackCircuit ::+    Proxy dfA ->+    Circuit (Reverse ()) (Reverse (Df.Df (Dom dfA) (BwdPayload dfA)))+  ackCircuit _ =+    reverseCircuit+      $ Circuit+      $ P.const+        ( boolsToBwd (Proxy @(Df.Df _ _)) bwdAcks+        , ()+        )+  driveCircuit = reverseCircuit (driveC def bwdPayload)++{- | Given behavior along the forward channel, turn an arbitrary 'DfConv'+circuit into an easily-testable 'Df' circuit representing the backward+channel. Behavior along the forward channel is specified by a+@[Maybe (FwdPayload dfA)]@ (a list of data values to feed in), and a @[Bool]@+(a list of acknowledges to provide).+-}+dfConvTestBenchRev ::+  ( DfConv dfA+  , DfConv dfB+  , NFDataX (FwdPayload dfA)+  , ShowX (FwdPayload dfA)+  , Show (FwdPayload dfA)+  , Dom dfA ~ Dom dfB+  , HiddenClockResetEnable (Dom dfA)+  ) =>+  Proxy dfA ->+  Proxy dfB ->+  [Maybe (FwdPayload dfA)] ->+  [Bool] ->+  Circuit dfA dfB ->+  Circuit+    (Df.Df (Dom dfB) (BwdPayload dfB))+    (Df.Df (Dom dfA) (BwdPayload dfA))+dfConvTestBenchRev dfA dfB fwdPayload fwdAcks circ =+  mapCircuit ((),) P.snd P.snd ((),)+    $ reverseCircuit+    $ tupCircuits driveCircuit idC+    |> toDfCircuit dfA+    |> circ+    |> fromDfCircuit dfB+    |> tupCircuits (ackCircuit dfB) idC+ where+  driveCircuit = driveC def fwdPayload+  ackCircuit :: Proxy dfB -> Circuit (Df.Df (Dom dfB) (FwdPayload dfB)) ()+  ackCircuit _ =+    Circuit+      $ P.const+        ( boolsToBwd (Proxy @(Df.Df _ _)) fwdAcks+        , ()+        )
+ src/Protocols/Experimental/Hedgehog.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE UndecidableInstances #-}++{- |+A collection of Hedgehog helpers to test Circuit components. To test a+protocol component against a combinatorial model, see 'idWithModel'. To write+your own tester, see 'Test'.+-}+module Protocols.Experimental.Hedgehog (+  -- * Types+  ExpectOptions (..),+  defExpectOptions,+  StallMode (..),+  Test (..),+  TestType,++  -- * Test functions+  idWithModel,+  idWithModelSingleDomain,+  propWithModel,+  propWithModelSingleDomain,++  -- * Monadic test functions+  idWithModelT,+  idWithModelSingleDomainT,+  propWithModelT,+  propWithModelSingleDomainT,++  -- * Internals+  genStallAck,+  genStallMode,+  genStalls,+  expectedEmptyCycles,+) where++-- base+import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Proxy (Proxy (Proxy))+import GHC.Stack (HasCallStack)+import Prelude++-- clash-protocols+import Protocols+import Protocols.Experimental.Hedgehog.Internal+import Protocols.Experimental.Hedgehog.Types+import Protocols.Experimental.Simulate++-- clash-prelude+import Clash.Prelude qualified as C++-- clash-prelude-hedgehog+import Clash.Hedgehog.Sized.Vector (genVec)++-- hedgehog+import Hedgehog ((===))+import Hedgehog qualified as H+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++-- lifted-async+import Control.Concurrent.Async.Lifted++-- monad-control+import Control.Monad.Trans.Control (MonadBaseControl)++-- | Whether to stall or not. Used in 'idWithModel'.+data StallMode = NoStall | Stall+  deriving (Show, Enum, Bounded)++{- | Like 'C.resetGenN', but works on 'Int' instead of 'C.SNat'. Not+synthesizable.+-}+resetGen :: (C.KnownDomain dom) => Int -> C.Reset dom+resetGen n =+  C.unsafeFromActiveHigh+    (C.fromList (replicate n True <> repeat False))++{- | Attach a timeout to a property. Fails if the property does not finish in+the given time. The timeout is given in milliseconds.+-}+withTimeoutMs ::+  (MonadIO m, MonadBaseControl IO m) => Int -> H.PropertyT m a -> H.PropertyT m a+withTimeoutMs timeout v = do+  result <-+    race+      (liftIO $ threadDelay (timeout * 1000))+      v+  case result of+    Left () -> fail "Timeout exceeded"+    Right x -> pure x++{- | Test a protocol against a pure model implementation. Circuit under test will+be arbitrarily stalled on the left hand and right hand side and tested for+a number of properties:++  * Whether it does not produce too little data.+  * Whether it does not produce /more/ data than expected.+  * Whether it responds to backpressure correctly+  * Whether it (eventually) drives a /nack/ while in reset.++Finally, the data will be tested against the property supplied in the last+argument.+-}+propWithModel ::+  forall a b.+  (Test a, Test b, HasCallStack) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (ExpectType a -> ExpectType b) ->+  -- | Implementation+  Circuit a b ->+  {- | Property to test for. Function is given the data produced by the model+  as a first argument, and the sampled data as a second argument.+  -}+  (ExpectType b -> ExpectType b -> H.PropertyT IO ()) ->+  H.Property+propWithModel eOps gen model dut prop = H.property $ propWithModelT eOps gen model dut prop++{- |+Monadic version of 'propWithModel'.+Allows property-based protocol testing in any monad supporting 'MonadIO' and 'MonadBaseControl IO'.+This is useful for integrating with monadic test frameworks or when additional effects are needed during testing.+-}+propWithModelT ::+  forall a b m.+  (Test a, Test b, HasCallStack, Monad m, MonadIO m, MonadBaseControl IO m) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (ExpectType a -> ExpectType b) ->+  -- | Implementation+  Circuit a b ->+  {- | Property to test for. Function is given the data produced by the model+  as a first argument, and the sampled data as a second argument.+  -}+  (ExpectType b -> ExpectType b -> H.PropertyT m ()) ->+  H.PropertyT m ()+propWithModelT eOpts genData model prot prop =+  maybe id withTimeoutMs (eoTimeoutMs eOpts) $ do+    dat <- H.forAll genData+    when (eoTrace eOpts) $ liftIO $ putStr "propWithModel: dat: " >> print dat++    -- TODO: Different 'n's for each output+    n <- H.forAll (Gen.integral (Range.linear 0 (eoStallsMax eOpts)))+    when (eoTrace eOpts) $ liftIO $ putStr "propWithModel: n: " >> print n++    -- TODO: Different distributions?+    let+      genStall = Gen.int (Range.linear 1 eOpts.eoConsecutiveStalls)++    -- Generate stalls for LHS part of the protocol. The first line determines+    -- whether to stall or not. The second determines how many cycles to stall+    -- on each _valid_ cycle.+    lhsStallModes <- H.forAll (genVec genStallMode)+    when (eoTrace eOpts) $+      liftIO $+        putStr "propWithModel: lhsStallModes: " >> print lhsStallModes+    lhsStalls <- H.forAll (traverse (genStalls genStall n) lhsStallModes)+    when (eoTrace eOpts) $ liftIO $ putStr "propWithModel: lhsStalls: " >> print lhsStalls++    -- Generate stalls for RHS part of the protocol. The first line determines+    -- whether to stall or not. The second determines how many cycles to stall+    -- on each _valid_ cycle.+    rhsStallModes <- H.forAll (genVec genStallMode)+    when (eoTrace eOpts) $+      liftIO $+        putStr "propWithModel: rhsStallModes: " >> print rhsStallModes+    rhsStalls <- H.forAll (traverse (genStalls genStall n) rhsStallModes)+    when (eoTrace eOpts) $ liftIO $ putStr "propWithModel: rhsStalls: " >> print rhsStalls++    let+      simConfig = def{resetCycles = eoResetCycles eOpts}+      simDriveConfig =+        if eoDriveEarly eOpts+          then def{resetCycles = max 1 (eoResetCycles eOpts - 5)}+          else def{resetCycles = eoResetCycles eOpts}+      expected = model dat+      lhsStallC = stallC simConfig lhsStalls+      rhsStallC = stallC simConfig rhsStalls+      stalledProtocol =+        driveC simDriveConfig (toSimulateType (Proxy @a) dat)+          |> lhsStallC+          |> prot+          |> rhsStallC+      sampled = sampleC simConfig stalledProtocol++    -- expectN errors if circuit does not produce enough data+    trimmed <- expectN (Proxy @b) eOpts sampled++    when (eoTrace eOpts) $ liftIO $ putStrLn "propWithModel: before forcing trimmed.."+    _ <- H.evalNF trimmed+    when (eoTrace eOpts) $ liftIO $ putStrLn "propWithModel: before forcing expected.."+    _ <- H.evalNF expected++    when (eoTrace eOpts) $+      liftIO $+        putStrLn "propWithModel: executing property.."+    prop expected trimmed++{- | Test a protocol against a pure model implementation. Circuit under test will+be arbitrarily stalled on the left hand and right hand side and tested for+a number of properties:++  * Whether it does not produce too little data+  * Whether it does not produce /more/ data than expected+  * Whether the expected data corresponds to the sampled data+  * Whether it responds to backpressure correctly+  * Whether it (eventually) drives a /nack/ while in reset++For testing custom properties, see 'propWithModel'.+-}+idWithModel ::+  forall a b.+  (Test a, Test b, HasCallStack) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (ExpectType a -> ExpectType b) ->+  -- | Implementation+  Circuit a b ->+  H.Property+idWithModel eOpts genData model prot = H.property $ idWithModelT eOpts genData model prot++{- |+Monadic version of 'idWithModel'.+Runs the protocol-vs-model test using the default equality property (===) in any monad supporting 'MonadIO' and 'MonadBaseControl IO'.+Use this when you want to run the test in a monadic context or need additional effects.+-}+idWithModelT ::+  forall a b m.+  (Test a, Test b, HasCallStack, Monad m, MonadIO m, MonadBaseControl IO m) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (ExpectType a -> ExpectType b) ->+  -- | Implementation+  Circuit a b ->+  H.PropertyT m ()+idWithModelT eOpts genData model prot = propWithModelT eOpts genData model prot (===)++-- | Same as 'propWithModel', but with single clock, reset, and enable.+propWithModelSingleDomain ::+  forall dom a b.+  (Test a, Test b, C.KnownDomain dom, HasCallStack) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> ExpectType a -> ExpectType b) ->+  -- | Implementation+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> Circuit a b) ->+  {- | Property to test for. Function is given the data produced by the model+  as a first argument, and the sampled data as a second argument.+  -}+  (ExpectType b -> ExpectType b -> H.PropertyT IO ()) ->+  H.Property+propWithModelSingleDomain eOpts genData model dut prop =+  H.property $+    propWithModelSingleDomainT eOpts genData model dut prop++{- |+Monadic version of 'propWithModelSingleDomain'.+Allows property-based protocol testing for single-domain circuits in any monad supporting 'MonadIO' and 'MonadBaseControl IO'.+This is useful for monadic test integration or when effects are required during testing.+-}+propWithModelSingleDomainT ::+  forall dom a b m.+  ( Test a+  , Test b+  , C.KnownDomain dom+  , HasCallStack+  , Monad m+  , MonadIO m+  , MonadBaseControl IO m+  ) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> ExpectType a -> ExpectType b) ->+  -- | Implementation+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> Circuit a b) ->+  {- | Property to test for. Function is given the data produced by the model+  as a first argument, and the sampled data as a second argument.+  -}+  (ExpectType b -> ExpectType b -> H.PropertyT m ()) ->+  H.PropertyT m ()+propWithModelSingleDomainT eOpts genData model0 circuit0 =+  propWithModelT eOpts genData model1 circuit1+ where+  clk = C.clockGen+  rst = resetGen (eoResetCycles eOpts)+  ena = C.enableGen++  model1 = model0 clk rst ena+  circuit1 = circuit0 clk rst ena++-- | Same as 'propWithModel', but with single clock, reset, and enable.+idWithModelSingleDomain ::+  forall dom a b.+  (Test a, Test b, C.KnownDomain dom, HasCallStack) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> ExpectType a -> ExpectType b) ->+  -- | Implementation+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> Circuit a b) ->+  H.Property+idWithModelSingleDomain eOpts genData model0 circuit0 =+  H.property $+    idWithModelSingleDomainT eOpts genData model0 circuit0++{- |+Monadic version of 'idWithModelSingleDomain'.+Runs the single-domain protocol-vs-model test using the default equality property (===) in any monad supporting 'MonadIO' and 'MonadBaseControl IO'.+Use this for monadic test frameworks or when additional effects are needed.+-}+idWithModelSingleDomainT ::+  forall dom a b m.+  ( Test a+  , Test b+  , C.KnownDomain dom+  , HasCallStack+  , Monad m+  , MonadIO m+  , MonadBaseControl IO m+  ) =>+  -- | Options, see t'ExpectOptions'+  ExpectOptions ->+  -- | Test data generator+  H.Gen (ExpectType a) ->+  -- | Model+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> ExpectType a -> ExpectType b) ->+  -- | Implementation+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> Circuit a b) ->+  H.PropertyT m ()+idWithModelSingleDomainT eOpts genData model0 circuit0 =+  propWithModelSingleDomainT eOpts genData model0 circuit0 (===)++-- | Generator for 'StallMode'. Shrinks towards 'NoStall'.+genStallMode :: H.Gen StallMode+genStallMode = Gen.enumBounded++-- | Generator for 'StallMode'. Shrinks towards 'StallWithNack'.+genStallAck :: H.Gen StallAck+genStallAck = Gen.enumBounded++{- | Generator for stall information for 'stallC'. Generates stalls according+to distribution given in first argument. The second argument indicates how+many cycles the component is expecting / is producing data for. If the last+argument is 'NoStall', no stalls will be generated at all.+-}+genStalls :: H.Gen Int -> Int -> StallMode -> H.Gen (StallAck, [Int])+genStalls genInt n = \case+  NoStall -> (,[]) <$> genStallAck+  Stall -> (,) <$> genStallAck <*> Gen.list (Range.singleton n) genInt
+ src/Protocols/Experimental/Hedgehog/Internal.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Internals for "Protocols.Experimental.Hedgehog".+-}+module Protocols.Experimental.Hedgehog.Internal where++-- base+import Data.Proxy (Proxy (Proxy))+import GHC.Stack (HasCallStack)+import Prelude++-- clash-protocols+import Protocols.Experimental.Df qualified as DfExperimental+import Protocols.Experimental.Hedgehog.Types+import Protocols.Experimental.Simulate+import Protocols.Internal.TH++-- clash-prelude+import Clash.Prelude (type (*), type (+), type (<=))+import Clash.Prelude qualified as C++-- hedgehog+import Hedgehog qualified as H+import Hedgehog.Internal.Property qualified as H++{- | Conservative settings for t'ExpectOptions':+- Reset for 30 cycles+- Insert at most 10 stall moments+- Every stall moment is at most 10 cycles long+- Sample at most 1000 cycles+- Automatically derive when to stop sampling empty samples using `expectedEmptyCycles`.+-}+defExpectOptions :: ExpectOptions+defExpectOptions =+  ExpectOptions+    { -- XXX: These numbers are arbitrary, and should be adjusted to fit the+      --      protocol being tested. Annoyingly, upping these values will+      --      increase the time it takes to run the tests. This is because+      --      the test will run for at least the number of cycles specified+      --      in 'eoStopAfterEmpty'.+      eoStopAfterEmpty = Nothing+    , eoSampleMax = 1000+    , eoStallsMax = 10+    , eoConsecutiveStalls = 10+    , eoResetCycles = 30+    , eoDriveEarly = True+    , eoTimeoutMs = Nothing+    , eoTrace = False+    }++instance (TestType a, C.KnownDomain dom) => Test (DfExperimental.Df dom a) where+  expectN ::+    forall m.+    (HasCallStack, H.MonadTest m) =>+    Proxy (DfExperimental.Df dom a) ->+    ExpectOptions ->+    [Maybe a] ->+    m [a]+  expectN Proxy eOpts sampled = do+    go eOpts.eoSampleMax maxEmptyCycles sampled+   where+    maxEmptyCycles = expectedEmptyCycles eOpts+    go :: (HasCallStack) => Int -> Int -> [Maybe a] -> m [a]+    go _timeout _n [] =+      -- This really should not happen, protocols should produce data indefinitely+      error "unexpected end of signal"+    go 0 _ _ =+      -- Sample limit reached+      H.failWith+        Nothing+        ( "Sample limit reached after sampling "+            <> show eOpts.eoSampleMax+            <> " samples. "+            <> "Consider increasing 'eoSampleMax' in 'ExpectOptions'."+        )+    go _ 0 _ =+      -- Saw enough valid samples, return to user+      pure []+    go sampleTimeout _emptyTimeout (Just a : as) =+      -- Valid sample+      (a :) <$> go (sampleTimeout - 1) maxEmptyCycles as+    go sampleTimeout emptyTimeout (Nothing : as) =+      -- Empty sample+      go sampleTimeout (emptyTimeout - 1) as++instance+  ( Test a+  , C.KnownNat n+  , 1 <= (n * SimulateChannels a)+  , 1 <= n+  ) =>+  Test (C.Vec n a)+  where+  expectN ::+    forall m.+    (HasCallStack, H.MonadTest m) =>+    Proxy (C.Vec n a) ->+    ExpectOptions ->+    C.Vec n (SimulateFwdType a) ->+    m (C.Vec n (ExpectType a))+  -- TODO: This creates some pretty terrible error messages, as one+  -- TODO: simulate channel is checked at a time.+  expectN Proxy opts = mapM (expectN (Proxy @a) opts)++instance Test () where+  expectN _ _ _ = pure ()++instance+  ( Test a+  , Test b+  , 1 <= (SimulateChannels a + SimulateChannels b)+  ) =>+  Test (a, b)+  where+  expectN ::+    forall m.+    (HasCallStack, H.MonadTest m) =>+    Proxy (a, b) ->+    ExpectOptions ->+    (SimulateFwdType a, SimulateFwdType b) ->+    m (ExpectType a, ExpectType b)+  expectN Proxy opts (sampledA, sampledB) = do+    -- TODO: This creates some pretty terrible error messages, as one+    -- TODO: simulate channel is checked at a time.+    trimmedA <- expectN (Proxy @a) opts sampledA+    trimmedB <- expectN (Proxy @b) opts sampledB+    pure (trimmedA, trimmedB)++-- XXX: We only generate up to 9 tuples instead of maxTupleSize because NFData+-- instances are only available up to 9-tuples.+-- see https://hackage.haskell.org/package/deepseq-1.5.1.0/docs/src/Control.DeepSeq.html#line-1125+testTupleInstances 3 9
+ src/Protocols/Experimental/Hedgehog/Types.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_HADDOCK hide #-}++-- These types should be re-exported from the Protocols.Experimental.Hedgehog module+module Protocols.Experimental.Hedgehog.Types where++-- deepseq+import Control.DeepSeq++import Clash.Prelude qualified as C+import Data.Maybe (fromMaybe)+import Data.Proxy+import GHC.Stack (HasCallStack)+import Protocols.Experimental.Simulate.Types++-- hedgehog+import Hedgehog qualified as H++-- | Superclass class to reduce syntactical noise.+class (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a++instance (NFData a, C.NFDataX a, C.ShowX a, C.Show a, Eq a) => TestType a++-- | Options for 'expectN' function. See individual fields for more information.+data ExpectOptions = ExpectOptions+  { eoStopAfterEmpty :: Maybe Int+  {- ^ Explicitly control the number of samples empty samples simulate before we stop+  the simulation. When set to `Nothing`, this is derived using `expectedEmptyCycles`.+  -}+  , eoSampleMax :: Int+  {- ^ Produce an error if the circuit produces more than /n/ valid samples. This+  is used to terminate (potentially) infinitely running circuits.+  -}+  , eoStallsMax :: Int+  -- ^ Generate at most /n/ stall moments of zero or more cycles(set by 'eoConsecutiveStalls').+  , eoConsecutiveStalls :: Int+  -- ^ Maximum number of consecutive stalls that are allowed to be inserted.+  , eoResetCycles :: Int+  -- ^ Ignore first /n/ cycles+  , eoDriveEarly :: Bool+  {- ^ Start driving the circuit with its reset asserted. Circuits should+  never acknowledge data while this is happening.+  -}+  , eoTimeoutMs :: Maybe Int+  -- ^ Terminate the test after /n/ milliseconds.+  , eoTrace :: Bool+  -- ^ Trace data generation for debugging purposes+  }++-- | Default derivation of `eoStopAfterEmpty` when it is set to `Nothing`.+expectedEmptyCycles :: ExpectOptions -> Int+expectedEmptyCycles eOpts =+  -- +2 on `eoStallsMax` to account worst case left side stalling + right side stalling+  -- +1 on `eoConsecutiveStalls` to consume 1 sample after stalling+  -- +100 arbitrarily chosen to allow the circuit to have some internal latency.+  fromMaybe+    (eOpts.eoStallsMax * (eOpts.eoConsecutiveStalls + 1) + eOpts.eoResetCycles + 100)+    eOpts.eoStopAfterEmpty++{- | Provides a way of comparing expected data with data produced by a+protocol component.+-}+class+  ( Drivable a+  , TestType (SimulateFwdType a)+  , TestType (ExpectType a)+  ) =>+  Test a+  where+  {- | Trim each channel to the lengths given as the third argument. See+  result documentation for failure modes.+  -}+  expectN ::+    (HasCallStack, H.MonadTest m) =>+    Proxy a ->+    -- | Options, see t'ExpectOptions'+    ExpectOptions ->+    -- | Raw sampled data+    SimulateFwdType a ->+    {- | Depending on "ExpectOptions", fails the test if:++    * Circuit produced less data than expected+    * Circuit produced more data than expected++    If it does not fail, /SimulateFwdType a/ will contain exactly the number+    of expected data packets.++    TODO:+    Should probably return a 'Vec (SimulateChannels) Failures'+    in order to produce pretty reports.+    -}+    m (ExpectType a)
+ src/Protocols/Experimental/PacketStream.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Experimental simulation and generic Hedgehog support for "Protocols.PacketStream".+-}+module Protocols.Experimental.PacketStream (+  module Protocols.PacketStream,+) where++import Clash.Prelude+import Control.DeepSeq (NFData)+import Data.Maybe qualified as Maybe+import Data.Proxy+import Prelude hiding (head)++import Protocols.Experimental.Df qualified as Df+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog (Test (..))+import Protocols.Experimental.Simulate+import Protocols.PacketStream++instance Backpressure (PacketStream dom dataWidth meta) where+  boolsToBwd _ = fromList_lazy . fmap PacketStreamS2M++instance+  (KnownDomain dom) =>+  Simulate (PacketStream dom dataWidth meta)+  where+  type+    SimulateFwdType (PacketStream dom dataWidth meta) =+      [Maybe (PacketStreamM2S dataWidth meta)]+  type SimulateBwdType (PacketStream dom dataWidth meta) = [PacketStreamS2M]+  type SimulateChannels (PacketStream dom dataWidth meta) = 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 $+      DfConv.stall Proxy Proxy conf stallAck stalls++instance+  (KnownDomain dom) =>+  Drivable (PacketStream dom dataWidth meta)+  where+  type+    ExpectType (PacketStream dom dataWidth meta) =+      [PacketStreamM2S dataWidth meta]++  toSimulateType Proxy = fmap Just+  fromSimulateType Proxy = Maybe.catMaybes++  driveC conf vals =+    withClockResetEnable clockGen resetGen enableGen $+      DfConv.drive Proxy conf vals+  sampleC conf ckt =+    withClockResetEnable clockGen resetGen enableGen $+      DfConv.sample Proxy conf ckt++instance+  ( KnownNat dataWidth+  , NFDataX meta+  , NFData meta+  , ShowX meta+  , Show meta+  , Eq meta+  , KnownDomain dom+  ) =>+  Test (PacketStream dom dataWidth meta)+  where+  expectN Proxy options sampled =+    expectN (Proxy @(Df.Df dom _)) options sampled
+ src/Protocols/Experimental/Simulate.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Experimental protocol-agnostic simulation support.++This module contains the generic simulation classes and helpers that used to be+part of the default "Protocols" import surface. New tests should prefer+protocol-specific drivers and checkers over adding more assumptions here.+-}+module Protocols.Experimental.Simulate (+  module Protocols.Experimental.Simulate.Types,+  simulateC,+  simulateCS,+  simulateCSE,+  simulateCircuit,+  def,+) where++import Clash.Explicit.Prelude qualified as CE+import Clash.Prelude (type (*), type (+))+import Clash.Prelude qualified as C+import Data.Default (Default (def))+import Data.Proxy+import Data.Tuple (swap)++import Protocols.Experimental.Simulate.Types+import Protocols.Internal+import Protocols.Internal.TH (+  backPressureTupleInstances,+  drivableTupleInstances,+  simulateTupleInstances,+ )+import Protocols.Plugin.Cpp (maxTupleSize)++{- $setup+>>> import Protocols+>>> import Protocols.Experimental.Df+>>> import Protocols.Experimental.Simulate+-}++instance Backpressure () where+  boolsToBwd _ _ = ()++instance (Backpressure a, Backpressure b) => Backpressure (a, b) where+  boolsToBwd _ bs = (boolsToBwd (Proxy @a) bs, boolsToBwd (Proxy @b) bs)++backPressureTupleInstances 3 maxTupleSize++instance (C.KnownNat n, Backpressure a) => Backpressure (C.Vec n a) where+  boolsToBwd _ bs = C.repeat (boolsToBwd (Proxy @a) bs)++instance Backpressure (CSignal dom a) where+  boolsToBwd _ _ = ()++instance Simulate () where+  type SimulateFwdType () = ()+  type SimulateBwdType () = ()+  type SimulateChannels () = 0++  simToSigFwd _ = id+  simToSigBwd _ = id+  sigToSimFwd _ = id+  sigToSimBwd _ = id++  stallC _ _ = idC++instance Drivable () where+  type ExpectType () = ()++  toSimulateType Proxy () = ()+  fromSimulateType Proxy () = ()++  driveC _ _ = idC+  sampleC _ _ = ()++instance (Simulate a, Simulate b) => Simulate (a, b) where+  type SimulateFwdType (a, b) = (SimulateFwdType a, SimulateFwdType b)+  type SimulateBwdType (a, b) = (SimulateBwdType a, SimulateBwdType b)+  type SimulateChannels (a, b) = SimulateChannels a + SimulateChannels b++  simToSigFwd Proxy ~(fwdsA, fwdsB) = (simToSigFwd (Proxy @a) fwdsA, simToSigFwd (Proxy @b) fwdsB)+  simToSigBwd Proxy ~(bwdsA, bwdsB) = (simToSigBwd (Proxy @a) bwdsA, simToSigBwd (Proxy @b) bwdsB)+  sigToSimFwd Proxy ~(fwdSigA, fwdSigB) = (sigToSimFwd (Proxy @a) fwdSigA, sigToSimFwd (Proxy @b) fwdSigB)+  sigToSimBwd Proxy ~(bwdSigA, bwdSigB) = (sigToSimBwd (Proxy @a) bwdSigA, sigToSimBwd (Proxy @b) bwdSigB)++  stallC conf stalls =+    let+      (stallsL, stallsR) = C.splitAtI @(SimulateChannels a) @(SimulateChannels b) stalls+      Circuit stalledL = stallC @a conf stallsL+      Circuit stalledR = stallC @b conf stallsR+     in+      Circuit $ \(~((fwdL0, fwdR0), (bwdL0, bwdR0))) ->+        let+          (fwdL1, bwdL1) = stalledL (fwdL0, bwdL0)+          (fwdR1, bwdR1) = stalledR (fwdR0, bwdR0)+         in+          ((fwdL1, fwdR1), (bwdL1, bwdR1))++simulateTupleInstances 3 maxTupleSize++instance (Drivable a, Drivable b) => Drivable (a, b) where+  type ExpectType (a, b) = (ExpectType a, ExpectType b)++  toSimulateType Proxy (t1, t2) =+    ( toSimulateType (Proxy @a) t1+    , toSimulateType (Proxy @b) t2+    )++  fromSimulateType Proxy (t1, t2) =+    ( fromSimulateType (Proxy @a) t1+    , fromSimulateType (Proxy @b) t2+    )++  driveC conf (fwd1, fwd2) =+    let (Circuit f1, Circuit f2) = (driveC @a conf fwd1, driveC @b conf fwd2)+     in Circuit (\(_, ~(bwd1, bwd2)) -> ((), (snd (f1 ((), bwd1)), snd (f2 ((), bwd2)))))++  sampleC conf (Circuit f) =+    let+      bools = replicate (resetCycles conf) False <> repeat True+      (_, (fwd1, fwd2)) = f ((), (boolsToBwd (Proxy @a) bools, boolsToBwd (Proxy @b) bools))+     in+      ( sampleC @a conf (Circuit $ \_ -> ((), fwd1))+      , sampleC @b conf (Circuit $ \_ -> ((), fwd2))+      )++drivableTupleInstances 3 maxTupleSize++instance (Simulate a) => Simulate (Reverse a) where+  type SimulateFwdType (Reverse a) = SimulateBwdType a+  type SimulateBwdType (Reverse a) = SimulateFwdType a+  type SimulateChannels (Reverse a) = SimulateChannels a++  simToSigFwd Proxy = simToSigBwd (Proxy @a)+  simToSigBwd Proxy = simToSigFwd (Proxy @a)+  sigToSimFwd Proxy = sigToSimBwd (Proxy @a)+  sigToSimBwd Proxy = sigToSimFwd (Proxy @a)++  stallC conf stalls =+    let Circuit stalled = stallC @a conf stalls+     in Circuit $ \(fwd, bwd) -> swap (stalled (bwd, fwd))++instance (CE.KnownNat n, Simulate a) => Simulate (C.Vec n a) where+  type SimulateFwdType (C.Vec n a) = C.Vec n (SimulateFwdType a)+  type SimulateBwdType (C.Vec n a) = C.Vec n (SimulateBwdType a)+  type SimulateChannels (C.Vec n a) = n * SimulateChannels a++  simToSigFwd Proxy = C.map (simToSigFwd (Proxy @a))+  simToSigBwd Proxy = C.map (simToSigBwd (Proxy @a))+  sigToSimFwd Proxy = C.map (sigToSimFwd (Proxy @a))+  sigToSimBwd Proxy = C.map (sigToSimBwd (Proxy @a))++  stallC conf stalls0 =+    let+      stalls1 = C.unconcatI @n @(SimulateChannels a) stalls0+      stalled = C.map (toSignals . stallC @a conf) stalls1+     in+      Circuit $ \(fwds, bwds) -> C.unzip (C.zipWith ($) stalled (C.zip fwds bwds))++instance (C.KnownNat n, Drivable a) => Drivable (C.Vec n a) where+  type ExpectType (C.Vec n a) = C.Vec n (ExpectType a)++  toSimulateType Proxy = C.map (toSimulateType (Proxy @a))+  fromSimulateType Proxy = C.map (fromSimulateType (Proxy @a))++  driveC conf fwds =+    let circuits = C.map (($ ()) . curry . (toSignals @_ @a) . driveC conf) fwds+     in Circuit (\(_, bwds) -> ((), C.map snd (C.zipWith ($) circuits bwds)))++  sampleC conf (Circuit f) =+    let+      bools = replicate (resetCycles conf) False <> repeat True+      (_, fwds) = f ((), (C.repeat (boolsToBwd (Proxy @a) bools)))+     in+      C.map (\fwd -> sampleC @a conf (Circuit $ \_ -> ((), fwd))) fwds++instance (C.KnownDomain dom) => Simulate (CSignal dom a) where+  type SimulateFwdType (CSignal dom a) = [a]+  type SimulateBwdType (CSignal dom a) = ()+  type SimulateChannels (CSignal dom a) = 1++  simToSigFwd Proxy list = C.fromList_lazy list+  simToSigBwd Proxy () = ()+  sigToSimFwd Proxy sig = C.sample_lazy sig+  sigToSimBwd Proxy _ = ()++  stallC _ _ = idC++instance (C.NFDataX a, C.ShowX a, Show a, C.KnownDomain dom) => Drivable (CSignal dom a) where+  type ExpectType (CSignal dom a) = [a]++  toSimulateType Proxy = id+  fromSimulateType Proxy = id++  driveC _conf [] = error "CSignal.driveC: Can't drive with empty list"+  driveC SimulationConfig{resetCycles} fwd0@(f : _) =+    let fwd1 = C.fromList_lazy (replicate resetCycles f <> fwd0 <> repeat f)+     in Circuit (\_ -> ((), fwd1))++  sampleC SimulationConfig{resetCycles, ignoreReset, timeoutAfter} (Circuit f) =+    let sampled = CE.sampleN_lazy timeoutAfter (snd (f ((), ())))+     in if ignoreReset then drop resetCycles sampled else sampled++{- | Simulate a circuit. Includes samples while reset is asserted.+Not synthesizable.++To figure out what input you need to supply, either solve the type+"SimulateFwdType" manually, or let the repl do the work for you! Example:++>>> :kind! (forall dom a. SimulateFwdType (Df dom a))+...+= [Maybe a]++This would mean a @Circuit (Df dom a) (Df dom b)@ would need+@[Maybe a]@ as the last argument of 'simulateC' and would result in+@[Maybe b]@. Note that for this particular type you can neither supply+stalls nor introduce backpressure. If you want to do this use+'Protocols.Experimental.Df.stall'.+-}+simulateC ::+  forall a b.+  (Drivable a, Drivable b) =>+  -- | Circuit to simulate+  Circuit a b ->+  {- | Simulation configuration. Note that some options only apply to 'sampleC'+  and some only to 'driveC'.+  -}+  SimulationConfig ->+  -- | Circuit input+  SimulateFwdType a ->+  -- | Circuit output+  SimulateFwdType b+simulateC c conf as =+  sampleC conf (driveC conf as |> c)++{- | Like 'simulateC', but does not allow caller to control and observe+backpressure. Furthermore, it ignores all data produced while the reset is+asserted.++Example:++>>> import qualified Protocols.Df as Df+>>> take 2 (simulateCS (Df.catMaybes @C.System @Int) [Nothing, Just 1, Nothing, Just 3])+[1,3]+-}+simulateCS ::+  forall a b.+  (Drivable a, Drivable b) =>+  -- | Circuit to simulate+  Circuit a b ->+  -- | Circuit input+  ExpectType a ->+  -- | Circuit output+  ExpectType b+simulateCS c =+  fromSimulateType (Proxy @b)+    . simulateC c def{ignoreReset = True}+    . toSimulateType (Proxy @a)++-- | Like 'simulateCS', but takes a circuit expecting a clock, reset, and enable.+simulateCSE ::+  forall dom a b.+  (Drivable a, Drivable b, C.KnownDomain dom) =>+  -- | Circuit to simulate+  (C.Clock dom -> C.Reset dom -> C.Enable dom -> Circuit a b) ->+  -- | Circuit input+  ExpectType a ->+  -- | Circuit output+  ExpectType b+simulateCSE c = simulateCS (c clk rst ena)+ where+  clk = C.clockGen+  rst = resetGen (resetCycles def)+  ena = C.enableGen++  resetGen n =+    C.unsafeFromActiveHigh $+      C.fromList (replicate n True <> repeat False)++{- | Applies conversion functions defined in the 'Simulate' instance of @a@ and+@b@ to the given simulation types, and applies the results to the internal+function of the given t'Circuit'. The resulting internal types are converted to+the simulation types.+-}+simulateCircuit ::+  forall a b.+  (Simulate a, Simulate b) =>+  SimulateFwdType a ->+  SimulateBwdType b ->+  Circuit a b ->+  (SimulateBwdType a, SimulateFwdType b)+simulateCircuit fwds bwds circ =+  (sigToSimBwd (Proxy @a) bwdSig, sigToSimFwd (Proxy @b) fwdSig)+ where+  (bwdSig, fwdSig) =+    toSignals circ $+      (simToSigFwd (Proxy @a) fwds, simToSigBwd (Proxy @b) bwds)
+ src/Protocols/Experimental/Simulate/Types.hs view
@@ -0,0 +1,192 @@+module Protocols.Experimental.Simulate.Types where++import Clash.Prelude qualified as C+import Data.Default (Default (..))+import Data.Proxy+import GHC.Base (Type)+import Protocols.Plugin++{- $setup+>>> import Protocols+>>> import Protocols.Experimental.Simulate+-}++-- | Conversion from booleans to protocol specific acknowledgement values.+class (Protocol a) => Backpressure a where+  {- | Interpret list of booleans as a list of acknowledgements at every cycle.+  Implementations don't have to account for finite lists.+  -}+  boolsToBwd :: Proxy a -> [Bool] -> Bwd a++{- | Specifies option for simulation functions. Don't use this constructor+directly, as it may be extend with other options in the future. Use 'def'+instead.+-}+data SimulationConfig = SimulationConfig+  { resetCycles :: Int+  {- ^ Assert reset for a number of cycles before driving the protocol++  Default: 100+  -}+  , timeoutAfter :: Int+  {- ^ Timeout after /n/ cycles. Only affects sample functions.++  Default: 'maxBound'+  -}+  , ignoreReset :: Bool+  {- ^ Ignore cycles while in reset (sampleC)++  Default: False+  -}+  }+  deriving (Show)++instance Default SimulationConfig where+  def =+    SimulationConfig+      { resetCycles = 100+      , timeoutAfter = maxBound+      , ignoreReset = False+      }++{- | Determines what kind of acknowledgement signal 'stallC' will send when its+input component is not sending any data. Note that, in the Df protocol,+protocols may send arbitrary acknowledgement signals when this happens.+-}+data StallAck+  = -- | Send Nack+    StallWithNack+  | -- | Send Ack+    StallWithAck+  | -- | Send @errorX "No defined ack"@+    StallWithErrorX+  | -- | Passthrough acknowledgement of RHS component+    StallTransparently+  | -- | Cycle through all modes+    StallCycle+  deriving (Eq, Bounded, Enum, Show)++{- | Class that defines how to /drive/, /sample/, and /stall/ a "Circuit" of+some shape. The "Backpressure" instance requires that the /backward/ type of the+circuit can be generated from a list of Booleans.+-}+class (C.KnownNat (SimulateChannels a), Backpressure a, Simulate a) => Drivable a where+  -- TODO: documentatie verplaatsen+  -- Type a /Circuit/ driver needs or sampler yields. For example:+  --+  -- >>> :kind! (forall dom a. SimulateFwdType (Df dom a))+  -- ...+  -- = [Data a]+  --+  -- This means sampling a @Circuit () (Df dom a)@ with 'sampleC' yields+  -- @[Data a]@.++  {- | Similar to 'SimulateFwdType', but without backpressure information. For+  example:++  >>> :kind! (forall dom a. ExpectType (Df dom a))+  ...+  = [a]++  Useful in situations where you only care about the "pure functionality" of+  a circuit, not its timing information. Leveraged by various functions+  in "Protocols.Experimental.Hedgehog" and 'Protocols.Experimental.Simulate.simulateCS'.+  -}+  type ExpectType a :: Type++  {- | Convert a /ExpectType a/, a type representing data without backpressure,+  into a type that does, /SimulateFwdType a/.+  -}+  toSimulateType ::+    -- | Type witness+    Proxy a ->+    -- | Expect type: input for a protocol /without/ stall information+    ExpectType a ->+    -- | Expect type: input for a protocol /with/ stall information+    SimulateFwdType a++  {- | Convert a /ExpectType a/, a type representing data without backpressure,+  into a type that does, /SimulateFwdType a/.+  -}+  fromSimulateType ::+    -- | Type witness+    Proxy a ->+    -- | Expect type: input for a protocol /with/ stall information+    SimulateFwdType a ->+    -- | Expect type: input for a protocol /without/ stall information+    ExpectType a++  {- | Create a /driving/ circuit. Can be used in combination with 'sampleC'+  to simulate a circuit. Related: 'Protocols.Experimental.Simulate.simulateC'.+  -}+  driveC ::+    SimulationConfig ->+    SimulateFwdType a ->+    Circuit () a++  {- | Sample a circuit that is trivially drivable. Use 'driveC'  to create+  such a circuit. Related: 'Protocols.Experimental.Simulate.simulateC'.+  -}+  sampleC ::+    SimulationConfig ->+    Circuit () a ->+    SimulateFwdType a++{- | Defines functions necessary for implementation of the+'Protocols.Experimental.Simulate.simulateCircuit' function. This kind of+simulation requires a lists for both the forward and the backward direction.++This class requires the definition of the types that the test supplies and+returns. Its functions are converters from these /simulation types/ to types on+the 'Clash.Signal.Signal' level. The+'Protocols.Experimental.Simulate.simulateCircuit' function can thus receive the+necessary simulation types, convert them to types on the 'Clash.Signal.Signal'+level, pass those signals to the circuit, and convert the result of the circuit+back to the simulation types giving the final result.+-}+class (C.KnownNat (SimulateChannels a), Protocol a) => Simulate a where+  {- | The type that a test must provide to the+  'Protocols.Experimental.Simulate.simulateCircuit' function in the forward+  direction. Usually this is some sort of list.+  -}+  type SimulateFwdType a :: Type++  {- | The type that a test must provide to the+  'Protocols.Experimental.Simulate.simulateCircuit' function in the backward+  direction. Usually this is some sort of list+  -}+  type SimulateBwdType a :: Type++  {- | The number of simulation channels this channel has after flattening it.+  For example, @(Df dom a, Df dom a)@ has 2, while+  @Vec 4 (Df dom a, Df dom a)@ has 8.+  -}+  type SimulateChannels a :: C.Nat++  -- | Convert the forward simulation type to the 'Fwd' of @a@.+  simToSigFwd :: Proxy a -> SimulateFwdType a -> Fwd a++  -- | Convert the backward simulation type to the 'Bwd' of @a@.+  simToSigBwd :: Proxy a -> SimulateBwdType a -> Bwd a++  -- | Convert a signal of type @Bwd a@ to the backward simulation type.+  sigToSimFwd :: Proxy a -> Fwd a -> SimulateFwdType a++  -- | Convert a signal of type @Fwd a@ to the forward simulation type.+  sigToSimBwd :: Proxy a -> Bwd a -> SimulateBwdType a++  {- | Create a /stalling/ circuit. For each simulation channel (see+  'SimulateChannels') a tuple determines how the component stalls:++  * 'StallAck': determines how the backward (acknowledgement) channel+    should behave whenever the component does not receive data from the+    left hand side or when it's intentionally stalling.++  * A list of 'Int's that determine how many stall cycles to insert on+    every cycle the left hand side component produces data. I.e., stalls+    are /not/ inserted whenever the left hand side does /not/ produce data.+  -}+  stallC ::+    SimulationConfig ->+    C.Vec (SimulateChannels a) (StallAck, [Int]) ->+    Circuit a a
+ src/Protocols/Experimental/Wishbone.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Types modelling the Wishbone bus protocol.+-}+module Protocols.Experimental.Wishbone where++import Clash.Prelude (Nat, (:::))+import Prelude hiding (head, not, (&&))++import Clash.Signal.Internal (Signal (..))+import Control.DeepSeq (NFData)+import Protocols+import Protocols.Idle++import Clash.Prelude qualified as C++-- | Data communicated from a Wishbone Master to a Wishbone Slave+data WishboneM2S addressBits dataBytes = WishboneM2S+  { addr :: "ADR" ::: C.BitVector addressBits+  {- ^ The address output array [ADR_O()] is used to pass a binary address. The higher array+  boundary is specific to the address width of the core, and the lower array boundary is+  determined by the data port size and granularity. For example the array size on a 32-bit+  data port with BYTE granularity is [ADR_O(n..2)]. In some cases (such as FIFO+  interfaces) the array may not be present on the interface.+  -}+  , writeData :: "DAT_MOSI" ::: C.BitVector (dataBytes C.* 8)+  {- ^ The data output array [DAT_O()] is used to pass binary data. The array boundaries are+  determined by the port size, with a maximum port size of 64-bits (e.g. [DAT_I(63..0)]).+  -}+  , busSelect :: "SEL" ::: C.BitVector dataBytes+  {- ^ The select output array [SEL_O()] indicates where valid data is expected on the [DAT_I()]+  signal array during READ cycles, and where it is placed on the [DAT_O()] signal array+  during WRITE cycles. The array boundaries are determined by the granularity of a port.+  For example, if 8-bit granularity is used on a 64-bit port, then there would be an array of+  eight select signals with boundaries of [SEL_O(7..0)]. Each individual select signal+  correlates to one of eight active bytes on the 64-bit data port.+  -}+  , lock :: "LOCK" ::: Bool+  {- ^ The lock output [LOCK_O] when asserted, indicates that the current bus cycle is+  uninterruptible. Lock is asserted to request complete ownership of the bus. Once the+  transfer has started, the INTERCON does not grant the bus to any other MASTER, until+  the current MASTER negates [LOCK_O] or [CYC_O].+  -}+  , busCycle :: "CYC" ::: Bool+  {- ^ The cycle output [CYC_O], when asserted, indicates that a valid bus cycle is in progress.+  The signal is asserted for the duration of all bus cycles. For example, during a BLOCK+  transfer cycle there can be multiple data transfers. The [CYC_O] signal is asserted during+  the first data transfer, and remains asserted until the last data transfer. The [CYC_O]+  signal is useful for interfaces with multi-port interfaces (such as dual port memories). In+  these cases, the [CYC_O] signal requests use of a common bus from an arbiter.+  -}+  , strobe :: "STB" ::: Bool+  {- ^ The strobe output [STB_O] indicates a valid data transfer cycle. It is used to qualify+  various other signals on the interface such as [SEL_O()]. The SLAVE asserts either the+  [ACK_I], [ERR_I] or [RTY_I] signals in response to every assertion of the [STB_O] signal.+  -}+  , writeEnable :: "WE" ::: Bool+  {- ^ The write enable output [WE_O] indicates whether the current local bus cycle is a READ+  or WRITE cycle. The signal is negated during READ cycles, and is asserted during WRITE+  cycles.+  -}+  , cycleTypeIdentifier :: "CTI" ::: CycleTypeIdentifier+  {- ^ The Cycle Type Identifier [CTI_IO()] Address Tag provides additional information+  about the current cycle. The MASTER sends this information to the SLAVE. The SLAVE+  can use this information to prepare the response for the next cycle.+  -}+  , burstTypeExtension :: "BTE" ::: BurstTypeExtension+  {- ^ The Burst Type Extension [BTE_O()] Address Tag is sent by the MASTER to the+  SLAVE to provide additional information about the current burst. Currently this+  information is only relevant for incrementing bursts, but future burst types may use these+  signals.+  -}+  }+  deriving (NFData, C.Generic, C.NFDataX, Eq, C.BitPack)++instance+  (C.KnownNat addressBits, C.KnownNat dataBytes) =>+  C.ShowX (WishboneM2S addressBits dataBytes)+  where+  showX = show++-- Compact printing for M2S values. This handles undefined values in the+-- structure too.+instance+  (C.KnownNat addressBits, C.KnownNat dataBytes) =>+  Show (WishboneM2S addressBits dataBytes)+  where+  show WishboneM2S{..} =+    "WishboneM2S [ "+      <> prefix busCycle+      <> "CYC "+      <> prefix strobe+      <> "STB "+      <> prefix writeEnable+      <> "WE, "+      <> "ADR = "+      <> C.showX addr+      <> ", "+      <> "DAT = "+      <> C.showX writeData+      <> ", "+      <> "SEL = "+      <> C.showX busSelect+      <> ", "+      <> "CTI = "+      <> cycle'+      <> ", "+      <> "BTE = "+      <> burst+      <> " ]"+   where+    prefix True = " "+    prefix False = "!"++    burst = case burstTypeExtension of+      LinearBurst -> "linear"+      Beat4Burst -> "beat 4"+      Beat8Burst -> "beat 8"+      Beat16Burst -> "beat 16"++    cycle' = case cycleTypeIdentifier of+      Classic -> "classic"+      ConstantAddressBurst -> "constant addr"+      IncrementingBurst -> "incrementing"+      EndOfBurst -> "end-of-burst"+      CycleTypeIdentifier val -> "reserved (" <> C.showX val <> ")"++-- | Data communicated from a Wishbone Slave to a Wishbone Master+data WishboneS2M dataBytes = WishboneS2M+  { readData :: "DAT_MISO" ::: C.BitVector (dataBytes C.* 8)+  {- ^ The data output array [DAT_O()] is used to pass binary data. The array boundaries are+  determined by the port size, with a maximum port size of 64-bits (e.g. [DAT_I(63..0)]).+  -}+  , acknowledge :: "ACK" ::: Bool+  {- ^ The acknowledge output [ACK_O], when asserted, indicates the termination of a normal+  bus cycle. Also see the [ERR_O] and [RTY_O] signal descriptions.+  -}+  , err :: "ERR" ::: Bool+  {- ^ The error output [ERR_O] indicates an abnormal cycle termination. The source of the+  error, and the response generated by the MASTER is defined by the IP core supplier. Also+  see the [ACK_O] and [RTY_O] signal descriptions.+  -}+  , stall :: "STALL" ::: Bool+  {- ^ The pipeline stall signal [STALL_O] indicates that the slave cannot accept additional+  transactions in its queue.+  This signal is used in pipelined mode+  -}+  , retry :: "RTY" ::: Bool+  {- ^ The retry output [RTY_O] indicates that the interface is not ready to+  accept or send data, and that the cycle should be retried. When and how the cycle is retried+  is defined by the IP core supplier. Also see the [ERR_O] and [RTY_O] signal descriptions.+  -}+  }+  deriving (NFData, C.Generic, C.NFDataX, Eq, C.BitPack)++instance (C.KnownNat dataBytes) => C.ShowX (WishboneS2M dataBytes) where+  showX = show++-- Compact printing for S2M values. This handles undefined values in the+-- structure too.+instance (C.KnownNat dataBytes) => Show (WishboneS2M dataBytes) where+  show WishboneS2M{..} =+    "WishboneS2M [ "+      <> prefix acknowledge+      <> "ACK "+      <> prefix err+      <> "ERR "+      <> prefix stall+      <> "STALL "+      <> prefix retry+      <> "RETRY, "+      <> "DAT = "+      <> C.showX readData+      <> " ]"+   where+    prefix True = " "+    prefix False = "!"++{- | Identifier for different types of cycle-modes, used to potentially+  increase throughput by reducing handshake-overhead+-}+newtype CycleTypeIdentifier = CycleTypeIdentifier (C.BitVector 3)+  deriving stock (Eq, Show, C.Generic)+  deriving anyclass (NFData, C.NFDataX, C.ShowX, C.BitPack)++pattern+  Classic+  , ConstantAddressBurst+  , IncrementingBurst+  , EndOfBurst ::+    CycleTypeIdentifier++-- | Classic Wishbone cycle type+pattern Classic = CycleTypeIdentifier 0++-- | Burst Wishbone cycle using a constant address (and operation)+pattern ConstantAddressBurst = CycleTypeIdentifier 1++-- | Burst incrementing the address based on burst-types+pattern IncrementingBurst = CycleTypeIdentifier 2++-- | Cycle-Type-Identifier signalling the end of a non-classic cycle+pattern EndOfBurst = CycleTypeIdentifier 7++-- | Burst-mode types when 'IncrementingBurst' cycle type is used+data BurstTypeExtension+  = -- | Linear address-increase+    LinearBurst+  | -- | Wrap-4, address LSBs are modulo 4+    Beat4Burst+  | -- | Wrap-8, address LSBs are modulo 8+    Beat8Burst+  | -- | Wrap-16, address LSBs are modulo 16+    Beat16Burst+  deriving (NFData, C.Generic, C.NFDataX, Show, C.ShowX, Eq, C.BitPack)++-- | Wishbone protocol mode that a component operates in+data WishboneMode+  = -- | Standard mode, generally using a "wait-for-ack" approach+    Standard+  | -- | Pipelined mode, generally allowing for more asynchronous requests+    Pipelined+  deriving (C.Generic, Show, Eq)++-- | The Wishbone protocol (http://cdn.opencores.org/downloads/wbspec_b4.pdf)+data+  Wishbone+    (dom :: C.Domain)+    (mode :: WishboneMode)+    (addressBits :: Nat)+    (dataBytes :: Nat)++instance Protocol (Wishbone dom mode addressBits dataBytes) where+  type+    Fwd (Wishbone dom mode addressBits dataBytes) =+      Signal dom (WishboneM2S addressBits dataBytes)++  type Bwd (Wishbone dom mode addressBits dataBytes) = Signal dom (WishboneS2M dataBytes)++instance+  (C.KnownNat aw, C.KnownNat dw) =>+  IdleCircuit (Wishbone dom mode aw dw)+  where+  idleFwd _ = C.pure emptyWishboneM2S+  idleBwd _ = C.pure emptyWishboneS2M++-- | Construct "default" Wishbone M2S signals+emptyWishboneM2S ::+  (C.KnownNat addressBits, C.KnownNat dataBytes) =>+  WishboneM2S addressBits dataBytes+emptyWishboneM2S =+  WishboneM2S+    { addr = C.deepErrorX "M2S address not defined"+    , writeData = C.deepErrorX "M2S writeData not defined"+    , busSelect = C.deepErrorX "M2S busSelect not defined"+    , lock = False+    , busCycle = False+    , strobe = False+    , writeEnable = False+    , cycleTypeIdentifier = Classic+    , burstTypeExtension = LinearBurst+    }++-- | Construct "default" Wishbone S2M signals+emptyWishboneS2M :: (C.KnownNat dataBytes) => WishboneS2M dataBytes+emptyWishboneS2M =+  WishboneS2M+    { readData = C.deepErrorX "S2M readData not defined"+    , acknowledge = False+    , err = False+    , retry = False+    , stall = False+    }++{- | Given a tuple of a wishbone request and corresponding response, determine+whether transactions are in progress(returns true for any 'hasTerminateFlag').+This is useful to determine whether a Wishbone bus is active.++>>> :{+let m2s = (emptyWishboneM2S @32 @4){busCycle = True, strobe = True}+    s2m = emptyWishboneS2M{acknowledge = True}+  in hasBusActivity (m2s, s2m)+:}+True++>>> :{+let m2s = (emptyWishboneM2S @32 @4){busCycle = True, strobe = True}+    s2m = emptyWishboneS2M{retry = True}+  in hasBusActivity (m2s, s2m)+:}+True++>>> :{+let m2s = (emptyWishboneM2S @32 @4){busCycle = True}+    s2m = emptyWishboneS2M{acknowledge = True}+  in hasBusActivity (m2s, s2m)+:}+False++>>> :{+let m2s = (emptyWishboneM2S @32 @4){busCycle = True, strobe = True}+    s2m = emptyWishboneS2M+  in hasBusActivity (m2s, s2m)+:}+False++>>> :{+let m2s = emptyWishboneM2S @32 @4+    s2m = emptyWishboneS2M{acknowledge = True}+  in hasBusActivity (m2s, s2m)+:}+False+-}+hasBusActivity :: (WishboneM2S addressBits dataBytes, WishboneS2M dataBytes) -> Bool+hasBusActivity (m2s, s2m) = busCycle m2s C.&& strobe m2s C.&& hasTerminateFlag s2m++-- | Helper function to determine whether a Slave signals the termination of a cycle.+hasTerminateFlag :: WishboneS2M dataBytes -> Bool+hasTerminateFlag s2m = acknowledge s2m || err s2m || retry s2m++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom mode aw dw.+  ( C.KnownDomain dom+  , C.HiddenReset dom+  , C.KnownNat aw+  , C.KnownNat dw+  ) =>+  Circuit (Wishbone dom mode aw dw) (Wishbone dom mode aw dw)+forceResetSanity = forceResetSanityGeneric
+ src/Protocols/Experimental/Wishbone/Standard.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++-- | Circuits and utilities for working with Standard-mode Wishbone circuits.+module Protocols.Experimental.Wishbone.Standard where++import Clash.Prelude+import Data.Bifunctor qualified as B+import Protocols+import Protocols.Experimental.Wishbone+import Prelude hiding (head, not, repeat, (!!), (&&), (||))++-- | Distribute requests amongst N slave circuits+roundrobin ::+  forall n dom addressBits dataBytes.+  ( KnownNat n+  , HiddenClockResetEnable dom+  , KnownNat addressBits+  , KnownNat dataBytes+  , 1 <= n+  ) =>+  Circuit+    (Wishbone dom 'Standard addressBits dataBytes)+    (Vec n (Wishbone dom 'Standard addressBits dataBytes))+roundrobin = Circuit $ \(m2s, s2ms) -> B.first head $ fn (singleton m2s, s2ms)+ where+  Circuit fn = sharedBus selectFn+  selectFn (unbundle -> (mIdx, sIdx, _)) =+    liftA2 (,) mIdx (satSucc SatWrap <$> sIdx)++{- | General-purpose shared-bus with N masters and M slaves.++  A selector signal is used to compute the next M-S pair.+-}+sharedBus ::+  forall n m dom addressBits dataBytes.+  ( KnownNat n+  , KnownNat m+  , HiddenClockResetEnable dom+  , KnownNat addressBits+  , KnownNat dataBytes+  ) =>+  -- | Function used to select which M-S pair should be connected next.+  ( Signal+      dom+      ( Index n+      , Index m+      , Vec n (WishboneM2S addressBits dataBytes)+      ) ->+    Signal dom (Index n, Index m)+  ) ->+  Circuit+    (Vec n (Wishbone dom 'Standard addressBits dataBytes))+    (Vec m (Wishbone dom 'Standard addressBits dataBytes))+sharedBus selectFn = Circuit go+ where+  go (bundle -> m2ss0, bundle -> s2ms0) = (unbundle s2ms1, unbundle m2ss1)+   where+    mIdx0 = regEn (0 :: Index n) acceptIds mIdx1+    sIdx0 = regEn (0 :: Index m) acceptIds sIdx1++    (mIdx1, sIdx1) = unbundle $ selectFn (liftA3 (,,) mIdx0 sIdx0 m2ss0)++    m2s = liftA2 (!!) m2ss0 mIdx0+    s2m = liftA2 (!!) s2ms0 sIdx0++    acceptIds = (not . busCycle <$> m2s) .&&. (not . lock <$> m2s)++    m2ss1 = liftA3 replace sIdx0 m2s $ pure (repeat emptyWishboneM2S)+    s2ms1 = liftA3 replace mIdx0 s2m $ pure (repeat emptyWishboneS2M)++-- | Crossbar switch allowing N masters to be routed dynamically to M slaves.+crossbarSwitch ::+  forall n m dom addressBits dataBytes.+  ( KnownNat n+  , KnownNat m+  , KnownDomain dom+  , KnownNat addressBits+  , KnownNat dataBytes+  ) =>+  Circuit+    ( CSignal dom (Vec n (Index m)) -- route+    , Vec n (Wishbone dom 'Standard addressBits dataBytes) -- masters+    )+    (Vec m (Wishbone dom 'Standard addressBits dataBytes)) -- slaves+crossbarSwitch = Circuit go+ where+  go ((route, bundle -> m2ss0), bundle -> s2ms0) =+    (((), unbundle s2ms1), unbundle m2ss1)+   where+    m2ss1 = scatter @_ @_ @_ @_ @0 (repeat emptyWishboneM2S) <$> route <*> m2ss0+    s2ms1 = gather <$> s2ms0 <*> route++-- | State used to guarantee correct response timing in 'memoryWb'.+data MemoryDelayState = Wait | AckRead+  deriving (Generic, NFDataX)++{- | Memory component circuit using a specific RAM function++  This circuit uses 'Standard' mode and only supports the classic cycle type.+  Because of this, the data rate is limited by the one-cycle delay of the RAM+  function when reading and the inserted stall-cycle.++  The data rate could be increased by using registered feedback cycles or+  by using a pipelined circuit which would eliminate one wait cycle.++  Since the underlying block RAM operates on the whole bitvector, the only+  accepted bus selector value is 'maxBound'. All other bus selector values+  will cause an ERR response.++  TODO create pipelined memory circuit+-}+memoryWb ::+  forall dom addressBits dataBytes.+  ( KnownDomain dom+  , KnownNat addressBits+  , KnownNat dataBytes+  , HiddenClockResetEnable dom+  ) =>+  ( Signal dom (BitVector addressBits) ->+    Signal dom (Maybe (BitVector addressBits, BitVector (dataBytes * 8))) ->+    Signal dom (BitVector (dataBytes * 8))+  ) ->+  Circuit (Wishbone dom 'Standard addressBits dataBytes) ()+memoryWb ram = Circuit go+ where+  go (m2s, ()) = (s2m1, ())+   where+    (readAddr, write, s2m0) = unbundle $ mealy fsm Wait m2s+    s2m1 = (\s2m dat -> s2m{readData = dat}) <$> s2m0 <*> readValue+    readValue = ram readAddr write++  fsm st (m2s :: WishboneM2S addressBits dataBytes)+    -- Manager must be active if we're in this state+    | AckRead <- st = (Wait, (0, Nothing, noS2M{acknowledge = True}))+    -- Stay in Wait for invalid transactions+    | isError = (Wait, (0, Nothing, noS2M{err = True}))+    -- write requests can be ACKed directly+    | isWrite = (Wait, (0, write, noS2M{acknowledge = True}))+    -- For read requests we go to AckRead state+    | isRead = (AckRead, (m2s.addr, Nothing, noS2M))+    | otherwise = (Wait, (0, Nothing, noS2M))+   where+    noS2M = emptyWishboneS2M :: WishboneS2M dataBytes+    managerActive = m2s.busCycle && m2s.strobe+    isError = managerActive && (m2s.busSelect /= maxBound)+    isWrite = managerActive && m2s.writeEnable+    isRead = managerActive && not (m2s.writeEnable)+    write = Just (m2s.addr, m2s.writeData)
+ src/Protocols/Experimental/Wishbone/Standard/Hedgehog.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+-- TODO: Fix warnings introduced by GHC 9.2 w.r.t. incomplete lazy pattern matches+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Types and functions to aid with testing Wishbone circuits.++This module provides two "modes" of Wishbone Specification compliance checks:++ * "lenient" mode++ * "common sense" mode++__\"lenient\" mode__++The Wishbone spec mostly specifies the handshake protocols but does not make many+assumptions about which signals *should* be valid in response to what. This is+presumably done so to allow circuits to be very flexible, however it makes for+a relatively weak validation tool.++__\"common sense\" mode__++The Wishbone spec itself makes very little assumptions about how interactions+should look like outside of basic hand-shaking.+This "common sense" compliance checking additionally checks for:+ - A read request is acked with defined data+   - response data respects the 'busSelect' signal+ - A write request must contain valid data according to the 'busSelect' signal+-}+module Protocols.Experimental.Wishbone.Standard.Hedgehog (+  -- * Types+  WishboneMasterRequest (..),++  -- * Circuits+  stallStandard,+  driveStandard,+  validatorCircuit,+  validatorCircuitLenient,+  observeComposedWishboneCircuit,++  -- * Properties+  wishbonePropWithModel,++  -- * Generators+  genWishboneTransfer,++  -- * Simulation+  sample,+  sampleUnfiltered,++  -- * helpers+  m2sToRequest,+  eqWishboneS2M,+)+where++import Clash.Hedgehog.Sized.BitVector (genDefinedBitVector)+import Clash.Hedgehog.Sized.Unsigned (genUnsigned)+import Clash.Prelude as C hiding (cycle, indices, not, sample, (&&), (||))+import Clash.Signal.Internal (Signal ((:-)))+import Control.DeepSeq (NFData)+import Data.Bifunctor qualified as B+import Data.List.Extra+import Data.String.Interpolate (i)+import GHC.Stack (HasCallStack)+import Hedgehog ((===))+import Hedgehog qualified as H+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Protocols hiding (circuit)+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.Wishbone+import Prelude as P hiding (cycle)++-- | Datatype representing a single transaction request sent from a Wishbone Master to a Wishbone Slave+data WishboneMasterRequest addressBits dataBytes+  = Read (BitVector addressBits) (BitVector dataBytes)+  | Write (BitVector addressBits) (BitVector dataBytes) (BitVector (dataBytes * 8))+  deriving stock (C.Generic)+  deriving anyclass (NFData, C.BitPack)++deriving instance+  (KnownNat addressBits, KnownNat dataBytes) =>+  (C.NFDataX (WishboneMasterRequest addressBits dataBytes))++deriving instance+  (KnownNat addressBits, KnownNat dataBytes) =>+  (Show (WishboneMasterRequest addressBits dataBytes))++deriving instance+  (KnownNat addressBits, KnownNat dataBytes) =>+  (ShowX (WishboneMasterRequest addressBits dataBytes))++deriving instance+  (KnownNat addressBits, KnownNat dataBytes) =>+  (Eq (WishboneMasterRequest addressBits dataBytes))++{- | Checks equality for relevant parts of a t'WishboneS2M' response based on the+corresponding 'WishboneMasterRequest'. For a+'Protocols.Experimental.Wishbone.Standard.Hedgehog.Write' request, the+'readData' field is ignored, for a+'Protocols.Experimental.Wishbone.Standard.Hedgehog.Read' request only the+selected bytes are checked.++>>>+:{+let+  readReqA = Read (0 :: BitVector 32) (0b1111 :: BitVector 4)+  readReqB = Read (0 :: BitVector 32) (0b0001 :: BitVector 4)+  writeReq = Write (0 :: BitVector 32) (0b1111 :: BitVector 4) (0x12345678 :: BitVector 32)+  s2mA = (emptyWishboneS2M @4)+    { readData = 0x00FF+    , acknowledge = True+    , err = False+    , retry = False+    }+  s2mB = (emptyWishboneS2M @4)+    { readData = 0xFFFF+    , acknowledge = True+    , err = False+    , retry = False+    }+  s2mC = (emptyWishboneS2M @4)+    { readData = deepErrorX ""+    , acknowledge = True+    , err = False+    , retry = False+    }+:}++>>> eqWishboneS2M readReqA s2mA s2mB+False+>>> eqWishboneS2M readReqB s2mA s2mB+True+>>> eqWishboneS2M writeReq s2mA s2mB+True+>>> eqWishboneS2M writeReq s2mA s2mC+True+-}+eqWishboneS2M ::+  forall (addressBits :: Natural) (dataBytes :: Natural).+  (KnownNat dataBytes) =>+  -- | Request that determines which fields to check+  WishboneMasterRequest addressBits dataBytes ->+  -- | Wishbone Subordinate response A+  WishboneS2M dataBytes ->+  -- | Wishbone Subordinate response B+  WishboneS2M dataBytes ->+  Bool+eqWishboneS2M Write{} s2mA s2mB =+  s2mA{readData = 0 :: BitVector 0} == s2mB{readData = 0 :: BitVector 0}+eqWishboneS2M (Read _ sel) s2mA s2mB =+  let+    maskBytes wb = wb{readData = pack $ mux (unpack sel) vecBytes (C.repeat 0)}+     where+      vecBytes :: Vec dataBytes (BitVector 8)+      vecBytes = unpack wb.readData+   in+    if s2mA.acknowledge+      then maskBytes s2mA == maskBytes s2mB+      else+        s2mA{readData = 0 :: BitVector 0} == s2mB{readData = 0 :: BitVector 0}++-- Validation for (lenient) spec compliance+--++data LenientValidationState+  = LVSQuiet+  | LVSInCycleNoStrobe+  | LVSWaitForSlave+  deriving (Generic, NFDataX)++nextStateLenient ::+  LenientValidationState ->+  WishboneM2S addressBits dataBytes ->+  WishboneS2M dataBytes ->+  Either String (Bool, LenientValidationState)+--               ^ go to next cycle+nextStateLenient _ m2s s2m+  | P.length (filter ($ s2m) [acknowledge, err, retry]) > 1 =+      Left "More than one termination signal asserted"+  | not (busCycle m2s) && (acknowledge s2m || err s2m || retry s2m) =+      Left "Termination signals outside of a bus cycle"+nextStateLenient state m2s s2m = case state of+  LVSQuiet ->+    if+      | busCycle m2s && P.not (strobe m2s) -> Right (False, LVSInCycleNoStrobe)+      | busCycle m2s && strobe m2s -> Right (False, LVSWaitForSlave)+      | otherwise -> Right (True, LVSQuiet)+  LVSInCycleNoStrobe ->+    if+      | not (busCycle m2s) -> Right (False, LVSQuiet)+      | busCycle m2s && strobe m2s -> Right (False, LVSWaitForSlave)+      | otherwise -> Right (True, LVSInCycleNoStrobe)+  LVSWaitForSlave ->+    if+      | busCycle m2s && P.not (strobe m2s) -> Right (False, LVSInCycleNoStrobe)+      | not (busCycle m2s) -> Right (False, LVSQuiet)+      | acknowledge s2m || err s2m || retry s2m -> Right (True, LVSQuiet)+      | otherwise -> Right (True, LVSWaitForSlave)++--+-- Validation for "common sense" compliance+--++type CommonSenseValidationError = String++data CommonSenseValidationState+  = CSVSQuiet+  | CSVSInCycleNoStrobe+  | CSVSReadCycle+  | CSVSWriteCycle+  deriving (Eq, Show, Generic, NFDataX)++nextStateCommonSense ::+  forall addressBits dataBytes.+  (KnownNat dataBytes) =>+  CommonSenseValidationState ->+  WishboneM2S addressBits dataBytes ->+  WishboneS2M dataBytes ->+  Either CommonSenseValidationError (Bool, CommonSenseValidationState)+--                                    ^ go to next cycle+nextStateCommonSense _ _ s2m+  | P.length (filter ($ s2m) [acknowledge, err, retry]) > 1 =+      Left "More than one termination signal asserted"+nextStateCommonSense state m2s@WishboneM2S{..} s2m@WishboneS2M{..} = case state of+  CSVSQuiet ->+    if+      | busCycle && not strobe -> Right (True, CSVSInCycleNoStrobe)+      | busCycle && strobe && writeEnable -> Right (False, CSVSWriteCycle)+      | busCycle && strobe && not writeEnable -> Right (False, CSVSReadCycle)+      | hasTerminateFlag s2m -> Left "Termination signals outside of a bus cycle"+      | otherwise -> Right (True, CSVSQuiet)+  CSVSInCycleNoStrobe ->+    if+      | not busCycle -> Right (True, CSVSQuiet)+      | not strobe -> Right (True, CSVSInCycleNoStrobe)+      | writeEnable -> Right (False, CSVSWriteCycle)+      | not writeEnable -> Right (False, CSVSReadCycle)+      | otherwise -> C.error "Should not happen"+  CSVSReadCycle ->+    if+      | not busCycle -> Right (True, CSVSQuiet)+      | not strobe -> Right (True, CSVSInCycleNoStrobe)+      | acknowledge ->+          if responseValid m2s s2m+            then Right (True, CSVSQuiet)+            else Left "read-response does not respect SEL"+      | err || retry -> Right (True, CSVSQuiet)+      | writeEnable -> Left "asserted WE while in a read cycle"+      | otherwise -> Right (True, CSVSReadCycle)+  CSVSWriteCycle ->+    if+      | not busCycle -> Right (True, CSVSQuiet)+      | not strobe -> Right (True, CSVSInCycleNoStrobe)+      | not writeEnable -> Left "deasserted WE while in a write cycle"+      | not $ requestValid m2s -> Left "write request does not respect SEL"+      | err || retry -> Right (True, CSVSQuiet)+      | acknowledge -> Right (True, CSVSQuiet)+      | otherwise -> Right (True, CSVSWriteCycle)+ where+  responseValid WishboneM2S{busSelect = sel} WishboneS2M{readData = dat} = selectValidData sel dat+  requestValid WishboneM2S{busSelect = sel, writeData = dat} = selectValidData sel dat++{- | This function checks whether all bytes selected by \"SEL\" in a value+  contain defined data.+-}+selectValidData ::+  forall dataBytes.+  (HasCallStack, KnownNat dataBytes) =>+  BitVector dataBytes ->+  BitVector (dataBytes * 8) ->+  Bool+selectValidData byteSelect rawDat =+  all+    not+    [ hasUndefined part+    | idx <- indices byteSelect+    , let part = dat ! idx+    ]+ where+  dat :: C.Vec dataBytes (BitVector 8)+  dat = case maybeIsX rawDat of+    Just val -> bitCoerce val+    Nothing -> C.deepErrorX "value to be 'select-checked' has an undefined spine"++  indices :: forall n. (KnownNat n) => BitVector n -> [Index n]+  indices bv = filter (testBit bv . fromIntegral) [0 .. maxBound]++-- | Create a stalling wishbone 'Standard' circuit.+stallStandard ::+  forall dom addressBits dataBytes.+  ( C.KnownNat addressBits+  , C.KnownDomain dom+  , C.KnownNat dataBytes+  ) =>+  -- | Number of cycles to stall the master for on each valid bus-cycle+  [Int] ->+  Circuit+    (Wishbone dom 'Standard addressBits dataBytes)+    (Wishbone dom 'Standard addressBits dataBytes)+stallStandard stallsPerCycle =+  Circuit $+    B.second (emptyWishboneM2S :-)+      . uncurry (go stallsPerCycle Nothing)+ where+  go ::+    [Int] ->+    Maybe (WishboneS2M dataBytes) ->+    Signal dom (WishboneM2S addressBits dataBytes) ->+    Signal dom (WishboneS2M dataBytes) ->+    ( Signal dom (WishboneS2M dataBytes)+    , Signal dom (WishboneM2S addressBits dataBytes)+    )++  go [] lastRep (_ :- m2s) ~(_ :- s2m) =+    B.bimap (emptyWishboneS2M :-) (emptyWishboneM2S :-) $ go [] lastRep m2s s2m+  go (st : stalls) lastRep (m :- m2s) ~(_ :- s2m)+    -- not in a bus cycle, just pass through+    | not (busCycle m) =+        B.bimap+          (emptyWishboneS2M :-)+          (emptyWishboneM2S :-)+          (go (st : stalls) lastRep m2s s2m)+  go (st : stalls) Nothing (m :- m2s) ~(s :- s2m)+    -- received a reply but still need to stall+    | busCycle m && strobe m && st > 0 && hasTerminateFlag s =+        B.bimap+          -- tell the master that the slave has no reply yet+          (emptyWishboneS2M :-)+          -- tell the slave that the cycle is over+          (emptyWishboneM2S :-)+          (go (st - 1 : stalls) (Just s) m2s s2m)+    -- received a reply but still need to stall+    | busCycle m && strobe m && st > 0 && not (hasTerminateFlag s) =+        B.bimap+          -- tell the master that the slave has no reply yet+          (emptyWishboneS2M :-)+          -- tell the slave that the cycle is over+          (m :-)+          (go (st - 1 : stalls) Nothing m2s s2m)+    -- done stalling, got a reply last second, pass through+    | busCycle m && strobe m && st == 0 && hasTerminateFlag s =+        B.bimap+          (s :-)+          (m :-)+          (go stalls Nothing m2s s2m)+    -- done stalling but no termination signal yet, just pass through to give the slave+    -- the chance to reply+    | busCycle m && strobe m && st == 0 && not (hasTerminateFlag s) =+        B.bimap+          (emptyWishboneS2M :-)+          (m :-)+          (go (0 : stalls) Nothing m2s s2m)+    -- master cancelled cycle+    | otherwise = B.bimap (emptyWishboneS2M :-) (m :-) (go stalls Nothing m2s s2m)+  go (st : stalls) (Just rep) (m :- m2s) ~(_ :- s2m)+    -- need to keep stalling, already got the reply+    | busCycle m && strobe m && st > 0 =+        B.bimap+          -- keep stalling+          (emptyWishboneS2M :-)+          -- tell the slave that the cycle is over+          (emptyWishboneM2S :-)+          (go (st - 1 : stalls) (Just rep) m2s s2m)+    -- done stalling, give reply+    | busCycle m && strobe m && st == 0 =+        B.bimap+          (rep :-)+          (emptyWishboneM2S :-)+          (go stalls Nothing m2s s2m)+    -- master cancelled cycle+    | otherwise = B.bimap (emptyWishboneS2M :-) (m :-) (go stalls Nothing m2s s2m)++data DriverState addressBits dataBytes+  = -- | State in which the driver still needs to perform N resets+    DSReset Int [(WishboneMasterRequest addressBits dataBytes, Int)]+  | -- | State in which the driver is issuing a new request to the slave+    DSNewRequest+      (WishboneMasterRequest addressBits dataBytes)+      Int+      [(WishboneMasterRequest addressBits dataBytes, Int)]+  | -- | State in which the driver is waiting (and holding the request) for the slave to reply+    DSWaitForReply+      (WishboneMasterRequest addressBits dataBytes)+      Int+      [(WishboneMasterRequest addressBits dataBytes, Int)]+  | -- | State in which the driver is waiting for N cycles before starting a new request+    DSStall Int [(WishboneMasterRequest addressBits dataBytes, Int)]+  | -- | State in which the driver has no more work to do+    DSDone++-- | Create a wishbone 'Standard' circuit to drive other circuits.+driveStandard ::+  forall dom addressBits dataBytes.+  ( C.KnownNat addressBits+  , C.KnownDomain dom+  , C.KnownNat dataBytes+  ) =>+  ExpectOptions ->+  -- | Requests to send out+  [(WishboneMasterRequest addressBits dataBytes, Int)] ->+  Circuit () (Wishbone dom 'Standard addressBits dataBytes)+driveStandard ExpectOptions{..} requests =+  Circuit $+    ((),)+      . C.fromList_lazy+      . (emptyWishboneM2S :)+      . go (DSReset eoResetCycles requests)+      . (\s -> C.sample_lazy s)+      . snd+ where+  go st0 ~(s2m : s2ms) =+    let (st1, m2s) = step st0 s2m+     in m2s : (s2m `C.seqX` go st1 s2ms)++  transferToSignals ::+    forall addrWidth dw.+    ( C.KnownNat addrWidth+    , C.KnownNat dw+    ) =>+    WishboneMasterRequest addrWidth dw ->+    WishboneM2S addrWidth dw+  transferToSignals (Read addr sel) =+    (emptyWishboneM2S @addrWidth @dw)+      { busCycle = True+      , strobe = True+      , addr = addr+      , busSelect = sel+      , writeEnable = False+      }+  transferToSignals (Write addr sel dat) =+    (emptyWishboneM2S @addrWidth @dw)+      { busCycle = True+      , strobe = True+      , addr = addr+      , busSelect = sel+      , writeEnable = True+      , writeData = dat+      }++  step ::+    DriverState addressBits dataBytes ->+    -- \| respone from *last* cycle+    WishboneS2M dataBytes ->+    (DriverState addressBits dataBytes, WishboneM2S addressBits dataBytes)+  step (DSReset _ []) _s2m = (DSDone, emptyWishboneM2S)+  step (DSReset 0 ((req, n) : reqs)) s2m = step (DSNewRequest req n reqs) s2m+  step (DSReset n reqs) _s2m = (DSReset (n - 1) reqs, emptyWishboneM2S)+  step (DSNewRequest req n reqs) _s2m = (DSWaitForReply req n reqs, transferToSignals req)+  step (DSWaitForReply req n reqs) s2m+    | acknowledge s2m || err s2m = step (DSStall n reqs) s2m+    | retry s2m = (DSNewRequest req n reqs, emptyWishboneM2S)+    | otherwise = (DSWaitForReply req n reqs, transferToSignals req)+  step (DSStall 0 []) _s2m = (DSDone, emptyWishboneM2S)+  step (DSStall 0 ((req, n) : reqs)) s2m = step (DSNewRequest req n reqs) s2m+  step (DSStall n reqs) _s2m = (DSStall (n - 1) reqs, emptyWishboneM2S)+  step DSDone _s2m = (DSDone, emptyWishboneM2S)++{- | Circuit which validates the wishbone communication signals between a+  master and a slave circuit.++  Halts execution using 'error' when a "common sense" spec validation occurs.++  N.B. Not synthesisable.+-}+validatorCircuit ::+  forall dom addressBits dataBytes.+  ( HasCallStack+  , HiddenClockResetEnable dom+  , KnownNat addressBits+  , KnownNat dataBytes+  ) =>+  Circuit+    (Wishbone dom 'Standard addressBits dataBytes)+    (Wishbone dom 'Standard addressBits dataBytes)+validatorCircuit =+  Circuit $ mealyB go (0 :: Integer, (emptyWishboneM2S, emptyWishboneS2M), CSVSQuiet)+ where+  go (cycle, (m2s0, s2m0), state0) (m2s1, s2m1) =+    case nextStateCommonSense state0 m2s0 s2m0 of+      Left err ->+        error $+          "Wishbone common-sense validation error on cycle "+            <> show cycle+            <> ": "+            <> err+            <> "\n\n"+            <> "M2S: "+            <> show m2s0+            <> "\n"+            <> "S2M: "+            <> show s2m0+      Right (True, state1) -> ((cycle + 1, (m2s1, s2m1), state1), (s2m1, m2s1))+      Right (False, state1) -> go (cycle, (m2s0, s2m0), state1) (m2s1, s2m1)++{- | Circuit which validates the wishbone communication signals between a+  master and a slave circuit.++  Halts execution using 'error' when a spec validation occurs.++  N.B. Not synthesisable.+-}+validatorCircuitLenient ::+  forall dom addressBits dataBytes.+  ( HasCallStack+  , HiddenClockResetEnable dom+  , KnownNat addressBits+  , KnownNat dataBytes+  ) =>+  Circuit+    (Wishbone dom 'Standard addressBits dataBytes)+    (Wishbone dom 'Standard addressBits dataBytes)+validatorCircuitLenient =+  Circuit $ mealyB go (0 :: Integer, (emptyWishboneM2S, emptyWishboneS2M), LVSQuiet)+ where+  go (cycle, (m2s0, s2m0), state0) (m2s1, s2m1) =+    case nextStateLenient state0 m2s0 s2m0 of+      Left err ->+        error $+          "Wishbone lenient validation error on cycle "+            <> show cycle+            <> ": "+            <> err+            <> "\n\n"+            <> "M2S: "+            <> show m2s0+            <> "\n"+            <> "S2M: "+            <> show s2m0+      Right (True, state1) -> ((cycle + 1, (m2s1, s2m1), state1), (s2m1, m2s1))+      Right (False, state1) -> go (cycle, (m2s0, s2m0), state1) (m2s1, s2m1)++-- | Test a wishbone 'Standard' circuit against a pure model.+wishbonePropWithModel ::+  forall dom addressBits dataBytes st m.+  ( C.KnownNat addressBits+  , C.HiddenClockResetEnable dom+  , C.KnownNat dataBytes+  , Monad m+  ) =>+  ExpectOptions ->+  {- | Check whether a S2M signal for a given request is matching a pure model using @st@+  as its state.+  Return an error message 'Left' or the updated state 'Right'+  -}+  ( WishboneMasterRequest addressBits dataBytes ->+    WishboneS2M dataBytes ->+    st ->+    Either String st+  ) ->+  -- | The circuit to run the test against.+  Circuit (Wishbone dom 'Standard addressBits dataBytes) () ->+  -- | Inputs to the circuit and model+  H.Gen [WishboneMasterRequest addressBits dataBytes] ->+  -- | Initial state of the model+  st ->+  H.PropertyT m ()+wishbonePropWithModel eOpts model circuit0 inputGen st = do+  input <- H.forAll inputGen++  let+    n = P.length input+    genStall = Gen.integral (Range.linear 0 10)++  reqStalls <- H.forAll (Gen.list (Range.singleton n) genStall)++  let+    resets = 5+    driver = driveStandard @dom (defExpectOptions{eoResetCycles = resets}) (P.zip input reqStalls)+    circuit1 = validatorCircuit |> circuit0+    (m2s, s2m) = P.unzip $ sample eOpts driver circuit1++  H.footnoteShow m2s+  H.footnoteShow s2m++  matchModel 0 s2m input st === Right ()+ where+  matchModel ::+    Int ->+    [WishboneS2M dataBytes] ->+    [WishboneMasterRequest addressBits dataBytes] ->+    st ->+    Either (Int, String) ()+  matchModel cyc (s : s2m) (req : reqs0) state+    | not (hasTerminateFlag s) = s `C.seqX` matchModel (succ cyc) s2m (req : reqs0) state+    | otherwise = case model req s state of+        Left err -> Left (cyc, err)+        Right st1 -> s `C.seqX` matchModel (succ cyc) s2m reqs1 st1+         where+          reqs1+            | retry s = req : reqs0+            | otherwise = reqs0+  matchModel _ [] [] _ = Right () -- We're done!+  matchModel cyc [] reqs _ = Left (cyc, [i|The implementation did not produce enough responses: #{reqs}|])+  matchModel cyc resps [] _+    | null (P.filter hasTerminateFlag resps) = Right () -- If there's only empty responses left we're done!+    | otherwise = Left (cyc, [i|The implementation produced too many responses: #{resps}|])++{- | Given a wishbone manager and wishbone subordinate, connect them and+sample their forward and backward channel lazily.+-}+observeComposedWishboneCircuit ::+  forall dom mode addressBits dataBytes.+  (KnownDomain dom) =>+  Circuit () (Wishbone dom mode addressBits dataBytes) ->+  Circuit (Wishbone dom mode addressBits dataBytes) () ->+  ( [WishboneM2S addressBits dataBytes]+  , [WishboneS2M dataBytes]+  )+observeComposedWishboneCircuit (Circuit master) (Circuit slave) =+  let ~((), m2s) = master ((), s2m)+      ~(s2m, ()) = slave (m2s, ())+   in (sample_lazy m2s, sample_lazy s2m)++-- | Generate a random Wishbone transfer based on an address range and a payload generator.+genWishboneTransfer ::+  (KnownNat addressBits, KnownNat dataBytes) =>+  Range.Range (Unsigned addressBits) ->+  H.Gen (WishboneMasterRequest addressBits dataBytes)+genWishboneTransfer addrRange = do+  addr <- genUnsigned addrRange+  sel <- genDefinedBitVector+  dat <- genDefinedBitVector+  Gen.choice+    [ pure $ Read (pack addr) sel+    , pure $ Write (pack addr) sel dat+    ]++{- | Interpret a t'WishboneM2S' as a 'WishboneMasterRequest'.+Only works for valid requests and performs no checks.+-}+m2sToRequest ::+  (KnownNat addressBits, KnownNat dataBytes) =>+  WishboneM2S addressBits dataBytes ->+  WishboneMasterRequest addressBits dataBytes+m2sToRequest m2s+  | m2s.writeEnable = Write m2s.addr m2s.busSelect m2s.writeData+  | otherwise = Read m2s.addr m2s.busSelect++{- | Simulates a wishbone manager and subordinate and returns their transactions.+The results are filtered to only include transactions that have bus activity,+for a version that includes all cycles, see 'sampleUnfiltered'.+-}+sample ::+  (KnownDomain dom) =>+  ExpectOptions ->+  Circuit () (Wishbone dom mode addressBits dataBytes) ->+  Circuit (Wishbone dom mode addressBits dataBytes) () ->+  [(WishboneM2S addressBits dataBytes, WishboneS2M dataBytes)]+sample eOpts manager subordinate =+  P.filter hasBusActivity $+    sampleUnfiltered eOpts manager subordinate++{- | Simulates a wishbone manager and subordinate and the state of the bus for+every cycle. For a time independent version that only includes transactions,+see 'sample'.+-}+sampleUnfiltered ::+  (KnownDomain dom) =>+  ExpectOptions ->+  Circuit () (Wishbone dom mode addressBits dataBytes) ->+  Circuit (Wishbone dom mode addressBits dataBytes) () ->+  [(WishboneM2S addressBits dataBytes, WishboneS2M dataBytes)]+sampleUnfiltered eOpts manager subordinate =+  takeWhileAnyInWindow (expectedEmptyCycles eOpts) hasBusActivity $+    P.take eOpts.eoSampleMax $+      uncurry P.zip $+        observeComposedWishboneCircuit manager subordinate
+ src/Protocols/Idle.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC "-Wno-orphans" #-}++{- |+Utilities to easily create idle circuits for protocols.+-}+module Protocols.Idle (+  -- * Type classes+  IdleCircuit (..),++  -- * Utility functions+  idleSource,+  idleSink,+  forceResetSanityGeneric,+) where++import Clash.Prelude+import Prelude ()++import Data.Proxy+import Protocols.Internal+import Protocols.Internal.TH (idleCircuitTupleInstances)+import Protocols.Plugin.Cpp (maxTupleSize)++instance (IdleCircuit a, IdleCircuit b) => IdleCircuit (a, b) where+  idleFwd _ = (idleFwd $ Proxy @a, idleFwd $ Proxy @b)+  idleBwd _ = (idleBwd $ Proxy @a, idleBwd $ Proxy @b)++instance (IdleCircuit a, KnownNat n) => IdleCircuit (Vec n a) where+  idleFwd _ = repeat $ idleFwd $ Proxy @a+  idleBwd _ = repeat $ idleBwd $ Proxy @a++instance IdleCircuit () where+  idleFwd _ = ()+  idleBwd _ = ()++-- Derive instances for tuples up to maxTupleSize+idleCircuitTupleInstances 3 maxTupleSize++-- | Idle state of a source, this circuit does not produce any data.+idleSource :: forall p. (IdleCircuit p) => Circuit () p+idleSource = Circuit $ const ((), idleFwd $ Proxy @p)++-- | Idle state of a sink, this circuit does not consume any data.+idleSink :: forall p. (IdleCircuit p) => Circuit p ()+idleSink = Circuit $ const (idleBwd $ Proxy @p, ())++{- | Force a /nack/ on the backward channel and /no data/ on the forward+channel if reset is asserted.++Generic helper behind protocol-specific @forceResetSanity@ combinators such as+'Protocols.Df.forceResetSanity'.+-}+forceResetSanityGeneric ::+  forall dom a fwd bwd.+  ( KnownDomain dom+  , HiddenReset dom+  , IdleCircuit a+  , Fwd a ~ Signal dom fwd+  , Bwd a ~ Signal dom bwd+  ) =>+  Circuit a a+forceResetSanityGeneric = Circuit go+ where+  go (fwd, bwd) =+    unbundle+      $ mux+        rstAsserted+        (bundle (idleBwd $ Proxy @a, idleFwd $ Proxy @a))+        (bundle (bwd, fwd))++#if MIN_VERSION_clash_prelude(1,8,0)+  rstAsserted = unsafeToActiveHigh hasReset+#else+  rstAsserted = unsafeToHighPolarity hasReset+#endif
+ src/Protocols/Internal.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fplugin Protocols.Plugin #-}++-- TODO: Hide internal documentation+-- {-# OPTIONS_HADDOCK hide #-}++{- |+Internal module to prevent hs-boot files (breaks Haddock)+-}+module Protocols.Internal (+  module Protocols.Internal,+  module Protocols.Internal.Types,+  module Protocols.Plugin,+  module Protocols.Plugin.Units,+  module Protocols.Plugin.TaggedBundle,+) where++import Control.DeepSeq (NFData)+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe)+import Data.Proxy+import Prelude hiding (const, map)++import Clash.Prelude qualified as C++import Protocols.Internal.Types+import Protocols.Plugin+import Protocols.Plugin.TaggedBundle+import Protocols.Plugin.Units++import Control.Arrow ((***))+import Data.Coerce (coerce)+import Data.Default (Default (def))+import Data.Functor.Identity (Identity (..), runIdentity)+import Data.Kind (Type)+import Data.Tuple (swap)+import GHC.Generics (Generic)++{- $setup+>>> import Protocols+-}++-- | Protocol-agnostic acknowledgement+newtype Ack = Ack Bool+  deriving stock (Generic, Show)+  deriving anyclass (C.Bundle, C.ShowX)+  deriving newtype (C.NFDataX, Eq, Ord, C.BitPack)++-- | Acknowledge. Used in circuit-notation plugin to drive ignore components.+instance Default Ack where+  def = Ack True++{- | Left-to-right circuit composition.++@+                       Circuit a c++           +---------------------------------+++            Circuit a b    |>    Circuit b c++           +-----------+         +-----------++    Fwd a  |           |  Fwd b  |           |  Fwd c+  +------->+           +-------->+           +-------->+           |           |         |           |+           |           |         |           |+    Bwd a  |           |  Bwd b  |           |  Bwd c+  <--------+           +<--------+           +<-------++           |           |         |           |+           +-----------+         +-----------++@+-}+infixr 1 |>++(|>) :: Circuit a b -> Circuit b c -> Circuit a c+(Circuit fab) |> (Circuit fbc) = Circuit $ \(s2rAc, r2sAc) ->+  let+    ~(r2sAb, s2rAb) = fab (s2rAc, r2sBc)+    ~(r2sBc, s2rBc) = fbc (s2rAb, r2sAc)+   in+    (r2sAb, s2rBc)++{- | Right-to-left circuit composition.++@+                       Circuit a c++           +---------------------------------+++            Circuit b c    <|    Circuit a b++           +-----------+         +-----------++    Fwd c  |           |  Fwd b  |           |  Fwd a+  <--------+           +<--------+           +<-------++           |           |         |           |+           |           |         |           |+    Bwd c  |           |  Bwd b  |           |  Bwd a+  +------->+           +-------->+           +-------->+           |           |         |           |+           +-----------+         +-----------++@+-}+infixr 1 <|++(<|) :: Circuit b c -> Circuit a b -> Circuit a c+(<|) = flip (|>)++-- | View Circuit as its internal representation.+toSignals :: Circuit a b -> ((Fwd a, Bwd b) -> (Bwd a, Fwd b))+toSignals = coerce++-- | View signals as a Circuit+fromSignals :: ((Fwd a, Bwd b) -> (Bwd a, Fwd b)) -> Circuit a b+fromSignals = coerce++{- | Circuit equivalent of 'id'. Useful for explicitly assigning a type to+another protocol, or to return a result when using the circuit-notation+plugin.++Examples:++@+idC \@(Df dom a) <| somePolymorphicProtocol+@++@+swap :: Circuit (Df dom a, Df dom b) (Df dom b, Df dom a)+swap = circuit $ \(a, b) -> do+  idC -< (b, a)+@+-}+idC :: forall a. Circuit a a+idC = Circuit swap++{- | Copy a circuit /n/ times. Note that this will copy hardware. If you are+looking for a circuit that turns a single channel into multiple, check out+'Protocols.Df.fanout'.+-}+repeatC ::+  forall n a b.+  Circuit a b ->+  Circuit (C.Vec n a) (C.Vec n b)+repeatC (Circuit f) =+  Circuit (C.unzip . C.map f . uncurry C.zip)++{- | Applies the mappings @Fwd a -> Fwd b@ and @Bwd b -> Bwd a@ to the circuit's signals.++The idea here is that you want to treat some @a -> b@ as a @Circuit a b@, but @Circuit a b@ is+actually the type @(Fwd a, Bwd b) -> (Bwd a, Fwd b)@. To bridge this gap, we say that @a -> b@ can+be our map from @Fwd a -> Fwd b@, but then we need to fill in the @Bwd b -> Bwd a@ still. In almost+all cases, the former is the function you want to apply, and the latter is the inverse. For+instance, the 'Clash.Prelude.++' operator on vectors can be made into a @Circuit a b@ with+@applyC (uncurry (++)) splitAtI@, since 'Clash.Prelude.splitAtI' is the inverse of+'Clash.Prelude.++'.+-}+applyC ::+  forall a b.+  (Fwd a -> Fwd b) ->+  (Bwd b -> Bwd a) ->+  Circuit a b+applyC fwdFn bwdFn = Circuit go+ where+  go :: (Fwd a, Bwd b) -> (Bwd a, Fwd b)+  go (fwdA, bwdB) = (bwdFn bwdB, fwdFn fwdA)++{- | Combine two separate circuits into one. If you are looking to combine+multiple streams into a single stream, checkout 'Protocols.Df.fanin'.+-}+prod2C ::+  forall a c b d.+  Circuit a b ->+  Circuit c d ->+  Circuit (a, c) (b, d)+prod2C ab cd = circuit $ \(a, c) -> do+  b <- ab -< a+  d <- cd -< c+  idC -< (b, d)++{- | Combine three separate circuits into one. If you are looking to combine+multiple streams into a single stream, checkout 'Protocols.Df.fanin'.+-}+prod3C ::+  forall a c b d e f.+  Circuit a b ->+  Circuit c d ->+  Circuit e f ->+  Circuit (a, c, e) (b, d, f)+prod3C ab cd ef = circuit $ \(a, c, e) -> do+  b <- ab -< a+  d <- cd -< c+  f <- ef -< e+  idC -< (b, d, f)++{- | Combine four separate circuits into one. If you are looking to combine+multiple streams into a single stream, checkout 'Protocols.Df.fanin'.+-}+prod4C ::+  forall a c b d e f g h.+  Circuit a b ->+  Circuit c d ->+  Circuit e f ->+  Circuit g h ->+  Circuit (a, c, e, g) (b, d, f, h)+prod4C ab cd ef gh = circuit $ \(a, c, e, g) -> do+  b <- ab -< a+  d <- cd -< c+  f <- ef -< e+  h <- gh -< g+  idC -< (b, d, f, h)++{- | Allows for optional data.+Depending on the value of @keep@, the data can either be included or left out.+When left out, the data is represented instead as type @()@.+-}+type family KeepType (keep :: Bool) (optionalType :: Type) = t | t -> keep optionalType where+  KeepType 'True optionalType = Identity optionalType+  KeepType 'False optionalType = Proxy optionalType++#if !MIN_VERSION_clash_prelude(1, 8, 2)+deriving instance (C.ShowX t) => (C.ShowX (Proxy t))+deriving instance (C.NFDataX t) => (C.NFDataX (Proxy t))+#endif++{- | We want to define operations on 'KeepType' that work for both possibilities+(@keep = 'True@ and @keep = 'False@), but we can't pattern match directly.+Instead we need to define a class and instantiate+the class for both @'True@ and @'False@.+-}+class+  ( Eq (KeepType keep Bool)+  , Show (KeepType keep Bool)+  , C.ShowX (KeepType keep Bool)+  , NFData (KeepType keep Bool)+  , C.NFDataX (KeepType keep Bool)+  , Hashable (KeepType keep Bool)+  ) =>+  KeepTypeClass (keep :: Bool)+  where+  -- | Get the value of @keep@ at the term level.+  getKeep :: KeepType keep optionalType -> Bool++  {- | Convert an optional value to a normal value,+  or Nothing if the field is turned off.+  -}+  fromKeepType :: KeepType keep optionalType -> Maybe optionalType++  {- | Convert a normal value to an optional value.+  Either preserves the value or returns @Proxy@.+  -}+  toKeepType :: optionalType -> KeepType keep optionalType++  -- | Map a function over an optional value+  mapKeepType ::+    (optionalType -> optionalType) -> KeepType keep optionalType -> KeepType keep optionalType++instance KeepTypeClass 'True where+  getKeep _ = True+  fromKeepType i = Just (runIdentity i)+  toKeepType v = Identity v+  mapKeepType = fmap++instance KeepTypeClass 'False where+  getKeep _ = False+  fromKeepType _ = Nothing+  toKeepType _ = Proxy+  mapKeepType = fmap++{- | Grab a value from 'KeepType', given a default value. Uses 'fromMaybe'+and 'fromKeepType'.+-}+fromKeepTypeDef ::+  (KeepTypeClass keep) =>+  optionalType ->+  KeepType keep optionalType ->+  optionalType+fromKeepTypeDef deflt val = fromMaybe deflt (fromKeepType val)++{- | Convert one optional field to another, keeping the value the same if+possible. If not possible, a default argument is provided.+-}+convKeepType ::+  (KeepTypeClass a, KeepTypeClass b) => t -> KeepType a t -> KeepType b t+convKeepType b = toKeepType . fromKeepTypeDef b++-- | Omitted value in @KeepType 'False t@.+keepTypeFalse :: KeepType 'False t+keepTypeFalse = Proxy++-- | Grab value in @KeepType 'True t@. No default is needed.+fromKeepTypeTrue :: KeepType 'True t -> t+fromKeepTypeTrue = runIdentity++{- | Protocol to reverse a circuit.+'Fwd' becomes 'Bwd' and vice versa.+No changes are made otherwise.+-}+data Reverse a++instance (Protocol a) => Protocol (Reverse a) where+  type Fwd (Reverse a) = Bwd a+  type Bwd (Reverse a) = Fwd a++{- | Apply 'Reverse' both sides of a circuit, and then switch them.+Input and output of the underlying circuit are the same,+but with the order of the tuple switched in both cases.+-}+reverseCircuit :: Circuit a b -> Circuit (Reverse b) (Reverse a)+reverseCircuit ckt = Circuit (swap . toSignals ckt . swap)++{- | If two protocols, @a@ and @a'@, have the same 'Fwd' and 'Bwd' values,+convert a @Circuit a@ to a @Circuit a'@ without changing the underlying function at all.+-}+coerceCircuit ::+  (Fwd a ~ Fwd a', Bwd a ~ Bwd a', Fwd b ~ Fwd b', Bwd b ~ Bwd b') =>+  Circuit a b ->+  Circuit a' b'+coerceCircuit (Circuit f) = Circuit f++{- | Change a circuit by changing its underlying function's inputs and outputs.+It takes 4 functions as input: @ia@, @oa@, @ob@, and @ib@.+@ia@ modifies the 'Bwd' input, @ib@ modifies the 'Fwd' input,+@oa@ modifies the 'Bwd' output, and @ob@ modifies the 'Fwd' output.+-}+mapCircuit ::+  (Fwd a' -> Fwd a) ->+  (Bwd a -> Bwd a') ->+  (Fwd b -> Fwd b') ->+  (Bwd b' -> Bwd b) ->+  Circuit a b ->+  Circuit a' b'+mapCircuit ia oa ob ib (Circuit f) = Circuit ((oa *** ob) . f . (ia *** ib))++{- | "Bundle" together a pair of t'Circuit's into a t'Circuit' with two inputs and outputs.+The t'Circuit's run in parallel.+-}+tupCircuits :: Circuit a b -> Circuit c d -> Circuit (a, c) (b, d)+tupCircuits (Circuit f) (Circuit g) = Circuit (reorder . (f *** g) . reorder)+ where+  reorder ~(~(a, b), ~(c, d)) = ((a, c), (b, d))++-- | Can be inserted between a manager and subordinate to monitor their interaction+circuitMonitor ::+  (Protocol p, Fwd p ~ C.Signal dom fwd, Bwd p ~ C.Signal dom bwd) =>+  Circuit p (p, CSignal dom (fwd, bwd))+circuitMonitor = Circuit (\ ~(fwd, (bwd, _)) -> (bwd, (fwd, C.bundle (fwd, bwd))))
+ src/Protocols/Internal/TH.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_HADDOCK hide #-}++module Protocols.Internal.TH where++import Clash.Prelude qualified as C+import Control.Monad (zipWithM)+import Control.Monad.Extra (concatMapM)+import Data.Proxy+import GHC.TypeNats+import Language.Haskell.TH+import Protocols.Experimental.Hedgehog.Types+import Protocols.Experimental.Simulate.Types+import Protocols.Internal.Types+import Protocols.Plugin++{- | Template haskell function to generate IdleCircuit instances for the tuples+n through m inclusive. To see a 2-tuple version of the pattern we generate,+see @Protocols.IdleCircuit@.+-}+idleCircuitTupleInstances :: Int -> Int -> DecsQ+idleCircuitTupleInstances n m = concatMapM idleCircuitTupleInstance [n .. m]++{- | Template Haskell function to generate an IdleCircuit instance for an+n-tuple.+-}+idleCircuitTupleInstance :: Int -> DecsQ+idleCircuitTupleInstance n =+  [d|+    instance ($instCtx) => IdleCircuit $instTy where+      idleFwd _ = $fwdExpr+      idleBwd _ = $bwdExpr+    |]+ where+  circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n]+  instCtx = foldl appT (tupleT n) $ map (\ty -> [t|IdleCircuit $ty|]) circTys+  instTy = foldl appT (tupleT n) circTys+  fwdExpr = tupE $ map mkFwdExpr circTys+  mkFwdExpr ty = [e|idleFwd $ Proxy @($ty)|]+  bwdExpr = tupE $ map mkBwdExpr circTys+  mkBwdExpr ty = [e|idleBwd $ Proxy @($ty)|]++simulateTupleInstances :: Int -> Int -> DecsQ+simulateTupleInstances n m = concatMapM simulateTupleInstance [n .. m]++simulateTupleInstance :: Int -> DecsQ+simulateTupleInstance n =+  [d|+    instance ($instCtx) => Simulate $instTy where+      type SimulateFwdType $instTy = $fwdType+      type SimulateBwdType $instTy = $bwdType+      type SimulateChannels $instTy = $channelSum++      simToSigFwd _ $(tildeP fwdPat0) = $(tupE $ zipWith (\ty expr -> [e|simToSigFwd (Proxy @($ty)) $expr|]) circTys fwdExpr)+      simToSigBwd _ $(tildeP bwdPat0) = $(tupE $ zipWith (\ty expr -> [e|simToSigBwd (Proxy @($ty)) $expr|]) circTys bwdExpr)+      sigToSimFwd _ $(tildeP fwdPat0) = $(tupE $ zipWith (\ty expr -> [e|sigToSimFwd (Proxy @($ty)) $expr|]) circTys fwdExpr)+      sigToSimBwd _ $(tildeP bwdPat0) = $(tupE $ zipWith (\ty expr -> [e|sigToSimBwd (Proxy @($ty)) $expr|]) circTys bwdExpr)++      stallC $(varP $ mkName "conf") $(varP $ mkName "rem0") = $stallCExpr+    |]+ where+  -- Generate the types for the instance+  circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n]+  instTy = foldl appT (tupleT n) circTys+  instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Simulate $ty|]) circTys+  fwdType = foldl appT (tupleT n) $ map (\ty -> [t|SimulateFwdType $ty|]) circTys+  bwdType = foldl appT (tupleT n) $ map (\ty -> [t|SimulateBwdType $ty|]) circTys+  channelSum = foldl1 (\a b -> [t|$a + $b|]) $ map (\ty -> [t|SimulateChannels $ty|]) circTys++  -- Relevant expressions and patterns+  fwdPat0 = tupP $ map (\i -> varP $ mkName $ "fwd" <> show i) [1 .. n]+  bwdPat0 = tupP $ map (\i -> varP $ mkName $ "bwd" <> show i) [1 .. n]+  fwdExpr = map (\i -> varE $ mkName $ "fwd" <> show i) [1 .. n]+  bwdExpr = map (\i -> varE $ mkName $ "bwd" <> show i) [1 .. n]+  fwdExpr1 = map (\i -> varE $ mkName $ "fwdStalled" <> show i) [1 .. n]+  bwdExpr1 = map (\i -> varE $ mkName $ "bwdStalled" <> show i) [1 .. n]++  -- stallC Declaration: Split off the stall vectors from the large input vector+  mkStallVec i ty =+    [d|+      $[p|+         ( $(varP (mkName $ "stalls" <> show i))+           , $(varP (mkName $ if i == n then "_" else "rem" <> show i))+           )+         |] =+          C.splitAtI @(SimulateChannels $ty)+            $(varE $ mkName $ "rem" <> show (i - 1))+      |]++  -- stallC Declaration: Generate stalling circuits+  mkStallCircuit i ty =+    [d|+      $[p|Circuit $(varP $ mkName $ "stalled" <> show i)|] =+        stallC @($ty) conf $(varE $ mkName $ "stalls" <> show i)+      |]++  -- Generate the stallC expression+  stallCExpr = do+    stallVecs <-+      concat <$> zipWithM mkStallVec [1 .. n] circTys+    stallCircuits <-+      concat <$> zipWithM mkStallCircuit [1 .. n] circTys+    LetE (stallVecs <> stallCircuits)+      <$> [e|Circuit $ \(~($fwdPat0, $bwdPat0)) -> $circuitResExpr|]++  circuitResExpr = do+    stallCResultDecs <- concatMapM mkStallCResultDec [1 .. n]+    LetE stallCResultDecs <$> [e|($(tupE fwdExpr1), $(tupE bwdExpr1))|]++  mkStallCResultDec i =+    [d|+      $[p|+         ( $(varP $ mkName $ "fwdStalled" <> show i)+           , $(varP $ mkName $ "bwdStalled" <> show i)+           )+         |] =+          $(varE $ mkName $ "stalled" <> show i)+            ( $(varE $ mkName $ "fwd" <> show i)+            , $(varE $ mkName $ "bwd" <> show i)+            )+      |]++drivableTupleInstances :: Int -> Int -> DecsQ+drivableTupleInstances n m = concatMapM drivableTupleInstance [n .. m]++drivableTupleInstance :: Int -> DecsQ+drivableTupleInstance n =+  [d|+    instance ($instCtx) => Drivable $instTy where+      type+        ExpectType $instTy =+          $(foldl appT (tupleT n) $ map (\ty -> [t|ExpectType $ty|]) circTys)+      toSimulateType Proxy $(tupP circPats) = $toSimulateExpr++      fromSimulateType Proxy $(tupP circPats) = $fromSimulateExpr++      driveC $(varP $ mkName "conf") $(tupP fwdPats) = $(letE driveCDecs driveCExpr)+      sampleC conf (Circuit f) =+        let+          $(varP $ mkName "bools") = replicate (resetCycles conf) False <> repeat True+          $(tupP fwdPats) = snd $ f ((), $(tupE $ map mkSampleCExpr circTys))+         in+          $( tupE $+               zipWith (\ty fwd -> [|sampleC @($ty) conf (Circuit $ const ((), $fwd))|]) circTys fwdExprs+           )+    |]+ where+  circStrings = map (\i -> "c" <> show i) [1 .. n]+  circTys = map (varT . mkName) circStrings+  circPats = map (varP . mkName) circStrings+  circExprs = map (varE . mkName) circStrings+  instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Drivable $ty|]) circTys+  instTy = foldl appT (tupleT n) circTys+  fwdPats = map (varP . mkName . ("fwd" <>)) circStrings+  fwdExprs = map (varE . mkName . ("fwd" <>)) circStrings+  bwdExprs = map (varE . mkName . ("bwd" <>)) circStrings+  bwdPats = map (varP . mkName . ("bwd" <>)) circStrings++  mkSampleCExpr ty = [e|boolsToBwd (Proxy @($ty)) bools|]+  driveCDecs =+    pure $+      valD+        (tupP $ map (\p -> [p|(Circuit $p)|]) circPats)+        (normalB $ tupE $ zipWith (\ty fwd -> [e|driveC @($ty) conf $fwd|]) circTys fwdExprs)+        []++  driveCExpr =+    [e|+      Circuit $ \(_, $(tildeP $ tupP bwdPats)) -> ((), $(tupE $ zipWith mkDriveCExpr circExprs bwdExprs))+      |]+  mkDriveCExpr c bwd = [e|snd ($c ((), $bwd))|]+  toSimulateExpr = tupE $ zipWith (\ty c -> [|toSimulateType (Proxy @($ty)) $c|]) circTys circExprs+  fromSimulateExpr = tupE $ zipWith (\ty c -> [|fromSimulateType (Proxy @($ty)) $c|]) circTys circExprs++backPressureTupleInstances :: Int -> Int -> DecsQ+backPressureTupleInstances n m = concatMapM backPressureTupleInstance [n .. m]++backPressureTupleInstance :: Int -> DecsQ+backPressureTupleInstance n =+  [d|+    instance ($instCtx) => Backpressure $instTy where+      boolsToBwd _ bs = $(tupE $ map (\ty -> [e|boolsToBwd (Proxy @($ty)) bs|]) circTys)+    |]+ where+  circTys = map (\i -> varT $ mkName $ "c" <> show i) [1 .. n]+  instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Backpressure $ty|]) circTys+  instTy = foldl appT (tupleT n) circTys++testTupleInstances :: Int -> Int -> DecsQ+testTupleInstances n m = concatMapM testTupleInstance [n .. m]++testTupleInstance :: Int -> DecsQ+testTupleInstance n =+  [d|+    instance ($instCtx) => Test $instTy where+      expectN Proxy $(varP $ mkName "opts") $(tupP sampledPats) = $(doE stmts)+    |]+ where+  circStrings = map (\i -> "c" <> show i) [1 .. n]+  circTys = map (varT . mkName) circStrings+  instCtx = foldl appT (tupleT n) $ map (\ty -> [t|Test $ty|]) circTys+  instTy = foldl appT (tupleT n) circTys++  sampledPats = map (varP . mkName . ("sampled" <>)) circStrings+  sampledExprs = map (varE . mkName . ("sampled" <>)) circStrings+  trimmedPats = map (varP . mkName . ("trimmed" <>)) circStrings+  trimmedExprs = map (varE . mkName . ("trimmed" <>)) circStrings++  mkTrimStmt trim ty sam = bindS trim [e|expectN (Proxy @($ty)) opts $sam|]+  expectResult = noBindS [e|pure $(tupE trimmedExprs)|]+  stmts = zipWith3 mkTrimStmt trimmedPats circTys sampledExprs <> [expectResult]
+ src/Protocols/Internal/Types.hs view
@@ -0,0 +1,16 @@+module Protocols.Internal.Types where++import Data.Proxy+import GHC.Base (Type)+import Protocols.Plugin++{- $setup+>>> import Protocols+-}++{- | Idle state of a Circuit. Aims to provide no data for both the forward and+backward direction. Transactions are not acknowledged.+-}+class (Protocol p) => IdleCircuit p where+  idleFwd :: Proxy p -> Fwd (p :: Type)+  idleBwd :: Proxy p -> Bwd (p :: Type)
+ src/Protocols/PacketStream.hs view
@@ -0,0 +1,50 @@+{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Provides the PacketStream protocol, a simple streaming protocol for+transferring packets of data between components.++Apart from the protocol definition, some components, all of which are generic in+@dataWidth@, are also provided:++1. Several small utilities such as filtering a stream based on its metadata.+2. FIFOs+3. Components which upsize or downsize @dataWidth@+4. Components which read from the stream (depacketizers)+5. Components which write to the stream (packetizers)+6. Components which split and merge a stream based on its metadata+-}+module Protocols.PacketStream (+  module Protocols.PacketStream.Base,++  -- * FIFOs+  module Protocols.PacketStream.PacketFifo,+  module Protocols.PacketStream.AsyncFifo,++  -- * Converters+  module Protocols.PacketStream.Converters,++  -- * Depacketizers+  module Protocols.PacketStream.Depacketizers,++  -- * Packetizers+  module Protocols.PacketStream.Packetizers,++  -- * Padding removal+  module Protocols.PacketStream.Padding,++  -- * Routing components+  module Protocols.PacketStream.Routing,+)+where++import Protocols.PacketStream.AsyncFifo+import Protocols.PacketStream.Base+import Protocols.PacketStream.Converters+import Protocols.PacketStream.Depacketizers+import Protocols.PacketStream.PacketFifo+import Protocols.PacketStream.Packetizers+import Protocols.PacketStream.Padding+import Protocols.PacketStream.Routing
+ src/Protocols/PacketStream/AsyncFifo.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Provides `asyncFifoC` for crossing clock domains in the packet stream protocol.+-}+module Protocols.PacketStream.AsyncFifo (asyncFifoC) where++import Data.Maybe.Extra (toMaybe)++import Clash.Explicit.Prelude (asyncFIFOSynchronizer)+import Clash.Prelude++import Protocols+import Protocols.PacketStream.Base++{- | Asynchronous FIFO circuit that can be used to safely cross clock domains.+Uses `Clash.Explicit.Prelude.asyncFIFOSynchronizer` internally.+-}+asyncFifoC ::+  forall+    (wDom :: Domain)+    (rDom :: Domain)+    (depth :: Nat)+    (dataWidth :: Nat)+    (meta :: Type).+  (KnownDomain wDom) =>+  (KnownDomain rDom) =>+  (KnownNat depth) =>+  (KnownNat dataWidth) =>+  (2 <= depth) =>+  (1 <= dataWidth) =>+  (NFDataX meta) =>+  -- | 2^depth is the number of elements this component can store+  SNat depth ->+  -- | Clock signal in the write domain+  Clock wDom ->+  -- | Reset signal in the write domain+  Reset wDom ->+  -- | Enable signal in the write domain+  Enable wDom ->+  -- | Clock signal in the read domain+  Clock rDom ->+  -- | Reset signal in the read domain+  Reset rDom ->+  -- | Enable signal in the read domain+  Enable rDom ->+  Circuit (PacketStream wDom dataWidth meta) (PacketStream rDom dataWidth meta)+asyncFifoC depth wClk wRst wEn rClk rRst rEn =+  exposeClockResetEnable forceResetSanity wClk wRst wEn |> fromSignals ckt+ where+  ckt (fwdIn, bwdIn) = (bwdOut, fwdOut)+   where+    (element, isEmpty, isFull) = asyncFIFOSynchronizer depth wClk rClk wRst rRst wEn rEn readReq fwdIn+    notEmpty = not <$> isEmpty+    -- If the FIFO is empty, we output Nothing. Else, we output the oldest element.+    fwdOut = toMaybe <$> notEmpty <*> element+    -- Assert backpressure when the FIFO is full.+    bwdOut = PacketStreamS2M . not <$> isFull+    -- Next component is ready to read if the fifo is not empty and it does not assert backpressure.+    readReq = notEmpty .&&. _ready <$> bwdIn
+ src/Protocols/PacketStream/Base.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Definitions and instances of the PacketStream protocol.+-}+module Protocols.PacketStream.Base (+  -- * Protocol definition+  PacketStreamM2S (..),+  PacketStreamS2M (..),+  PacketStream,++  -- * Constants+  nullByte,++  -- * CSignal conversion+  toCSignal,+  unsafeFromCSignal,+  unsafeDropBackpressure,++  -- * Basic operations on the PacketStream protocol+  empty,+  consume,+  forceResetSanity,+  zeroOutInvalidBytesC,+  stripTrailingEmptyC,+  unsafeAbortOnBackpressureC,+  truncateAbortedPackets,++  -- * Components imported from DfConv+  void,+  fanout,+  registerBwd,+  registerFwd,+  registerBoth,++  -- * Operations on metadata+  fstMeta,+  sndMeta,+  mapMeta,+  filterMeta,+  firstMeta,+  secondMeta,+  bimapMeta,+  eitherMeta,++  -- * Operations on metadata (Signal versions)+  mapMetaS,+  filterMetaS,+  firstMetaS,+  secondMetaS,+  bimapMetaS,+  eitherMetaS,+) where++import Prelude qualified as P++import Control.DeepSeq (NFData)++import Clash.Prelude hiding (empty, sample)++import Data.Bifunctor qualified as B+import Data.Coerce (coerce)+import Data.Maybe qualified as Maybe+import Data.Proxy++import Protocols+import Protocols.DfConv qualified as DfConv+import Protocols.Idle++{- |+Data sent from manager to subordinate.++Heavily inspired by the M2S data of AMBA AXI4-Stream, but simplified:++- @_tdata@ is moved into @_data@, which serves the exact same purpose: the actual+  data of the transfer.+- @_tkeep@ is changed to `_last`.+- @_tstrb@ is removed as there are no position bytes.+- @_tid@ is removed, because packets may not be interrupted by other packets.+- @_tdest@ is moved into `_meta`.+- @_tuser@ is moved into `_meta`.+- @_tvalid@ is modeled by wrapping this type into a @Maybe@.+-}+data PacketStreamM2S (dataWidth :: Nat) (meta :: Type) = PacketStreamM2S+  { _data :: Vec dataWidth (BitVector 8)+  -- ^ The bytes to be transmitted.+  , _last :: Maybe (Index (dataWidth + 1))+  {- ^ If this is @Just@ then it signals that this transfer is the end of a+  packet and contains the number of valid bytes in '_data', starting from+  index @0@.++  If it is @Nothing@ then this transfer is not yet the end of a packet and all+  bytes are valid. This implies that no null bytes are allowed in the middle of+  a packet, only after a packet.+  -}+  , _meta :: meta+  -- ^ Metadata of a packet. Must be constant during a packet.+  , _abort :: Bool+  {- ^ Iff true, the packet corresponding to this transfer is invalid. The subordinate+  must either drop the packet or forward the `_abort`.+  -}+  }+  deriving (Generic, ShowX, Show, NFData, Bundle, Functor)++deriving instance+  (KnownNat dataWidth, NFDataX meta) =>+  NFDataX (PacketStreamM2S dataWidth meta)++{- |+Two PacketStream transfers are equal if and only if:++1. They have the same `_last`+2. They have the same `_meta`.+3. They have the same `_abort`.+4. All bytes in `_data` which are enabled by `_last` are equal.++Data bytes that are not enabled are not considered in the equality check,+because the protocol allows them to be /undefined/.++=== Examples++>>> t1 = PacketStreamM2S (0x11 :> 0x22 :> 0x33 :> Nil) Nothing () False+>>> t2 = PacketStreamM2S (0x11 :> 0x22 :> 0x33 :> Nil) (Just 2) () False+>>> t3 = PacketStreamM2S (0x11 :> 0x22 :> 0xFF :> Nil) (Just 2) () False+>>> t4 = PacketStreamM2S (0x11 :> 0x22 :> undefined :> Nil) (Just 2) () False++>>> t1 == t1+True+>>> t2 == t3+True+>>> t1 /= t2+True+>>> t3 == t4+True+-}+instance (KnownNat dataWidth, Eq meta) => Eq (PacketStreamM2S dataWidth meta) where+  t1 == t2 = lastEq && metaEq && abortEq && dataEq+   where+    lastEq = _last t1 == _last t2+    metaEq = _meta t1 == _meta t2+    abortEq = _abort t1 == _abort t2++    -- Bitmask used for data equality. If the index of a data byte is larger+    -- than or equal to the size of `_data`, it is a null byte and must be+    -- disregarded in the equality check.+    mask = case _last t1 of+      Nothing -> repeat False+      Just size -> imap (\i _ -> resize i >= size) (_data t1)++    dataEq = case compareSNat (SNat @dataWidth) d0 of+      SNatLE -> True+      SNatGT ->+        leToPlus @1 @dataWidth+          $ fold (&&)+          $ zipWith3 (\b1 b2 isNull -> isNull || b1 == b2) (_data t1) (_data t2) mask++-- | Used by circuit-notation to create an empty stream+instance Default (Maybe (PacketStreamM2S dataWidth meta)) where+  def = Nothing++deriveAutoReg ''PacketStreamM2S++{- |+Data sent from the subordinate to manager.++The only information transmitted is whether the subordinate is ready to receive data.+-}+newtype PacketStreamS2M = PacketStreamS2M+  { _ready :: Bool+  -- ^ Iff True, the subordinate is ready to receive data.+  }+  -- deriving (Bundle, Eq, Generic, NFData, NFDataX, Show, ShowX)+  deriving stock (Generic, Show)+  deriving anyclass (Bundle, ShowX)+  deriving newtype (NFDataX, Eq)++-- | Used by circuit-notation to create a sink that always acknowledges+instance Default PacketStreamS2M where+  def = PacketStreamS2M True++deriveAutoReg ''PacketStreamS2M++{- |+Simple valid-ready streaming protocol for transferring packets between components.++Invariants:++1. A manager must not check the `Bwd` channel when it is sending @Nothing@ over the `Fwd` channel.+2. A manager must keep sending the same data until the subordinate has acknowledged it, i.e. upon observing `_ready` as @True@.+3. A manager must keep the metadata (`_meta`) of an entire packet it sends constant.+4. A subordinate which receives a transfer with `_abort` asserted must either forward this `_abort` or drop the packet.+5. A packet may not be interrupted by another packet.++This protocol allows the last transfer of a packet to have zero valid bytes in+'_data', so it also allows 0-byte packets. Note that concrete implementations+of the protocol are free to disallow 0-byte packets or packets with a trailing+zero-byte transfer for whatever reason.++The value of data bytes which are not enabled is /undefined/.+-}+data PacketStream (dom :: Domain) (dataWidth :: Nat) (meta :: Type)++instance Protocol (PacketStream dom dataWidth meta) where+  type+    Fwd (PacketStream dom dataWidth meta) =+      Signal dom (Maybe (PacketStreamM2S dataWidth meta))+  type Bwd (PacketStream dom dataWidth meta) = Signal dom PacketStreamS2M++instance IdleCircuit (PacketStream dom dataWidth meta) where+  idleBwd _ = pure (PacketStreamS2M False)+  idleFwd _ = pure Nothing++instance DfConv.DfConv (PacketStream dom dataWidth meta) where+  type Dom (PacketStream dom dataWidth meta) = dom+  type FwdPayload (PacketStream dom dataWidth meta) = PacketStreamM2S dataWidth meta++  toDfCircuit _ = fromSignals go+   where+    go (fwdIn, bwdIn) =+      (+        ( fmap coerce bwdIn+        , pure (deepErrorX "PacketStream toDfCircuit: undefined")+        )+      , P.fst fwdIn+      )++  fromDfCircuit _ = fromSignals go+   where+    go (fwdIn, bwdIn) =+      ( coerce <$> P.fst bwdIn+      ,+        ( fwdIn+        , pure (deepErrorX "PacketStream fromDfCircuit: undefined")+        )+      )++{- |+Undefined PacketStream null byte. Will throw an error if evaluated. The source+of the error should be supplied for a more informative error message; otherwise+it is unclear which component threw the error.+-}+nullByte ::+  -- | Component which caused the error+  String ->+  BitVector 8+nullByte src =+  deepErrorX+    $ src+    <> ": value of PacketStream null byte is undefined. "+    <> "Data bytes that are not enabled must not be evaluated."++{- |+Circuit to convert a 'CSignal' into a 'PacketStream'.+This is unsafe, because it ignores all incoming backpressure.+-}+unsafeFromCSignal ::+  forall dom dataWidth meta.+  Circuit+    (CSignal dom (Maybe (PacketStreamM2S dataWidth meta)))+    (PacketStream dom dataWidth meta)+unsafeFromCSignal = Circuit (\(fwdInS, _) -> ((), fwdInS))++-- | Converts a 'PacketStream' into a 'CSignal': always acknowledges.+toCSignal ::+  forall dom dataWidth meta.+  (HiddenClockResetEnable dom) =>+  Circuit+    (PacketStream dom dataWidth meta)+    (CSignal dom (Maybe (PacketStreamM2S dataWidth meta)))+toCSignal = forceResetSanity |> Circuit (\(fwdIn, _) -> (pure (PacketStreamS2M True), fwdIn))++-- | Drop all backpressure signals.+unsafeDropBackpressure ::+  (HiddenClockResetEnable dom) =>+  Circuit+    (PacketStream dom dwIn meta)+    (PacketStream dom dwOut meta) ->+  Circuit+    (CSignal dom (Maybe (PacketStreamM2S dwIn meta)))+    (CSignal dom (Maybe (PacketStreamM2S dwOut meta)))+unsafeDropBackpressure ckt = unsafeFromCSignal |> ckt |> toCSignal++{- |+Sets '_abort' upon receiving backpressure from the subordinate.++__UNSAFE__: because @fwdOut@ depends on @bwdIn@, this may introduce+combinatorial loops. You need to make sure that a sequential element is+inserted along this path. It is possible to use one of the skid buffers to+ensure this. For example:++>>> safeAbortOnBackpressureC1 = unsafeAbortOnBackpressureC |> registerFwd+>>> safeAbortOnBackpressureC2 = unsafeAbortOnBackpressureC |> registerBwd++Note that `registerFwd` utilizes less resources than `registerBwd`.+-}+unsafeAbortOnBackpressureC ::+  forall (dataWidth :: Nat) (meta :: Type) (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  Circuit+    (CSignal dom (Maybe (PacketStreamM2S dataWidth meta)))+    (PacketStream dom dataWidth meta)+unsafeAbortOnBackpressureC =+  Circuit $ \(fwdInS, bwdInS) -> ((), go <$> bundle (fwdInS, bwdInS))+ where+  go (fwdIn, bwdIn) =+    fmap (\pkt -> pkt{_abort = _abort pkt || not (_ready bwdIn)}) fwdIn++{- |+Force a /nack/ on the backward channel and /Nothing/ on the forward+channel if reset is asserted.+-}+forceResetSanity ::+  forall dom dataWidth meta.+  (KnownDomain dom, HiddenReset dom) =>+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+forceResetSanity = forceResetSanityGeneric++{- |+Strips trailing zero-byte transfers from packets in the stream. That is,+if a packet consists of more than one transfer and '_last' of the last+transfer in that packet is @Just 0@, the last transfer of that packet will+be dropped and '_last' of the transfer before that will be set to @maxBound@.+If such a trailing zero-byte transfer had '_abort' asserted, it will be+preserved.++Has one clock cycle latency, but runs at full throughput.+-}+stripTrailingEmptyC ::+  forall (dataWidth :: Nat) (meta :: Type) (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (NFDataX meta) =>+  Circuit+    (PacketStream dom dataWidth meta)+    (PacketStream dom dataWidth meta)+stripTrailingEmptyC = forceResetSanity |> fromSignals (mealyB go (False, False, Nothing))+ where+  go (notFirst, flush, cache) (Nothing, bwdIn) =+    ((notFirst, flush', cache'), (PacketStreamS2M True, fwdOut))+   where+    fwdOut = if flush then cache else Nothing+    (flush', cache')+      | flush && _ready bwdIn = (False, Nothing)+      | otherwise = (flush, cache)+  go (notFirst, flush, cache) (Just transferIn, bwdIn) = (nextStOut, (bwdOut, fwdOut))+   where+    (notFirst', flush', cache', fwdOut) = case _last transferIn of+      Nothing -> (True, False, Just transferIn, cache)+      Just i ->+        let trailing = i == 0 && notFirst+         in ( False+            , not trailing+            , if trailing then Nothing else Just transferIn+            , if trailing+                then (\x -> x{_last = Just maxBound, _abort = _abort x || _abort transferIn}) <$> cache+                else cache+            )++    bwdOut = PacketStreamS2M (Maybe.isNothing cache || _ready bwdIn)++    nextStOut+      | Maybe.isNothing cache || _ready bwdIn = (notFirst', flush', cache')+      | otherwise = (notFirst, flush, cache)++-- | Sets data bytes that are not enabled in a @PacketStream@ to @0x00@.+zeroOutInvalidBytesC ::+  forall (dom :: Domain) (dataWidth :: Nat) (meta :: Type).+  (KnownNat dataWidth) =>+  (1 <= dataWidth) =>+  Circuit+    (PacketStream dom dataWidth meta)+    (PacketStream dom dataWidth meta)+zeroOutInvalidBytesC = Circuit $ \(fwdIn, bwdIn) -> (bwdIn, fmap (go <$>) fwdIn)+ where+  go transferIn = transferIn{_data = dataOut}+   where+    dataOut = case _last transferIn of+      Nothing -> _data transferIn+      Just i ->+        imap+          (\(j :: Index dataWidth) byte -> if resize j < i then byte else 0x00)+          (_data transferIn)++data TruncateState = Forwarding | Truncating+  deriving (Show, ShowX, Eq, Generic, NFDataX)++{- |+When a packet is aborted, this circuit will truncate the current packet by setting the+'_last' field of the transaction to @Just 0@ and the '_abort' field to @True@.+All subsequent transactions will be consumed without being forwarded.+-}+truncateAbortedPackets ::+  forall (dom :: Domain) (dataWidth :: Nat) (meta :: Type).+  (HiddenClockResetEnable dom, KnownNat dataWidth, ShowX meta) =>+  (1 <= dataWidth) =>+  Circuit+    (PacketStream dom dataWidth meta)+    (PacketStream dom dataWidth meta)+truncateAbortedPackets = forceResetSanity |> Circuit (unbundle . mealy go Forwarding . bundle)+ where+  go state (Nothing, _) = (state, (deepErrorX "truncateAbortedPackets: undefined ack", Nothing))+  go Truncating (Just m2s, _) = (nextState, (PacketStreamS2M True, Nothing))+   where+    nextState+      | Maybe.isJust m2s._last = Forwarding+      | otherwise = Truncating+  go Forwarding (Just m2sLeft, PacketStreamS2M ack) = (nextState, (PacketStreamS2M ack, Just m2sRight))+   where+    m2sRight+      | m2sLeft._abort = m2sLeft{_last = Just 0}+      | otherwise = m2sLeft++    nextState+      -- Note that there is no need to move to 'Truncating' if the transfer we+      -- see here is the last transfer of a packet (i.e., '_last' is @Just _@).+      | Maybe.isNothing m2sLeft._last && m2sLeft._abort && ack = Truncating+      | otherwise = Forwarding++{- |+Copy data of a single `PacketStream` to multiple. LHS will only receive+an acknowledgement when all RHS receivers have acknowledged data.+-}+fanout ::+  forall n dataWidth meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat n) =>+  (KnownNat dataWidth) =>+  (1 <= n) =>+  (NFDataX meta) =>+  Circuit+    (PacketStream dom dataWidth meta)+    (Vec n (PacketStream dom dataWidth meta))+fanout = DfConv.fanout Proxy Proxy++{- |+Place a register on the /forward/ part of a circuit.+This adds combinational delay on the /backward/ path.+-}+registerFwd ::+  forall dataWidth meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (NFDataX meta) =>+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+registerFwd = DfConv.registerFwd Proxy Proxy++{- |+Place a register on the /backward/ part of a circuit.+This adds combinational delay on the /forward/ path.+-}+registerBwd ::+  forall dataWidth meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (NFDataX meta) =>+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+registerBwd = DfConv.registerBwd Proxy Proxy++{- |+A pipeline skid buffer: places registers on both the /backward/ and /forward/+part of a circuit. This completely breaks up the combinatorial path between+the left and right side of this component. In order to achieve this, it has to+buffer @Fwd@ twice.++Another benefit of this component is that the circuit on the left hand side+may now use @Bwd@ in order to compute its @Fwd@, because this cannot+introduce combinatorial loops anymore.++Runs at full throughput, but causes 2 clock cycles of latency.+-}+registerBoth ::+  forall dataWidth meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (NFDataX meta) =>+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+registerBoth = registerBwd |> registerFwd++-- | Never produces a value.+empty :: Circuit () (PacketStream dom dataWidth meta)+empty = Circuit (const ((), pure Nothing))++-- | Always acknowledges incoming data.+consume :: (HiddenReset dom) => Circuit (PacketStream dom dataWidth meta) ()+consume = Circuit (const (pure (PacketStreamS2M True), ()))++-- | Never acknowledges incoming data.+void :: (HiddenClockResetEnable dom) => Circuit (PacketStream dom dataWidth meta) ()+void = DfConv.void Proxy++-- | Like 'P.fst', but over the metadata of a 'PacketStream'.+fstMeta :: Circuit (PacketStream dom dataWidth (a, b)) (PacketStream dom dataWidth a)+fstMeta = mapMeta P.fst++-- | Like 'P.snd', but over the metadata of a 'PacketStream'.+sndMeta :: Circuit (PacketStream dom dataWidth (a, b)) (PacketStream dom dataWidth b)+sndMeta = mapMeta P.snd++-- | Like 'Data.List.map', but over the metadata of a 'PacketStream'.+mapMeta ::+  -- | Function to apply on the metadata+  (metaIn -> metaOut) ->+  Circuit (PacketStream dom dataWidth metaIn) (PacketStream dom dataWidth metaOut)+mapMeta f = mapMetaS (pure f)++{- |+Like 'mapMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+mapMetaS ::+  -- | Function to apply on the metadata, wrapped in a @Signal@+  Signal dom (metaIn -> metaOut) ->+  Circuit (PacketStream dom dataWidth metaIn) (PacketStream dom dataWidth metaOut)+mapMetaS fS = Circuit $ \(fwdIn, bwdIn) -> (bwdIn, go <$> bundle (fwdIn, fS))+ where+  go (inp, f) = (\inPkt -> inPkt{_meta = f (_meta inPkt)}) <$> inp++-- | Like 'Data.List.filter', but over the metadata of a 'PacketStream'.+filterMeta ::+  -- | Predicate which specifies whether to keep a fragment based on its metadata+  (meta -> Bool) ->+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+filterMeta p = filterMetaS (pure p)++{- |+Like 'filterMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+filterMetaS ::+  {- | Predicate which specifies whether to keep a fragment based on its metadata,+  wrapped in a @Signal@+  -}+  Signal dom (meta -> Bool) ->+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+filterMetaS pS = Circuit $ \(fwdIn, bwdIn) -> unbundle (go <$> bundle (fwdIn, bwdIn, pS))+ where+  go (Nothing, bwdIn, _) = (bwdIn, Nothing)+  go (Just inPkt, bwdIn, predicate)+    | predicate (_meta inPkt) = (bwdIn, Just inPkt)+    | otherwise = (PacketStreamS2M True, Nothing)++-- | Like 'Data.Either.either', but over the metadata of a 'PacketStream'.+eitherMeta ::+  (a -> c) ->+  (b -> c) ->+  Circuit+    (PacketStream dom dataWidth (Either a b))+    (PacketStream dom dataWidth c)+eitherMeta f g = eitherMetaS (pure f) (pure g)++{- |+Like 'eitherMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+eitherMetaS ::+  Signal dom (a -> c) ->+  Signal dom (b -> c) ->+  Circuit+    (PacketStream dom dataWidth (Either a b))+    (PacketStream dom dataWidth c)+eitherMetaS fS gS = mapMetaS (liftA2 P.either fS gS)++-- | Like 'Data.Bifunctor.bimap', but over the metadata of a 'PacketStream'.+bimapMeta ::+  (B.Bifunctor p) =>+  (a -> b) ->+  (c -> d) ->+  Circuit+    (PacketStream dom dataWidth (p a c))+    (PacketStream dom dataWidth (p b d))+bimapMeta f g = bimapMetaS (pure f) (pure g)++{- |+Like 'bimapMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+bimapMetaS ::+  (B.Bifunctor p) =>+  Signal dom (a -> b) ->+  Signal dom (c -> d) ->+  Circuit+    (PacketStream dom dataWidth (p a c))+    (PacketStream dom dataWidth (p b d))+bimapMetaS fS gS = mapMetaS (liftA2 B.bimap fS gS)++-- | Like 'Data.Bifunctor.first', but over the metadata of a 'PacketStream'.+firstMeta ::+  (B.Bifunctor p) =>+  (a -> b) ->+  Circuit+    (PacketStream dom dataWidth (p a c))+    (PacketStream dom dataWidth (p b c))+firstMeta f = firstMetaS (pure f)++{- |+Like 'firstMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+firstMetaS ::+  (B.Bifunctor p) =>+  Signal dom (a -> b) ->+  Circuit+    (PacketStream dom dataWidth (p a c))+    (PacketStream dom dataWidth (p b c))+firstMetaS fS = mapMetaS (B.first <$> fS)++-- | Like 'Data.Bifunctor.second', but over the metadata of a 'PacketStream'.+secondMeta ::+  (B.Bifunctor p) =>+  (b -> c) ->+  Circuit+    (PacketStream dom dataWidth (p a b))+    (PacketStream dom dataWidth (p a c))+secondMeta f = secondMetaS (pure f)++{- |+Like 'secondMeta' but can reason over signals,+this circuit combinator is akin to `Clash.HaskellPrelude.<*>`.+-}+secondMetaS ::+  (B.Bifunctor p) =>+  Signal dom (b -> c) ->+  Circuit+    (PacketStream dom dataWidth (p a b))+    (PacketStream dom dataWidth (p a c))+secondMetaS fS = mapMetaS (B.second <$> fS)
+ src/Protocols/PacketStream/Converters.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Provides an upconverter and downconverter for changing the data width of+packet streams.+-}+module Protocols.PacketStream.Converters (+  downConverterC,+  upConverterC,+  unsafeUpConverterC,+) where++import Clash.Prelude++import Data.Maybe (fromMaybe, isJust)+import Data.Maybe.Extra+import Data.Type.Equality ((:~:) (Refl))++import Protocols (CSignal, Circuit (..), fromSignals, idC, (|>))+import Protocols.PacketStream.Base++-- | State of 'upConverter'.+data UpConverterState (dwIn :: Nat) (n :: Nat) (meta :: Type) = UpConverterState+  { _ucBuf :: Vec (dwIn * n) (BitVector 8)+  -- ^ The data buffer we are filling.+  , _ucIdx :: Index n+  -- ^ Where in _ucBuf we need to write the next data.+  , _ucIdx2 :: Index (dwIn * n + 1)+  {- ^ Used when @dwIn@ is not a power of two to determine the adjusted '_last',+  to avoid multiplication (infers an expensive DSP slice).+  If @dwIn@ is a power of two then we can multiply by shifting left with+  a constant, which is free in hardware in terms of resource usage.+  -}+  , _ucFlush :: Bool+  -- ^ If true, we should output the current state as a PacketStream transfer.+  , _ucAborted :: Bool+  -- ^ Whether the current transfer we are building is aborted.+  , _ucLastIdx :: Maybe (Index (dwIn * n + 1))+  -- ^ If Just, the current buffer contains the last byte of the current packet.+  , _ucMeta :: meta+  -- ^ Metadata of the current transfer we are a building.+  }+  deriving (Generic, NFDataX, Show, ShowX)++-- | Computes the next state for 'upConverter'.+nextState ::+  forall (dwIn :: Nat) (meta :: Type) (n :: Nat).+  (1 <= dwIn) =>+  (1 <= n) =>+  (KnownNat dwIn) =>+  (KnownNat n) =>+  (NFDataX meta) =>+  UpConverterState dwIn n meta ->+  Maybe (PacketStreamM2S dwIn meta) ->+  PacketStreamS2M ->+  UpConverterState dwIn n meta+nextState st@(UpConverterState{..}) Nothing (PacketStreamS2M inReady) =+  nextSt+ where+  outReady = not _ucFlush || inReady+  -- If we can accept data we can always set _ucFlush to false,+  -- since we only change state if we can transmit and receive data+  nextStRaw =+    st+      { _ucFlush = False+      , _ucAborted = not _ucFlush && _ucAborted+      , _ucLastIdx = Nothing+      }+  nextSt = if outReady then nextStRaw else st+nextState st@(UpConverterState{..}) (Just PacketStreamM2S{..}) (PacketStreamS2M inReady) =+  nextSt+ where+  nextAbort = (not _ucFlush && _ucAborted) || _abort+  -- If we are not flushing we can accept data to be stored in _ucBuf,+  -- but when we are flushing we can only accept if the current+  -- output fragment is accepted by the sink+  outReady = not _ucFlush || inReady+  bufFull = _ucIdx == maxBound++  nextBuf =+    bitCoerce+      $ replace+        _ucIdx+        (pack _data :: BitVector (8 * dwIn))+        (bitCoerce _ucBuf :: Vec n (BitVector (8 * dwIn)))++  nextFlush = isJust _last || bufFull+  nextIdx = if nextFlush then 0 else _ucIdx + 1++  -- If @dwIn@ is not a power of two, we need to do some extra bookkeeping to+  -- avoid multiplication to calculate _last. If not, _ucIdx2 stays at 0 and is+  -- never used, and should therefore be optimized out by synthesis tools.+  (nextIdx2, nextLastIdx) = case sameNat (SNat @(FLog 2 dwIn)) (SNat @(CLog 2 dwIn)) of+    Just Refl ->+      ( 0+      , (\i -> shiftL (resize _ucIdx) (natToNum @(Log 2 dwIn)) + resize i) <$> _last+      )+    Nothing ->+      ( if nextFlush then 0 else _ucIdx2 + natToNum @dwIn+      , (\i -> _ucIdx2 + resize i) <$> _last+      )++  nextStRaw =+    UpConverterState+      { _ucBuf = nextBuf+      , _ucIdx = nextIdx+      , _ucIdx2 = nextIdx2+      , _ucFlush = nextFlush+      , _ucAborted = nextAbort+      , _ucLastIdx = nextLastIdx+      , _ucMeta = _meta+      }+  nextSt = if outReady then nextStRaw else st++upConverter ::+  forall (dwIn :: Nat) (meta :: Type) (dom :: Domain) (n :: Nat).+  (HiddenClockResetEnable dom) =>+  (1 <= dwIn) =>+  (1 <= n) =>+  (KnownNat dwIn) =>+  (KnownNat n) =>+  (NFDataX meta) =>+  ( Signal dom (Maybe (PacketStreamM2S dwIn meta))+  , Signal dom PacketStreamS2M+  ) ->+  ( Signal dom PacketStreamS2M+  , Signal dom (Maybe (PacketStreamM2S (dwIn * n) meta))+  )+upConverter = mealyB go s0+ where+  errPrefix = "upConverterT: undefined initial "+  s0 =+    UpConverterState+      { _ucBuf = repeat (nullByte "upConverter")+      , _ucIdx = 0+      , _ucIdx2 = 0+      , _ucFlush = False+      , _ucAborted = False+      , _ucLastIdx = deepErrorX (errPrefix <> " _ucLastIdx")+      , _ucMeta = deepErrorX (errPrefix <> " _ucMeta")+      }+  go st@(UpConverterState{..}) (fwdIn, bwdIn) =+    (nextState st fwdIn bwdIn, (PacketStreamS2M outReady, fwdOut))+   where+    outReady = not _ucFlush || _ready bwdIn++    fwdOut =+      toMaybe _ucFlush+        $ PacketStreamM2S+          { _data = _ucBuf+          , _last = _ucLastIdx+          , _meta = _ucMeta+          , _abort = _ucAborted+          }++{- |+Converts packet streams of arbitrary data width @dwIn@ to packet streams of+a bigger (or equal) data width @dwIn * n@, where @n > 0@.+When @n ~ 1@, this component is just the identity circuit, `idC`.++If '_abort' is asserted on any of the input sub-transfers, it will be asserted+on the corresponding output transfer as well. All zero-byte transfers are+preserved.++Has one cycle of latency, all M2S outputs are registered.+Provides full throughput.+-}+upConverterC ::+  forall (dwIn :: Nat) (n :: Nat) (meta :: Type) (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  (1 <= dwIn) =>+  (1 <= n) =>+  (KnownNat dwIn) =>+  (KnownNat n) =>+  (NFDataX meta) =>+  -- | Upconverter circuit+  Circuit (PacketStream dom dwIn meta) (PacketStream dom (dwIn * n) meta)+upConverterC = case sameNat d1 (SNat @n) of+  Just Refl -> idC+  _ -> forceResetSanity |> fromSignals upConverter++{- |+Unsafe version of 'upConverterC'.++Because 'upConverterC' runs at full throughput, i.e. it only asserts backpressure+if the subordinate asserts backpressure, we supply this variant which drops all+backpressure signals. This can be used when the source circuit does not support+backpressure. Using this variant in that case will improve timing and probably+reduce resource usage.+-}+unsafeUpConverterC ::+  forall (dwIn :: Nat) (meta :: Type) (dom :: Domain) (n :: Nat).+  (HiddenClockResetEnable dom) =>+  (1 <= dwIn) =>+  (1 <= n) =>+  (KnownNat dwIn) =>+  (KnownNat n) =>+  (NFDataX meta) =>+  -- | Unsafe upconverter circuit+  Circuit+    (CSignal dom (Maybe (PacketStreamM2S dwIn meta)))+    (CSignal dom (Maybe (PacketStreamM2S (dwIn * n) meta)))+unsafeUpConverterC = case sameNat d1 (SNat @n) of+  Just Refl -> idC+  _ -> unsafeDropBackpressure (fromSignals upConverter)++-- | State of 'downConverterT'.+data DownConverterState (dwOut :: Nat) (n :: Nat) (meta :: Type) = DownConverterState+  { _dcBuf :: Vec (dwOut * n) (BitVector 8)+  -- ^ Registered _data of the last transfer.+  , _dcLast :: Bool+  -- ^ Is the last transfer the end of a packet?+  , _dcMeta :: meta+  -- ^ Registered _meta of the last transfer.+  , _dcAborted :: Bool+  {- ^ Registered _abort of the last transfer. All sub-transfers corresponding+  to this transfer need to be marked with the same _abort value.+  -}+  , _dcSize :: Index (dwOut * n + 1)+  -- ^ Number of valid bytes in _dcBuf.+  , _dcZeroByteTransfer :: Bool+  {- ^ Is the current transfer we store a zero-byte transfer? In this case,+  _dcSize is 0 but we still need to transmit something in order to+  preserve zero-byte transfers.+  -}+  }+  deriving (Generic, NFDataX)++-- | State transition function of 'downConverterC', in case @n > 1@.+downConverterT ::+  forall (dwOut :: Nat) (n :: Nat) (meta :: Type).+  (KnownNat dwOut) =>+  (KnownNat n) =>+  (1 <= dwOut) =>+  (1 <= n) =>+  (NFDataX meta) =>+  DownConverterState dwOut n meta ->+  (Maybe (PacketStreamM2S (dwOut * n) meta), PacketStreamS2M) ->+  ( DownConverterState dwOut n meta+  , (PacketStreamS2M, Maybe (PacketStreamM2S dwOut meta))+  )+downConverterT st@(DownConverterState{..}) (fwdIn, bwdIn) =+  (nextSt, (PacketStreamS2M readyOut, fwdOut))+ where+  (shiftedBuf, dataOut) =+    leToPlus @dwOut @(dwOut * n)+      $ shiftOutFrom0 (SNat @dwOut) _dcBuf++  -- Either we preserve a zero-byte transfer or we have some real data to transmit.+  fwdOut =+    toMaybe (_dcSize > 0 || _dcZeroByteTransfer)+      $ PacketStreamM2S+        { _data = dataOut+        , _last =+            if _dcZeroByteTransfer+              then Just 0+              else toMaybe (_dcSize <= natToNum @dwOut && _dcLast) (resize _dcSize)+        , _meta = _dcMeta+        , _abort = _dcAborted+        }++  -- If the state buffer is empty, or if the state buffer is not empty and+  -- the final sub-transfer is acknowledged this clock cycle, we can acknowledge+  -- newly received valid data and load it into our registers.+  emptyState = _dcSize == 0 && not _dcZeroByteTransfer+  readyOut =+    emptyState || (_dcSize <= natToNum @dwOut && _ready bwdIn)++  nextSt+    | isJust fwdIn && readyOut = newState (fromJustX fwdIn)+    | not emptyState && _ready bwdIn =+        st+          { _dcBuf = shiftedBuf+          , _dcSize = satSub SatBound _dcSize (natToNum @dwOut)+          , _dcZeroByteTransfer = False+          }+    | otherwise = st++  -- Computes a new state from a valid incoming transfer.+  newState PacketStreamM2S{..} =+    DownConverterState+      { _dcBuf = _data+      , _dcMeta = _meta+      , _dcSize = fromMaybe (natToNum @(dwOut * n)) _last+      , _dcLast = isJust _last+      , _dcAborted = _abort+      , _dcZeroByteTransfer = _last == Just 0+      }++{- |+Converts packet streams of a data width which is a multiple of @n@, i.e.+@dwOut * n@, to packet streams of a smaller (or equal) data width @dwOut@,+where @n > 0@.+When @n ~ 1@, this component is just the identity circuit, `idC`.++If '_abort' is asserted on an input transfer, it will be asserted on all+corresponding output sub-transfers as well. All zero-byte transfers are+preserved.++Has one clock cycle of latency, all M2S outputs are registered.+Throughput is optimal, a transfer of @k@ valid bytes is transmitted in @k@+clock cycles. To be precise, throughput is at least @(1 / n)%@, so at+least @50%@ if @n = 2@ for example. We specify /at least/,+because the throughput may be on the last transfer of a packet, when not all+bytes have to be valid. If there is only one valid byte in the last transfer,+then the throughput will always be @100%@ for that particular transfer.+-}+downConverterC ::+  forall (dwOut :: Nat) (n :: Nat) (meta :: Type) (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  (KnownNat dwOut) =>+  (KnownNat n) =>+  (1 <= dwOut) =>+  (1 <= n) =>+  (NFDataX meta) =>+  -- | Downconverter circuit+  Circuit (PacketStream dom (dwOut * n) meta) (PacketStream dom dwOut meta)+downConverterC = case sameNat d1 (SNat @n) of+  Just Refl -> idC+  _ -> forceResetSanity |> fromSignals (mealyB downConverterT s0)+   where+    errPrefix = "downConverterT: undefined initial "+    s0 =+      DownConverterState+        { _dcBuf = deepErrorX (errPrefix <> "_dcBuf")+        , _dcLast = deepErrorX (errPrefix <> "_dcLast")+        , _dcMeta = deepErrorX (errPrefix <> "_dcMeta")+        , _dcAborted = deepErrorX (errPrefix <> "_dcAborted")+        , _dcSize = 0+        , _dcZeroByteTransfer = False+        }
+ src/Protocols/PacketStream/Depacketizers.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}+{-# OPTIONS_GHC -fplugin Protocols.Plugin #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utility circuits for reading from a packet stream.+-}+module Protocols.PacketStream.Depacketizers (+  depacketizerC,+  depacketizeToDfC,+) where++import Clash.Prelude+import Clash.Sized.Vector.Extra++import Protocols+import Protocols.PacketStream.Base++import Data.Constraint (Dict (Dict))+import Data.Constraint.Nat.Extra+import Data.Data ((:~:) (Refl))+import Data.Maybe++{- | Vectors of this size are able to hold @headerBytes `DivRU` dataWidth@+     transfers of size @dataWidth@, which is bigger than or equal to @headerBytes@.+-}+type BufSize (headerBytes :: Nat) (dataWidth :: Nat) =+  dataWidth * headerBytes `DivRU` dataWidth++{- | Since the header might be unaligned compared to the data width+     we need to store a partial fragment when forwarding.+     The number of bytes we need to store depends on our "unalignedness".++     Ex. We parse a header of 17 bytes and our @dataWidth@ is 4 bytes.+     That means at the end of the header we can have up to 3 bytes left+     in the fragment which we may need to forward.+-}+type ForwardBytes (headerBytes :: Nat) (dataWidth :: Nat) =+  (dataWidth - (headerBytes `Mod` dataWidth)) `Mod` dataWidth++-- | Depacketizer constraints.+type DepacketizerCt (headerBytes :: Nat) (dataWidth :: Nat) =+  ( KnownNat headerBytes+  , KnownNat dataWidth+  , 1 <= headerBytes+  , 1 <= dataWidth+  , BufSize headerBytes dataWidth ~ headerBytes + ForwardBytes headerBytes dataWidth+  , headerBytes `Mod` dataWidth <= dataWidth+  , ForwardBytes headerBytes dataWidth <= dataWidth+  )++{- | Depacketizer state. Either we are parsing a header, or we are forwarding+  the rest of the packet along with the parsed header in its metadata.+-}+data DepacketizerState (headerBytes :: Nat) (dataWidth :: Nat)+  = Parse+      { _aborted :: Bool+      {- ^ Whether the packet is aborted. We need this, because _abort might+      have been set in the bytes to be parsed.+      -}+      , _buf :: Vec (BufSize headerBytes dataWidth) (BitVector 8)+      {- ^ The first @headerBytes@ of this buffer are for the parsed header.+      The bytes after that are data bytes that could not be sent immediately+      due to misalignment of @dataWidth@ and @headerBytes@.+      -}+      , _counter :: Index (headerBytes `DivRU` dataWidth)+      -- ^ @maxBound + 1@ is the number of fragments we need to parse.+      }+  | Forward+      { _aborted :: Bool+      , _buf :: Vec (BufSize headerBytes dataWidth) (BitVector 8)+      , _counter :: Index (headerBytes `DivRU` dataWidth)+      , _lastFwd :: Bool+      {- ^ True iff we have seen @_last@ set but the number of data bytes was too+      big to send immediately along with our buffered bytes.+      -}+      }+  deriving (Show, ShowX, Generic)++deriving instance+  (DepacketizerCt headerBytes dataWidth) =>+  NFDataX (DepacketizerState headerBytes dataWidth)++-- | Initial state of @depacketizerT@.+instance+  (DepacketizerCt headerBytes dataWidth) =>+  Default (DepacketizerState headerBytes dataWidth)+  where+  def :: DepacketizerState headerBytes dataWidth+  def = Parse False (deepErrorX "depacketizerT: undefined initial buffer") maxBound++-- | Depacketizer state transition function.+depacketizerT ::+  forall+    (headerBytes :: Nat)+    (header :: Type)+    (metaIn :: Type)+    (metaOut :: Type)+    (dataWidth :: Nat).+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (NFDataX metaIn) =>+  (DepacketizerCt headerBytes dataWidth) =>+  (header -> metaIn -> metaOut) ->+  DepacketizerState headerBytes dataWidth ->+  (Maybe (PacketStreamM2S dataWidth metaIn), PacketStreamS2M) ->+  ( DepacketizerState headerBytes dataWidth+  , (PacketStreamS2M, Maybe (PacketStreamM2S dataWidth metaOut))+  )+depacketizerT _ Parse{..} (Just PacketStreamM2S{..}, _) = (nextStOut, (PacketStreamS2M outReady, Nothing))+ where+  nextAborted = _aborted || _abort+  nextCounter = pred _counter+  nextParseBuf = fst (shiftInAtN _buf _data)++  prematureEnd idx = case sameNat d0 (SNat @(headerBytes `Mod` dataWidth)) of+    Just Refl -> idx /= maxBound+    _ -> idx < natToNum @(headerBytes `Mod` dataWidth)++  -- Upon seeing _last being set, move back to the initial state if the+  -- right amount of bytes were not parsed yet, or if they were, but there+  -- were no data bytes after that.+  nextStOut = case (_counter == 0, _last) of+    (False, Nothing) ->+      Parse nextAborted nextParseBuf nextCounter+    (False, Just _) ->+      def+    (True, Just idx)+      | prematureEnd idx ->+          def+    (True, _) ->+      Forward nextAborted nextParseBuf nextCounter (isJust _last)++  outReady+    | Forward{_lastFwd = True} <- nextStOut = False+    | otherwise = True+depacketizerT toMetaOut st@Forward{..} (Just pkt@PacketStreamM2S{..}, bwdIn) = (nextStOut, (PacketStreamS2M outReady, Just outPkt))+ where+  nextAborted = _aborted || _abort+  nextBuf = header ++ nextFwdBytes+  newLast = adjustLast <$> _last+  (header, fwdBytes) = splitAt (SNat @headerBytes) _buf+  (dataOut, nextFwdBytes) = splitAt (SNat @dataWidth) (fwdBytes ++ _data)++  -- Only use if headerBytes `Mod` dataWidth > 0.+  adjustLast ::+    Index (dataWidth + 1) -> Either (Index (dataWidth + 1)) (Index (dataWidth + 1))+  adjustLast idx+    | _lastFwd = Right (idx - x)+    | idx <= x = Left (idx + y)+    | otherwise = Right (idx - x)+   where+    x = natToNum @(headerBytes `Mod` dataWidth)+    y = natToNum @(ForwardBytes headerBytes dataWidth)++  outPkt = case sameNat d0 (SNat @(headerBytes `Mod` dataWidth)) of+    Just Refl ->+      pkt+        { _data = _data+        , _last = if _lastFwd then Just 0 else _last+        , _meta = toMetaOut (bitCoerce header) _meta+        , _abort = nextAborted+        }+    Nothing ->+      pkt+        { _data = dataOut+        , _last =+            if _lastFwd+              then either Just Just =<< newLast+              else either Just (const Nothing) =<< newLast+        , _meta = toMetaOut (bitCoerce header) _meta+        , _abort = nextAborted+        }++  nextForwardSt = Forward nextAborted nextBuf maxBound+  nextSt = case sameNat d0 (SNat @(headerBytes `Mod` dataWidth)) of+    Just Refl+      | isJust _last -> def+      | otherwise -> nextForwardSt False+    Nothing ->+      case (_lastFwd, newLast) of+        (False, Nothing) -> nextForwardSt False+        (False, Just (Right _)) -> nextForwardSt True+        _ -> def++  nextStOut = if _ready bwdIn then nextSt else st++  outReady+    | Forward{_lastFwd = True} <- nextStOut = False+    | otherwise = _ready bwdIn+depacketizerT _ st (Nothing, _) = (st, (deepErrorX "undefined ack", Nothing))++{- |+Reads bytes at the start of each packet into `_meta`. If a packet contains+less valid bytes than @headerBytes + 1@, it will silently drop that packet.++If @dataWidth@ divides @headerBytes@, this component runs at full throughput.+Otherwise, it gives backpressure for one clock cycle per packet larger than+@headerBytes + 1@ valid bytes.+-}+depacketizerC ::+  forall+    (headerBytes :: Nat)+    (header :: Type)+    (metaIn :: Type)+    (metaOut :: Type)+    (dataWidth :: Nat)+    (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (NFDataX metaIn) =>+  (KnownNat headerBytes) =>+  (KnownNat dataWidth) =>+  (1 <= headerBytes) =>+  (1 <= dataWidth) =>+  -- |  Mapping from the parsed header and input `_meta` to the output `_meta`+  (header -> metaIn -> metaOut) ->+  Circuit (PacketStream dom dataWidth metaIn) (PacketStream dom dataWidth metaOut)+depacketizerC toMetaOut = forceResetSanity |> fromSignals ckt+ where+  ckt = case ( eqTimesDivRu @dataWidth @headerBytes+             , leModulusDivisor @headerBytes @dataWidth+             , leModulusDivisor @(dataWidth - (headerBytes `Mod` dataWidth)) @dataWidth+             ) of+    (Dict, Dict, Dict) -> mealyB (depacketizerT toMetaOut) def++-- | Df depacketizer constraints.+type DepacketizeToDfCt (headerBytes :: Nat) (dataWidth :: Nat) =+  ( KnownNat headerBytes+  , KnownNat dataWidth+  , 1 <= headerBytes+  , 1 <= dataWidth+  , headerBytes <= headerBytes `DivRU` dataWidth * dataWidth+  )++data DfDepacketizerState (headerBytes :: Nat) (dataWidth :: Nat)+  = DfParse+      { _dfAborted :: Bool+      {- ^ Whether the current packet is aborted. We need this, because _abort+      might have been set in the bytes to be parsed.+      -}+      , _dfParseBuf :: Vec (BufSize headerBytes dataWidth) (BitVector 8)+      -- ^ Buffer for the header that we need to parse.+      , _dfCounter :: Index (headerBytes `DivRU` dataWidth)+      -- ^ @maxBound + 1@ is the number of fragments we need to parse.+      }+  | DfConsumePadding+      { _dfAborted :: Bool+      , _dfParseBuf :: Vec (BufSize headerBytes dataWidth) (BitVector 8)+      }+  deriving (Generic, Show, ShowX)++deriving instance+  (DepacketizeToDfCt headerBytes dataWidth) =>+  (NFDataX (DfDepacketizerState headerBytes dataWidth))++-- | Initial state of @depacketizeToDfT@.+instance+  (DepacketizeToDfCt headerBytes dataWidth) =>+  Default (DfDepacketizerState headerBytes dataWidth)+  where+  def :: DfDepacketizerState headerBytes dataWidth+  def = DfParse False (deepErrorX "depacketizeToDfT: undefined initial buffer") maxBound++-- | Df depacketizer transition function.+depacketizeToDfT ::+  forall+    (headerBytes :: Nat)+    (header :: Type)+    (meta :: Type)+    (a :: Type)+    (dataWidth :: Nat).+  (NFDataX meta) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (DepacketizeToDfCt headerBytes dataWidth) =>+  (header -> meta -> a) ->+  DfDepacketizerState headerBytes dataWidth ->+  (Maybe (PacketStreamM2S dataWidth meta), Ack) ->+  (DfDepacketizerState headerBytes dataWidth, (PacketStreamS2M, Maybe a))+depacketizeToDfT _ DfParse{..} (Just (PacketStreamM2S{..}), _) = (nextStOut, (PacketStreamS2M readyOut, Nothing))+ where+  nextAborted = _dfAborted || _abort+  nextParseBuf = fst (shiftInAtN _dfParseBuf _data)++  prematureEnd idx =+    case compareSNat (SNat @(headerBytes `Mod` dataWidth)) d0 of+      SNatGT -> idx < (natToNum @(headerBytes `Mod` dataWidth))+      _ -> idx < (natToNum @dataWidth)++  (nextStOut, readyOut) =+    case (_dfCounter == 0, _last) of+      (False, Nothing) ->+        (DfParse nextAborted nextParseBuf (pred _dfCounter), True)+      (False, Just _) ->+        (def, True)+      (True, Just idx) ->+        if nextAborted || prematureEnd idx+          then (def, True)+          else (DfConsumePadding nextAborted nextParseBuf, False)+      (True, Nothing) ->+        (DfConsumePadding nextAborted nextParseBuf, True)+depacketizeToDfT toOut st@DfConsumePadding{..} (Just (PacketStreamM2S{..}), Ack readyIn) = (nextStOut, (PacketStreamS2M readyOut, fwdOut))+ where+  nextAborted = _dfAborted || _abort+  outDf = toOut (bitCoerce (takeLe (SNat @headerBytes) _dfParseBuf)) _meta++  (nextSt, fwdOut) =+    if isJust _last+      then (def, if nextAborted then Nothing else Just outDf)+      else (st{_dfAborted = nextAborted}, Nothing)++  readyOut = isNothing fwdOut || readyIn+  nextStOut = if readyOut then nextSt else st+depacketizeToDfT _ st (Nothing, _) = (st, (deepErrorX "undefined ack", Nothing))++{- |+Reads bytes at the start of each packet into a header structure, and+transforms this header structure along with the input metadata to an output+structure @a@, which is transmitted over a @Df@ channel. Such a structure+is sent once per packet over the @Df@ channel, but only if the packet was big+enough (contained at least @headerBytes@ valid data bytes) and did not+contain any transfer with @_abort@ set.+The remainder of the packet (padding) is dropped.++If the packet is not padded, or if the packet is padded but the padding fits+in the last transfer of the packet together with valid data bytes, this+component will give one clock cycle of backpressure per packet (for efficiency+reasons). Otherwise, it runs at full throughput.+-}+depacketizeToDfC ::+  forall+    (headerBytes :: Nat)+    (header :: Type)+    (meta :: Type)+    (a :: Type)+    (dataWidth :: Nat)+    (dom :: Domain).+  (HiddenClockResetEnable dom) =>+  (NFDataX meta) =>+  (NFDataX a) =>+  (BitPack header) =>+  (KnownNat headerBytes) =>+  (KnownNat dataWidth) =>+  (1 <= headerBytes) =>+  (1 <= dataWidth) =>+  (BitSize header ~ headerBytes * 8) =>+  -- | Mapping from the parsed header and input `_meta` to the `Df` output+  (header -> meta -> a) ->+  Circuit (PacketStream dom dataWidth meta) (Df dom a)+depacketizeToDfC toOut = forceResetSanity |> fromSignals ckt+ where+  ckt = case leTimesDivRu @dataWidth @headerBytes of+    Dict -> mealyB (depacketizeToDfT toOut) def
+ src/Protocols/PacketStream/Hedgehog.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Provides Hedgehog generators, models and utility functions for testing+`PacketStream` circuits.+-}+module Protocols.PacketStream.Hedgehog (+  -- * Utility functions+  chopBy,+  chopPacket,+  chunkByPacket,+  chunkToPacket,+  fullPackets,+  smearAbort,++  -- * Models+  dropAbortedPackets,+  downConvert,+  upConvert,+  depacketizerModel,+  depacketizeToDfModel,+  dropTailModel,+  packetizerModel,+  packetizeFromDfModel,++  -- * Hedgehog generators+  AbortMode (..),+  PacketOptions (..),+  defPacketOptions,+  genValidPacket,+  genPackets,+) where++import Clash.Hedgehog.Sized.Vector (genVec)+import Clash.Prelude+import Clash.Sized.Vector qualified as Vec++import Data.List qualified as L+import Data.Maybe (fromJust, isJust)++import Hedgehog (Gen, Range)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Protocols.PacketStream.Base++-- | Partition a list based on given function.+chunkBy :: (a -> Bool) -> [a] -> [[a]]+chunkBy _ [] = []+chunkBy predicate list = L.filter (not . null) (chunkByHelper predicate list [])++-- Helper function to accumulate chunks.+chunkByHelper :: (a -> Bool) -> [a] -> [a] -> [[a]]+chunkByHelper _ [] acc = [L.reverse acc]+chunkByHelper predicate (x : xs) acc+  | predicate x = L.reverse (x : acc) : chunkByHelper predicate xs []+  | otherwise = chunkByHelper predicate xs (x : acc)++-- | Partition a list of `PacketStream` transfers into complete packets.+chunkByPacket ::+  [PacketStreamM2S dataWidth meta] ->+  [[PacketStreamM2S dataWidth meta]]+chunkByPacket = chunkBy (isJust . _last)++{- |+If a packet contains a transfer with `_abort` set, set the `_abort` of+all following transfers in the same packet.+-}+smearAbort ::+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S dataWidth meta]+smearAbort [] = []+smearAbort (x : xs) = L.reverse $ L.foldl' go [x] xs+ where+  go [] _ = []+  go l@(a : _) (PacketStreamM2S dat last' meta abort) =+    PacketStreamM2S dat last' meta (_abort a || abort) : l++-- | Partition a list into groups of given size+chopBy :: Int -> [a] -> [[a]]+chopBy _ [] = []+chopBy n xs = as : chopBy n bs where (as, bs) = L.splitAt n xs++{- |+Merge a list of `PacketStream` transfers with data width @1@ to+a single `PacketStream` transfer with data width @dataWidth@.+-}+chunkToPacket ::+  (KnownNat dataWidth) =>+  [PacketStreamM2S 1 meta] ->+  PacketStreamM2S dataWidth meta+chunkToPacket xs =+  PacketStreamM2S+    { _last =+        (\i -> let l = fromIntegral (L.length xs) in if i == 0 then l - 1 else l)+          <$> _last lastTransfer+    , _abort = any _abort xs+    , _meta = _meta lastTransfer+    , _data = L.foldr ((+>>) . head . _data) (repeat (nullByte "chunkToPacket")) xs+    }+ where+  lastTransfer = L.last xs++{- |+Split a single `PacketStream` transfer with data width @dataWidth@ to+a list of `PacketStream` transfers with data width @1@.+-}+chopPacket ::+  forall dataWidth meta.+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  PacketStreamM2S dataWidth meta ->+  [PacketStreamM2S 1 meta]+chopPacket PacketStreamM2S{..} = packets+ where+  lasts = case _last of+    Nothing -> L.repeat Nothing+    Just size ->+      if size == 0+        then [Just 0]+        else L.replicate (fromIntegral size - 1) Nothing L.++ [Just (1 :: Index 2)]++  datas = case _last of+    Nothing -> toList _data+    Just size -> L.take (max 1 (fromIntegral size)) $ toList _data++  packets =+    ( \(size, dat) ->+        PacketStreamM2S (pure dat) size _meta _abort+    )+      <$> L.zip lasts datas++-- | Set `_last` of the last transfer in the list to @Just 1@+fullPackets ::+  (KnownNat dataWidth) =>+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S dataWidth meta]+fullPackets [] = []+fullPackets fragments =+  let lastFragment = (L.last fragments){_last = Just 1}+   in L.init fragments L.++ [lastFragment]++-- | Drops packets if one of the transfers in the packet has `_abort` set.+dropAbortedPackets ::+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S dataWidth meta]+dropAbortedPackets packets = L.concat $ L.filter (not . any _abort) (chunkByPacket packets)++{- |+Splits a list of `PacketStream` transfers with data width @1@ into+a list of `PacketStream` transfers with data width @dataWidth@+-}+downConvert ::+  forall dataWidth meta.+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S 1 meta]+downConvert = L.concatMap chopPacket++{- |+Merges a list of `PacketStream` transfers with data width @dataWidth@ into+a list of `PacketStream` transfers with data width @1@+-}+upConvert ::+  forall dataWidth meta.+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  [PacketStreamM2S 1 meta] ->+  [PacketStreamM2S dataWidth meta]+upConvert packets =+  L.map+    chunkToPacket+    (chunkByPacket packets >>= chopBy (natToNum @dataWidth))++-- | Model of the generic `Protocols.PacketStream.depacketizerC`.+depacketizerModel ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (metaIn :: Type)+    (header :: Type)+    (metaOut :: Type).+  (KnownNat dataWidth) =>+  (KnownNat headerBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (NFDataX metaIn) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (header -> metaIn -> metaOut) ->+  [PacketStreamM2S dataWidth metaIn] ->+  [PacketStreamM2S dataWidth metaOut]+depacketizerModel toMetaOut ps = L.concat dataWidthPackets+ where+  hdrBytes = natToNum @headerBytes++  parseHdr ::+    ([PacketStreamM2S 1 metaIn], [PacketStreamM2S 1 metaIn]) ->+    [PacketStreamM2S 1 metaOut]+  parseHdr (hdrF, fwdF) = fmap (\f -> f{_meta = metaOut}) fwdF'+   where+    fwdF' = case fwdF of+      [] ->+        [ PacketStreamM2S+            (Vec.singleton (nullByte "depacketizerModel"))+            (Just 0)+            (deepErrorX "depacketizerModel: should be replaced")+            (_abort (L.last hdrF))+        ]+      _ -> fwdF++    hdr = bitCoerce $ Vec.unsafeFromList @headerBytes $ _data <$> hdrF+    metaIn = case hdrF of+      [] ->+        -- There are @headerBytes@ packets in this list, and (1 <= headerBytes)+        error "depacketizerModel: absurd"+      (hdrF0 : _) -> _meta hdrF0+    metaOut = toMetaOut hdr metaIn++  bytePackets :: [[PacketStreamM2S 1 metaIn]]+  bytePackets =+    L.filter+      ( \fs ->+          let len' = L.length fs+           in len' > hdrBytes || len' == hdrBytes && _last (L.last fs) == Just 1+      )+      $ downConvert+      . smearAbort+      <$> chunkByPacket ps++  parsedPackets :: [[PacketStreamM2S 1 metaOut]]+  parsedPackets = L.map go bytePackets++  go = parseHdr . L.splitAt hdrBytes++  dataWidthPackets :: [[PacketStreamM2S dataWidth metaOut]]+  dataWidthPackets = L.map upConvert parsedPackets++-- | Model of the generic `Protocols.PacketStream.depacketizeToDfC`.+depacketizeToDfModel ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (a :: Type)+    (header :: Type)+    (metaIn :: Type).+  (KnownNat dataWidth) =>+  (KnownNat headerBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (header -> metaIn -> a) ->+  [PacketStreamM2S dataWidth metaIn] ->+  [a]+depacketizeToDfModel toOut ps = L.map parseHdr bytePackets+ where+  parseHdr :: [PacketStreamM2S 1 metaIn] -> a+  parseHdr [] =+    -- There are at least @headerBytes@ packets in this list, and+    -- (1 <= headerBytes)+    error "depacketizeToDfModel: absurd"+  parseHdr hdrF@(hdrF0 : _) =+    toOut+      (bitCoerce $ Vec.unsafeFromList $ L.map _data hdrF)+      (_meta hdrF0)++  bytePackets :: [[PacketStreamM2S 1 metaIn]]+  bytePackets =+    L.filter+      ( \pkt ->+          (L.length pkt > natToNum @headerBytes)+            || (L.length pkt == natToNum @headerBytes && _last (L.last pkt) == Just 1)+      )+      (chunkByPacket $ downConvert (dropAbortedPackets ps))++-- | Model of 'Protocols.PacketStream.dropTailC'.+dropTailModel ::+  forall dataWidth meta n.+  (KnownNat dataWidth) =>+  (1 <= dataWidth) =>+  (1 <= n) =>+  SNat n ->+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S dataWidth meta]+dropTailModel SNat packets = L.concatMap go (chunkByPacket packets)+ where+  go :: [PacketStreamM2S dataWidth meta] -> [PacketStreamM2S dataWidth meta]+  go packet =+    upConvert+      $ L.init trimmed+      L.++ [(L.last trimmed){_last = _last $ L.last bytePkts, _abort = aborted}]+   where+    aborted = L.any _abort packet+    bytePkts = downConvert packet+    trimmed = L.take (L.length bytePkts - natToNum @n) bytePkts++-- | Model of the generic `Protocols.PacketStream.packetizerC`.+packetizerModel ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (metaIn :: Type)+    (header :: Type)+    (metaOut :: Type).+  (KnownNat dataWidth) =>+  (KnownNat headerBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (metaIn -> metaOut) ->+  (metaIn -> header) ->+  [PacketStreamM2S dataWidth metaIn] ->+  [PacketStreamM2S dataWidth metaOut]+packetizerModel toMetaOut toHeader ps = L.concatMap (upConvert . prependHdr) bytePackets+ where+  prependHdr :: [PacketStreamM2S 1 metaIn] -> [PacketStreamM2S 1 metaOut]+  prependHdr [] =+    -- 'chunkBy' filters empty lists, so all elements of bytePackets are+    -- guaranteed to be non-null+    error "packetizerModel: Unreachable code"+  prependHdr fragments@(h : _) =+    hdr L.++ L.map (\f -> f{_meta = metaOut}) fragments+   where+    metaOut = toMetaOut (_meta h)+    hdr = L.map go (toList $ bitCoerce (toHeader (_meta h)))+    go byte = PacketStreamM2S (singleton byte) Nothing metaOut (_abort h)++  bytePackets :: [[PacketStreamM2S 1 metaIn]]+  bytePackets = downConvert . smearAbort <$> chunkByPacket ps++-- | Model of the generic `Protocols.PacketStream.packetizeFromDfC`.+packetizeFromDfModel ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (a :: Type)+    (header :: Type)+    (metaOut :: Type).+  (KnownNat dataWidth) =>+  (KnownNat headerBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (a -> metaOut) ->+  (a -> header) ->+  [a] ->+  [PacketStreamM2S dataWidth metaOut]+packetizeFromDfModel toMetaOut toHeader = L.concatMap (upConvert . dfToPacket)+ where+  dfToPacket :: a -> [PacketStreamM2S 1 metaOut]+  dfToPacket d =+    fullPackets+      $ L.map+        (\byte -> PacketStreamM2S (singleton byte) Nothing (toMetaOut d) False)+        (toList $ bitCoerce (toHeader d))++-- | Abort generation options for packet generation.+data AbortMode+  = Abort+      { amPacketGen :: Gen Bool+      -- ^ Determines the chance to generate aborted fragments in a packet.+      , amTransferGen :: Gen Bool+      -- ^ Determines the frequency of aborted fragments in a packet.+      }+  | NoAbort++-- | Various configuration options for packet generation.+data PacketOptions = PacketOptions+  { poAllowEmptyPackets :: Bool+  -- ^ Whether to allow the generation of zero-byte packets.+  , poAllowTrailingEmpty :: Bool+  -- ^ Whether to allow the generation of trailing zero-byte transfers.+  , poAbortMode :: AbortMode+  {- ^ If set to @NoAbort@, no transfers in the packet will have '_abort' set.+  Else, randomly generate them according to some distribution. See 'AbortMode'.+  -}+  }++{- |+Default packet generation options:++- Allow the generation of a zero-byte packet;+- Allow the generation of a trailing zero-byte transfer;+- 50% chance to generate aborted transfers. If aborts are generated, 10% of+  transfers will be aborted.+-}+defPacketOptions :: PacketOptions+defPacketOptions =+  PacketOptions+    { poAllowEmptyPackets = True+    , poAllowTrailingEmpty = True+    , poAbortMode =+        Abort+          { amPacketGen = Gen.enumBounded+          , amTransferGen =+              Gen.frequency+                [ (90, Gen.constant False)+                , (10, Gen.constant True)+                ]+          }+    }++{- |+Generate packets with a user-supplied generator and a linear range.+-}+genPackets ::+  forall (dataWidth :: Nat) (meta :: Type).+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  -- | Minimum amount of packets to generate.+  Int ->+  -- | Maximum amount of packets to generate.+  Int ->+  -- | Packet generator.+  Gen [PacketStreamM2S dataWidth meta] ->+  Gen [PacketStreamM2S dataWidth meta]+genPackets minB maxB pktGen = L.concat <$> Gen.list (Range.linear minB maxB) pktGen+{-# INLINE genPackets #-}++{- |+Generate a valid packet, i.e. a packet of which all transfers carry the same+`_meta` and with all bytes in `_data` that are not enabled set to 0x00.+-}+genValidPacket ::+  forall (dataWidth :: Nat) (meta :: Type).+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  -- | Configuration options for packet generation.+  PacketOptions ->+  -- | Generator for the metadata.+  Gen meta ->+  {- | The amount of transfers with @_last = Nothing@ to generate.+  This function will always generate an extra transfer with @_last = Just i@.+  -}+  Range Int ->+  Gen [PacketStreamM2S dataWidth meta]+genValidPacket PacketOptions{..} metaGen size =+  let+    abortGen = case poAbortMode of+      NoAbort -> Gen.constant False+      Abort pktGen transferGen -> do+        allowAborts <- pktGen+        (if allowAborts then transferGen else Gen.constant False)+   in+    do+      meta <- metaGen+      transfers <- Gen.list size (genTransfer meta abortGen)+      lastTransfer <-+        genLastTransfer+          meta+          ( (null transfers && poAllowEmptyPackets)+              || (not (null transfers) && poAllowTrailingEmpty)+          )+          abortGen+      pure (transfers L.++ [lastTransfer])++-- | Generate a single transfer which is not yet the end of a packet.+genTransfer ::+  forall (dataWidth :: Nat) (meta :: Type).+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  {- | We need to use the same metadata+  for every transfer in a packet to satisfy the protocol+  invariant that metadata is constant for an entire packet.+  -}+  meta ->+  -- | Whether to set '_abort'.+  Gen Bool ->+  Gen (PacketStreamM2S dataWidth meta)+genTransfer meta abortGen =+  PacketStreamM2S+    <$> genVec Gen.enumBounded+    <*> Gen.constant Nothing+    <*> Gen.constant meta+    <*> abortGen++{- |+Generate the last transfer of a packet, i.e. a transfer with @_last@ set as @Just@.+All bytes which are not enabled are forced /undefined/.+-}+genLastTransfer ::+  forall (dataWidth :: Nat) (meta :: Type).+  (1 <= dataWidth) =>+  (KnownNat dataWidth) =>+  {- | We need to use the same metadata+  for every transfer in a packet to satisfy the protocol+  invariant that metadata is constant for an entire packet.+  -}+  meta ->+  -- | Whether we are allowed to generate a 0-byte transfer.+  Bool ->+  -- | Whether to set '_abort'.+  Gen Bool ->+  Gen (PacketStreamM2S dataWidth meta)+genLastTransfer meta allowEmpty abortGen =+  setNull+    <$> ( PacketStreamM2S+            <$> genVec Gen.enumBounded+            <*> (Just <$> Gen.enum (if allowEmpty then 0 else 1) maxBound)+            <*> Gen.constant meta+            <*> abortGen+        )++setNull ::+  forall (dataWidth :: Nat) (meta :: Type).+  (KnownNat dataWidth) =>+  PacketStreamM2S dataWidth meta ->+  PacketStreamM2S dataWidth meta+setNull transfer =+  let i = fromJust (_last transfer)+   in transfer+        { _data =+            fromJust+              ( Vec.fromList+                  $ L.take (fromIntegral i) (toList (_data transfer))+                  L.++ L.replicate ((natToNum @dataWidth) - fromIntegral i) (nullByte "setNull")+              )+        }
+ src/Protocols/PacketStream/PacketFifo.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Optimized store and forward FIFO circuit for packet streams.+-}+module Protocols.PacketStream.PacketFifo (+  packetFifoC,+  FullMode (..),+) where++import Clash.Prelude++import Data.Maybe+import Data.Maybe.Extra (toMaybe)++import Protocols+import Protocols.PacketStream.Base++type PacketStreamContent (dataWidth :: Nat) (meta :: Type) =+  (Vec dataWidth (BitVector 8), Maybe (Index (dataWidth + 1)))++-- | Specifies the behaviour of `packetFifoC` when it is full.+data FullMode+  = -- | Assert backpressure when the FIFO is full.+    Backpressure+  | {- | Drop new packets when the FIFO is full.+    The FIFO never asserts backpressure.+    -}+    Drop++toPacketStreamContent ::+  PacketStreamM2S dataWidth meta -> PacketStreamContent dataWidth meta+toPacketStreamContent PacketStreamM2S{..} = (_data, _last)++toPacketStreamM2S ::+  PacketStreamContent dataWidth meta -> meta -> PacketStreamM2S dataWidth meta+toPacketStreamM2S (d, l) m = PacketStreamM2S d l m False++data PacketFifoState contentDepth metaDepth = PacketFifoState+  { _canRead :: Bool+  -- ^ We need this to avoid read-write conflicts.+  , _dropping :: Bool+  -- ^ Whether we are dropping the current packet.+  , _basePtr :: Unsigned contentDepth+  {- ^ Points to the base address of the current packet, i.e. the address of+  the first transfer.+  -}+  , _cReadPtr :: Unsigned contentDepth+  -- ^ Read pointer in the content block ram.+  , _cWritePtr :: Unsigned contentDepth+  -- ^ Write pointer in the content block ram.+  , _mReadPtr :: Unsigned metaDepth+  -- ^ Read pointer in the metadata block ram.+  , _mWritePtr :: Unsigned metaDepth+  -- ^ Write pointer in the metadata block ram.+  }+  deriving (Generic, NFDataX, Show, ShowX)++-- | State transition function of 'packetFifoC', mode @Backpressure@.+packetFifoT ::+  forall+    (dataWidth :: Nat)+    (meta :: Type)+    (contentDepth :: Nat)+    (metaDepth :: Nat).+  (KnownNat dataWidth) =>+  (KnownNat contentDepth) =>+  (KnownNat metaDepth) =>+  (1 <= contentDepth) =>+  (1 <= metaDepth) =>+  (NFDataX meta) =>+  PacketFifoState contentDepth metaDepth ->+  ( Maybe (PacketStreamM2S dataWidth meta)+  , PacketStreamS2M+  , PacketStreamContent dataWidth meta+  , meta+  ) ->+  ( PacketFifoState contentDepth metaDepth+  , ( Unsigned contentDepth+    , Unsigned metaDepth+    , Maybe (Unsigned contentDepth, PacketStreamContent dataWidth meta)+    , Maybe (Unsigned metaDepth, meta)+    , PacketStreamS2M+    , Maybe (PacketStreamM2S dataWidth meta)+    )+  )+packetFifoT st@PacketFifoState{..} (fwdIn, bwdIn, cRam, mRam) =+  (nextSt, (cReadPtr', mReadPtr', cWriteCmd, mWriteCmd, bwdOut, fwdOut))+ where+  -- Status signals+  pktTooBig = _cWritePtr + 1 == _cReadPtr && fifoEmpty+  (lastPkt, dropping) = case fwdIn of+    Nothing -> (False, _dropping || pktTooBig)+    Just PacketStreamM2S{..} -> (isJust _last, _dropping || pktTooBig || _abort)++  fifoEmpty = _mReadPtr == _mWritePtr+  fifoSinglePacket = _mReadPtr + 1 == _mWritePtr+  fifoFull =+    (_cWritePtr + 1 == _cReadPtr)+      || (_mWritePtr + 1 == _mReadPtr && lastPkt)++  -- Enables+  readEn = _canRead && not fifoEmpty+  cReadEn = readEn && _ready bwdIn+  mReadEn = readEn && _ready bwdIn && isJust (snd cRam)++  -- Output+  bwdOut = PacketStreamS2M (not fifoFull || dropping)+  fwdOut =+    if readEn+      then Just (toPacketStreamM2S cRam mRam)+      else Nothing++  -- New state++  -- Our block RAM is read-before-write, so we cannot use the read value next+  -- clock cycle if there is a read-write conflict. Such a conflict might happen+  -- when we finish writing a packet into the FIFO while:+  -- 1. The FIFO is empty.+  -- 2. The FIFO has one packet inside and we finish outputting it this clock cycle.+  canRead' = not (lastPkt && (fifoEmpty || (mReadEn && fifoSinglePacket)))+  dropping' = dropping && not lastPkt++  basePtr' = if lastPkt && _ready bwdOut then cWritePtr' else _basePtr+  cReadPtr' = if cReadEn then _cReadPtr + 1 else _cReadPtr+  mReadPtr' = if mReadEn then _mReadPtr + 1 else _mReadPtr++  (cWriteCmd, cWritePtr') =+    if not dropping && not fifoFull+      then+        ( (\t -> (_cWritePtr, toPacketStreamContent t)) <$> fwdIn+        , _cWritePtr + 1+        )+      else+        ( Nothing+        , if dropping then _basePtr else _cWritePtr+        )++  -- Write the metadata into RAM upon the last transfer of a packet, and+  -- advance the write pointer. This allows us to write the data of a packet+  -- into RAM even if the metadata RAM is currently full (hoping that it will+  -- free up before we read the end of the packet). It also prevents unnecessary+  -- writes in case a packet is aborted or too big.+  (mWriteCmd, mWritePtr') =+    if not dropping && not fifoFull && lastPkt+      then ((\t -> (_mWritePtr, _meta t)) <$> fwdIn, _mWritePtr + 1)+      else (Nothing, _mWritePtr)++  nextSt = case fwdIn of+    Nothing -> st{_canRead = True, _cReadPtr = cReadPtr', _mReadPtr = mReadPtr'}+    Just _ ->+      PacketFifoState+        { _canRead = canRead'+        , _dropping = dropping'+        , _basePtr = basePtr'+        , _cReadPtr = cReadPtr'+        , _cWritePtr = cWritePtr'+        , _mReadPtr = mReadPtr'+        , _mWritePtr = mWritePtr'+        }++-- | Implementation of 'packetFifoC', mode @Drop@.+packetFifoImpl ::+  forall+    (dom :: Domain)+    (dataWidth :: Nat)+    (meta :: Type)+    (contentSizeBits :: Nat)+    (metaSizeBits :: Nat).+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (1 <= contentSizeBits) =>+  (1 <= metaSizeBits) =>+  (NFDataX meta) =>+  -- | Depth of the content of the packet buffer, this is equal to 2^contentSizeBits+  SNat contentSizeBits ->+  -- | Depth of the content of the meta buffer, this is equal to 2^metaSizeBits+  SNat metaSizeBits ->+  -- | Input packetStream+  ( Signal dom (Maybe (PacketStreamM2S dataWidth meta))+  , Signal dom PacketStreamS2M+  ) ->+  -- | Output CSignal s+  ( Signal dom PacketStreamS2M+  , Signal dom (Maybe (PacketStreamM2S dataWidth meta))+  )+packetFifoImpl SNat SNat (fwdIn, bwdIn) = (PacketStreamS2M . not <$> fullBuffer, fwdOut)+ where+  fwdOut = toMaybe <$> (not <$> emptyBuffer) <*> (toPacketStreamM2S <$> ramContent <*> ramMeta)++  -- The backing ram+  ramContent =+    blockRam1+      NoClearOnReset+      (SNat @(2 ^ contentSizeBits))+      (errorX "initial block ram content")+      cReadAddr'+      writeCommand+  ramMeta =+    blockRam1+      NoClearOnReset+      (SNat @(2 ^ metaSizeBits))+      (errorX "initial block ram meta content")+      mReadAddr'+      mWriteCommand++  -- The write commands to the RAM+  writeCommand =+    toMaybe+      <$> writeEnable+      <*> bundle (cWordAddr, toPacketStreamContent . fromJustX <$> fwdIn)+  mWriteCommand = toMaybe <$> nextPacketIn <*> bundle (mWriteAddr, _meta . fromJustX <$> fwdIn)++  -- Addresses for the content data+  cWordAddr, cPacketAddr, cReadAddr :: Signal dom (Unsigned contentSizeBits)+  cWordAddr = register 0 $ mux dropping' cPacketAddr $ mux writeEnable (cWordAddr + 1) cWordAddr+  cPacketAddr = register 0 $ mux nextPacketIn (cWordAddr + 1) cPacketAddr+  cReadAddr' = mux readEnable (cReadAddr + 1) cReadAddr+  cReadAddr = register 0 cReadAddr'++  -- Addresses for the meta data+  mWriteAddr, mReadAddr :: Signal dom (Unsigned metaSizeBits)+  mWriteAddr = register 0 mWriteAddr'+  mWriteAddr' = mux nextPacketIn (mWriteAddr + 1) mWriteAddr++  mReadAddr' = mux mReadEnable (mReadAddr + 1) mReadAddr+  mReadAddr = register 0 mReadAddr'+  -- only read the next value if we've outputted the last word of a packet+  mReadEnable = lastWordOut .&&. readEnable++  -- Registers : status+  dropping', dropping, emptyBuffer :: Signal dom Bool+  -- start dropping packet on abort+  dropping' = abortIn .||. dropping+  dropping = register False $ dropping' .&&. (not <$> lastWordIn)+  -- the buffer is empty if the metaBuffer is empty as the meta buffer+  -- only updates when a packet is complete+  emptyBuffer = register 0 mWriteAddr .==. mReadAddr++  -- Only write if there is space and we're not dropping+  writeEnable = writeRequest .&&. (not <$> fullBuffer) .&&. (not <$> dropping')+  -- Read when the word has been received+  readEnable = (not <$> emptyBuffer) .&&. (_ready <$> bwdIn)++  -- The status signals+  fullBuffer = ((cWordAddr + 1) .==. cReadAddr) .||. ((mWriteAddr + 1) .==. mReadAddr)+  writeRequest = isJust <$> fwdIn+  lastWordIn = maybe False (isJust . _last) <$> fwdIn+  lastWordOut = maybe False (isJust . _last) <$> fwdOut+  abortIn = maybe False _abort <$> fwdIn+  nextPacketIn = lastWordIn .&&. writeEnable++{- |+FIFO circuit optimized for the PacketStream protocol. Contains two FIFOs, one+for packet data ('_data', '_last') and one for packet metadata ('_meta').+Because metadata is constant per packet, the metadata FIFO can be significantly+shallower, saving resources.++Moreover, the output of the FIFO has some other properties:++- All packets which contain a transfer with '_abort' set are dropped.+- All packets that are bigger than or equal to @2^contentDepth - 1@ transfers are dropped.+- There are no gaps in output packets, i.e. @Nothing@ in between valid transfers of a packet.++The circuit is able to satisfy these properties because it first loads an entire+packet before it may transmit it. That is also why packets bigger than the+content FIFO need to be dropped.++Two modes can be selected:++- @Backpressure@: assert backpressure like normal when the FIFO is full.+- @Drop@: never give backpressure, instead drop the current packet we are loading.+-}+packetFifoC ::+  forall+    (dom :: Domain)+    (dataWidth :: Nat)+    (meta :: Type)+    (contentDepth :: Nat)+    (metaDepth :: Nat).+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (1 <= contentDepth) =>+  (1 <= metaDepth) =>+  (NFDataX meta) =>+  -- |  The content FIFO will contain @2^contentDepth@ entries.+  SNat contentDepth ->+  -- | The metadata FIFO will contain @2^metaDepth@ entries.+  SNat metaDepth ->+  -- | The backpressure behaviour of the FIFO when it is full.+  FullMode ->+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+packetFifoC cSize@SNat mSize@SNat fullMode =+  let+    ckt (fwdIn, bwdIn) = (bwdOut, fwdOut)+     where+      ramContent =+        blockRam1+          NoClearOnReset+          (SNat @(2 ^ contentDepth))+          (deepErrorX "initial block ram content")+          cReadPtr+          cWriteCommand+      ramMeta =+        blockRam1+          NoClearOnReset+          (SNat @(2 ^ metaDepth))+          (deepErrorX "initial block ram meta content")+          mReadPtr+          mWriteCommand++      (cReadPtr, mReadPtr, cWriteCommand, mWriteCommand, bwdOut, fwdOut) =+        mealyB+          (packetFifoT @dataWidth @meta @contentDepth @metaDepth)+          (PacketFifoState False False 0 0 0 0 0)+          (fwdIn, bwdIn, ramContent, ramMeta)+   in+    case fullMode of+      Backpressure ->+        forceResetSanity |> fromSignals ckt+      Drop ->+        toCSignal+          |> unsafeAbortOnBackpressureC+          |> forceResetSanity+          |> fromSignals (packetFifoImpl cSize mSize)
+ src/Protocols/PacketStream/Packetizers.hs view
@@ -0,0 +1,437 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utility circuits for appending headers to the beginning of packets.+-}+module Protocols.PacketStream.Packetizers (+  packetizerC,+  packetizeFromDfC,+) where++import Clash.Prelude++import Protocols+import Protocols.PacketStream.Base++import Clash.Sized.Vector.Extra (takeLe)+import Data.Constraint (Dict (Dict))+import Data.Constraint.Nat.Extra (leModulusDivisor, strictlyPositiveDivRu)+import Data.Maybe+import Data.Maybe.Extra+import Data.Type.Equality ((:~:) (Refl))++type PacketizerCt (header :: Type) (headerBytes :: Nat) (dataWidth :: Nat) =+  ( BitPack header+  , BitSize header ~ headerBytes * 8+  , KnownNat headerBytes+  , KnownNat dataWidth+  , 1 <= headerBytes+  , 1 <= dataWidth+  )++data PacketizerState1 (metaOut :: Type) (headerBytes :: Nat) (dataWidth :: Nat)+  = Insert1+      { _aborted1 :: Bool+      }+  | Forward1+      { _aborted1 :: Bool+      , _hdrBuf1 :: Vec headerBytes (BitVector 8)+      }+  | LastForward1+      { _aborted1 :: Bool+      , _hdrBuf1 :: Vec headerBytes (BitVector 8)+      }+  deriving (Generic, NFDataX, Show, ShowX)++-- | Packetizer transition function in case @dataWidth > headerBytes@+packetizerT1 ::+  forall+    (headerBytes :: Nat)+    (dataWidth :: Nat)+    (header :: Type)+    (metaIn :: Type)+    (metaOut :: Type).+  (PacketizerCt header headerBytes dataWidth) =>+  (headerBytes + 1 <= dataWidth) =>+  (metaIn -> metaOut) ->+  (metaIn -> header) ->+  PacketizerState1 metaOut headerBytes dataWidth ->+  (Maybe (PacketStreamM2S dataWidth metaIn), PacketStreamS2M) ->+  ( PacketizerState1 metaOut headerBytes dataWidth+  , (PacketStreamS2M, Maybe (PacketStreamM2S dataWidth metaOut))+  )+packetizerT1 toMetaOut toHeader st (Just inPkt, bwdIn) =+  let+    go buf = (nextStOut, (bwdOut, Just outPkt))+     where+      bytesOut :: Vec (dataWidth - headerBytes) (BitVector 8)+      (bytesOut, newBuf) =+        leToPlus @headerBytes @dataWidth $ splitAt (SNat @(dataWidth - headerBytes)) (_data inPkt)+      nextAborted = _aborted1 st || _abort inPkt++      outPkt =+        inPkt+          { _data = buf ++ bytesOut+          , _last = newLast+          , _meta = toMetaOut (_meta inPkt)+          , _abort = nextAborted+          }++      (nextSt, newLast) = case _last inPkt of+        Nothing -> (Forward1 nextAborted newBuf, Nothing)+        Just i+          | i <= natToNum @(dataWidth - headerBytes) ->+              (Insert1 False, Just (i + natToNum @headerBytes))+          | otherwise -> (LastForward1 nextAborted newBuf, Nothing)++      nextStOut = if _ready bwdIn then nextSt else st+      bwdOut = case nextStOut of+        LastForward1{} -> PacketStreamS2M False+        _ -> bwdIn+   in+    case st of+      Insert1{} -> go (bitCoerce (toHeader (_meta inPkt)))+      Forward1{..} -> go _hdrBuf1+      LastForward1{..} -> (nextStOut, (bwdIn, Just outPkt))+       where+        outPkt =+          inPkt+            { _data = _hdrBuf1 ++ repeat (nullByte "packetizerT1")+            , _last = (\i -> i - natToNum @(dataWidth - headerBytes)) <$> _last inPkt+            , _meta = toMetaOut (_meta inPkt)+            , _abort = _aborted1 || _abort inPkt+            }+        nextStOut = if _ready bwdIn then Insert1 False else st+packetizerT1 _ _ s (Nothing, _) = (s, (deepErrorX "undefined ack", Nothing))++data PacketizerState2 (metaOut :: Type) (headerBytes :: Nat) (dataWidth :: Nat)+  = LoadHeader2+  | Insert2+      { _aborted2 :: Bool+      , _hdrBuf2 :: Vec headerBytes (BitVector 8)+      , _counter2 :: Index (headerBytes `DivRU` dataWidth)+      }+  | Forward2+      { _aborted2 :: Bool+      }+  deriving (Generic, NFDataX, Show, ShowX)++-- | Packetizer transition function in case @dataWidth <= headerBytes@ and @headerBytes % dataWidth ~ 0@+packetizerT2 ::+  forall+    (headerBytes :: Nat)+    (dataWidth :: Nat)+    (header :: Type)+    (metaIn :: Type)+    (metaOut :: Type).+  (PacketizerCt header headerBytes dataWidth) =>+  (headerBytes `Mod` dataWidth ~ 0) =>+  (dataWidth <= headerBytes) =>+  (metaIn -> metaOut) ->+  (metaIn -> header) ->+  PacketizerState2 metaOut headerBytes dataWidth ->+  (Maybe (PacketStreamM2S dataWidth metaIn), PacketStreamS2M) ->+  ( PacketizerState2 metaOut headerBytes dataWidth+  , (PacketStreamS2M, Maybe (PacketStreamM2S dataWidth metaOut))+  )+-- Load the metadata into a buffer. This costs one extra cycle of latency, but it reduces resource usage.+packetizerT2 _ toHeader LoadHeader2 (Just inPkt, _) =+  (Insert2 False (bitCoerce (toHeader (_meta inPkt))) 0, (PacketStreamS2M False, Nothing))+packetizerT2 toMetaOut _ st@Insert2{..} (Just inPkt, bwdIn) =+  (nextStOut, (PacketStreamS2M False, Just outPkt))+ where+  (newBuf, dataOut) = leToPlus @dataWidth @headerBytes $ shiftOutFrom0 (SNat @dataWidth) _hdrBuf2+  nextAborted = _aborted2 || _abort inPkt+  outPkt =+    inPkt+      { _data = dataOut+      , _last = Nothing+      , _meta = toMetaOut (_meta inPkt)+      , _abort = nextAborted+      }++  nextSt+    | _counter2 == maxBound = Forward2 nextAborted+    | otherwise = Insert2 nextAborted newBuf (succ _counter2)++  nextStOut = if _ready bwdIn then nextSt else st+packetizerT2 toMetaOut _ Forward2{..} (Just inPkt, bwdIn) =+  (nextStOut, (bwdIn, Just outPkt))+ where+  nextAborted = _aborted2 || _abort inPkt+  outPkt =+    inPkt+      { _meta = toMetaOut (_meta inPkt)+      , _abort = nextAborted+      }+  nextStOut+    | isJust (_last inPkt) && _ready bwdIn = LoadHeader2+    | otherwise = Forward2 nextAborted+packetizerT2 _ _ s (Nothing, _) = (s, (deepErrorX "undefined ack", Nothing))++data PacketizerState3 (headerBytes :: Nat) (dataWidth :: Nat)+  = LoadHeader3+  | Insert3+      { _aborted3 :: Bool+      , _hdrBuf3 :: Vec (headerBytes + dataWidth) (BitVector 8)+      , _counter3 :: Index (headerBytes `DivRU` dataWidth)+      }+  | Forward3+      { _aborted3 :: Bool+      , _hdrBuf3 :: Vec (headerBytes + dataWidth) (BitVector 8)+      }+  | LastForward3+      { _aborted3 :: Bool+      , _hdrBuf3 :: Vec (headerBytes + dataWidth) (BitVector 8)+      }+  deriving (Generic, Show, ShowX)++deriving instance+  (KnownNat headerBytes, KnownNat dataWidth) =>+  NFDataX (PacketizerState3 headerBytes dataWidth)++-- | Packetizer transition function in case @dataWidth <= headerBytes@ and @headerBytes % dataWidth > 0@+packetizerT3 ::+  forall+    (headerBytes :: Nat)+    (dataWidth :: Nat)+    (header :: Type)+    (metaIn :: Type)+    (metaOut :: Type).+  (PacketizerCt header headerBytes dataWidth) =>+  (1 <= headerBytes `Mod` dataWidth) =>+  (headerBytes `Mod` dataWidth <= dataWidth) =>+  (dataWidth <= headerBytes) =>+  (metaIn -> metaOut) ->+  (metaIn -> header) ->+  PacketizerState3 headerBytes dataWidth ->+  (Maybe (PacketStreamM2S dataWidth metaIn), PacketStreamS2M) ->+  ( PacketizerState3 headerBytes dataWidth+  , (PacketStreamS2M, Maybe (PacketStreamM2S dataWidth metaOut))+  )+packetizerT3 _ toHeader LoadHeader3 (Just inPkt, _bwdIn) =+  (nextStOut, (PacketStreamS2M False, Nothing))+ where+  nextStOut = Insert3 False (bitCoerce (toHeader (_meta inPkt)) ++ _data inPkt) 0+packetizerT3 toMetaOut _ st@Insert3{..} (Just inPkt, bwdIn) =+  (nextStOut, (bwdOut, Just outPkt))+ where+  nextAborted = _aborted3 || _abort inPkt+  (newHdrBuf, dataOut') = shiftOutFrom0 (SNat @dataWidth) _hdrBuf3++  outPkt =+    inPkt+      { _data = dataOut'+      , _last = lastOut+      , _meta = toMetaOut (_meta inPkt)+      }++  (lastOut, nextSt) = case (_counter3 == maxBound, _last inPkt) of+    (False, _) -> (Nothing, Insert3 nextAborted newHdrBuf (succ _counter3))+    (True, Nothing) -> (Nothing, Forward3 nextAborted newHdrBuf)+    (True, Just i) ->+      if i <= natToNum @(dataWidth - headerBytes `Mod` dataWidth)+        then (Just (i + natToNum @(headerBytes `Mod` dataWidth)), LoadHeader3)+        else (Nothing, LastForward3 nextAborted newHdrBuf)+  nextStOut = if _ready bwdIn then nextSt else st+  bwdOut = case nextSt of+    LoadHeader3 -> bwdIn+    Forward3{} -> bwdIn+    _ -> PacketStreamS2M False+packetizerT3 toMetaOut _ st@Forward3{..} (Just inPkt, bwdIn) =+  (nextStOut, (bwdOut, Just outPkt))+ where+  bytesOut :: Vec (dataWidth - headerBytes `Mod` dataWidth) (BitVector 8)+  buf :: Vec (headerBytes `Mod` dataWidth) (BitVector 8)+  (bytesOut, buf) = splitAt (SNat @(dataWidth - headerBytes `Mod` dataWidth)) (_data inPkt)+  newBuf :: Vec (headerBytes + dataWidth) (BitVector 8)+  newBuf =+    buf+      ++ repeat @(headerBytes + dataWidth - headerBytes `Mod` dataWidth) (nullByte "packetizerT3")+  nextAborted = _aborted3 || _abort inPkt++  outPkt =+    inPkt+      { _data = take (SNat @(headerBytes `Mod` dataWidth)) _hdrBuf3 ++ bytesOut+      , _last = lastOut+      , _meta = toMetaOut (_meta inPkt)+      , _abort = nextAborted+      }++  (lastOut, nextSt) = case _last inPkt of+    Nothing -> (Nothing, Forward3 nextAborted newBuf)+    Just i ->+      if i <= natToNum @(dataWidth - headerBytes `Mod` dataWidth)+        then (Just (i + natToNum @(headerBytes `Mod` dataWidth)), LoadHeader3)+        else (Nothing, LastForward3 nextAborted newBuf)+  nextStOut = if _ready bwdIn then nextSt else st++  bwdOut = case nextSt of+    LastForward3{} -> PacketStreamS2M False+    _ -> bwdIn+packetizerT3 toMetaOut _ st@LastForward3{..} (Just inPkt, bwdIn) =+  (nextStOut, (bwdIn, Just outPkt))+ where+  outPkt =+    inPkt+      { _data = takeLe (SNat @dataWidth) _hdrBuf3+      , _last = (\i -> i - natToNum @(dataWidth - headerBytes `Mod` dataWidth)) <$> _last inPkt+      , _meta = toMetaOut (_meta inPkt)+      , _abort = _aborted3 || _abort inPkt+      }+  nextStOut = if _ready bwdIn then LoadHeader3 else st+packetizerT3 _ _ s (Nothing, _) = (s, (deepErrorX "undefined ack", Nothing))++{- |+Writes a portion of the metadata to the front of the packet stream, and shifts+the stream accordingly. This portion is defined by the @(metaIn -> header)@+input function. If this function is `id`, the entire metadata is put in front+of the packet stream.+-}+packetizerC ::+  forall+    (dom :: Domain)+    (dataWidth :: Nat)+    (metaIn :: Type)+    (metaOut :: Type)+    (header :: Type)+    (headerBytes :: Nat).+  (HiddenClockResetEnable dom) =>+  (NFDataX metaOut) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (KnownNat headerBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (KnownNat dataWidth) =>+  -- | Mapping from input `_meta` to output `_meta`+  (metaIn -> metaOut) ->+  -- | Mapping from input `_meta` to the header that will be packetized+  (metaIn -> header) ->+  Circuit (PacketStream dom dataWidth metaIn) (PacketStream dom dataWidth metaOut)+packetizerC toMetaOut toHeader = fromSignals outCircuit+ where+  outCircuit = case leModulusDivisor @headerBytes @dataWidth of+    Dict -> case compareSNat (SNat @(headerBytes + 1)) (SNat @dataWidth) of+      SNatLE -> mealyB (packetizerT1 @headerBytes toMetaOut toHeader) (Insert1 False)+      SNatGT ->+        case ( sameNat (SNat @(headerBytes `Mod` dataWidth)) d0+             , compareSNat d1 (SNat @(headerBytes `Mod` dataWidth))+             ) of+          (Just Refl, _) -> mealyB (packetizerT2 @headerBytes toMetaOut toHeader) LoadHeader2+          (Nothing, SNatLE) -> mealyB (packetizerT3 @headerBytes toMetaOut toHeader) LoadHeader3+          (_, _) ->+            clashCompileError+              "packetizerC: unreachable. Report this at https://github.com/clash-lang/clash-protocols/issues"++data DfPacketizerState (metaOut :: Type) (headerBytes :: Nat) (dataWidth :: Nat)+  = DfIdle+  | DfInsert+      { _dfCounter :: Index (headerBytes `DivRU` dataWidth - 1)+      , _dfHdrBuf :: Vec (headerBytes - dataWidth) (BitVector 8)+      }+  deriving (Generic, Show, ShowX)++deriving instance+  (dataWidth <= headerBytes, KnownNat headerBytes, KnownNat dataWidth) =>+  NFDataX (DfPacketizerState metaOut headerBytes dataWidth)++-- | packetizeFromDf state transition function in case dataWidth < headerBytes.+packetizeFromDfT ::+  forall+    (dataWidth :: Nat)+    (a :: Type)+    (metaOut :: Type)+    (header :: Type)+    (headerBytes :: Nat).+  (NFDataX metaOut) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (KnownNat headerBytes) =>+  (KnownNat dataWidth) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes `DivRU` dataWidth) =>+  ((dataWidth + 1) <= headerBytes) =>+  -- | Mapping from `Df` input to output `_meta`+  (a -> metaOut) ->+  -- | Mapping from `Df` input to the header that will be packetized+  (a -> header) ->+  DfPacketizerState metaOut headerBytes dataWidth ->+  (Maybe a, PacketStreamS2M) ->+  ( DfPacketizerState metaOut headerBytes dataWidth+  , (Ack, Maybe (PacketStreamM2S dataWidth metaOut))+  )+packetizeFromDfT toMetaOut toHeader DfIdle (Just dataIn, bwdIn) = (nextStOut, (Ack False, Just outPkt))+ where+  (dataOut, hdrBuf) = splitAt (SNat @dataWidth) (bitCoerce (toHeader dataIn))+  outPkt = PacketStreamM2S dataOut Nothing (toMetaOut dataIn) False+  nextStOut = if _ready bwdIn then DfInsert 0 hdrBuf else DfIdle++-- fwdIn is always Data in this state, because we assert backpressure in Idle before we go here+-- Thus, we don't need to store the metadata in the state.+packetizeFromDfT toMetaOut _ st@DfInsert{..} (Just dataIn, bwdIn) = (nextStOut, (bwdOut, Just outPkt))+ where+  (dataOut, newHdrBuf) =+    splitAt (SNat @dataWidth) (_dfHdrBuf ++ repeat @dataWidth (nullByte "packetizeFromDfT"))+  outPkt = PacketStreamM2S dataOut newLast (toMetaOut dataIn) False++  newLast = toMaybe (_dfCounter == maxBound) $ case compareSNat (SNat @(headerBytes `Mod` dataWidth)) d0 of+    SNatGT -> natToNum @(headerBytes `Mod` dataWidth)+    _ -> natToNum @dataWidth++  bwdOut = Ack (_ready bwdIn && _dfCounter == maxBound)+  nextSt = if _dfCounter == maxBound then DfIdle else DfInsert (succ _dfCounter) newHdrBuf+  nextStOut = if _ready bwdIn then nextSt else st+packetizeFromDfT _ _ s (Nothing, _) = (s, (deepErrorX "undefined ack", Nothing))++{- |+Starts a packet stream upon receiving some data over a `Df` channel.+The bytes to be packetized and the output metadata are specified by the+input functions.+-}+packetizeFromDfC ::+  forall+    (dom :: Domain)+    (dataWidth :: Nat)+    (a :: Type)+    (metaOut :: Type)+    (header :: Type)+    (headerBytes :: Nat).+  (HiddenClockResetEnable dom) =>+  (NFDataX metaOut) =>+  (BitPack header) =>+  (BitSize header ~ headerBytes * 8) =>+  (KnownNat headerBytes) =>+  (KnownNat dataWidth) =>+  (1 <= headerBytes) =>+  (1 <= dataWidth) =>+  -- | Mapping from `Df` input to output `_meta`+  (a -> metaOut) ->+  -- | Mapping from `Df` input to the header that will be packetized+  (a -> header) ->+  Circuit (Df dom a) (PacketStream dom dataWidth metaOut)+packetizeFromDfC toMetaOut toHeader = case strictlyPositiveDivRu @headerBytes @dataWidth of+  Dict -> case compareSNat (SNat @headerBytes) (SNat @dataWidth) of+    -- We don't need a state machine in this case, as we are able to packetize+    -- the entire payload in one clock cycle.+    SNatLE -> Circuit (unbundle . fmap go . bundle)+     where+      go (Nothing, _) = (deepErrorX "undefined ack", Nothing)+      go (Just dataIn, bwdIn) = (Ack (_ready bwdIn), Just outPkt)+       where+        outPkt = PacketStreamM2S dataOut (Just l) (toMetaOut dataIn) False+        dataOut =+          bitCoerce (toHeader dataIn)+            ++ repeat @(dataWidth - headerBytes) (nullByte "packetizeFromDfC")+        l = case compareSNat (SNat @(headerBytes `Mod` dataWidth)) d0 of+          SNatGT -> natToNum @(headerBytes `Mod` dataWidth)+          _ -> natToNum @dataWidth+    SNatGT -> fromSignals (mealyB (packetizeFromDfT toMetaOut toHeader) DfIdle)
+ src/Protocols/PacketStream/Padding.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright   :  (C) 2024, QBayLogic B.V.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Provides a generic component which enforces some expected packet length field+in the metadata.+-}+module Protocols.PacketStream.Padding (+  stripPaddingC,+) where++import Clash.Prelude++import Data.Bifunctor qualified as B+import Data.Maybe+import Data.Type.Equality ((:~:) (Refl))++import Protocols+import Protocols.PacketStream.Base++-- | State of `stripPaddingT`.+data StripPaddingState p dataWidth meta+  = Counting+      { _buffer :: PacketStreamM2S dataWidth meta+      {- ^ Contains the last transfer, with `_abort` set if a premature end+      was detected. If the packet contained padding, `_last` is already+      correctly adjusted.+      -}+      , _valid :: Bool+      -- ^ Qualifier for _buffer. If false, its value is undefined.+      , _counter :: Unsigned p+      -- ^ Counts the actual length of the current packet.+      }+  | Strip+      { _buffer :: PacketStreamM2S dataWidth meta+      {- ^ We need to wait until forwarding the last transfer, as the padding+      may be aborted. In this state we do not need _valid, as the buffered+      transfer is always valid.+      -}+      }+  deriving (Generic, NFDataX)++-- | State transition function of `stripPaddingC`.+stripPaddingT ::+  forall dataWidth meta p.+  (KnownNat dataWidth) =>+  (KnownNat p) =>+  (meta -> Unsigned p) ->+  StripPaddingState p dataWidth meta ->+  ( Maybe (PacketStreamM2S dataWidth meta)+  , PacketStreamS2M+  ) ->+  ( StripPaddingState p dataWidth meta+  , ( PacketStreamS2M+    , Maybe (PacketStreamM2S dataWidth meta)+    )+  )+stripPaddingT _ st@Counting{} (Nothing, bwdIn) = (nextSt, (deepErrorX "undefined ack", fwdOut))+ where+  fwdOut =+    if _valid st+      then Just (_buffer st)+      else Nothing++  nextSt+    | isJust fwdOut && _ready bwdIn = st{_valid = False}+    | otherwise = st+stripPaddingT toLength st@Counting{} (Just inPkt, bwdIn) = (nextSt, (bwdOut, fwdOut))+ where+  expectedLen = toLength (_meta inPkt)++  toAdd :: Unsigned p+  toAdd = case _last inPkt of+    Nothing -> natToNum @dataWidth+    -- Here we do a slightly dangerous resize. Because @dataWidth@ should+    -- never be bigger than @2^p@, this is not an issue in practice, so I+    -- don't believe it requires a constraint as long as it is well-documented.+    Just size -> bitCoerce (resize size :: Index (2 ^ p))++  carry :: Bool+  nextCount :: Unsigned p+  (carry, nextCount) =+    B.bimap unpack unpack+      $ split+      $ add (_counter st) toAdd++  -- True if the payload size is smaller than expected.+  -- We have to take the carry into account as well, otherwise if the+  -- calculation overflows then we will wrongly signal a premature end.+  prematureEnd =+    isJust (_last inPkt)+      && (nextCount < expectedLen)+      && not carry++  tooBig = nextCount > expectedLen || carry++  fwdOut =+    if _valid st+      then Just (_buffer st)+      else Nothing++  bwdOut = PacketStreamS2M (isNothing fwdOut || _ready bwdIn)++  nextLast+    -- If @dataWidth is 1, the adjusted `_last` is always @Just 0@.+    -- Otherwise, we need to do some arithmetic.+    | tooBig = case sameNat d1 (SNat @dataWidth) of+        Just Refl -> Just 0+        Nothing -> Just $ bitCoerce $ resize $ expectedLen - _counter st+    | otherwise = _last inPkt++  nextBuf = inPkt{_last = nextLast, _abort = _abort inPkt || prematureEnd}+  nextValid = isJust (_last inPkt) || not tooBig++  nextCounter =+    if prematureEnd || isJust (_last inPkt)+      then 0+      else nextCount++  nextSt+    | isJust fwdOut && not (_ready bwdIn) = st+    | isNothing (_last inPkt) && tooBig = Strip nextBuf+    | otherwise = Counting nextBuf nextValid nextCounter+stripPaddingT _ st@Strip{} (Nothing, _) = (st, (deepErrorX "undefined ack", Nothing))+stripPaddingT _ Strip{_buffer = f} (Just inPkt, _) =+  (nextSt, (PacketStreamS2M True, Nothing))+ where+  nextAborted = _abort f || _abort inPkt++  nextSt =+    if isJust (_last inPkt)+      then Counting f{_abort = nextAborted} True 0+      else Strip (f{_abort = nextAborted})++{- |+Removes padding from packets according to some expected packet length field+in the metadata. If the actual length of a packet is smaller than expected,+the packet is aborted.++Has one clock cycle of latency, because all M2S outputs are registered.+Runs at full throughput.++__NB__: @dataWidth@ /must/ be smaller than @2^p@. Because this should never+occur in practice, this constraint is not enforced on the type-level.+-}+stripPaddingC ::+  forall dataWidth meta p dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat dataWidth) =>+  (KnownNat p) =>+  (NFDataX meta) =>+  -- | Function that extracts the expected packet length from the metadata+  (meta -> Unsigned p) ->+  Circuit (PacketStream dom dataWidth meta) (PacketStream dom dataWidth meta)+stripPaddingC toLength =+  forceResetSanity+    |> fromSignals (mealyB (stripPaddingT toLength) s0)+ where+  s0 =+    Counting+      { _buffer = deepErrorX "stripPaddingT: undefined initial buffer."+      , _valid = False+      , _counter = 0+      }
+ src/Protocols/PacketStream/Routing.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Provides a packet arbiter and dispatcher, for merging and splitting packet streams.+-}+module Protocols.PacketStream.Routing (+  packetArbiterC,+  packetDispatcherC,+  routeBy,+) where++import Clash.Prelude++import Protocols+import Protocols.Df qualified as Df+import Protocols.PacketStream.Base++import Data.Bifunctor qualified as B+import Data.Maybe++-- | Merges multiple packet streams into one, respecting packet boundaries.+packetArbiterC ::+  forall dataWidth sources meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat sources) =>+  (1 <= sources) =>+  -- | Determines the mode of arbitration. See `Df.CollectMode`+  Df.CollectMode ->+  Circuit+    (Vec sources (PacketStream dom dataWidth meta))+    (PacketStream dom dataWidth meta)+packetArbiterC mode =+  Circuit (B.first unbundle . mealyB go (maxBound, True) . B.first bundle)+ where+  go (i, first) (fwds, bwd@(PacketStreamS2M ack)) = ((i', continue), (bwds, fwd))+   where+    bwds = replace i bwd (repeat (PacketStreamS2M False))+    fwd = fwds !! i++    -- We may only switch sources if we are not currently in the middle+    -- of forwarding a packet.+    continue = case (fwd, mode) of+      (Nothing, Df.NoSkip) -> False+      (Nothing, _) -> first+      (Just transferIn, _) -> isJust (_last transferIn) && ack++    i' = case (mode, continue) of+      (_, False) -> i+      (Df.NoSkip, _) -> satSucc SatWrap i+      (Df.Skip, _) -> satSucc SatWrap i+      (Df.Parallel, _) ->+        -- Index of first sink with data+        fromMaybe maxBound+          $ fold @(sources - 1) (<|>) (zipWith (<$) indicesI fwds)++{- |+Routes packets depending on their metadata, using given routing functions.++Data is sent to at most one sink, for which the dispatch function evaluates to+@True@ when applied to the input metadata. If none of the predicates hold, the+input packet is dropped. If more than one of the predicates hold, the sink+that occurs first in the vector is picked.++Sends out packets in the same clock cycle as they are received, this+component has zero latency and runs at full throughput.+-}+packetDispatcherC ::+  forall dataWidth sinks meta dom.+  (HiddenClockResetEnable dom) =>+  (KnownNat sinks) =>+  -- | Dispatch function+  Vec sinks (meta -> Bool) ->+  Circuit+    (PacketStream dom dataWidth meta)+    (Vec sinks (PacketStream dom dataWidth meta))+packetDispatcherC predicates =+  Circuit (B.second unbundle . unbundle . fmap go . bundle . B.second bundle)+ where+  idleOtp = repeat Nothing+  go (Nothing, _) = (deepErrorX "undefined ack", idleOtp)+  go (Just x, bwds) = case findIndex id (zipWith ($) predicates (pure $ _meta x)) of+    Just i -> (bwds !! i, replace i (Just x) idleOtp)+    Nothing -> (PacketStreamS2M True, idleOtp)++{- |+Routing function for `packetDispatcherC` that matches against values with+an `Eq` instance. Useful to route according to a record field.+-}+routeBy ::+  (Eq a) =>+  (meta -> a) ->+  Vec sinks a ->+  Vec sinks (meta -> Bool)+routeBy f = map $ \x -> (== x) . f
+ src/Protocols/ToConst.hs view
@@ -0,0 +1,31 @@+{- | Definitions for the 'ToConst' protocol. Usable to pass constant values in+circuits.+-}+module Protocols.ToConst (+  ToConst,+  ToConstBwd,+  to,+  from,+  toBwd,+  fromBwd,+) where++import Protocols.Plugin (Circuit (..), ToConst, ToConstBwd)++-- | Convert a value to a t'Circuit' that produces a constant value on the forward channel.+to :: a -> Circuit () (ToConst a)+to a = Circuit (\_ -> ((), a))++-- | Extract the constant value from the forward direction.+from :: Circuit () (ToConst a) -> a+from (Circuit f) = snd (f ((), ()))++{- | Convert a value to a t'Circuit' that produces a constant value in the+backward direction.+-}+toBwd :: a -> Circuit (ToConstBwd a) ()+toBwd a = Circuit (\_ -> (a, ()))++-- | Extract the constant value from the backward direction.+fromBwd :: Circuit (ToConstBwd a) () -> a+fromBwd (Circuit f) = fst (f ((), ()))
+ src/Protocols/Vec.hs view
@@ -0,0 +1,180 @@+-- | Utility functions for working with 'Vec's of t'Circuit's.+module Protocols.Vec (+  vecCircuits,+  append,+  append3,+  split,+  split3,+  zip,+  zip3,+  zip4,+  zip5,+  unzip,+  unzip3,+  unzip4,+  unzip5,+  concat,+  unconcat,+) where++-- base+import Data.Tuple+import Prelude ()++-- clash-prelude+import Clash.Prelude hiding (+  concat,+  split,+  unconcat,+  unzip,+  unzip3,+  unzip4,+  unzip5,+  zip,+  zip3,+  zip4,+  zip5,+ )+import Clash.Prelude qualified as C++-- clash-protocols-base+import Protocols.Internal (applyC)+import Protocols.Plugin++{- | Bundle together a 'Vec' of t'Circuit's into a t'Circuit' with 'Vec' input+and output. The t'Circuit's all run in parallel.++A general inverse of 'vecCircuits' cannot exist, because we cannot guarantee+that the @n@th output circuit depends only on the @n@th input circuit.+-}+vecCircuits :: (C.KnownNat n) => C.Vec n (Circuit a b) -> Circuit (C.Vec n a) (C.Vec n b)+vecCircuits fs = Circuit (\inps -> C.unzip $ f <$> fs <*> uncurry C.zip inps)+ where+  f (Circuit ff) = ff++-- | Append two separate vectors of the same circuits into one vector of circuits+append ::+  (C.KnownNat n0) =>+  Circuit (C.Vec n0 circuit, C.Vec n1 circuit) (C.Vec (n0 + n1) circuit)+append = applyC (uncurry (++)) splitAtI++-- | Append three separate vectors of the same circuits into one vector of circuits+append3 ::+  (C.KnownNat n0, C.KnownNat n1, KnownNat n2) =>+  Circuit+    (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit)+    (C.Vec (n0 + n1 + n2) circuit)+append3 = applyC (uncurry3 append3Vec) split3Vec++-- | Split a vector of circuits into two vectors of circuits.+split ::+  (C.KnownNat n0) =>+  Circuit (C.Vec (n0 + n1) circuit) (C.Vec n0 circuit, C.Vec n1 circuit)+split = applyC splitAtI (uncurry (++))++-- | Split a vector of circuits into three vectors of circuits.+split3 ::+  (C.KnownNat n0, C.KnownNat n1, C.KnownNat n2) =>+  Circuit+    (C.Vec (n0 + n1 + n2) circuit)+    (C.Vec n0 circuit, C.Vec n1 circuit, C.Vec n2 circuit)+split3 = applyC split3Vec (uncurry3 append3Vec)++{- | Transforms two vectors of circuits into a vector of tuples of circuits.+Only works if the two vectors have the same length.+-}+zip ::+  (C.KnownNat n) =>+  Circuit (C.Vec n a, C.Vec n b) (C.Vec n (a, b))+zip = applyC (uncurry C.zip) C.unzip++{- | Transforms three vectors of circuits into a vector of tuples of circuits.+Only works if the three vectors have the same length.+-}+zip3 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n a, C.Vec n b, C.Vec n c) (C.Vec n (a, b, c))+zip3 = applyC (uncurry3 C.zip3) C.unzip3++{- | Transforms four vectors of circuits into a vector of tuples of circuits.+Only works if the four vectors have the same length.+-}+zip4 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d) (C.Vec n (a, b, c, d))+zip4 = applyC (\(a, b, c, d) -> C.zip4 a b c d) C.unzip4++{- | Transforms five vectors of circuits into a vector of tuples of circuits.+Only works if the five vectors have the same length.+-}+zip5 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d, C.Vec n e) (C.Vec n (a, b, c, d, e))+zip5 = applyC (\(a, b, c, d, e) -> C.zip5 a b c d e) C.unzip5++-- | Unzip a vector of tuples of circuits into a tuple of vectors of circuits.+unzip ::+  (C.KnownNat n) =>+  Circuit (C.Vec n (a, b)) (C.Vec n a, C.Vec n b)+unzip = applyC C.unzip (uncurry C.zip)++-- | Unzip a vector of 3-tuples of circuits into a 3-tuple of vectors of circuits.+unzip3 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n (a, b, c)) (C.Vec n a, C.Vec n b, C.Vec n c)+unzip3 = applyC C.unzip3 (uncurry3 C.zip3)++-- | Unzip a vector of 4-tuples of circuits into a 4-tuple of vectors of circuits.+unzip4 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n (a, b, c, d)) (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d)+unzip4 = applyC C.unzip4 (uncurry4 C.zip4)+ where+  uncurry4 :: (a -> b -> c -> d -> e) -> ((a, b, c, d) -> e)+  uncurry4 f ~(a, b, c, d) = f a b c d++-- | Unzip a vector of 5-tuples of circuits into a 5-tuple of vectors of circuits.+unzip5 ::+  (C.KnownNat n) =>+  Circuit (C.Vec n (a, b, c, d, e)) (C.Vec n a, C.Vec n b, C.Vec n c, C.Vec n d, C.Vec n e)+unzip5 = applyC C.unzip5 (uncurry5 C.zip5)+ where+  uncurry5 :: (a -> b -> c -> d -> e -> f) -> ((a, b, c, d, e) -> f)+  uncurry5 f ~(a, b, c, d, e) = f a b c d e++-- | Transform a vector of vectors of circuits into a vector of circuits.+concat ::+  (C.KnownNat n0, C.KnownNat n1) =>+  Circuit (C.Vec n0 (C.Vec n1 circuit)) (C.Vec (n0 * n1) circuit)+concat = applyC C.concat (C.unconcat SNat)++-- | Transform a vector of circuits into a vector of vectors of circuits.+unconcat ::+  (C.KnownNat n, C.KnownNat m) =>+  SNat m ->+  Circuit (C.Vec (n * m) circuit) (C.Vec n (C.Vec m circuit))+unconcat SNat = applyC (C.unconcat SNat) C.concat++-- Internal utilities++-- | Uncurry a function with three arguments into a function that takes a 3-tuple as argument.+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c++-- Append three vectors of `a` into one vector of `a`.+append3Vec ::+  (KnownNat n0, KnownNat n1, KnownNat n2) =>+  C.Vec n0 a ->+  C.Vec n1 a ->+  C.Vec n2 a ->+  C.Vec (n0 + n1 + n2) a+append3Vec v0 v1 v2 = v0 ++ v1 ++ v2++-- Split a C.Vector of 3-tuples into three vectors of the same length.+split3Vec ::+  (KnownNat n0, KnownNat n1, KnownNat n2) =>+  C.Vec (n0 + n1 + n2) a ->+  (C.Vec n0 a, C.Vec n1 a, C.Vec n2 a)+split3Vec v = (v0, v1, v2)+ where+  (v0, splitAtI -> (v1, v2)) = splitAtI v
+ src/Test/Tasty/Hedgehog/Extra.hs view
@@ -0,0 +1,18 @@+{- |+Extras for module 'Test.Tasty.Hedgehog'. Functions in this module should be+upstreamed if possible.+-}+module Test.Tasty.Hedgehog.Extra (testProperty) where++import Data.String+import Hedgehog (Property)+import Test.Tasty (TestTree)+import Test.Tasty.Hedgehog qualified as H+import Prelude++-- | Like 'Test.Tasty.Hedgehog.testProperty', but inserts correct name+testProperty :: [Char] -> Property -> TestTree+testProperty nm = H.testPropertyNamed testName propName+ where+  testName = fromString $ "prop " <> nm+  propName = fromString $ "prop_" <> nm
+ tests/Tests/Haxioms.hs view
@@ -0,0 +1,98 @@+module Tests.Haxioms where++import Numeric.Natural+import Prelude++import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++{- | Generate a 'Natural' greater than or equal to /n/. Can generate 'Natural's+up to /n+1000/. This should be enough, given that naturals in this module are+used in proofs.+-}+genNatural :: Natural -> Gen Natural+genNatural min_ = Gen.integral (Range.linear min_ (1000 + min_))++-- | Like 'DivRU', but at term-level.+divRU :: Natural -> Natural -> Natural+divRU dividend divider =+  case dividend `divMod` divider of+    (n, 0) -> n+    (n, _) -> n + 1++{- | Test whether the following equation holds:++     Mod a b + 1 <= b++Given:++     1 <= b++Tests: 'Data.Constraint.Nat.Extra.leModulusDivisor'.+-}+prop_leModulusDivisor :: Property+prop_leModulusDivisor = property $ do+  a <- forAll (genNatural 0)+  b <- forAll (genNatural 1)+  assert (a `mod` b + 1 <= b)++{- | Test whether the following equation holds:++    1 <= DivRU a b++Given:++    1 <= a, 1 <= b++Tests: 'Data.Constraint.Nat.Extra.strictlyPositiveDivRu'.+-}+prop_strictlyPositiveDivRu :: Property+prop_strictlyPositiveDivRu = property $ do+  a <- forAll (genNatural 1)+  b <- forAll (genNatural 1)+  assert (1 <= divRU a b)++{- | Test whether the following equation holds:++     b <= a * DivRU b a++Given:++     1 <= a++Tests: 'Data.Constraint.Nat.Extra.leTimesDivRu'.+-}+prop_leTimesDivRu :: Property+prop_leTimesDivRu = property $ do+  a <- forAll (genNatural 1)+  b <- forAll (genNatural 0)+  assert (b <= a * divRU b a)++{- | Test whether the following equation holds:++     a * DivRU b a ~ b + Mod (a - Mod b a) a++Given:++     1 <= a++Tests: 'Data.Constraint.Nat.Extra.eqTimesDivRu'.+-}+prop_eqTimesDivRu :: Property+prop_eqTimesDivRu = property $ do+  a <- forAll (genNatural 1)+  b <- forAll (genNatural 0)+  a * (b `divRU` a) === b + (a - b `mod` a) `mod` a++tests :: TestTree+tests =+  localOption (mkTimeout 10_000_000 {- 10 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 100_000))+      $(testGroupGenerator)
+ tests/Tests/Protocols.hs view
@@ -0,0 +1,26 @@+module Tests.Protocols (tests, main) where++import Test.Tasty+import Tests.Protocols.Avalon qualified+import Tests.Protocols.Axi4 qualified+import Tests.Protocols.Df qualified+import Tests.Protocols.DfConv qualified+import Tests.Protocols.PacketStream qualified+import Tests.Protocols.Vec qualified+import Tests.Protocols.Wishbone qualified++tests :: TestTree+tests =+  testGroup+    "Protocols"+    [ Tests.Protocols.Df.tests+    , Tests.Protocols.DfConv.tests+    , Tests.Protocols.Avalon.tests+    , Tests.Protocols.Axi4.tests+    , Tests.Protocols.PacketStream.tests+    , Tests.Protocols.Wishbone.tests+    , Tests.Protocols.Vec.tests+    ]++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/Avalon.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE RecordWildCards #-}++module Tests.Protocols.Avalon where++-- base+import Prelude++-- clash-prelude+import Clash.Prelude qualified as C++-- extra+import Data.Proxy (Proxy (..))++-- hedgehog+import Hedgehog+import Hedgehog.Gen qualified as Gen++-- tasty+import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++-- clash-protocols (me!)+import Protocols+import Protocols.Experimental.Avalon.MemMap+import Protocols.Experimental.Avalon.Stream+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog+import Protocols.Internal++-- tests++import Tests.Protocols.Df qualified as DfTest+import Util++---------------------------------------------------------------+---------------------------- TESTS ----------------------------+---------------------------------------------------------------++type SharedConfig =+  'AvalonMmSharedConfig 2 'True 'True 2 'True 'True 2 'True 2 'True 'True 'True+type ManagerConfig =+  'AvalonMmManagerConfig 'False 'False 'False SharedConfig+type SubordinateConfig =+  'AvalonMmSubordinateConfig+    'True+    'True+    'True+    'False+    'True+    'False+    'False+    'False+    'False+    SharedConfig++genWriteImpt :: Gen (AvalonWriteImpt 'True SharedConfig)+genWriteImpt =+  AvalonWriteImpt+    <$> (toKeepType <$> Gen.enumBounded)+    <*> (toKeepType <$> Gen.enumBounded)+    <*> (toKeepType <$> Gen.enumBounded)+    <*> pure (toKeepType 1)++genReadReqImpt :: Gen (AvalonReadReqImpt 'True SharedConfig)+genReadReqImpt =+  AvalonReadReqImpt+    <$> (toKeepType <$> Gen.enumBounded)+    <*> (toKeepType <$> Gen.enumBounded)+    <*> pure (toKeepType 1)++genReadImpt :: Gen (AvalonReadImpt SharedConfig)+genReadImpt =+  AvalonReadImpt+    <$> (toKeepType <$> Gen.enumBounded)+    <*> (toKeepType <$> Gen.enumBounded)++readReqImpt :: AvalonReadReqImpt 'True SharedConfig+readReqImpt =+  AvalonReadReqImpt+    { rri_addr = toKeepType 0+    , rri_byteEnable = toKeepType 0+    , rri_burstCount = toKeepType 1+    }++readImpt :: AvalonReadImpt SharedConfig+readImpt =+  AvalonReadImpt+    { ri_readData = toKeepType 0+    , ri_endOfPacket = toKeepType False+    }++-- feed ReadImpt's to a manager-to-subordinate converter, and see that the fwd+-- data is preserved+prop_avalon_convert_manager_subordinate :: Property+prop_avalon_convert_manager_subordinate =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData $ (Left <$> genReadReqImpt) C.<|> (Right <$> genWriteImpt))+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBench+          Proxy+          Proxy+          (repeat True)+          (repeat (Just readImpt))+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (AvalonMmManager dom ManagerConfig)+      (AvalonMmSubordinate dom 0 SubordinateConfig)+  ckt = DfConv.convert Proxy Proxy++-- feed ReadReqImpt's to a manager-to-subordinate converter, and see that the+-- bwd data is preserved+prop_avalon_convert_manager_subordinate_rev :: Property+prop_avalon_convert_manager_subordinate_rev =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genReadImpt)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBenchRev+          Proxy+          Proxy+          (repeat (Just $ Left readReqImpt))+          (repeat True)+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (AvalonMmManager dom ManagerConfig)+      (AvalonMmSubordinate dom 0 SubordinateConfig)+  ckt = DfConv.convert Proxy Proxy++-- feed ReadImpt's to a subordinate-to-manager converter, and see that the fwd+-- data is preserved+prop_avalon_convert_subordinate_manager :: Property+prop_avalon_convert_subordinate_manager =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData $ (Left <$> genReadReqImpt) C.<|> (Right <$> genWriteImpt))+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBench+          Proxy+          Proxy+          (repeat True)+          (repeat (Just readImpt))+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (AvalonMmSubordinate dom 0 SubordinateConfig)+      (AvalonMmManager dom ManagerConfig)+  ckt = DfConv.convert Proxy Proxy++-- feed ReadReqImpt's to a subordinate-to-manager converter, and see that the+-- bwd data is preserved+prop_avalon_convert_subordinate_manager_rev :: Property+prop_avalon_convert_subordinate_manager_rev =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genReadImpt)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBenchRev+          Proxy+          Proxy+          (repeat (Just $ Left readReqImpt))+          (repeat True)+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (AvalonMmSubordinate dom 0 SubordinateConfig)+      (AvalonMmManager dom ManagerConfig)+  ckt = DfConv.convert Proxy Proxy++-- also test out the DfConv instance for AvalonStream++prop_avalon_stream_fifo_id :: Property+prop_avalon_stream_fifo_id =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData genInfo)+    (C.exposeClockResetEnable id)+    (C.exposeClockResetEnable @C.System ckt)+    (\a b -> tally a === tally b)+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (AvalonStream dom ('AvalonStreamConfig 2 2 'True 'True 2 0) Int)+      (AvalonStream dom ('AvalonStreamConfig 2 2 'True 'True 2 0) Int)+  ckt = DfConv.fifo Proxy Proxy (C.SNat @10)++  genInfo =+    AvalonStreamM2S+      <$> DfTest.genSmallInt+      <*> Gen.enumBounded+      <*> Gen.enumBounded+      <*> (toKeepType <$> Gen.enumBounded)+      <*> (toKeepType <$> Gen.enumBounded)+      <*> Gen.enumBounded++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 12_000_000 {- 12 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/Axi4.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE RecordWildCards #-}++module Tests.Protocols.Axi4 where++-- base+import Prelude++-- clash-prelude+import Clash.Prelude qualified as C++-- extra+import Data.Proxy (Proxy (..))++-- hedgehog+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified 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 (me!)+import Protocols+import Protocols.Experimental.Axi4.Common+import Protocols.Experimental.Axi4.ReadAddress+import Protocols.Experimental.Axi4.ReadData+import Protocols.Experimental.Axi4.Stream+import Protocols.Experimental.Axi4.WriteAddress+import Protocols.Experimental.Axi4.WriteData+import Protocols.Experimental.Axi4.WriteResponse+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog+import Protocols.Internal++-- tests++import Tests.Protocols.Df qualified as DfTest+import Util++---------------------------------------------------------------+---------------------------- TESTS ----------------------------+---------------------------------------------------------------++type ConfAW =+  'Axi4WriteAddressConfig 'True 'True 2 2 'True 'True 'True 'True 'True 'True+type ConfW = 'Axi4WriteDataConfig 'True 2+type ConfB = 'Axi4WriteResponseConfig 'True 2+type ConfAR =+  'Axi4ReadAddressConfig 'True 'True 2 2 'True 'True 'True 'True 'True 'True+type ConfR = 'Axi4ReadDataConfig 'True 2++prop_axi4_convert_write_id :: Property+prop_axi4_convert_write_id =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genInfo)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBench+          Proxy+          Proxy+          (repeat True)+          (repeat $ Just (toKeepType ROkay, 0))+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      ( Axi4WriteAddress dom ConfAW Int+      , Axi4WriteData dom ConfW Int+      , Reverse (Axi4WriteResponse dom ConfB Int)+      )+      ( Axi4WriteAddress dom ConfAW Int+      , Axi4WriteData dom ConfW Int+      , Reverse (Axi4WriteResponse dom ConfB Int)+      )+  ckt = DfConv.convert Proxy Proxy++  genInfo =+    (,,,,)+      <$> genWriteAddrInfo+      <*> genBurstLen+      <*> genBurst+      <*> genStrobe+      <*> DfTest.genSmallInt+  genWriteAddrInfo =+    Axi4WriteAddressInfo+      <$> Gen.enumBounded+      <*> Gen.enumBounded+      <*> (toKeepType <$> Gen.enumBounded)+      <*> ( toKeepType+              <$> ( pure Bs1+                      C.<|> pure Bs2+                      C.<|> pure Bs4+                      C.<|> pure Bs8+                      C.<|> pure Bs16+                      C.<|> pure Bs32+                      C.<|> pure Bs64+                      C.<|> pure Bs128+                  )+          )+      <*> (toKeepType <$> (pure NonExclusiveAccess C.<|> pure ExclusiveAccess))+      <*> ( toKeepType+              <$> ( (,,,)+                      <$> (pure NonBufferable C.<|> pure Bufferable)+                      <*> (pure NonModifiable C.<|> pure Modifiable)+                      <*> (pure OtherNoLookupCache C.<|> pure OtherLookupCache)+                      <*> (pure NoLookupCache C.<|> pure LookupCache)+                  )+          )+      <*> ( toKeepType+              <$> ( (,,)+                      <$> (pure Privileged C.<|> pure NotPrivileged)+                      <*> (pure Secure C.<|> pure NonSecure)+                      <*> (pure Instruction C.<|> pure Data)+                  )+          )+      <*> (toKeepType <$> Gen.enumBounded)+      <*> DfTest.genSmallInt++  genBurstLen = pure (toKeepType 0)+  genBurst = toKeepType <$> (pure BmFixed C.<|> pure BmIncr C.<|> pure BmWrap)+  genStrobe = genVec $ pure Nothing C.<|> (Just <$> Gen.enumBounded)++prop_axi4_convert_write_id_rev :: Property+prop_axi4_convert_write_id_rev =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genInfo)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBenchRev+          Proxy+          Proxy+          (repeat $ Just fwdInfo)+          (repeat True)+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      ( Axi4WriteAddress dom ConfAW Int+      , Axi4WriteData dom ConfW Int+      , Reverse (Axi4WriteResponse dom ConfB Int)+      )+      ( Axi4WriteAddress dom ConfAW Int+      , Axi4WriteData dom ConfW Int+      , Reverse (Axi4WriteResponse dom ConfB Int)+      )+  ckt = DfConv.convert Proxy Proxy++  genInfo = (,) <$> genResp <*> DfTest.genSmallInt+  genResp =+    toKeepType+      <$> ( pure ROkay+              C.<|> pure RExclusiveOkay+              C.<|> pure RSlaveError+              C.<|> pure RDecodeError+          )++  fwdInfo =+    ( Axi4WriteAddressInfo+        { _awiid = 0+        , _awiaddr = 0+        , _awiregion = toKeepType 0+        , _awisize = toKeepType Bs1+        , _awilock = toKeepType NonExclusiveAccess+        , _awicache =+            toKeepType+              ( NonBufferable+              , NonModifiable+              , OtherNoLookupCache+              , NoLookupCache+              )+        , _awiprot =+            toKeepType+              ( Privileged+              , Secure+              , Instruction+              )+        , _awiqos = toKeepType 0+        , _awiuser = 0+        }+    , toKeepType 0+    , toKeepType BmFixed+    , C.repeat Nothing+    , 0+    )++prop_axi4_convert_read_id :: Property+prop_axi4_convert_read_id =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genInfo)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBench+          Proxy+          Proxy+          (repeat True)+          (repeat $ Just (0, 0, toKeepType ROkay))+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      ( Axi4ReadAddress dom ConfAR Int+      , Reverse (Axi4ReadData dom ConfR Int Int)+      )+      ( Axi4ReadAddress dom ConfAR Int+      , Reverse (Axi4ReadData dom ConfR Int Int)+      )+  ckt = DfConv.convert Proxy Proxy++  genInfo =+    Axi4ReadAddressInfo+      <$> Gen.enumBounded+      <*> Gen.enumBounded+      <*> (toKeepType <$> Gen.enumBounded)+      <*> Gen.integral (Range.linear 0 10)+      <*> ( toKeepType+              <$> ( pure Bs1+                      C.<|> pure Bs2+                      C.<|> pure Bs4+                      C.<|> pure Bs8+                      C.<|> pure Bs16+                      C.<|> pure Bs32+                      C.<|> pure Bs64+                      C.<|> pure Bs128+                  )+          )+      <*> (toKeepType <$> (pure BmFixed C.<|> pure BmIncr C.<|> pure BmWrap))+      <*> (toKeepType <$> (pure NonExclusiveAccess C.<|> pure ExclusiveAccess))+      <*> ( toKeepType+              <$> ( (,,,)+                      <$> (pure NonBufferable C.<|> pure Bufferable)+                      <*> (pure NonModifiable C.<|> pure Modifiable)+                      <*> (pure NoLookupCache C.<|> pure LookupCache)+                      <*> (pure OtherNoLookupCache C.<|> pure OtherLookupCache)+                  )+          )+      <*> ( toKeepType+              <$> ( (,,)+                      <$> (pure Privileged C.<|> pure NotPrivileged)+                      <*> (pure Secure C.<|> pure NonSecure)+                      <*> (pure Instruction C.<|> pure Data)+                  )+          )+      <*> (toKeepType <$> Gen.enumBounded)+      <*> DfTest.genSmallInt++prop_axi4_convert_read_id_rev :: Property+prop_axi4_convert_read_id_rev =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData genInfo)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBenchRev+          Proxy+          Proxy+          (repeat $ Just fwdInfo)+          (repeat True)+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      ( Axi4ReadAddress dom ConfAR Int+      , Reverse (Axi4ReadData dom ConfR Int Int)+      )+      ( Axi4ReadAddress dom ConfAR Int+      , Reverse (Axi4ReadData dom ConfR Int Int)+      )+  ckt = DfConv.convert Proxy Proxy++  genInfo =+    (,,)+      <$> DfTest.genSmallInt+      <*> DfTest.genSmallInt+      <*> ( toKeepType+              <$> ( pure ROkay+                      C.<|> pure RExclusiveOkay+                      C.<|> pure RSlaveError+                      C.<|> pure RDecodeError+                  )+          )++  fwdInfo =+    Axi4ReadAddressInfo+      { _ariid = 0+      , _ariaddr = 0+      , _ariregion = toKeepType 0+      , _arilen = toKeepType 0+      , _arisize = toKeepType Bs1+      , _ariburst = toKeepType BmFixed+      , _arilock = toKeepType NonExclusiveAccess+      , _aricache =+          toKeepType+            ( NonBufferable+            , NonModifiable+            , NoLookupCache+            , OtherNoLookupCache+            )+      , _ariprot =+          toKeepType+            ( Privileged+            , Secure+            , Instruction+            )+      , _ariqos = toKeepType 0+      , _ariuser = 0+      }++-- also test out the DfConv instance for Axi4Stream++prop_axi4_stream_fifo_id :: Property+prop_axi4_stream_fifo_id =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData genInfo)+    (C.exposeClockResetEnable id)+    (C.exposeClockResetEnable @C.System ckt)+    (\a b -> tally a === tally b)+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (Axi4Stream dom ('Axi4StreamConfig 5 2 2) Int)+      (Axi4Stream dom ('Axi4StreamConfig 5 2 2) Int)+  ckt = DfConv.fifo Proxy Proxy (C.SNat @10)++  genInfo =+    Axi4StreamM2S+      <$> genVec Gen.enumBounded+      <*> genVec Gen.enumBounded+      <*> genVec Gen.enumBounded+      <*> Gen.enumBounded+      <*> Gen.enumBounded+      <*> Gen.enumBounded+      <*> DfTest.genSmallInt++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 12_000_000 {- 12 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/Df.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE CPP #-}+-- TODO: Fix warnings introduced by GHC 9.2 w.r.t. incomplete lazy pattern matches+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+-- Hashable (Index n)+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Tests.Protocols.Df where++-- base+import Data.Bifunctor (Bifunctor (first))+import Data.Coerce (coerce)+import Data.Foldable (fold)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Tuple (swap)+import GHC.Stack (HasCallStack)+import Prelude+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (Applicative(liftA2))+#endif++-- clash-prelude++import Clash.Explicit.Prelude qualified as E+import Clash.Explicit.Reset (noReset)+import Clash.Prelude (Vec (Nil, (:>)), type (<=))+import Clash.Prelude qualified as C++-- containers+import Data.HashMap.Strict qualified as HashMap+import Data.HashSet qualified as HashSet++-- extra+import Data.Either (partitionEithers)+import Data.List (mapAccumL, partition, transpose)++-- deepseq+import Control.DeepSeq (NFData)++-- hashable+import Data.Hashable (Hashable)++-- hedgehog+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++-- tasty+import Test.Tasty+import Test.Tasty.HUnit (Assertion, testCase, (@?=))+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++-- clash-protocols (me!)+import Protocols+import Protocols.Df qualified as Df+import Protocols.Experimental.Hedgehog++-- tests+import Util++newtype PlusInt = PlusInt Int+  deriving stock (C.Generic, Show)+  deriving anyclass (C.ShowX)+  deriving newtype (NFData, C.NFDataX, Eq)++instance Semigroup PlusInt where+  (<>) :: PlusInt -> PlusInt -> PlusInt+  PlusInt i <> PlusInt j = PlusInt (i + j)++instance Monoid PlusInt where+  mempty = PlusInt 0++instance Hashable (C.Index n)++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe genA = Gen.choice [Gen.constant Nothing, Just <$> genA]++smallInt :: Range Int+smallInt = Range.linear 0 10++genSmallInt :: Gen Int+genSmallInt =+  Gen.frequency+    [ (90, Gen.integral smallInt)+    , (10, Gen.constant (Range.lowerBound 99 smallInt))+    ]++genSmallPlusInt :: Gen PlusInt+genSmallPlusInt = coerce <$> genSmallInt++genData :: Gen a -> Gen [a]+genData genA = do+  n <- genSmallInt+  Gen.list (Range.singleton n) genA++genVecData :: (C.KnownNat n, 1 <= n) => Gen a -> Gen (C.Vec n [a])+genVecData genA = do+  n <- genSmallInt+  genVec (Gen.list (Range.singleton n) genA)++-- Same as 'idWithModel', but specialized on 'Df'+idWithModelDf ::+  forall a b.+  (HasCallStack, TestType a, TestType b) =>+  -- | Options, see 'ExpectOptions'+  ExpectOptions ->+  {- | Test data generator, length of generated data is number of _valid_+  cycles. If an input consists of multiple input channels where the number+  of valid cycles differs, this should return the _maximum_ number of valid+  cycles of all channels.+  -}+  Gen [a] ->+  -- | Model+  ([a] -> [b]) ->+  -- | Implementation+  Circuit (Df C.System a) (Df C.System b) ->+  Property+idWithModelDf = idWithModel++-- | Same as 'idWithModelDf' but with hardcoded data generator+idWithModelDf' ::+  -- | Model+  ([Int] -> [Int]) ->+  -- | Implementation+  Circuit (Df C.System Int) (Df C.System Int) ->+  Property+idWithModelDf' = idWithModelDf defExpectOptions (genData genSmallInt)++---------------------------------------------------------------+---------------------------- TESTS ----------------------------+---------------------------------------------------------------+prop_id :: Property+prop_id = idWithModelDf' id idC++prop_map :: Property+prop_map = idWithModelDf' (map succ) (Df.map succ)++prop_filter :: Property+prop_filter = idWithModelDf' (filter (> 5)) (Df.filter (> 5))++prop_catMaybes :: Property+prop_catMaybes =+  idWithModelDf+    defExpectOptions+    (genData (genMaybe genSmallInt))+    catMaybes+    Df.catMaybes++-- A parameterized test definition validating that an expander which+-- simply releases a value downstream once every N cycles+-- does not otherwise change the contents of the stream.+testExpanderPassThrough :: forall n. (C.KnownNat n) => C.SNat n -> Property+testExpanderPassThrough _periodicity =+  idWithModelSingleDomain @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable id)+    ( C.exposeClockResetEnable $+        passThroughExpander |> Df.catMaybes+    )+ where+  -- Just stares at a value for a few cycles and then forwards it+  passThroughExpander ::+    forall dom a.+    (C.HiddenClockResetEnable dom) =>+    Circuit (Df dom a) (Df dom (Maybe a))+  passThroughExpander = Df.expander (0 :: C.Index n) $ \count input ->+    let done = count == maxBound+     in ( if done then 0 else count + 1+        , if done then Just input else Nothing+        , done+        )++prop_expander_passthrough_linerate :: Property+prop_expander_passthrough_linerate = testExpanderPassThrough C.d1++prop_expander_passthrough_slow :: Property+prop_expander_passthrough_slow = testExpanderPassThrough C.d4++-- A parameterized test definition validating that an expander duplicates+-- input values N times and sends them downstream.+testExpanderDuplicate :: forall n. (C.KnownNat n) => C.SNat n -> Property+testExpanderDuplicate duplication =+  idWithModelSingleDomain @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable (concatMap (replicate (C.snatToNum duplication))))+    ( C.exposeClockResetEnable+        duplicator+    )+ where+  -- Creates n copies of a value+  duplicator ::+    forall dom a.+    (C.HiddenClockResetEnable dom) =>+    Circuit (Df dom a) (Df dom a)+  duplicator = Df.expander (0 :: C.Index n) $ \count input ->+    let done = count == maxBound+     in ( if done then 0 else count + 1+        , input+        , done+        )++prop_expander_duplicate_linerate :: Property+prop_expander_duplicate_linerate = testExpanderDuplicate C.d1++prop_expander_duplicate_slow :: Property+prop_expander_duplicate_slow = testExpanderDuplicate C.d4++-- A paremterized test definition validating that a compressor correctly+-- sums up batches of N values.+testCompressorSum :: forall n. (C.KnownNat n) => C.SNat n -> Property+testCompressorSum batchSize =+  idWithModelSingleDomain @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable referenceImpl)+    ( C.exposeClockResetEnable+        passThroughExpander+    )+ where+  chunk = C.snatToNum batchSize+  -- Given [a,b,c,d,e] and chunk = 2, yield [a+b,c+d]+  referenceImpl = map sum . takeWhile ((== chunk) . length) . map (take chunk) . iterate (drop chunk)+  -- Sum groups of `n` samples together+  passThroughExpander ::+    forall dom.+    (C.HiddenClockResetEnable dom) =>+    Circuit (Df dom Int) (Df dom Int)+  passThroughExpander = Df.compressor (0 :: C.Index n, 0 :: Int) $ \(count, total) input ->+    let done = count == maxBound+        total' = total + input+     in ( if done then (0, 0) else (count + 1, total')+        , if done then Just total' else Nothing+        )++prop_compressor_sum_linerate :: Property+prop_compressor_sum_linerate = testCompressorSum C.d1++prop_compressor_sum_slow :: Property+prop_compressor_sum_slow = testCompressorSum C.d4++prop_registerFwd :: Property+prop_registerFwd =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable id)+    (C.exposeClockResetEnable Df.registerFwd)++prop_registerBwd :: Property+prop_registerBwd =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable id)+    (C.exposeClockResetEnable Df.registerBwd)++prop_fanout1 :: Property+prop_fanout1 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable @C.System (Df.fanout @1))++prop_fanout2 :: Property+prop_fanout2 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable @C.System (Df.fanout @2))++prop_fanout7 :: Property+prop_fanout7 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable @C.System (Df.fanout @7))++prop_roundrobin :: Property+prop_roundrobin =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (C.exposeClockResetEnable chunksOf)+    (C.exposeClockResetEnable @C.System (Df.roundrobin @3))++prop_roundrobinCollectNoSkip :: Property+prop_roundrobinCollectNoSkip =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (genVecData genSmallInt)+    (C.exposeClockResetEnable (concat . transpose . C.toList))+    (C.exposeClockResetEnable @C.System (Df.roundrobinCollect @3 Df.NoSkip))++prop_roundrobinCollectSkip :: Property+prop_roundrobinCollectSkip =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (genVecData genSmallInt)+    (C.exposeClockResetEnable (concat . transpose . C.toList))+    (C.exposeClockResetEnable @C.System (Df.roundrobinCollect @3 Df.Skip))+    prop+ where+  prop :: [Int] -> [Int] -> PropertyT IO ()+  prop expected actual = HashSet.fromList expected === HashSet.fromList actual++prop_roundrobinCollectParallel :: Property+prop_roundrobinCollectParallel =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (genVecData genSmallInt)+    (C.exposeClockResetEnable (concat . transpose . C.toList))+    (C.exposeClockResetEnable @C.System (Df.roundrobinCollect @3 Df.Parallel))+    prop+ where+  prop :: [Int] -> [Int] -> PropertyT IO ()+  prop expected actual = HashSet.fromList expected === HashSet.fromList actual++{- | Asserts that roundrobinCollect with Parallel mode behaves in a left-biased+fashion.+-}+case_roundrobinCollectParallel :: Assertion+case_roundrobinCollectParallel = do+  expected @?= actual+ where+  actual =+    E.sampleN 5+      . C.bundle+      . first C.bundle+      $ dut (input0 :> input1 :> input2 :> Nil, pure $ Ack True)++  expected =+    [ (Ack True :> Ack False :> Ack False :> Nil, Just (1 :: Int))+    , (Ack True :> Ack False :> Ack False :> Nil, Just 2)+    , (Ack False :> Ack True :> Ack False :> Nil, Just 10)+    , (Ack False :> Ack True :> Ack False :> Nil, Just 40)+    , (Ack False :> Ack False :> Ack True :> Nil, Just 100)+    ]++  input0 = C.fromList @_ @C.System [Just 1, Just 2, Nothing, Nothing, Nothing]+  input1 = C.fromList @_ @C.System [Just 10, Just 10, Just 10, Just 40, Nothing]+  input2 = C.fromList @_ @C.System [Just 100, Just 100, Just 100, Just 100, Just 100]++  dut =+    toSignals $+      C.withClockResetEnable @C.System C.clockGen noReset C.enableGen $+        Df.roundrobinCollect @3 Df.Parallel++prop_unbundleVec :: Property+prop_unbundleVec =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (fmap C.repeat <$> genData genSmallInt)+    (C.exposeClockResetEnable (vecFromList . transpose . map C.toList))+    (C.exposeClockResetEnable (Df.unbundleVec @3 @C.System @Int))++prop_bundleVec :: Property+prop_bundleVec =+  idWithModel+    defExpectOptions+    (C.repeat <$> genData genSmallPlusInt)+    (map vecFromList . transpose . C.toList)+    (Df.bundleVec @3 @C.System @PlusInt)++prop_fanin :: Property+prop_fanin =+  idWithModel+    defExpectOptions+    (genVecData genSmallInt)+    (map sum . transpose . C.toList)+    (Df.fanin @3 @C.System @Int (+))++prop_mfanin :: Property+prop_mfanin =+  idWithModel+    defExpectOptions+    (genVecData genSmallPlusInt)+    (map fold . transpose . C.toList)+    (Df.mfanin @3 @C.System @PlusInt)++prop_zipWith :: Property+prop_zipWith =+  idWithModel+    defExpectOptions+    ( do+        as <- genData genSmallInt+        bs <- genData genSmallInt+        let n = min (length as) (length bs)+        pure (take n as, take n bs)+    )+    (uncurry (zipWith (+)))+    (Df.zipWith @C.System @Int @Int (+))++prop_zip :: Property+prop_zip =+  idWithModel+    defExpectOptions+    ( do+        as <- genData genSmallInt+        bs <- genData genSmallInt+        let n = min (length as) (length bs)+        pure (take n as, take n bs)+    )+    (uncurry zip)+    (Df.zip @Int @Int @C.System)++prop_partition :: Property+prop_partition =+  idWithModel+    defExpectOptions+    (genData genSmallInt)+    (partition (> 5))+    (Df.partition @C.System @Int (> 5))++prop_partitionEithers :: Property+prop_partitionEithers =+  idWithModel+    defExpectOptions+    (genData (Gen.either genSmallInt Gen.alphaNum))+    partitionEithers+    (Df.partitionEithers @C.System @Int @Char)++prop_route :: Property+prop_route =+  idWithModel+    defExpectOptions+    (zip <$> genData Gen.enumBounded <*> genData genSmallInt)+    (\inp -> C.map (\i -> map snd (filter ((== i) . fst) inp)) C.indicesI)+    (Df.route @3 @C.System @Int)++prop_select :: Property+prop_select =+  idWithModel+    defExpectOptions+    goGen+    (snd . uncurry (mapAccumL goModel))+    (Df.select @3 @C.System @Int)+ where+  goModel :: C.Vec 3 [Int] -> C.Index 3 -> (C.Vec 3 [Int], Int)+  goModel vec ix = let (i : is) = vec C.!! ix in (C.replace ix is vec, i)++  goGen :: Gen (C.Vec 3 [Int], [C.Index 3])+  goGen = do+    n <- genSmallInt+    ixs <- Gen.list (Range.singleton n) Gen.enumBounded+    let tall i = fromMaybe 0 (HashMap.lookup i (tally ixs))+    dats <- mapM (\i -> Gen.list (Range.singleton (tall i)) genSmallInt) C.indicesI+    pure (dats, ixs)++prop_selectN :: Property+prop_selectN =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    goGen+    (\_ _ _ -> concat . snd . uncurry (mapAccumL goModel))+    (C.exposeClockResetEnable (Df.selectN @3 @10 @C.System @Int))+ where+  goModel :: C.Vec 3 [Int] -> (C.Index 3, C.Index 10) -> (C.Vec 3 [Int], [Int])+  goModel vec (ix, len) =+    let (as, bs) = splitAt (fromIntegral len) (vec C.!! ix)+     in (C.replace ix bs vec, as)++  goGen :: Gen (C.Vec 3 [Int], [(C.Index 3, C.Index 10)])+  goGen = do+    n <- genSmallInt+    ixs <- Gen.list (Range.singleton n) Gen.enumBounded+    lenghts <- Gen.list (Range.singleton n) Gen.enumBounded+    let tallied = tallyOn fst (fromIntegral . snd) (zip ixs lenghts)+        tall i = fromMaybe 0 (HashMap.lookup i tallied)+    dats <- mapM (\i -> Gen.list (Range.singleton (tall i)) genSmallInt) C.indicesI+    pure (dats, zip ixs lenghts)++prop_selectUntil :: Property+prop_selectUntil =+  idWithModel+    defExpectOptions+    goGen+    (concat . snd . uncurry (mapAccumL goModel))+    (Df.selectUntil @3 @C.System @(Int, Bool) snd)+ where+  goModel :: C.Vec 3 [(Int, Bool)] -> C.Index 3 -> (C.Vec 3 [(Int, Bool)], [(Int, Bool)])+  goModel vec ix =+    let (as, (b : bs)) = break snd (vec C.!! ix)+     in (C.replace ix bs vec, as <> [b])++  goGen :: Gen (C.Vec 3 [(Int, Bool)], [C.Index 3])+  goGen = do+    n <- genSmallInt+    ixs <- Gen.list (Range.singleton n) Gen.enumBounded+    dats <- mapM (\i -> goChannelInput (HashMap.lookup i (tally ixs))) C.indicesI+    pure (dats, ixs)++  goChannelInput :: Maybe Int -> Gen [(Int, Bool)]+  goChannelInput Nothing = pure []+  goChannelInput (Just n) = do+    inputs0 <- Gen.list (Range.singleton n) (Gen.list (Range.linear 1 10) genSmallInt)+    let tagEnd xs = zip (init xs) (repeat False) <> [(last xs, True)]+    pure (concatMap tagEnd inputs0)++prop_fifo :: Property+prop_fifo =+  idWithModelDf'+    id+    (C.withClockResetEnable C.clockGen C.resetGen C.enableGen Df.fifo (C.SNat @10))++prop_toMaybeFromMaybe :: Property+prop_toMaybeFromMaybe =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (genData genSmallInt)+    (\_ _ _ -> fmap (,0))+    (C.exposeClockResetEnable dut)+    (\sent received -> prop (fst <$> sent) received)+ where+  -- Calculate how many samples were dropped and use that to validate the received+  -- stream.+  prop :: [Int] -> [(Int, C.Unsigned 64)] -> PropertyT IO ()+  prop sents (unzip -> (receiveds, nDroppeds)) = do+    footnote ("sents: " <> show sents)+    footnote ("receiveds: " <> show receiveds)+    footnote ("nDroppeds: " <> show nDroppeds)+    footnote ("nDroppedSinceLasts: " <> show nDroppedSinceLasts)+    go sents (zip receiveds nDroppedSinceLasts)+   where+    nDroppedSinceLasts :: [C.Unsigned 64]+    nDroppedSinceLasts = 0 : zipWith (-) nDroppeds (0 : nDroppeds)++    go _ [] = pure ()+    go sent0 ((received, nDropped) : rest)+      | (s : ss) <- drop (fromIntegral nDropped) sent0 = do+          s === received+          go ss rest+      | otherwise = fail "Expected more sent values"++  -- XXX: This dut is a bit *meh*, because it inserts the dropped count into+  --      the Df stream, but it doesn't account for the rule that the data+  --      only "advances" when data is acked.+  dut ::+    (C.SystemClockResetEnable) =>+    Circuit+      (Df C.System Int)+      (Df C.System (Int, C.Unsigned 64))+  dut =+    Df.forceResetSanity+      |> Df.toMaybe+      |> Df.unsafeFromMaybe+      |> Circuit (first (,()) . swap . first (fmap go) . first C.bundle)+   where+    go :: (Maybe Int, C.Unsigned 64) -> Maybe (Int, C.Unsigned 64)+    go (a, b) = liftA2 (,) a (Just b)++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 12_000_000 {- 12 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/DfConv.hs view
@@ -0,0 +1,264 @@+-- TODO: Fix warnings introduced by GHC 9.2 w.r.t. incomplete lazy pattern matches+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Tests.Protocols.DfConv where++-- base++import Data.Maybe (fromMaybe)+import Prelude++-- clash-prelude+import Clash.Prelude qualified as C++-- list+import Data.List (mapAccumL, partition, transpose)++-- containers+import Data.HashMap.Strict qualified as HashMap++-- extra+import Data.Proxy (Proxy (..))++-- hedgehog+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified 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 (me!)+import Protocols+import Protocols.Experimental.DfConv qualified as DfConv+import Protocols.Experimental.Hedgehog+import Protocols.Internal++-- tests++import Tests.Protocols.Df qualified as DfTest+import Util++---------------------------------------------------------------+---------------------------- TESTS ----------------------------+---------------------------------------------------------------++-- test a small selection of dflike functions on df+-- this is moreso to test @instance DfConv Df@,+-- as well as @dfToDfConvInp@ etc,+-- rather than the functions themselves,+-- since we know they work from @Tests.Protocols.Df@++prop_df_map_inc :: Property+prop_df_map_inc =+  DfTest.idWithModelDf'+    (fmap (+ 1))+    (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int)+  ckt = DfConv.map Proxy Proxy (+ 1)++prop_df_filter_over_5 :: Property+prop_df_filter_over_5 =+  DfTest.idWithModelDf'+    (filter (> 5))+    (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int)+  ckt = DfConv.filter Proxy Proxy (> 5)++prop_df_mapmaybe_inc_over_5 :: Property+prop_df_mapmaybe_inc_over_5 =+  DfTest.idWithModelDf'+    (map (+ 1) . filter (> 5))+    (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int)+  ckt = DfConv.mapMaybe Proxy Proxy (\n -> if n > 5 then Just (n + 1) else Nothing)++prop_df_zipwith_add :: Property+prop_df_zipwith_add =+  idWithModel+    defExpectOptions+    ( do+        as <- DfTest.genData DfTest.genSmallInt+        bs <- DfTest.genData DfTest.genSmallInt+        let n = min (length as) (length bs)+        pure (take n as, take n bs)+    )+    (uncurry (zipWith (+)))+    (C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int, Df dom Int) (Df dom Int)+  ckt = DfConv.zipWith (Proxy, Proxy) Proxy (+)++prop_df_fanout1 :: Property+prop_df_fanout1 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 1 (Df dom Int))+  ckt = DfConv.fanout Proxy Proxy++prop_df_fanout2 :: Property+prop_df_fanout2 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 2 (Df dom Int))+  ckt = DfConv.fanout Proxy Proxy++prop_df_fanout7 :: Property+prop_df_fanout7 =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    (C.exposeClockResetEnable C.repeat)+    (C.exposeClockResetEnable ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (C.Vec 7 (Df dom Int))+  ckt = DfConv.fanout Proxy Proxy++prop_df_partition :: Property+prop_df_partition =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    (C.exposeClockResetEnable $ partition (> 5))+    (C.exposeClockResetEnable ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int, Df dom Int)+  ckt = DfConv.partition Proxy (Proxy, Proxy) (> 5)++prop_df_fanin :: Property+prop_df_fanin =+  idWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genVecData DfTest.genSmallInt)+    (C.exposeClockResetEnable $ map sum . transpose . C.toList)+    (C.exposeClockResetEnable ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (C.Vec 3 (Df dom Int)) (Df dom Int)+  ckt = DfConv.fanin Proxy Proxy (+)++prop_df_fifo_id :: Property+prop_df_fifo_id =+  propWithModelSingleDomain+    @C.System+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    (C.exposeClockResetEnable id)+    (C.exposeClockResetEnable @C.System ckt)+    (\a b -> tally a === tally b)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int)+  ckt = DfConv.fifo Proxy Proxy (C.SNat @10)++prop_select :: Property+prop_select =+  idWithModel+    defExpectOptions+    goGen+    (snd . uncurry (mapAccumL goModel))+    (C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit (C.Vec 3 (Df dom Int), Df dom (C.Index 3)) (Df dom Int)+  ckt = DfConv.select (Proxy @(Df _ Int), Proxy @(Df _ (C.Index 3))) (Proxy @(Df _ Int))++  goModel :: C.Vec 3 [Int] -> C.Index 3 -> (C.Vec 3 [Int], Int)+  goModel vec ix = let (i : is) = vec C.!! ix in (C.replace ix is vec, i)++  goGen :: Gen (C.Vec 3 [Int], [C.Index 3])+  goGen = do+    n <- DfTest.genSmallInt+    ixs <- Gen.list (Range.singleton n) Gen.enumBounded+    let tall i = fromMaybe 0 (HashMap.lookup i (tally ixs))+    dats <- mapM (\i -> Gen.list (Range.singleton (tall i)) DfTest.genSmallInt) C.indicesI+    pure (dats, ixs)++-- test out instance DfConv (Reverse a)++prop_reverse_df_convert_id :: Property+prop_reverse_df_convert_id =+  DfTest.idWithModelDf'+    id+    (C.withClockResetEnable C.clockGen C.resetGen C.enableGen ckt)+ where+  ckt :: (C.HiddenClockResetEnable dom) => Circuit (Df dom Int) (Df dom Int)+  ckt =+    coerceCircuit $+      reverseCircuit $+        DfConv.convert (Proxy @(Reverse (Df _ _))) (Proxy @(Reverse (Df _ _)))++-- test out the test bench+prop_test_bench_id :: Property+prop_test_bench_id =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBench+          Proxy+          Proxy+          (repeat True)+          (repeat (Just 0))+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (Df dom Int, Reverse (Df dom Int))+      (Df dom Int, Reverse (Df dom Int))+  ckt = DfConv.convert Proxy Proxy++prop_test_bench_rev_id :: Property+prop_test_bench_rev_id =+  DfTest.idWithModelDf+    defExpectOptions+    (DfTest.genData DfTest.genSmallInt)+    id+    ( C.withClockResetEnable @C.System C.clockGen C.resetGen C.enableGen $+        DfConv.dfConvTestBenchRev+          Proxy+          Proxy+          (repeat (Just 0))+          (repeat True)+          ckt+    )+ where+  ckt ::+    (C.HiddenClockResetEnable dom) =>+    Circuit+      (Df dom Int, Reverse (Df dom Int))+      (Df dom Int, Reverse (Df dom Int))+  ckt = DfConv.convert Proxy Proxy++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 20_000_000 {- 20 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/PacketStream.hs view
@@ -0,0 +1,26 @@+module Tests.Protocols.PacketStream (tests) where++import Test.Tasty++import Tests.Protocols.PacketStream.AsyncFifo qualified+import Tests.Protocols.PacketStream.Base qualified+import Tests.Protocols.PacketStream.Converters qualified+import Tests.Protocols.PacketStream.Depacketizers qualified+import Tests.Protocols.PacketStream.PacketFifo qualified+import Tests.Protocols.PacketStream.Packetizers qualified+import Tests.Protocols.PacketStream.Padding qualified+import Tests.Protocols.PacketStream.Routing qualified++tests :: TestTree+tests =+  testGroup+    "PacketStream"+    [ Tests.Protocols.PacketStream.AsyncFifo.tests+    , Tests.Protocols.PacketStream.Base.tests+    , Tests.Protocols.PacketStream.Converters.tests+    , Tests.Protocols.PacketStream.Depacketizers.tests+    , Tests.Protocols.PacketStream.PacketFifo.tests+    , Tests.Protocols.PacketStream.Packetizers.tests+    , Tests.Protocols.PacketStream.Padding.tests+    , Tests.Protocols.PacketStream.Routing.tests+    ]
+ tests/Tests/Protocols/PacketStream/AsyncFifo.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Tests.Protocols.PacketStream.AsyncFifo where++import Clash.Prelude++import Hedgehog (Property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty (TestTree, localOption, mkTimeout)+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++createDomain+  vSystem+    { vName = "TestDom50"+    , vPeriod = 20_000+    , vActiveEdge = Rising+    , vResetKind = Asynchronous+    , vInitBehavior = Unknown+    , vResetPolarity = ActiveHigh+    }++createDomain+  vSystem+    { vName = "TestDom125"+    , vPeriod = 8_000+    , vActiveEdge = Rising+    , vResetKind = Asynchronous+    , vInitBehavior = Unknown+    , vResetPolarity = ActiveHigh+    }++clk50 :: Clock TestDom50+clk50 = clockGen++clk125 :: Clock TestDom125+clk125 = clockGen++-- Assert the reset for a different amount of cycles in each domain+-- to properly test the async fifo.+rst50 :: Reset TestDom50+rst50 = resetGenN d30++rst125 :: Reset TestDom125+rst125 = resetGenN d40++en50 :: Enable TestDom50+en50 = enableGen++en125 :: Enable TestDom125+en125 = enableGen++generateAsyncFifoIdProp ::+  forall (wDom :: Domain) (rDom :: Domain).+  (KnownDomain wDom, KnownDomain rDom) =>+  Clock wDom ->+  Reset wDom ->+  Enable wDom ->+  Clock rDom ->+  Reset rDom ->+  Enable rDom ->+  Property+generateAsyncFifoIdProp wClk wRst wEn rClk rRst rEn =+  idWithModel+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 30)))+    id+    (asyncFifoC @wDom @rDom @4 @1 @Int d4 wClk wRst wEn rClk rRst rEn)++{- | The async FIFO circuit should forward all of its input data without loss and without producing extra data.+  This property tests whether this is true, when the clock of the writer and reader is equally fast (50 MHz).+-}+prop_asyncfifo_writer_speed_equal_to_reader_id :: Property+prop_asyncfifo_writer_speed_equal_to_reader_id = generateAsyncFifoIdProp clk50 rst50 en50 clk50 rst50 en50++{- | The async FIFO circuit should forward all of its input data without loss and without producing extra data.+  This property tests whether this is true, when the clock of the writer (50 MHz) is slower than the clock of the reader (125 MHz).+-}+prop_asyncfifo_writer_speed_slower_than_reader_id :: Property+prop_asyncfifo_writer_speed_slower_than_reader_id = generateAsyncFifoIdProp clk50 rst50 en50 clk125 rst125 en125++{- | The async FIFO circuit should forward all of its input data without loss and without producing extra data.+  This property tests whether this is true, when the clock of the writer (125 MHz) is faster than the clock of the reader (50 MHz).+-}+prop_asyncfifo_writer_speed_faster_than_reader_id :: Property+prop_asyncfifo_writer_speed_faster_than_reader_id = generateAsyncFifoIdProp clk125 rst125 en125 clk50 rst50 en50++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 100))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Base.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.Base (+  tests,+) where++import Clash.Prelude++import Data.List qualified as L+import "extra" Data.List.Extra (unsnoc)++import Hedgehog (Gen, Property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty (TestTree, localOption, mkTimeout)+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++prop_strip_trailing_empty :: Property+prop_strip_trailing_empty =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10)))+    (exposeClockResetEnable model')+    (exposeClockResetEnable (stripTrailingEmptyC @1 @Char))+ where+  model' packets = L.concatMap model (chunkByPacket packets)++  model :: [PacketStreamM2S 1 Char] -> [PacketStreamM2S 1 Char]+  model packet = case unsnoc packet of+    Nothing -> []+    Just (xs, l) -> case unsnoc xs of+      -- Preserve packets that consist of a single zero-byte transfer.+      Nothing -> [l]+      Just (ys, l2) ->+        if _last l == Just 0+          then ys L.++ [l2{_last = Just maxBound, _abort = _abort l2 || _abort l}]+          else packet++prop_truncate_aborted_packets :: Property+prop_truncate_aborted_packets =+  idWithModelSingleDomain+    @System+    defExpectOptions+    gen+    (exposeClockResetEnable model')+    (exposeClockResetEnable truncateAbortedPackets)+ where+  gen :: Gen [PacketStreamM2S 4 ()]+  gen = genPackets 0 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10))++  model' packets = L.concatMap model (chunkByPacket packets)++  model :: [PacketStreamM2S 4 ()] -> [PacketStreamM2S 4 ()]+  model [] = []+  model (x : xs)+    | x._abort = [x{_last = Just 0}]+    | otherwise = x : model xs++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 500))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Converters.hs view
@@ -0,0 +1,97 @@+module Tests.Protocols.PacketStream.Converters (+  tests,+) where++import Clash.Prelude++import Hedgehog (Property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++generateUpConverterProperty ::+  forall (dwIn :: Nat) (n :: Nat).+  (1 <= dwIn) =>+  (1 <= n) =>+  (1 <= dwIn * n) =>+  SNat dwIn ->+  SNat n ->+  Property+generateUpConverterProperty SNat SNat =+  idWithModelSingleDomain+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 20)))+    (exposeClockResetEnable (upConvert . downConvert))+    (exposeClockResetEnable @System (upConverterC @dwIn @n @Int))++generateDownConverterProperty ::+  forall (dwOut :: Nat) (n :: Nat).+  (1 <= dwOut) =>+  (1 <= n) =>+  (1 <= dwOut * n) =>+  SNat dwOut ->+  SNat n ->+  Property+generateDownConverterProperty SNat SNat =+  idWithModelSingleDomain+    defExpectOptions+    (genPackets 1 8 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10)))+    (exposeClockResetEnable (upConvert . downConvert))+    (exposeClockResetEnable @System (downConverterC @dwOut @n @Int))++prop_upConverter3to9 :: Property+prop_upConverter3to9 = generateUpConverterProperty d3 d3++prop_upConverter4to8 :: Property+prop_upConverter4to8 = generateUpConverterProperty d4 d2++prop_upConverter3to6 :: Property+prop_upConverter3to6 = generateUpConverterProperty d3 d2++prop_upConverter2to4 :: Property+prop_upConverter2to4 = generateUpConverterProperty d2 d2++prop_upConverter1to4 :: Property+prop_upConverter1to4 = generateUpConverterProperty d1 d4++prop_upConverter1to2 :: Property+prop_upConverter1to2 = generateUpConverterProperty d1 d2++prop_upConverter1to1 :: Property+prop_upConverter1to1 = generateUpConverterProperty d1 d1++prop_downConverter9to3 :: Property+prop_downConverter9to3 = generateDownConverterProperty d3 d3++prop_downConverter8to4 :: Property+prop_downConverter8to4 = generateDownConverterProperty d4 d2++prop_downConverter6to3 :: Property+prop_downConverter6to3 = generateDownConverterProperty d3 d2++prop_downConverter4to2 :: Property+prop_downConverter4to2 = generateDownConverterProperty d2 d2++prop_downConverter4to1 :: Property+prop_downConverter4to1 = generateDownConverterProperty d1 d4++prop_downConverter2to1 :: Property+prop_downConverter2to1 = generateDownConverterProperty d1 d2++prop_downConverter1to1 :: Property+prop_downConverter1to1 = generateDownConverterProperty d1 d1++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 500))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Depacketizers.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.Depacketizers (+  tests,+) where++import Clash.Prelude++import Hedgehog (Gen, Property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))++import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++{- |+Test @depacketizerC@ with varying data width, number of bytes in the+header, input metadata, and output metadata.+-}+depacketizerPropGen ::+  forall+    (metaIn :: Type)+    (metaOut :: Type)+    (dataWidth :: Nat)+    (headerBytes :: Nat).+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (TestType metaIn) =>+  (TestType metaOut) =>+  SNat dataWidth ->+  SNat headerBytes ->+  Gen metaIn ->+  (Vec headerBytes (BitVector 8) -> metaIn -> metaOut) ->+  Property+depacketizerPropGen SNat SNat metaGen toMetaOut =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 4 (genValidPacket defPacketOptions metaGen (Range.linear 0 30)))+    (exposeClockResetEnable (depacketizerModel toMetaOut))+    (exposeClockResetEnable ckt)+ where+  ckt ::+    (HiddenClockResetEnable System) =>+    Circuit+      (PacketStream System dataWidth metaIn)+      (PacketStream System dataWidth metaOut)+  ckt = depacketizerC toMetaOut++{- |+Test @depacketizeToDfC@ with varying data width, number of bytes in the+header, input metadata, and output type @a@.+-}+depacketizeToDfPropGen ::+  forall+    (metaIn :: Type)+    (a :: Type)+    (dataWidth :: Nat)+    (headerBytes :: Nat).+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (BitPack a) =>+  (BitSize a ~ headerBytes * 8) =>+  (TestType a) =>+  (TestType metaIn) =>+  SNat dataWidth ->+  SNat headerBytes ->+  Gen metaIn ->+  (Vec headerBytes (BitVector 8) -> metaIn -> a) ->+  Property+depacketizeToDfPropGen SNat SNat metaGen toOut =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions metaGen (Range.linear 0 20)))+    (exposeClockResetEnable (depacketizeToDfModel toOut))+    (exposeClockResetEnable ckt)+ where+  ckt ::+    (HiddenClockResetEnable System) =>+    Circuit (PacketStream System dataWidth metaIn) (Df System a)+  ckt = depacketizeToDfC toOut++{- |+Do something interesting with both the parsed header and the input+metadata for testing purposes. We just xor every byte in the parsed+header with the byte in the input metadata.+-}+exampleToMetaOut ::+  Vec headerBytes (BitVector 8) ->+  BitVector 8 ->+  Vec headerBytes (BitVector 8)+exampleToMetaOut hdr metaIn = map (`xor` metaIn) hdr++-- | headerBytes % dataWidth ~ 0+prop_const_depacketizer_d1_d14 :: Property+prop_const_depacketizer_d1_d14 =+  depacketizerPropGen d1 d14 (pure ()) const++prop_xor_depacketizer_d1_d14 :: Property+prop_xor_depacketizer_d1_d14 =+  depacketizerPropGen d1 d14 Gen.enumBounded exampleToMetaOut++-- | dataWidth < headerBytes+prop_const_depacketizer_d3_d11 :: Property+prop_const_depacketizer_d3_d11 =+  depacketizerPropGen d3 d11 (pure ()) const++prop_xor_depacketizer_d3_d11 :: Property+prop_xor_depacketizer_d3_d11 =+  depacketizerPropGen d3 d11 Gen.enumBounded exampleToMetaOut++-- | dataWidth ~ header byte size+prop_const_depacketizer_d7_d7 :: Property+prop_const_depacketizer_d7_d7 =+  depacketizerPropGen d7 d7 (pure ()) const++prop_xor_depacketizer_d7_d7 :: Property+prop_xor_depacketizer_d7_d7 =+  depacketizerPropGen d7 d7 Gen.enumBounded exampleToMetaOut++-- | dataWidth > header byte size+prop_const_depacketizer_d5_d4 :: Property+prop_const_depacketizer_d5_d4 =+  depacketizerPropGen d5 d4 (pure ()) const++prop_xor_depacketizer_d5_d4 :: Property+prop_xor_depacketizer_d5_d4 =+  depacketizerPropGen d5 d4 Gen.enumBounded exampleToMetaOut++-- | headerBytes % dataWidth ~ 0+prop_const_depacketize_to_df_d1_d14 :: Property+prop_const_depacketize_to_df_d1_d14 =+  depacketizeToDfPropGen d1 d14 (pure ()) const++prop_xor_depacketize_to_df_d1_d14 :: Property+prop_xor_depacketize_to_df_d1_d14 =+  depacketizeToDfPropGen d1 d14 Gen.enumBounded exampleToMetaOut++-- | dataWidth < headerBytes+prop_const_depacketize_to_df_d3_d11 :: Property+prop_const_depacketize_to_df_d3_d11 =+  depacketizeToDfPropGen d3 d11 (pure ()) const++prop_xor_depacketize_to_df_d3_d11 :: Property+prop_xor_depacketize_to_df_d3_d11 =+  depacketizeToDfPropGen d3 d11 Gen.enumBounded exampleToMetaOut++-- | dataWidth ~ header byte size+prop_const_depacketize_to_df_d7_d7 :: Property+prop_const_depacketize_to_df_d7_d7 =+  depacketizeToDfPropGen d7 d7 (pure ()) const++prop_xor_depacketize_to_df_d7_d7 :: Property+prop_xor_depacketize_to_df_d7_d7 =+  depacketizeToDfPropGen d7 d7 Gen.enumBounded exampleToMetaOut++-- | dataWidth > header byte size+prop_const_depacketize_to_df_d5_d4 :: Property+prop_const_depacketize_to_df_d5_d4 =+  depacketizeToDfPropGen d5 d4 (pure ()) const++prop_xor_depacketize_to_df_d5_d4 :: Property+prop_xor_depacketize_to_df_d5_d4 =+  depacketizeToDfPropGen d5 d4 Gen.enumBounded exampleToMetaOut++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 500))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/PacketFifo.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.PacketFifo (+  tests,+) where++import Clash.Prelude++import Data.Int (Int16)+import Data.List qualified as L++import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Prelude qualified as P++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.Experimental.Simulate+import Protocols.PacketStream.Hedgehog++-- | Drops packets that consist of more than 2^n transfers.+dropBigPackets ::+  SNat n ->+  [PacketStreamM2S dataWidth meta] ->+  [PacketStreamM2S dataWidth meta]+dropBigPackets n packets =+  L.concat+    $ L.filter+      (\p -> L.length p < 2 P.^ snatToInteger n)+      (chunkByPacket packets)++-- | Test for id and proper dropping of aborted packets.+prop_packet_fifo_id :: Property+prop_packet_fifo_id =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10)))+    (exposeClockResetEnable dropAbortedPackets)+    (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d10 Backpressure))++{- |+Ensure that backpressure because of a full content RAM and dropping of packets+that are too big to fit in the FIFO is tested.+-}+prop_packet_fifo_small_buffer_id :: Property+prop_packet_fifo_small_buffer_id =+  idWithModelSingleDomain+    @System+    defExpectOptions{eoStopAfterEmpty = Just 500} -- To account for empty cycles due to dropped packets+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 30)))+    (exposeClockResetEnable (dropBigPackets d3 . dropAbortedPackets))+    (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d3 d5 Backpressure))++{- |+Test for id using a small meta buffer to ensure backpressure using+the meta buffer is tested.+-}+prop_packet_fifo_small_meta_buffer_id :: Property+prop_packet_fifo_small_meta_buffer_id =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 30 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 4)))+    (exposeClockResetEnable dropAbortedPackets)+    (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d2 Backpressure))++-- | test for id and proper dropping of aborted packets+prop_overFlowDrop_packetFifo_id :: Property+prop_overFlowDrop_packetFifo_id =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 10)))+    (exposeClockResetEnable dropAbortedPackets)+    (exposeClockResetEnable (packetFifoC @_ @1 @Int16 d10 d10 Drop))++-- | test for proper dropping when full+prop_overFlowDrop_packetFifo_drop :: Property+prop_overFlowDrop_packetFifo_drop =+  propWithModelSingleDomain+    @System+    defExpectOptions+    -- make sure the timeout is long as the packetFifo can be quiet for a while while dropping+    (liftA3 (\a b c -> a L.++ b L.++ c) genSmall genBig genSmall)+    (exposeClockResetEnable id)+    (exposeClockResetEnable (packetFifoC @_ @4 @Int16 d3 d5 Drop))+    (\xs ys -> diff ys L.isSubsequenceOf xs)+ where+  genSmall =+    genValidPacket defPacketOptions{poAbortMode = NoAbort} Gen.enumBounded (Range.linear 0 3)+  genBig =+    genValidPacket+      defPacketOptions{poAbortMode = NoAbort}+      Gen.enumBounded+      (Range.linear 9 9)++-- | test to check if there are no gaps inside of packets+prop_packetFifo_no_gaps :: Property+prop_packetFifo_no_gaps = property $ do+  let maxInputSize = 50+      ckt =+        exposeClockResetEnable+          (packetFifoC d12 d12 Backpressure)+          systemClockGen+          resetGen+          enableGen+      gen =+        genPackets+          1+          10+          (genValidPacket defPacketOptions{poAbortMode = NoAbort} Gen.enumBounded (Range.linear 0 10))++  packets :: [PacketStreamM2S 4 Int16] <- forAll gen++  let packetSize = 2 P.^ snatToInteger d12+      cfg = SimulationConfig 1 (2 * packetSize) False+      cktResult = simulateC ckt cfg (Just <$> packets)++  assert $ noGaps $ L.take (5 * maxInputSize) cktResult+ where+  noGaps :: [Maybe (PacketStreamM2S 4 Int16)] -> Bool+  noGaps (Just (PacketStreamM2S{_last = Nothing}) : Nothing : _) = False+  noGaps (_ : xs) = noGaps xs+  noGaps _ = True++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 500))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Packetizers.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.Packetizers (+  tests,+) where++import Clash.Hedgehog.Sized.Vector (genVec)+import Clash.Prelude++import Hedgehog (Property)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols+import Protocols.Df qualified as Df+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++{- |+Test @packetizerC@ with varying data width, number of bytes in the+header, input metadata, and output metadata.++We consider the input metadata to be @Vec metaInBytes (BitVector 8)@ to+avoid unnecessary conversions, because @packetizerC@ requires that the+input metadata is convertible to this type anyway.+-}+packetizerPropGen ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (metaInBytes :: Nat)+    (metaOut :: Type).+  (KnownNat metaInBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (TestType metaOut) =>+  SNat dataWidth ->+  SNat headerBytes ->+  (Vec metaInBytes (BitVector 8) -> metaOut) ->+  (Vec metaInBytes (BitVector 8) -> Vec headerBytes (BitVector 8)) ->+  Property+packetizerPropGen SNat SNat toMetaOut toHeader =+  idWithModelSingleDomain+    @System+    defExpectOptions+    ( genPackets+        1+        10+        (genValidPacket defPacketOptions (genVec Gen.enumBounded) (Range.linear 0 10))+    )+    (exposeClockResetEnable model)+    (exposeClockResetEnable ckt)+ where+  model = packetizerModel toMetaOut toHeader+  ckt ::+    (HiddenClockResetEnable System) =>+    Circuit+      (PacketStream System dataWidth (Vec metaInBytes (BitVector 8)))+      (PacketStream System dataWidth metaOut)+  ckt = packetizerC toMetaOut toHeader++{- |+Test @packetizeFromDfC@ with varying data width, number of bytes in the+header, input type, and output metadata.++We consider the input type to be @Vec aBytes (BitVector 8)@ to+avoid unnecessary conversions, because @packetizerC@ requires that the+input type is convertible to this type anyway.+-}+packetizeFromDfPropGen ::+  forall+    (dataWidth :: Nat)+    (headerBytes :: Nat)+    (aBytes :: Nat)+    (metaOut :: Type).+  (KnownNat aBytes) =>+  (1 <= dataWidth) =>+  (1 <= headerBytes) =>+  (TestType metaOut) =>+  SNat dataWidth ->+  SNat headerBytes ->+  (Vec aBytes (BitVector 8) -> metaOut) ->+  (Vec aBytes (BitVector 8) -> Vec headerBytes (BitVector 8)) ->+  Property+packetizeFromDfPropGen SNat SNat toMetaOut toHeader =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (Gen.list (Range.linear 1 10) (genVec Gen.enumBounded))+    (exposeClockResetEnable model)+    (exposeClockResetEnable ckt)+ where+  model = packetizeFromDfModel toMetaOut toHeader+  ckt ::+    (HiddenClockResetEnable System) =>+    Circuit+      (Df.Df System (Vec aBytes (BitVector 8)))+      (PacketStream System dataWidth metaOut)+  ckt = packetizeFromDfC toMetaOut toHeader++{- |+Do something interesting with the input metadata to derive the output+metadata for testing purposes. We just xor-reduce the input metadata.+-}+myToMetaOut :: Vec n (BitVector 8) -> BitVector 8+myToMetaOut = foldr xor 0++{- |+Do something interesting with the input metadata to derive the header+for testing purposes. We just xor every byte in the input metadata with+an arbitrary constant and add some bytes.+-}+myToHeader ::+  forall metaInBytes headerBytes.+  (2 + metaInBytes ~ headerBytes) =>+  Vec metaInBytes (BitVector 8) ->+  Vec headerBytes (BitVector 8)+myToHeader metaIn = map (`xor` 0xAB) metaIn ++ (0x01 :> 0x02 :> Nil)++-- | headerBytes % dataWidth ~ 0+prop_const_packetizer_d1_d14 :: Property+prop_const_packetizer_d1_d14 =+  packetizerPropGen d1 d14 (const ()) id++prop_xor_packetizer_d1_d14 :: Property+prop_xor_packetizer_d1_d14 =+  packetizerPropGen d1 d14 myToMetaOut myToHeader++-- | dataWidth < headerBytes+prop_const_packetizer_d3_d11 :: Property+prop_const_packetizer_d3_d11 =+  packetizerPropGen d3 d11 (const ()) id++prop_xor_packetizer_d3_d11 :: Property+prop_xor_packetizer_d3_d11 =+  packetizerPropGen d3 d11 myToMetaOut myToHeader++-- | dataWidth ~ header byte size+prop_const_packetizer_d7_d7 :: Property+prop_const_packetizer_d7_d7 =+  packetizerPropGen d7 d7 (const ()) id++prop_xor_packetizer_d7_d7 :: Property+prop_xor_packetizer_d7_d7 =+  packetizerPropGen d7 d7 myToMetaOut myToHeader++-- | dataWidth > header byte size+prop_const_packetizer_d5_d4 :: Property+prop_const_packetizer_d5_d4 =+  packetizerPropGen d5 d4 (const ()) id++prop_xor_packetizer_d5_d4 :: Property+prop_xor_packetizer_d5_d4 =+  packetizerPropGen d5 d4 myToMetaOut myToHeader++-- | headerBytes % dataWidth ~ 0+prop_const_packetizeFromDf_d1_d14 :: Property+prop_const_packetizeFromDf_d1_d14 =+  packetizeFromDfPropGen d1 d14 (const ()) id++prop_xor_packetizeFromDf_d1_d14 :: Property+prop_xor_packetizeFromDf_d1_d14 =+  packetizeFromDfPropGen d1 d14 myToMetaOut myToHeader++-- | dataWidth < headerBytes+prop_const_packetizeFromDf_d3_d11 :: Property+prop_const_packetizeFromDf_d3_d11 =+  packetizeFromDfPropGen d3 d11 (const ()) id++prop_xor_packetizeFromDf_d3_d11 :: Property+prop_xor_packetizeFromDf_d3_d11 =+  packetizeFromDfPropGen d3 d11 myToMetaOut myToHeader++-- | dataWidth ~ header byte size+prop_const_packetizeFromDf_d7_d7 :: Property+prop_const_packetizeFromDf_d7_d7 =+  packetizeFromDfPropGen d7 d7 (const ()) id++prop_xor_packetizeFromDf_d7_d7 :: Property+prop_xor_packetizeFromDf_d7_d7 =+  packetizeFromDfPropGen d7 d7 myToMetaOut myToHeader++-- | dataWidth > header byte size+prop_const_packetizeFromDf_d5_d4 :: Property+prop_const_packetizeFromDf_d5_d4 =+  packetizeFromDfPropGen d5 d4 (const ()) id++prop_xor_packetizeFromDf_d5_d4 :: Property+prop_xor_packetizeFromDf_d5_d4 =+  packetizeFromDfPropGen d5 d4 myToMetaOut myToHeader++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 1_000))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Padding.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.Padding (+  tests,+) where++import Clash.Prelude++import "extra" Data.List.Extra qualified as L++import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++-- | Pure model of `stripPaddingC`.+stripPaddingModel ::+  forall p.+  (KnownNat p) =>+  [PacketStreamM2S 1 (Unsigned p)] ->+  [PacketStreamM2S 1 (Unsigned p)]+stripPaddingModel packets = L.concatMap go (chunkByPacket packets)+ where+  go packet+    | packetBytes == expectedSize = packet+    | packetBytes > expectedSize =+        case padding of+          [] ->+            -- There are (packetBytes - expectedSize) bytes, so more than 0+            error "stripPaddingModel: absurd"+          (padding0 : _) ->+            x L.++ [padding0{_last = Just 0, _abort = any _abort padding}]+    | otherwise = a L.++ [b{_abort = True}]+   where+    (a, b) = case L.unsnoc packet of+      Nothing -> error "stripPaddingModel: list should not be empty."+      Just (xs, l) -> (xs, l)++    packetBytes = L.length packet - (if _last b == Just 0 then 1 else 0)+    expectedSize = fromIntegral (_meta b)++    (x, padding) = L.splitAt expectedSize packet++{- |+Test `stripPaddingC` with a given @dataWidth@ against a pure model.++We make sure to test integer overflow by making the data type which holds+the expected packet length extra small: @Unsigned 6@.+-}+stripPaddingProperty ::+  forall dataWidth.+  (1 <= dataWidth) =>+  SNat dataWidth ->+  Property+stripPaddingProperty SNat =+  idWithModelSingleDomain+    @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 20)))+    (exposeClockResetEnable (upConvert . stripPaddingModel @6 . downConvert))+    (exposeClockResetEnable (stripPaddingC @dataWidth id))++prop_strip_padding_d1 :: Property+prop_strip_padding_d1 = stripPaddingProperty d1++prop_strip_padding_d2 :: Property+prop_strip_padding_d2 = stripPaddingProperty d2++prop_strip_padding_d4 :: Property+prop_strip_padding_d4 = stripPaddingProperty d4++prop_strip_padding_d5 :: Property+prop_strip_padding_d5 = stripPaddingProperty d5++prop_strip_padding_d8 :: Property+prop_strip_padding_d8 = stripPaddingProperty d8++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 1_000))+      $(testGroupGenerator)
+ tests/Tests/Protocols/PacketStream/Routing.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Tests.Protocols.PacketStream.Routing (+  tests,+) where++import Clash.Prelude++import Hedgehog hiding (Parallel)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range++import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++import Protocols.Df qualified as Df+import Protocols.Experimental.Hedgehog+import Protocols.Experimental.PacketStream+import Protocols.PacketStream.Hedgehog++import Data.List qualified as L++{- |+Tests a packet arbiter for any data width and number of sources. In particular,+tests that packets from all sources are sent out unmodified in the same order+they were in in the source streams.+-}+makePropPacketArbiter ::+  forall sources dataWidth.+  (1 <= sources) =>+  (1 <= dataWidth) =>+  SNat sources ->+  SNat dataWidth ->+  Df.CollectMode ->+  Property+makePropPacketArbiter SNat SNat mode =+  propWithModelSingleDomain+    @System+    defExpectOptions+    genSources+    (exposeClockResetEnable L.concat)+    (exposeClockResetEnable (packetArbiterC mode))+    (\xs ys -> partitionPackets xs === partitionPackets ys)+ where+  (minPackets, maxPackets) = case mode of+    -- NoSkip mode needs the same amount of packets generated for each+    -- source. Otherwise, starvation happens and the test won't end.+    Df.NoSkip -> (5, 5)+    _ -> (1, 10)+  genSources = mapM setMeta (indicesI @sources)+  setMeta j = do+    pkts <-+      genPackets+        @dataWidth+        minPackets+        maxPackets+        (genValidPacket defPacketOptions (pure ()) (Range.linear 0 10))+    pure $ L.map (\pkt -> pkt{_meta = j}) pkts++  partitionPackets packets =+    L.sortOn getMeta+      $ L.groupBy (\a b -> _meta a == _meta b)+      <$> chunkByPacket packets++  getMeta ((pkt : _) : _) = _meta pkt+  getMeta _ = error "makePropPacketArbiter: empty partition"++{- |+Generic test function for the packet dispatcher, testing for all data widths,+dispatch functions, and some meta types.+-}+makePropPacketDispatcher ::+  forall sinks dataWidth meta.+  (KnownNat sinks) =>+  (1 <= sinks) =>+  (1 <= dataWidth) =>+  (TestType meta) =>+  (Bounded meta) =>+  (Enum meta) =>+  (BitPack meta) =>+  SNat dataWidth ->+  -- | Dispatch function+  Vec sinks (meta -> Bool) ->+  Property+makePropPacketDispatcher SNat fs =+  idWithModelSingleDomain @System+    defExpectOptions+    (genPackets 1 10 (genValidPacket defPacketOptions Gen.enumBounded (Range.linear 0 6)))+    (exposeClockResetEnable (model 0))+    (exposeClockResetEnable (packetDispatcherC fs))+ where+  model ::+    Index sinks ->+    [PacketStreamM2S dataWidth meta] ->+    Vec sinks [PacketStreamM2S dataWidth meta]+  model _ [] = pure []+  model i (y : ys)+    | (fs !! i) (_meta y) =+        let next = model 0 ys+         in replace i (y : (next !! i)) next+    | i < maxBound = model (i + 1) (y : ys)+    | otherwise = model 0 ys++-- | Tests the @NoSkip@ packet arbiter with one source; essentially an id test.+prop_packet_arbiter_noskip_id :: Property+prop_packet_arbiter_noskip_id = makePropPacketArbiter d1 d2 Df.NoSkip++-- | Tests the @Skip@ packet arbiter with one source; essentially an id test.+prop_packet_arbiter_skip_id :: Property+prop_packet_arbiter_skip_id = makePropPacketArbiter d1 d2 Df.Skip++-- | Tests the @Parallel@ packet arbiter with one source; essentially an id test.+prop_packet_arbiter_parallel_id :: Property+prop_packet_arbiter_parallel_id = makePropPacketArbiter d1 d2 Df.Parallel++-- | Tests the @NoSkip@ arbiter with five sources.+prop_packet_arbiter_noskip :: Property+prop_packet_arbiter_noskip = makePropPacketArbiter d5 d2 Df.NoSkip++-- | Tests the @Skip@ arbiter with five sources.+prop_packet_arbiter_skip :: Property+prop_packet_arbiter_skip = makePropPacketArbiter d5 d2 Df.Skip++-- | Tests the @Parallel@ arbiter with five sources.+prop_packet_arbiter_parallel :: Property+prop_packet_arbiter_parallel = makePropPacketArbiter d5 d2 Df.Parallel++{- |+Tests that the packet dispatcher works correctly with one sink that accepts+all packets; essentially an id test.+-}+prop_packet_dispatcher_id :: Property+prop_packet_dispatcher_id =+  makePropPacketDispatcher+    d4+    ((const True :: Int -> Bool) :> Nil)++{- |+Tests the packet dispatcher for a data width of four bytes and three+overlapping but incomplete dispatch functions, effectively testing whether+the circuit sends input to the first allowed output channel and drops input+if there are none.+-}+prop_packet_dispatcher :: Property+prop_packet_dispatcher = makePropPacketDispatcher d4 fs+ where+  fs :: Vec 3 (Index 4 -> Bool)+  fs =+    (>= 3)+      :> (>= 2)+      :> (>= 1)+      :> Nil++tests :: TestTree+tests =+  localOption (mkTimeout 20_000_000 {- 20 seconds -})+    $ localOption+      (HedgehogTestLimit (Just 500))+      $(testGroupGenerator)
+ tests/Tests/Protocols/Plugin.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BlockArguments #-}+-- This /must/ be enabled in order for the plugin to do its work. You might+-- want to add this to 'ghc-options' in your cabal file.+{-# OPTIONS_GHC -fplugin=Protocols.Plugin #-}++-- For debugging purposes:+-- {-# OPTIONS_GHC -fplugin-opt=Protocols.Plugin:debug #-}++module Tests.Protocols.Plugin where++import Clash.Prelude qualified as C++import Protocols+import Protocols.Df qualified as Df++{- | Simply swap two streams. Note that the 'circuit' is a magic keyword the+'Protocols.Plugin' looks for in order to do its work.+-}+swapC :: Circuit (a, b) (b, a)+swapC = circuit $ \(a, b) -> (b, a)++-- | Put 'registerFwd' on both 'Df' input streams.+registerBoth ::+  (C.NFDataX a, C.NFDataX b, C.HiddenClockResetEnable dom) =>+  Circuit (Df dom a, Df dom b) (Df dom a, Df dom b)+registerBoth = circuit $ \(a, b) -> do+  -- We route /a/ to into a 'registerFwd'. Note that this takes care of routing+  -- both the /forward/ and /backward/ parts, even though it seems that it only+  -- handles the /forward/ part.+  a' <- Df.registerFwd -< a++  -- Similarly, we route /b/ to a register too+  b' <- Df.registerFwd -< b++  -- The final line of a circuit-do block needs to be an "assignment". Because+  -- we want to simply bundle two streams, we use 'idC' as our circuit of choice.+  idC -< (a', b')++-- | Fanout a stream and interact with some of the result streams.+fanOutThenRegisterMiddle ::+  (C.HiddenClockResetEnable dom) =>+  Circuit (Df dom Int) (Df dom Int, Df dom Int, Df dom Int)+fanOutThenRegisterMiddle = circuit $ \a -> do+  -- List notation can be used to specify a Vec. In this instance, fanout will+  -- infer that it needs to produce a 'Vec 3 Int'.+  [x, y, z] <- Df.fanout -< a++  -- Like in 'registerBoth', we can put a register on the forward part of 'y'.+  y' <- Df.registerFwd -< y++  -- We can use any Haskell notation between the arrows, as long as it results+  -- in a properly typed circuit. For example, we could map the function (+5)+  -- over the stream 'z'.+  z' <- Df.map (+ 5) -< z++  idC -< (x, y', z')++-- | Forget the /left/ part of a tuple of 'Df' streams+forgetLeft :: Circuit (Df dom a, Df dom b) (Df dom b)+forgetLeft = circuit $ \(a, b) -> do+  -- We can use an underscore to indicate that we'd like to throw away any+  -- data from stream 'a'. For 'Df' like protocols, a constant acknowledgement+  -- will be driven on the /backwards/ part of the protocol.+  _a <- idC -< a++  idC -< b++-- | Forget the /left/ part of a tuple of 'Df' streams.+forgetLeft2 :: Circuit (Df dom a, Df dom b) (Df dom b)+forgetLeft2 =+  -- If we know right from the start that'd we'd like to ignore an incoming+  -- stream, we can simply mark it with an underscore.+  circuit $ \(_a, b) -> b++-- | Convert a 2-vector into a 2-tuple+unvec :: Circuit (C.Vec 2 a) (a, a)+unvec =+  -- We don't always need /do/ notation+  circuit \[x, y] -> (x, y)
+ tests/Tests/Protocols/Vec.hs view
@@ -0,0 +1,189 @@+module Tests.Protocols.Vec where++-- base+import Prelude++-- clash-prelude+import Clash.Prelude (System)+import Clash.Prelude qualified as C++-- hedgehog+import Hedgehog++-- tasty+import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)++-- clash-protocols (me!)+import Protocols+import Protocols.Vec qualified as Vec++import Clash.Hedgehog.Sized.Vector (genVec)+import Protocols.Experimental.Hedgehog++-- tests+import Tests.Protocols.Df (genData, genSmallInt, genVecData)++prop_append :: Property+prop_append =+  idWithModel+    @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen =+    (,)+      <$> genVecData genSmallInt+      <*> genVecData genSmallInt+  dut = Vec.append+  model = uncurry (C.++)++prop_append3 :: Property+prop_append3 =+  idWithModel+    @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int), C.Vec 4 (Df System Int))+    @(C.Vec 9 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen :: Gen (C.Vec 2 [Int], C.Vec 3 [Int], C.Vec 4 [Int])+  gen =+    (,,)+      <$> genVecData genSmallInt+      <*> genVecData genSmallInt+      <*> genVecData genSmallInt+  dut = Vec.append3+  model (a, b, c) = (a C.++ b) C.++ c++prop_split :: Property+prop_split =+  idWithModel+    @(C.Vec 5 (Df System Int))+    @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVecData genSmallInt+  dut = Vec.split+  model = C.splitAtI++prop_split3 :: Property+prop_split3 =+  idWithModel+    @(C.Vec 9 (Df System Int))+    @(C.Vec 2 (Df System Int), C.Vec 3 (Df System Int), C.Vec 4 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVecData genSmallInt+  dut = Vec.split3+  model v = (v0, v1, v2)+   where+    (v0, C.splitAtI -> (v1, v2)) = C.splitAtI v++prop_zip :: Property+prop_zip =+  idWithModel+    @(C.Vec 2 (Df System Int), C.Vec 2 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen =+    (,)+      <$> genVecData genSmallInt+      <*> genVecData genSmallInt+  dut = Vec.zip+  model (a, b) = C.zip a b++prop_zip3 :: Property+prop_zip3 =+  idWithModel+    @(C.Vec 2 (Df System Int), C.Vec 2 (Df System Int), C.Vec 2 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen =+    (,,)+      <$> genVecData genSmallInt+      <*> genVecData genSmallInt+      <*> genVecData genSmallInt+  dut = Vec.zip3+  model (a, b, c) = C.zip3 a b c++prop_unzip :: Property+prop_unzip =+  idWithModel+    @(C.Vec 2 (Df System Int, Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVec ((,) <$> genData genSmallInt <*> genData genSmallInt)+  dut = Vec.unzip+  model = C.unzip++prop_unzip3 :: Property+prop_unzip3 =+  idWithModel+    @(C.Vec 2 (Df System Int, Df System Int, Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVec ((,,) <$> genData genSmallInt <*> genData genSmallInt <*> genData genSmallInt)+  dut = Vec.unzip3+  model = C.unzip3++prop_concat :: Property+prop_concat =+  idWithModel+    @(C.Vec 2 (C.Vec 3 (Df System Int)))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVec (genVecData genSmallInt)+  dut = Vec.concat+  model = C.concat++prop_unconcat :: Property+prop_unconcat =+  idWithModel+    @(C.Vec 6 (Df System Int))+    defExpectOptions+    gen+    model+    dut+ where+  gen = genVecData genSmallInt+  dut = Vec.unconcat C.d2+  model = C.unconcat C.d2++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 20_000_000 {- 20 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)++main :: IO ()+main = defaultMain tests
+ tests/Tests/Protocols/Wishbone.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE RecordWildCards #-}++module Tests.Protocols.Wishbone where++import Clash.Prelude as C hiding (not, (&&))+import Control.DeepSeq (force)+import Control.Exception (SomeException, evaluate, try)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Either (isLeft)+import Data.List qualified as L+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Protocols+import Protocols.Experimental.Hedgehog (defExpectOptions, eoSampleMax)+import Protocols.Experimental.Wishbone+import Protocols.Experimental.Wishbone.Standard+import Protocols.Experimental.Wishbone.Standard.Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit))+import Test.Tasty.Hedgehog.Extra (testProperty)+import Test.Tasty.TH (testGroupGenerator)+import Prelude hiding (undefined)++smallInt :: Range Int+smallInt = Range.linear 0 10++genSmallInt :: Gen Int+genSmallInt = Gen.integral smallInt++genData :: Gen a -> Gen [a]+genData = Gen.list (Range.linear 0 300)++genWbTransferPair ::+  (KnownNat addressBits, KnownNat dataBytes) =>+  Gen (WishboneMasterRequest addressBits dataBytes, Int)+genWbTransferPair =+  liftA2+    (,)+    (genWishboneTransfer Range.constantBounded)+    genSmallInt++--+-- 'addrReadId' circuit+--++addrReadIdWb ::+  forall dom addressBits dataBytes.+  (KnownNat addressBits, KnownNat dataBytes) =>+  Circuit (Wishbone dom 'Standard addressBits dataBytes) ()+addrReadIdWb = Circuit go+ where+  go (m2s, ()) = (reply <$> m2s, ())++  reply WishboneM2S{..}+    | busCycle && strobe && writeEnable =+        emptyWishboneS2M{acknowledge = True}+    | busCycle && strobe =+        (emptyWishboneS2M @dataBytes)+          { acknowledge = True+          , readData = resize addr+          }+    | otherwise = emptyWishboneS2M++addrReadIdWbModel ::+  (KnownNat addressBits, KnownNat dataBytes) =>+  WishboneMasterRequest addressBits dataBytes ->+  WishboneS2M dataBytes ->+  -- | pure state+  () ->+  Either String ()+addrReadIdWbModel (Read addr _) s@WishboneS2M{..} ()+  | acknowledge && hasX readData == Right (resize addr) = Right ()+  | otherwise =+      Left $ "Read should have been acknowledged with address as DAT " <> show s+addrReadIdWbModel Write{} s@WishboneS2M{..} ()+  | acknowledge && hasUndefined readData = Right ()+  | otherwise =+      Left $ "Write should have been acknowledged with no DAT " <> show s++prop_addrReadIdWb_model :: Property+prop_addrReadIdWb_model =+  property $+    withClockResetEnable clockGen resetGen enableGen $+      wishbonePropWithModel @System @10 @4+        defExpectOptions{eoSampleMax = 10_000}+        addrReadIdWbModel+        addrReadIdWb+        (genData $ genWishboneTransfer Range.constantBounded)+        ()++--+-- memory element circuit+--++memoryWbModel ::+  ( KnownNat addressBits+  , KnownNat dataBytes+  ) =>+  WishboneMasterRequest addressBits dataBytes ->+  WishboneS2M dataBytes ->+  [(BitVector addressBits, BitVector (dataBytes * 8))] ->+  Either String [(BitVector addressBits, BitVector (dataBytes * 8))]+memoryWbModel (Read addr sel) s st+  | sel /= maxBound && err s = Right st+  | sel /= maxBound && not (err s) =+      Left "Read with non maxBound SEL should cause ERR response"+  | otherwise = case lookup addr st of+      Just x | readData s == x && acknowledge s -> Right st+      Just x+        | otherwise ->+            Left $+              "Read from a known address did not yield the same value "+                <> showX x+                <> " : "+                <> show s+      Nothing | acknowledge s && hasX (readData s) == Right def -> Right st+      Nothing+        | otherwise ->+            Left $+              "Read from unknown address did no ACK with undefined result : "+                <> show s+memoryWbModel (Write addr sel a) s st+  | sel /= maxBound && err s = Right st+  | sel /= maxBound && not (err s) =+      Left "Write with non maxBound SEL should cause ERR response"+  | acknowledge s = Right ((addr, a) : st)+  | otherwise = Left $ "Write should be acked : " <> show s++prop_memoryWb_model :: Property+prop_memoryWb_model =+  property $+    withClockResetEnable clockGen resetGen enableGen $+      wishbonePropWithModel @System @8 @4+        defExpectOptions{eoSampleMax = 10_000}+        memoryWbModel+        (memoryWb (blockRam (C.replicate d256 0)))+        (genData (genWishboneTransfer Range.constantBounded))+        [] -- initial state++--+-- Helpers+--++(|>>) :: Circuit () b -> Circuit b () -> (Fwd b, Bwd b)+Circuit aFn |>> Circuit bFn = (s2rAb, r2sBc)+ where+  ~((), s2rAb) = aFn ((), r2sBc)+  ~(r2sBc, ()) = bFn (s2rAb, ())++evaluateUnitCircuit ::+  (KnownDomain dom, KnownNat dataBytes, KnownNat addressBits) =>+  Int ->+  Circuit () (Wishbone dom 'Standard addressBits dataBytes) ->+  Circuit (Wishbone dom 'Standard addressBits dataBytes) () ->+  Int+evaluateUnitCircuit n a b =+  let (bundle -> signals) = a |>> b+   in L.length $ sampleN n signals++--+-- validatorCircuit+--++prop_addrReadId_validator :: Property+prop_addrReadId_validator = property $ do+  reqs <- forAll $ genData (genWbTransferPair @8 @4)++  let+    circuitSignalsN =+      withClockResetEnable @System clockGen resetGen enableGen $+        let+          driver = driveStandard defExpectOptions{eoSampleMax = 10_000} reqs+          addrRead = addrReadIdWb+         in+          evaluateUnitCircuit+            sampleNumber+            driver+            (validatorCircuit |> addrRead)++  -- force evalution of sampling somehow+  assert (circuitSignalsN == sampleNumber)++prop_memoryWb_validator :: Property+prop_memoryWb_validator = property $ do+  reqs <- forAll $ genData (genWbTransferPair @8 @4)++  let+    circuitSignalsN =+      withClockResetEnable @System clockGen resetGen enableGen $+        let+          driver = driveStandard defExpectOptions{eoSampleMax = 10_000} reqs+          memory = memoryWb (blockRam (C.replicate d256 0))+         in+          evaluateUnitCircuit+            sampleNumber+            driver+            (validatorCircuit |> memory)++  -- force evalution of sampling somehow+  assert (circuitSignalsN == sampleNumber)++--+-- validatorCircuitLenient+--++prop_addrReadId_validator_lenient :: Property+prop_addrReadId_validator_lenient = property $ do+  reqs <- forAll $ genData (genWbTransferPair @8 @4)++  let+    circuitSignalsN =+      withClockResetEnable @System clockGen resetGen enableGen $+        let+          driver = driveStandard defExpectOptions{eoSampleMax = 10_000} reqs+          addrRead = addrReadIdWb+         in+          evaluateUnitCircuit+            sampleNumber+            driver+            (validatorCircuitLenient |> addrRead)++  -- force evalution of sampling somehow+  assert (circuitSignalsN == sampleNumber)++prop_memoryWb_validator_lenient :: Property+prop_memoryWb_validator_lenient = property $ do+  reqs <- forAll $ genData (genWbTransferPair @8 @4)++  let+    circuitSignalsN =+      withClockResetEnable @System clockGen resetGen enableGen $+        let+          driver = driveStandard defExpectOptions{eoSampleMax = 10_000} reqs+          memory = memoryWb (blockRam (C.replicate d256 0))+         in+          evaluateUnitCircuit+            sampleNumber+            driver+            (validatorCircuitLenient |> memory)++  -- force evalution of sampling somehow+  assert (circuitSignalsN == sampleNumber)++prop_specViolation_lenient :: Property+prop_specViolation_lenient = property $ do+  -- need AT LEAST one transaction so that multiple termination signals can be emitted+  reqs <- forAll $ Gen.list (Range.linear 1 500) (genWbTransferPair @8)++  let+    circuitSignalsN =+      withClockResetEnable @System clockGen resetGen enableGen $+        let+          driver = driveStandard @System @8 @1 defExpectOptions{eoSampleMax = 10_000} reqs+          invalid = invalidCircuit+         in+          evaluateUnitCircuit+            sampleNumber+            driver+            (validatorCircuitLenient |> invalid)++  -- an ErrorCall is expected, but really *any* exception is expected+  -- from the validator circuit+  res <- liftIO $ try @SomeException (evaluate (force circuitSignalsN))++  assert $ isLeft res+ where+  -- a circuit that terminates a cycle with more than one termination signal+  invalidCircuit :: Circuit (Wishbone dom 'Standard 8 1) ()+  invalidCircuit = Circuit go+   where+    go (m2s, ()) = (reply <$> m2s, ())++    reply WishboneM2S{..}+      | busCycle && strobe && writeEnable =+          emptyWishboneS2M{acknowledge = True, err = True}+      | busCycle && strobe =+          (emptyWishboneS2M @1)+            { acknowledge = True+            , err = True+            , readData = addr+            }+      | otherwise = emptyWishboneS2M++sampleNumber :: Int+sampleNumber = 1000++tests :: TestTree+tests =+  -- TODO: Move timeout option to hedgehog for better error messages.+  -- TODO: Does not seem to work for combinatorial loops like @let x = x in x@??+  localOption (mkTimeout 60_000_000 {- 60 seconds -}) $+    localOption+      (HedgehogTestLimit (Just 1000))+      $(testGroupGenerator)
+ tests/Util.hs view
@@ -0,0 +1,40 @@+module Util where++-- base+import Unsafe.Coerce (unsafeCoerce)++-- unordered-containers++import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap++-- hashable+import Data.Hashable (Hashable)++-- clash-prelude++import Clash.Prelude (type (<=))+import Clash.Prelude qualified as C++-- extra+import "extra" Data.List.Extra (transpose)+import "extra" Data.List.Extra qualified as Extra++-- hedgehog+import Hedgehog qualified as H++chunksOf :: forall n. (C.KnownNat n) => [Int] -> C.Vec n [Int]+chunksOf xs = vecFromList (transpose (Extra.chunksOf (C.natToNum @n) xs))++vecFromList :: forall n a. (C.KnownNat n, Monoid a) => [a] -> C.Vec n a+vecFromList as = C.takeI (unsafeCoerce (as <> repeat mempty))++genVec :: (C.KnownNat n, 1 <= n) => H.Gen a -> H.Gen (C.Vec n a)+genVec gen = sequence (C.repeat gen)++-- | Count the number of times an element occurs in a list+tally :: (Hashable a, Eq a) => [a] -> HashMap a Int+tally = tallyOn id (const 1)++tallyOn :: (Hashable b, Eq b) => (a -> b) -> (a -> Int) -> [a] -> HashMap b Int+tallyOn f g xs = HashMap.fromListWith (+) (zip (map f xs) (map g xs))
+ tests/doctests.hs view
@@ -0,0 +1,30 @@+module Main where++import Build_doctests (flags, module_sources, pkgs)+import System.Environment (lookupEnv)+import System.Process+import Test.DocTest (doctest)+import Prelude++getGlobalPackageDb :: IO String+getGlobalPackageDb = readProcess "ghc" ["--print-global-package-db"] ""++main :: IO ()+main = do+  inNixShell <- lookupEnv "IN_NIX_SHELL"+  extraFlags <-+    case inNixShell of+      Nothing -> pure []+      Just _ -> pure . ("-package-db=" ++) <$> getGlobalPackageDb++  let+    pluginFlags =+      [ "-fplugin"+      , "GHC.TypeLits.KnownNat.Solver"+      , "-fplugin"+      , "GHC.TypeLits.Normalise"+      , "-fplugin"+      , "GHC.TypeLits.Extra.Solver"+      ]++  doctest (flags ++ extraFlags ++ pkgs ++ pluginFlags ++ module_sources)
+ tests/unittests.hs view
@@ -0,0 +1,32 @@+module Main where++import Control.Concurrent (setNumCapabilities)+import System.Environment (lookupEnv, setEnv)+import Test.Tasty+import Text.Read (readMaybe)+import Prelude++import Tests.Haxioms qualified+import Tests.Protocols qualified++main :: IO ()+main = do+  -- Hedgehog already tets in parallel+  setEnv "TASTY_NUM_THREADS" "2"++  -- Detect "THREADS" environment variable on CI+  nThreads <- (readMaybe =<<) <$> lookupEnv "THREADS"+  case nThreads of+    Nothing -> pure ()+    Just n -> do+      setNumCapabilities n++  defaultMain tests++tests :: TestTree+tests =+  testGroup+    "Tests"+    [ Tests.Haxioms.tests+    , Tests.Protocols.tests+    ]