Add truncateAbortedPackets (clash-lang#159)

Author: lmbollen

clash-protocols/src/Protocols/PacketStream/Base.hs

@@ -29,6 +29,7 @@ module Protocols.PacketStream.Base (
   zeroOutInvalidBytesC,
   stripTrailingEmptyC,
   unsafeAbortOnBackpressureC,
+  truncateAbortedPackets,
 
   -- * Components imported from DfConv
   void,
@@ -439,6 +440,41 @@ zeroOutInvalidBytesC = Circuit $ \(fwdIn, bwdIn) -> (bwdIn, fmap (go <$>) fwdIn)
           (\(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.

clash-protocols/tests/Tests/Protocols/PacketStream/Base.hs

@@ -9,7 +9,7 @@ import Clash.Prelude
 import Data.List qualified as L
 import "extra" Data.List.Extra (unsnoc)
 
-import Hedgehog (Property)
+import Hedgehog (Gen, Property)
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Range qualified as Range
 
@@ -44,6 +44,26 @@ prop_strip_trailing_empty =
           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 -})