diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for `clash-protocols` + +## 0.1 -- 28-04-2026 + +* First release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +import Distribution.Extra.Doctest (defaultMainWithDoctests) +import Prelude + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/clash-protocols.cabal b/clash-protocols.cabal new file mode 100644 --- /dev/null +++ b/clash-protocols.cabal @@ -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. +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, diff --git a/src/Clash/Sized/Vector/Extra.hs b/src/Clash/Sized/Vector/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Sized/Vector/Extra.hs @@ -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 diff --git a/src/Data/Constraint/Nat/Extra.hs b/src/Data/Constraint/Nat/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Constraint/Nat/Extra.hs @@ -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)) diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Extra.hs @@ -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 _ _ _ = [] diff --git a/src/Data/Maybe/Extra.hs b/src/Data/Maybe/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Extra.hs @@ -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 diff --git a/src/Protocols.hs b/src/Protocols.hs new file mode 100644 --- /dev/null +++ b/src/Protocols.hs @@ -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 . +-} +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 diff --git a/src/Protocols/Df.hs b/src/Protocols/Df.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Df.hs @@ -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 diff --git a/src/Protocols/DfConv.hs b/src/Protocols/DfConv.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/DfConv.hs @@ -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 diff --git a/src/Protocols/Experimental/Avalon/MemMap.hs b/src/Protocols/Experimental/Avalon/MemMap.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Avalon/MemMap.hs @@ -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 diff --git a/src/Protocols/Experimental/Avalon/Stream.hs b/src/Protocols/Experimental/Avalon/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Avalon/Stream.hs @@ -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 diff --git a/src/Protocols/Experimental/Axi4/Common.hs b/src/Protocols/Experimental/Axi4/Common.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/Common.hs @@ -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) diff --git a/src/Protocols/Experimental/Axi4/ReadAddress.hs b/src/Protocols/Experimental/Axi4/ReadAddress.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/ReadAddress.hs @@ -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 diff --git a/src/Protocols/Experimental/Axi4/ReadData.hs b/src/Protocols/Experimental/Axi4/ReadData.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/ReadData.hs @@ -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 diff --git a/src/Protocols/Experimental/Axi4/Stream.hs b/src/Protocols/Experimental/Axi4/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/Stream.hs @@ -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 diff --git a/src/Protocols/Experimental/Axi4/WriteAddress.hs b/src/Protocols/Experimental/Axi4/WriteAddress.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/WriteAddress.hs @@ -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 diff --git a/src/Protocols/Experimental/Axi4/WriteData.hs b/src/Protocols/Experimental/Axi4/WriteData.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/WriteData.hs @@ -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} diff --git a/src/Protocols/Experimental/Axi4/WriteResponse.hs b/src/Protocols/Experimental/Axi4/WriteResponse.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Axi4/WriteResponse.hs @@ -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 diff --git a/src/Protocols/Experimental/Df.hs b/src/Protocols/Experimental/Df.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Df.hs @@ -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) diff --git a/src/Protocols/Experimental/DfConv.hs b/src/Protocols/Experimental/DfConv.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/DfConv.hs @@ -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 + , () + ) diff --git a/src/Protocols/Experimental/Hedgehog.hs b/src/Protocols/Experimental/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Hedgehog.hs @@ -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 diff --git a/src/Protocols/Experimental/Hedgehog/Internal.hs b/src/Protocols/Experimental/Hedgehog/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Hedgehog/Internal.hs @@ -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 diff --git a/src/Protocols/Experimental/Hedgehog/Types.hs b/src/Protocols/Experimental/Hedgehog/Types.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Hedgehog/Types.hs @@ -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) diff --git a/src/Protocols/Experimental/PacketStream.hs b/src/Protocols/Experimental/PacketStream.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/PacketStream.hs @@ -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 diff --git a/src/Protocols/Experimental/Simulate.hs b/src/Protocols/Experimental/Simulate.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Simulate.hs @@ -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) diff --git a/src/Protocols/Experimental/Simulate/Types.hs b/src/Protocols/Experimental/Simulate/Types.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Simulate/Types.hs @@ -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 diff --git a/src/Protocols/Experimental/Wishbone.hs b/src/Protocols/Experimental/Wishbone.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Wishbone.hs @@ -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 diff --git a/src/Protocols/Experimental/Wishbone/Standard.hs b/src/Protocols/Experimental/Wishbone/Standard.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Wishbone/Standard.hs @@ -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) diff --git a/src/Protocols/Experimental/Wishbone/Standard/Hedgehog.hs b/src/Protocols/Experimental/Wishbone/Standard/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Experimental/Wishbone/Standard/Hedgehog.hs @@ -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 diff --git a/src/Protocols/Idle.hs b/src/Protocols/Idle.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Idle.hs @@ -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 diff --git a/src/Protocols/Internal.hs b/src/Protocols/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Internal.hs @@ -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)))) diff --git a/src/Protocols/Internal/TH.hs b/src/Protocols/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Internal/TH.hs @@ -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] diff --git a/src/Protocols/Internal/Types.hs b/src/Protocols/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Internal/Types.hs @@ -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) diff --git a/src/Protocols/PacketStream.hs b/src/Protocols/PacketStream.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream.hs @@ -0,0 +1,50 @@ +{- | +Copyright : (C) 2024, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +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 diff --git a/src/Protocols/PacketStream/AsyncFifo.hs b/src/Protocols/PacketStream/AsyncFifo.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/AsyncFifo.hs @@ -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. + +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 diff --git a/src/Protocols/PacketStream/Base.hs b/src/Protocols/PacketStream/Base.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Base.hs @@ -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. + +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) diff --git a/src/Protocols/PacketStream/Converters.hs b/src/Protocols/PacketStream/Converters.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Converters.hs @@ -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. + +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 + } diff --git a/src/Protocols/PacketStream/Depacketizers.hs b/src/Protocols/PacketStream/Depacketizers.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Depacketizers.hs @@ -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. + +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 diff --git a/src/Protocols/PacketStream/Hedgehog.hs b/src/Protocols/PacketStream/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Hedgehog.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{- | +Copyright : (C) 2024, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +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") + ) + } diff --git a/src/Protocols/PacketStream/PacketFifo.hs b/src/Protocols/PacketStream/PacketFifo.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/PacketFifo.hs @@ -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. + +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) diff --git a/src/Protocols/PacketStream/Packetizers.hs b/src/Protocols/PacketStream/Packetizers.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Packetizers.hs @@ -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. + +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) diff --git a/src/Protocols/PacketStream/Padding.hs b/src/Protocols/PacketStream/Padding.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Padding.hs @@ -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. + +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 + } diff --git a/src/Protocols/PacketStream/Routing.hs b/src/Protocols/PacketStream/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/PacketStream/Routing.hs @@ -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. + +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 diff --git a/src/Protocols/ToConst.hs b/src/Protocols/ToConst.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/ToConst.hs @@ -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 ((), ())) diff --git a/src/Protocols/Vec.hs b/src/Protocols/Vec.hs new file mode 100644 --- /dev/null +++ b/src/Protocols/Vec.hs @@ -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 diff --git a/src/Test/Tasty/Hedgehog/Extra.hs b/src/Test/Tasty/Hedgehog/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Hedgehog/Extra.hs @@ -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 diff --git a/tests/Tests/Haxioms.hs b/tests/Tests/Haxioms.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Haxioms.hs @@ -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) diff --git a/tests/Tests/Protocols.hs b/tests/Tests/Protocols.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols.hs @@ -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 diff --git a/tests/Tests/Protocols/Avalon.hs b/tests/Tests/Protocols/Avalon.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Avalon.hs @@ -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 diff --git a/tests/Tests/Protocols/Axi4.hs b/tests/Tests/Protocols/Axi4.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Axi4.hs @@ -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 diff --git a/tests/Tests/Protocols/Df.hs b/tests/Tests/Protocols/Df.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Df.hs @@ -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 diff --git a/tests/Tests/Protocols/DfConv.hs b/tests/Tests/Protocols/DfConv.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/DfConv.hs @@ -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 diff --git a/tests/Tests/Protocols/PacketStream.hs b/tests/Tests/Protocols/PacketStream.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream.hs @@ -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 + ] diff --git a/tests/Tests/Protocols/PacketStream/AsyncFifo.hs b/tests/Tests/Protocols/PacketStream/AsyncFifo.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/AsyncFifo.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Base.hs b/tests/Tests/Protocols/PacketStream/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Base.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Converters.hs b/tests/Tests/Protocols/PacketStream/Converters.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Converters.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Depacketizers.hs b/tests/Tests/Protocols/PacketStream/Depacketizers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Depacketizers.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/PacketFifo.hs b/tests/Tests/Protocols/PacketStream/PacketFifo.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/PacketFifo.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Packetizers.hs b/tests/Tests/Protocols/PacketStream/Packetizers.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Packetizers.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Padding.hs b/tests/Tests/Protocols/PacketStream/Padding.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Padding.hs @@ -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) diff --git a/tests/Tests/Protocols/PacketStream/Routing.hs b/tests/Tests/Protocols/PacketStream/Routing.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/PacketStream/Routing.hs @@ -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) diff --git a/tests/Tests/Protocols/Plugin.hs b/tests/Tests/Protocols/Plugin.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Plugin.hs @@ -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) diff --git a/tests/Tests/Protocols/Vec.hs b/tests/Tests/Protocols/Vec.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Vec.hs @@ -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 diff --git a/tests/Tests/Protocols/Wishbone.hs b/tests/Tests/Protocols/Wishbone.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Protocols/Wishbone.hs @@ -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) diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -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)) diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -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) diff --git a/tests/unittests.hs b/tests/unittests.hs new file mode 100644 --- /dev/null +++ b/tests/unittests.hs @@ -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 + ]