From 1ef95dc925e69a3366d3ca761f68d25995c955f3 Mon Sep 17 00:00:00 2001 From: Lucas Bollen Date: Thu, 26 Sep 2024 10:30:18 +0200 Subject: [PATCH 1/5] Move `BackPressure`, `Simulate`, `Drivable` and `Test` To prevent cyclic dependencies when implementing TH functions that generate tuple instances for these typeclasses. --- clash-protocols/clash-protocols.cabal | 5 +- .../src/Protocols/Avalon/Stream.hs | 2 +- clash-protocols/src/Protocols/Axi4/Stream.hs | 2 +- clash-protocols/src/Protocols/Hedgehog.hs | 3 + .../src/Protocols/Hedgehog/Internal.hs | 66 +------ .../src/Protocols/Hedgehog/Types.hs | 79 ++++++++ clash-protocols/src/Protocols/Internal.hs | 162 ----------------- .../src/Protocols/Internal/Types.hs | 170 ++++++++++++++++++ 8 files changed, 260 insertions(+), 229 deletions(-) create mode 100644 clash-protocols/src/Protocols/Hedgehog/Types.hs diff --git a/clash-protocols/clash-protocols.cabal b/clash-protocols/clash-protocols.cabal index 8e9b3020..98d6cbb5 100644 --- a/clash-protocols/clash-protocols.cabal +++ b/clash-protocols/clash-protocols.cabal @@ -145,11 +145,11 @@ library Protocols.Axi4.WriteData Protocols.Axi4.WriteResponse Protocols.Df - Protocols.Internal Protocols.DfConv Protocols.Hedgehog Protocols.Hedgehog.Internal Protocols.Idle + Protocols.Internal Protocols.Internal.TH Protocols.Wishbone Protocols.Wishbone.Standard @@ -165,8 +165,9 @@ library autogen-modules: Paths_clash_protocols other-modules: - Protocols.Internal.Types Paths_clash_protocols + Protocols.Hedgehog.Types + Protocols.Internal.Types default-language: Haskell2010 diff --git a/clash-protocols/src/Protocols/Avalon/Stream.hs b/clash-protocols/src/Protocols/Avalon/Stream.hs index af5167d0..e7b69a74 100644 --- a/clash-protocols/src/Protocols/Avalon/Stream.hs +++ b/clash-protocols/src/Protocols/Avalon/Stream.hs @@ -29,7 +29,7 @@ import qualified Clash.Prelude as C import qualified Protocols.Df as Df import qualified Protocols.DfConv as DfConv -import Protocols.Hedgehog.Internal +import Protocols.Hedgehog import Protocols.Idle import Protocols.Internal diff --git a/clash-protocols/src/Protocols/Axi4/Stream.hs b/clash-protocols/src/Protocols/Axi4/Stream.hs index 818c1f23..e8214d15 100644 --- a/clash-protocols/src/Protocols/Axi4/Stream.hs +++ b/clash-protocols/src/Protocols/Axi4/Stream.hs @@ -26,7 +26,7 @@ import qualified Clash.Prelude as C import qualified Protocols.Df as Df import qualified Protocols.DfConv as DfConv -import Protocols.Hedgehog.Internal +import Protocols.Hedgehog import Protocols.Idle import Protocols.Internal diff --git a/clash-protocols/src/Protocols/Hedgehog.hs b/clash-protocols/src/Protocols/Hedgehog.hs index b6188ba2..af2296f2 100644 --- a/clash-protocols/src/Protocols/Hedgehog.hs +++ b/clash-protocols/src/Protocols/Hedgehog.hs @@ -55,6 +55,9 @@ import qualified Hedgehog.Range as Range -- lifted-async import Control.Concurrent.Async.Lifted (race) +-- me +import Protocols.Hedgehog.Types + -- | Whether to stall or not. Used in 'idWithModel'. data StallMode = NoStall | Stall deriving (Show, Enum, Bounded) diff --git a/clash-protocols/src/Protocols/Hedgehog/Internal.hs b/clash-protocols/src/Protocols/Hedgehog/Internal.hs index 176888f1..37ef7409 100644 --- a/clash-protocols/src/Protocols/Hedgehog/Internal.hs +++ b/clash-protocols/src/Protocols/Hedgehog/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} {- | @@ -20,37 +21,15 @@ import Protocols import qualified Protocols.Df as Df -- clash-prelude - import Clash.Prelude (type (*), type (+), type (<=)) import qualified Clash.Prelude as C --- deepseq -import Control.DeepSeq - -- hedgehog import qualified Hedgehog as H import qualified Hedgehog.Internal.Property as H --- | Options for 'expectN' function. See individual fields for more information. -data ExpectOptions = ExpectOptions - { eoStopAfterEmpty :: Int - -- ^ Stop sampling after seeing /n/ consecutive empty samples - , eoSampleMax :: Int - -- ^ Produce an error if the circuit produces more than /n/ valid samples. This - -- is used to terminate (potentially) infinitely running circuits. - -- - -- This number is used to generate stall information, so setting it to - -- unreasonable values will result in long runtimes. - , 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 - } +-- me +import Protocols.Hedgehog.Types {- | Resets for 30 cycles, checks for superfluous data for 50 cycles after seeing last valid data cycle, and times out after seeing 1000 consecutive @@ -72,45 +51,6 @@ defExpectOptions = , eoTrace = False } --- | 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 - -{- | Provides a way of comparing expected data with data produced by a -protocol component. --} -class - ( Drivable a - , TestType (SimulateFwdType a) - , TestType (ExpectType a) - , -- Foldable requirement on Vec :( - 1 <= SimulateChannels 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 '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) - instance (TestType a, C.KnownDomain dom) => Test (Df dom a) where expectN :: forall m. diff --git a/clash-protocols/src/Protocols/Hedgehog/Types.hs b/clash-protocols/src/Protocols/Hedgehog/Types.hs new file mode 100644 index 00000000..0dbe9cd4 --- /dev/null +++ b/clash-protocols/src/Protocols/Hedgehog/Types.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_HADDOCK hide #-} + +-- These types should be re-exported from the Protocols.Hedgehog module +module Protocols.Hedgehog.Types where + +-- deepseq +import Control.DeepSeq + +import qualified Clash.Prelude as C +import Data.Proxy +import GHC.Stack (HasCallStack) +import Protocols.Internal.Types + +-- hedgehog +import qualified Hedgehog 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 :: Int + -- ^ Stop sampling after seeing /n/ consecutive empty samples + , eoSampleMax :: Int + -- ^ Produce an error if the circuit produces more than /n/ valid samples. This + -- is used to terminate (potentially) infinitely running circuits. + -- + -- This number is used to generate stall information, so setting it to + -- unreasonable values will result in long runtimes. + , 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 + } + +{- | Provides a way of comparing expected data with data produced by a +protocol component. +-} +class + ( Drivable a + , TestType (SimulateFwdType a) + , TestType (ExpectType a) + , -- Foldable requirement on Vec :( + 1 C.<= SimulateChannels 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 '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/clash-protocols/src/Protocols/Internal.hs b/clash-protocols/src/Protocols/Internal.hs index 786a77ef..22558b66 100644 --- a/clash-protocols/src/Protocols/Internal.hs +++ b/clash-protocols/src/Protocols/Internal.hs @@ -88,12 +88,6 @@ infixr 1 |> in (r2sAb, s2rBc) --- | 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 - instance Backpressure () where boolsToBwd _ _ = () @@ -196,162 +190,6 @@ prod2C (Circuit a) (Circuit c) = --------------------------------- SIMULATION ----------------------------------- -{- | 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.Hedgehog" and '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: 'simulateC'. - driveC :: - SimulationConfig -> - SimulateFwdType a -> - Circuit () a - - -- | Sample a circuit that is trivially drivable. Use 'driveC' to create - -- such a circuit. Related: 'simulateC'. - sampleC :: - SimulationConfig -> - Circuit () a -> - SimulateFwdType a - -{- | Defines functions necessary for implementation of the '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 '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 '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 '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 - instance Simulate () where type SimulateFwdType () = () type SimulateBwdType () = () diff --git a/clash-protocols/src/Protocols/Internal/Types.hs b/clash-protocols/src/Protocols/Internal/Types.hs index 8303818e..e758ce3f 100644 --- a/clash-protocols/src/Protocols/Internal/Types.hs +++ b/clash-protocols/src/Protocols/Internal/Types.hs @@ -1,12 +1,182 @@ +{-# LANGUAGE FlexibleContexts #-} + module Protocols.Internal.Types where +import qualified Clash.Prelude as C +import Data.Default (Default (..)) 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) + +-- | 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.Hedgehog" and 'Protocols.Internal.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.Internal.simulateC'. + driveC :: + SimulationConfig -> + SimulateFwdType a -> + Circuit () a + + -- | Sample a circuit that is trivially drivable. Use 'driveC' to create + -- such a circuit. Related: 'Protocols.Internal.simulateC'. + sampleC :: + SimulationConfig -> + Circuit () a -> + SimulateFwdType a + +{- | Defines functions necessary for implementation of the 'Protocols.Internal.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.Internal.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.Internal.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.Internal.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 From 74abd4586d2e4814f75b115d99d4e307b71d1de1 Mon Sep 17 00:00:00 2001 From: Lucas Bollen Date: Thu, 26 Sep 2024 10:42:40 +0200 Subject: [PATCH 2/5] Add TH tuple instances for `Simulate` --- clash-protocols/src/Protocols/Internal.hs | 5 ++ clash-protocols/src/Protocols/Internal/TH.hs | 77 ++++++++++++++++++++ 2 files changed, 82 insertions(+) diff --git a/clash-protocols/src/Protocols/Internal.hs b/clash-protocols/src/Protocols/Internal.hs index 22558b66..f42e726b 100644 --- a/clash-protocols/src/Protocols/Internal.hs +++ b/clash-protocols/src/Protocols/Internal.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} #if !MIN_VERSION_clash_prelude(1, 8, 2) {-# OPTIONS_GHC -fno-warn-orphans #-} #endif @@ -33,8 +34,10 @@ import qualified Clash.Explicit.Prelude as CE import Clash.Prelude (type (*), type (+)) import qualified Clash.Prelude as C +import Protocols.Internal.TH (simulateTupleInstances) import Protocols.Internal.Types import Protocols.Plugin +import Protocols.Plugin.Cpp (maxTupleSize) import Protocols.Plugin.TaggedBundle import Protocols.Plugin.Units @@ -234,6 +237,8 @@ instance (Simulate a, Simulate b) => Simulate (a, b) where 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) diff --git a/clash-protocols/src/Protocols/Internal/TH.hs b/clash-protocols/src/Protocols/Internal/TH.hs index 72743204..02b7d290 100644 --- a/clash-protocols/src/Protocols/Internal/TH.hs +++ b/clash-protocols/src/Protocols/Internal/TH.hs @@ -2,9 +2,12 @@ module Protocols.Internal.TH where +import qualified Clash.Prelude as C import Control.Monad.Extra (concatMapM) +import GHC.TypeNats import Language.Haskell.TH 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, @@ -31,3 +34,77 @@ idleCircuitTupleInstance n = 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 _ $fwdPat0 = $(tupE $ zipWith (\ty expr -> [e|simToSigFwd (Proxy @($ty)) $expr|]) circTys fwdExpr) + simToSigBwd _ $bwdPat0 = $(tupE $ zipWith (\ty expr -> [e|simToSigBwd (Proxy @($ty)) $expr|]) circTys bwdExpr) + sigToSimFwd _ $fwdPat0 = $(tupE $ zipWith (\ty expr -> [e|sigToSimFwd (Proxy @($ty)) $expr|]) circTys fwdExpr) + sigToSimBwd _ $bwdPat0 = $(tupE $ zipWith (\ty expr -> [e|sigToSimBwd (Proxy @($ty)) $expr|]) circTys bwdExpr) + + stallC $(varP $ mkName "conf") $(varP $ mkName "rem0") = $(letE (stallVecs ++ stallCircuits) 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 + stallVecs = zipWith mkStallVec [1 .. n] circTys + mkStallVec i ty = + valD + mkStallPat + ( normalB [e|(C.splitAtI @(SimulateChannels $ty) $(varE (mkName $ "rem" <> show (i - 1))))|] + ) + [] + where + mkStallPat = + tupP + [ varP (mkName $ "stalls" <> show i) + , varP (mkName $ if i == n then "_" else "rem" <> show i) + ] + + -- stallC Declaration: Generate stalling circuits + stallCircuits = zipWith mkStallCircuit [1 .. n] circTys + mkStallCircuit i ty = + valD + [p|Circuit $(varP $ mkName $ "stalled" <> show i)|] + (normalB [e|stallC @($ty) conf $(varE $ mkName $ "stalls" <> show i)|]) + [] + + -- Generate the stallC expression + stallCExpr = + [e| + Circuit $ \($fwdPat0, $bwdPat0) -> $(letE stallCResultDecs [e|($(tupE fwdExpr1), $(tupE bwdExpr1))|]) + |] + + stallCResultDecs = map mkStallCResultDec [1 .. n] + mkStallCResultDec i = + valD + (tupP [varP $ mkName $ "fwdStalled" <> show i, varP $ mkName $ "bwdStalled" <> show i]) + ( normalB $ + appE (varE $ mkName $ "stalled" <> show i) $ + tupE [varE $ mkName $ "fwd" <> show i, varE $ mkName $ "bwd" <> show i] + ) + [] From 0569c4efbbfebc90a739414e02e5d18c665674fd Mon Sep 17 00:00:00 2001 From: Lucas Bollen Date: Fri, 27 Sep 2024 08:16:04 +0200 Subject: [PATCH 3/5] Add `backPressureTupleInstances` and `drivableTupleInstances` --- clash-protocols/src/Protocols/Internal.hs | 18 ++---- clash-protocols/src/Protocols/Internal/TH.hs | 67 ++++++++++++++++++++ 2 files changed, 74 insertions(+), 11 deletions(-) diff --git a/clash-protocols/src/Protocols/Internal.hs b/clash-protocols/src/Protocols/Internal.hs index f42e726b..5bdb83b0 100644 --- a/clash-protocols/src/Protocols/Internal.hs +++ b/clash-protocols/src/Protocols/Internal.hs @@ -34,7 +34,11 @@ import qualified Clash.Explicit.Prelude as CE import Clash.Prelude (type (*), type (+)) import qualified Clash.Prelude as C -import Protocols.Internal.TH (simulateTupleInstances) +import Protocols.Internal.TH ( + backPressureTupleInstances, + drivableTupleInstances, + simulateTupleInstances, + ) import Protocols.Internal.Types import Protocols.Plugin import Protocols.Plugin.Cpp (maxTupleSize) @@ -97,12 +101,7 @@ instance Backpressure () where instance (Backpressure a, Backpressure b) => Backpressure (a, b) where boolsToBwd _ bs = (boolsToBwd (Proxy @a) bs, boolsToBwd (Proxy @b) bs) -instance (Backpressure a, Backpressure b, Backpressure c) => Backpressure (a, b, c) where - boolsToBwd _ bs = - ( boolsToBwd (Proxy @a) bs - , boolsToBwd (Proxy @b) bs - , boolsToBwd (Proxy @c) bs - ) +backPressureTupleInstances 3 maxTupleSize instance (C.KnownNat n, Backpressure a) => Backpressure (C.Vec n a) where boolsToBwd _ bs = C.repeat (boolsToBwd (Proxy @a) bs) @@ -265,10 +264,7 @@ instance (Drivable a, Drivable b) => Drivable (a, b) where , sampleC @b conf (Circuit $ \_ -> ((), fwd2)) ) --- TODO TemplateHaskell? --- instance SimulateType (a, b, c) --- instance SimulateType (a, b, c, d) - +drivableTupleInstances 3 maxTupleSize 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) diff --git a/clash-protocols/src/Protocols/Internal/TH.hs b/clash-protocols/src/Protocols/Internal/TH.hs index 02b7d290..c3c9ffdd 100644 --- a/clash-protocols/src/Protocols/Internal/TH.hs +++ b/clash-protocols/src/Protocols/Internal/TH.hs @@ -4,6 +4,7 @@ module Protocols.Internal.TH where import qualified Clash.Prelude as C import Control.Monad.Extra (concatMapM) +import Data.Proxy import GHC.TypeNats import Language.Haskell.TH import Protocols.Internal.Types @@ -108,3 +109,69 @@ simulateTupleInstance n = tupE [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 From f1a0704497021d545d52cfb79ecdb055e8d50538 Mon Sep 17 00:00:00 2001 From: Lucas Bollen Date: Wed, 20 Nov 2024 10:58:57 +0100 Subject: [PATCH 4/5] Add TH function `testTupleInstances` Includes tuple instances of `Test` up to 9 tuples --- .../src/Protocols/Hedgehog/Internal.hs | 10 +++++--- clash-protocols/src/Protocols/Internal/TH.hs | 25 +++++++++++++++++++ 2 files changed, 32 insertions(+), 3 deletions(-) diff --git a/clash-protocols/src/Protocols/Hedgehog/Internal.hs b/clash-protocols/src/Protocols/Hedgehog/Internal.hs index 37ef7409..19846d56 100644 --- a/clash-protocols/src/Protocols/Hedgehog/Internal.hs +++ b/clash-protocols/src/Protocols/Hedgehog/Internal.hs @@ -19,6 +19,8 @@ import Prelude -- clash-protocols import Protocols import qualified Protocols.Df as Df +import Protocols.Hedgehog.Types +import Protocols.Internal.TH -- clash-prelude import Clash.Prelude (type (*), type (+), type (<=)) @@ -28,9 +30,6 @@ import qualified Clash.Prelude as C import qualified Hedgehog as H import qualified Hedgehog.Internal.Property as H --- me -import Protocols.Hedgehog.Types - {- | Resets for 30 cycles, checks for superfluous data for 50 cycles after seeing last valid data cycle, and times out after seeing 1000 consecutive empty cycles. @@ -124,3 +123,8 @@ instance 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/clash-protocols/src/Protocols/Internal/TH.hs b/clash-protocols/src/Protocols/Internal/TH.hs index c3c9ffdd..4e682f03 100644 --- a/clash-protocols/src/Protocols/Internal/TH.hs +++ b/clash-protocols/src/Protocols/Internal/TH.hs @@ -7,6 +7,7 @@ import Control.Monad.Extra (concatMapM) import Data.Proxy import GHC.TypeNats import Language.Haskell.TH +import Protocols.Hedgehog.Types import Protocols.Internal.Types import Protocols.Plugin @@ -175,3 +176,27 @@ backPressureTupleInstance n = 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] From e1d09b3056ce619aebf7222f91db3c36aa7d1065 Mon Sep 17 00:00:00 2001 From: Lucas Bollen Date: Wed, 20 Nov 2024 16:07:10 +0100 Subject: [PATCH 5/5] Re-export `Protocols.Hedgehog.Types` from `Protocols.Hedgehog.Internal` --- clash-protocols/src/Protocols/Hedgehog.hs | 3 --- clash-protocols/src/Protocols/Hedgehog/Internal.hs | 5 ++++- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/clash-protocols/src/Protocols/Hedgehog.hs b/clash-protocols/src/Protocols/Hedgehog.hs index af2296f2..b6188ba2 100644 --- a/clash-protocols/src/Protocols/Hedgehog.hs +++ b/clash-protocols/src/Protocols/Hedgehog.hs @@ -55,9 +55,6 @@ import qualified Hedgehog.Range as Range -- lifted-async import Control.Concurrent.Async.Lifted (race) --- me -import Protocols.Hedgehog.Types - -- | Whether to stall or not. Used in 'idWithModel'. data StallMode = NoStall | Stall deriving (Show, Enum, Bounded) diff --git a/clash-protocols/src/Protocols/Hedgehog/Internal.hs b/clash-protocols/src/Protocols/Hedgehog/Internal.hs index 19846d56..2a2df4f8 100644 --- a/clash-protocols/src/Protocols/Hedgehog/Internal.hs +++ b/clash-protocols/src/Protocols/Hedgehog/Internal.hs @@ -9,7 +9,10 @@ {- | Internals for "Protocols.Hedgehog". -} -module Protocols.Hedgehog.Internal where +module Protocols.Hedgehog.Internal ( + module Protocols.Hedgehog.Internal, + module Protocols.Hedgehog.Types, +) where -- base import Data.Proxy (Proxy (Proxy))