From 5b378a170291be4bbcb18e377e08b14872c0b4cf Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 9 Sep 2024 05:52:37 -0400
Subject: [PATCH 1/4] Introduce BiDf protocol

This introduces a new protocol, `BiDf`, which captures the common
pattern of a request `Df` channel paired with a `Df` for returning
corresponding responses.
---
 clash-protocols/clash-protocols.cabal         |   2 +
 clash-protocols/src/Protocols/BiDf.hs         | 102 ++++++++++++++++++
 clash-protocols/tests/Tests/Protocols.hs      |   4 +-
 clash-protocols/tests/Tests/Protocols/BiDf.hs |  56 ++++++++++
 4 files changed, 163 insertions(+), 1 deletion(-)
 create mode 100644 clash-protocols/src/Protocols/BiDf.hs
 create mode 100644 clash-protocols/tests/Tests/Protocols/BiDf.hs

diff --git a/clash-protocols/clash-protocols.cabal b/clash-protocols/clash-protocols.cabal
index 1017ec5b..2b2b9720 100644
--- a/clash-protocols/clash-protocols.cabal
+++ b/clash-protocols/clash-protocols.cabal
@@ -144,6 +144,7 @@ library
     Protocols.Axi4.WriteAddress
     Protocols.Axi4.WriteData
     Protocols.Axi4.WriteResponse
+    Protocols.BiDf
     Protocols.Df
     Protocols.DfConv
     Protocols.Hedgehog
@@ -175,6 +176,7 @@ test-suite unittests
   main-is: unittests.hs
   other-modules:
     Tests.Protocols
+    Tests.Protocols.BiDf
     Tests.Protocols.Df
     Tests.Protocols.DfConv
     Tests.Protocols.Avalon
diff --git a/clash-protocols/src/Protocols/BiDf.hs b/clash-protocols/src/Protocols/BiDf.hs
new file mode 100644
index 00000000..175cc8f8
--- /dev/null
+++ b/clash-protocols/src/Protocols/BiDf.hs
@@ -0,0 +1,102 @@
+{-# OPTIONS_GHC -fplugin Protocols.Plugin #-}
+
+-- | Bi-directional request/response-style 'Df' channels.
+module Protocols.BiDf (
+  BiDf,
+    -- * Conversion
+  fromDfs,
+  toDfs,
+  fromBiDf,
+  toBiDf,
+    -- * Trivial combinators
+  void,
+  loopback,
+    -- * Mapping
+  dimap,
+) where
+
+import Prelude ()
+
+import Clash.Prelude
+
+import Protocols
+import qualified Protocols.Df as Df
+
+-- | A 'Protocol' allowing requests to be passed downstream, with corresponding
+-- responses being passed back upstream. Responses are provided in the order that
+-- their corresponding requests were submitted.
+--
+-- *Correctness conditions*
+--
+--  - The response channel must not produce a value before the request channel
+--    has produced a value.
+--
+--  - Each request must be paired with exactly one response.
+--
+--  - Responses must be issued in the order that their corresponding requests arrived.
+--
+--  - Both the request and response channels must obey usual 'Df' correctness
+--    conditions.
+--
+--  - There must not be a combinational path from the request channel to the
+--    response channel.
+--
+type BiDf dom req resp =
+  (Df dom req, Reverse (Df dom resp))
+
+-- | Convert a circuit of 'Df's to a 'BiDf' circuit.
+toBiDf
+  :: Circuit (Df dom req) (Df dom resp)
+  -> Circuit (BiDf dom req resp) ()
+toBiDf c = circuit $ \bidf -> do
+  resp <- c -< req
+  req <- toDfs -< (bidf, resp)
+  idC -< ()
+
+-- | Convert a 'BiDf' circuit to a circuit of 'Df's.
+fromBiDf
+  :: Circuit (BiDf dom req resp) ()
+  -> Circuit (Df dom req) (Df dom resp)
+fromBiDf c = circuit $ \req -> do
+  (biDf, resp) <- fromDfs -< req
+  c -< biDf
+  idC -< resp
+
+-- | Convert a pair of a request and response 'Df`s into a 'BiDf'.
+toDfs :: Circuit (BiDf dom req resp, Df dom resp) (Df dom req)
+toDfs = fromSignals $ \(~((reqData, respAck), respData), reqAck) ->
+  (((reqAck, respData), respAck), reqData)
+
+-- | Convert a 'BiDf' into a pair of request and response 'Df`s.
+fromDfs :: Circuit (Df dom req) (BiDf dom req resp, Df dom resp)
+fromDfs = fromSignals $ \(reqData, ~((reqAck, respData), respAck)) ->
+  (reqAck, ((reqData, respAck), respData))
+
+-- | Ignore all requests, never providing responses.
+void :: (HiddenClockResetEnable dom) => Circuit (BiDf dom req resp') ()
+void = circuit $ \biDf -> do
+  req <- toDfs -< (biDf, resp)
+  resp <- Df.empty -< ()
+  Df.void -< req
+
+-- | Return mapped requests as responses.
+loopback
+  :: (HiddenClockResetEnable dom, NFDataX req)
+  => (req -> resp)
+  -> Circuit (BiDf dom req resp) ()
+loopback f = circuit $ \biDf -> do
+  req <- toDfs -< (biDf, resp)
+  resp <- Df.map f <| Df.registerFwd -< req
+  idC -< ()
+
+-- | Map both requests and responses.
+dimap
+  :: (req -> req')
+  -> (resp -> resp')
+  -> Circuit (BiDf dom req resp') (BiDf dom req' resp)
+dimap f g = circuit $ \biDf -> do
+  req <- toDfs -< (biDf, resp')
+  req' <- Df.map f -< req
+  resp' <- Df.map g -< resp
+  (biDf', resp) <- fromDfs -< req'
+  idC -< biDf'
diff --git a/clash-protocols/tests/Tests/Protocols.hs b/clash-protocols/tests/Tests/Protocols.hs
index a09bc008..23b01913 100644
--- a/clash-protocols/tests/Tests/Protocols.hs
+++ b/clash-protocols/tests/Tests/Protocols.hs
@@ -3,6 +3,7 @@ module Tests.Protocols (tests, main) where
 import Test.Tasty
 import qualified Tests.Protocols.Avalon
 import qualified Tests.Protocols.Axi4
+import qualified Tests.Protocols.BiDf
 import qualified Tests.Protocols.Df
 import qualified Tests.Protocols.DfConv
 import qualified Tests.Protocols.Wishbone
@@ -11,7 +12,8 @@ tests :: TestTree
 tests =
   testGroup
     "Protocols"
-    [ Tests.Protocols.Df.tests
+    [ Tests.Protocols.BiDf.tests
+    , Tests.Protocols.Df.tests
     , Tests.Protocols.DfConv.tests
     , Tests.Protocols.Avalon.tests
     , Tests.Protocols.Axi4.tests
diff --git a/clash-protocols/tests/Tests/Protocols/BiDf.hs b/clash-protocols/tests/Tests/Protocols/BiDf.hs
new file mode 100644
index 00000000..b05d6fdf
--- /dev/null
+++ b/clash-protocols/tests/Tests/Protocols/BiDf.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS_GHC -fplugin Protocols.Plugin #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Tests.Protocols.BiDf (tests) where
+
+-- clash-prelude
+import Clash.Prelude
+import qualified Clash.Sized.Vector as Vector
+import Clash.Hedgehog.Sized.Vector
+
+-- clash-protocols
+import Protocols
+import Protocols.Hedgehog
+import Protocols.BiDf as BiDf
+
+-- hedgehog
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+-- tasty
+import Test.Tasty
+import Test.Tasty.Hedgehog.Extra (testProperty)
+import Test.Tasty.TH (testGroupGenerator)
+
+-- | Ensure that 'BiDf.toDfs' composed with 'BiDf.fromDfs' behaves as an
+-- identity.
+prop_toDfs_fromDfs_id :: Property
+prop_toDfs_fromDfs_id =
+  idWithModelSingleDomain @System defExpectOptions gen (\_ _ _ -> id) (exposeClockResetEnable impl)
+ where
+  gen :: Gen [Int]
+  gen = Gen.list (Range.linear 0 10) (Gen.integral (Range.linear 0 100))
+
+  impl :: forall dom a. (HiddenClockResetEnable dom, NFDataX a)
+       => Circuit (Df dom a) (Df dom a)
+  impl = BiDf.toDfs <| BiDf.fromDfs
+
+-- | Ensure that 'BiDf.loopback' behaves as an identity.
+prop_loopback_id :: Property
+prop_loopback_id =
+  idWithModelSingleDomain @System defExpectOptions gen (\_ _ _ -> id) (exposeClockResetEnable impl)
+ where
+  gen :: Gen [Int]
+  gen = Gen.list (Range.linear 0 10) (Gen.integral (Range.linear 0 100))
+
+  impl :: forall dom a. (HiddenClockResetEnable dom, NFDataX a)
+       => Circuit (Df dom a) (Df dom a)
+  impl = circuit $ \req -> do
+    (biDf, resp) <- BiDf.fromDfs -< req
+    BiDf.loopback id -< biDf
+    idC -< resp
+
+tests :: TestTree
+tests =
+  $(testGroupGenerator)
\ No newline at end of file

From 241c6c19d3d1a6424640b689d68406b9c81158ec Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 9 Sep 2024 18:07:12 -0400
Subject: [PATCH 2/4] Introduce repeatWithIndexC

---
 clash-protocols-base/src/Protocols/Internal.hs | 13 +++++++++++++
 clash-protocols/src/Protocols.hs               |  1 +
 2 files changed, 14 insertions(+)

diff --git a/clash-protocols-base/src/Protocols/Internal.hs b/clash-protocols-base/src/Protocols/Internal.hs
index d82318b7..34d52c08 100644
--- a/clash-protocols-base/src/Protocols/Internal.hs
+++ b/clash-protocols-base/src/Protocols/Internal.hs
@@ -207,6 +207,19 @@ repeatC ::
 repeatC (Circuit f) =
   Circuit (C.unzip . C.map f . uncurry C.zip)
 
+{- | Copy a circuit /n/ times, providing access to the index of each replica.
+If looking for a circuit that turns a single channel into multiple, check out
+'Protocols.Df.fanout'.
+-}
+repeatWithIndexC
+  :: forall n a b. (C.KnownNat n) =>
+  (C.Index n -> Circuit a b) ->
+  Circuit (C.Vec n a) (C.Vec n b)
+repeatWithIndexC f =
+  Circuit (C.unzip . C.zipWith g C.indicesI . uncurry C.zip)
+  where
+    g i = case f i of Circuit f' -> f'
+
 {- | Combine two separate circuits into one. If you are looking to combine
 multiple streams into a single stream, checkout 'Protocols.Df.fanin'.
 -}
diff --git a/clash-protocols/src/Protocols.hs b/clash-protocols/src/Protocols.hs
index 0d2b1aff..bda4bd7e 100644
--- a/clash-protocols/src/Protocols.hs
+++ b/clash-protocols/src/Protocols.hs
@@ -30,6 +30,7 @@ module Protocols (
   -- * Basic circuits
   idC,
   repeatC,
+  repeatWithIndexC,
   prod2C,
 
   -- * Simulation

From f15e5caffd4a6fc1310c4015cb1a15038ef55527 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 9 Sep 2024 10:55:01 -0400
Subject: [PATCH 3/4] BiDf: Introduce fanin

This is a useful operation for servicing requests from a number of
sources with a single sink.
---
 clash-protocols/src/Protocols/BiDf.hs         | 37 +++++++++++++
 clash-protocols/tests/Tests/Protocols/BiDf.hs | 52 ++++++++++++++++++-
 2 files changed, 87 insertions(+), 2 deletions(-)

diff --git a/clash-protocols/src/Protocols/BiDf.hs b/clash-protocols/src/Protocols/BiDf.hs
index 175cc8f8..7079e8ac 100644
--- a/clash-protocols/src/Protocols/BiDf.hs
+++ b/clash-protocols/src/Protocols/BiDf.hs
@@ -13,6 +13,8 @@ module Protocols.BiDf (
   loopback,
     -- * Mapping
   dimap,
+  -- * Fan-in
+  fanin
 ) where
 
 import Prelude ()
@@ -100,3 +102,38 @@ dimap f g = circuit $ \biDf -> do
   resp' <- Df.map g -< resp
   (biDf', resp) <- fromDfs -< req'
   idC -< biDf'
+
+-- | Merge a number of 'BiDf's, preferring requests from the last channel.
+fanin
+  :: forall n dom req resp.
+     ( KnownNat n
+     , 1 <= n
+     , NFDataX req
+     , NFDataX resp
+     , HiddenClockResetEnable dom
+     )
+  => Circuit (Vec n (BiDf dom req resp)) (BiDf dom req resp)
+fanin = fromSignals $ \(upFwds, (reqAck, respData)) ->
+  let reqDatas :: Vec n (Signal dom (Df.Data req))
+      reqDatas = map fst upFwds
+      respAcks :: Vec n (Signal dom Ack)
+      respAcks = map snd upFwds
+
+      ((reqAcks, respAck), (respDatas, reqData)) =
+           toSignals fanin' ((reqDatas, respData), (respAcks, reqAck))
+  in (zip reqAcks respDatas, (reqData, respAck))
+ where
+  fanin'
+      :: Circuit (Vec n (Df dom req), Df dom resp)
+                 (Vec n (Df dom resp), Df dom req)
+  fanin' = circuit $ \(reqs, resp) -> do
+    [fwd0, fwd1]
+        <- Df.fanout
+        <| Df.roundrobinCollect @n Df.Parallel
+        <| repeatWithIndexC (\i -> Df.map (\x -> (i,x)))
+        -< reqs
+
+    activeN <- Df.map fst -< fwd1
+    resps <- Df.route <| Df.zip -< (activeN, resp)
+    req <- Df.map snd -< fwd0
+    idC -< (resps, req)
diff --git a/clash-protocols/tests/Tests/Protocols/BiDf.hs b/clash-protocols/tests/Tests/Protocols/BiDf.hs
index b05d6fdf..57fb5a74 100644
--- a/clash-protocols/tests/Tests/Protocols/BiDf.hs
+++ b/clash-protocols/tests/Tests/Protocols/BiDf.hs
@@ -4,7 +4,7 @@
 module Tests.Protocols.BiDf (tests) where
 
 -- clash-prelude
-import Clash.Prelude
+import Clash.Prelude as C
 import qualified Clash.Sized.Vector as Vector
 import Clash.Hedgehog.Sized.Vector
 
@@ -51,6 +51,54 @@ prop_loopback_id =
     BiDf.loopback id -< biDf
     idC -< resp
 
+-- | Test that 'BiDf.fanin' on a single 'BiDf' channel behaves as an identity.
+prop_fanin_id :: Property
+prop_fanin_id =
+  idWithModelSingleDomain @System defExpectOptions gen (\_ _ _ -> id) (exposeClockResetEnable impl)
+ where
+  gen :: Gen [Int]
+  gen = Gen.list (Range.linear 0 10) (Gen.integral (Range.linear 0 100))
+
+  impl
+   :: forall dom a. (HiddenClockResetEnable dom, NFDataX a)
+   => Circuit (Df dom a) (Df dom a)
+  impl = circuit $ \req -> do
+    (biDf, resp) <- BiDf.fromDfs -< req
+    BiDf.loopback id <| BiDf.fanin @1 -< [biDf]
+    idC -< resp
+
+-- | Test that 'BiDf.fanin' on a number of 'BiDf' channels behaves as an
+-- identity on each channel.
+prop_fanin :: Property
+prop_fanin =
+  idWithModelSingleDomain @System expectOpts
+    (gen @3)
+    (\_ _ _ -> id)
+    (exposeClockResetEnable impl)
+ where
+  expectOpts = defExpectOptions
+
+  gen :: forall n. KnownNat n => Gen (Vec n [(Index n, Int)])
+  gen = do
+    xs <- genVec @Gen @n $ Gen.list (Range.linear 0 10) (Gen.integral (Range.linear 0 100))
+    return $ C.zipWith (\i -> fmap (\x -> (i,x))) indicesI xs
+
+  impl
+    :: forall n dom a.
+      (HiddenClockResetEnable dom, KnownNat n, 1 <= n, NFDataX a)
+    => Circuit (Vec n (Df dom a)) (Vec n (Df dom a))
+  impl = circuit $ \reqs -> do
+    (biDfs, resps) <- unbundleC <| repeatC BiDf.fromDfs -< reqs
+    BiDf.loopback id <| BiDf.fanin @n -< biDfs
+    idC -< resps
+
+unbundleC :: forall n a b. Circuit (Vec n (a, b)) (Vec n a, Vec n b)
+unbundleC = fromSignals $ \(fwd, (bwdA, bwdB)) ->
+  let fwdA :: Vec n (Fwd a)
+      fwdB :: Vec n (Fwd b)
+      (fwdA, fwdB) = Vector.unzip fwd
+  in (Vector.zip bwdA bwdB, (fwdA, fwdB))
+
 tests :: TestTree
 tests =
-  $(testGroupGenerator)
\ No newline at end of file
+  $(testGroupGenerator)

From 6da66c9936b855925ff5b4e35bd94f15b5358124 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 18 Sep 2024 11:26:40 -0400
Subject: [PATCH 4/4] Update clash-protocols/src/Protocols/BiDf.hs

Co-authored-by: Peter Lebbing <peter@digitalbrains.com>
---
 clash-protocols/src/Protocols/BiDf.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/clash-protocols/src/Protocols/BiDf.hs b/clash-protocols/src/Protocols/BiDf.hs
index 7079e8ac..2c706fc9 100644
--- a/clash-protocols/src/Protocols/BiDf.hs
+++ b/clash-protocols/src/Protocols/BiDf.hs
@@ -31,7 +31,9 @@ import qualified Protocols.Df as Df
 -- *Correctness conditions*
 --
 --  - The response channel must not produce a value before the request channel
---    has produced a value.
+--    has produced a value. The response may be produced in the same cycle the
+--    request is acknowledged (but see the law about a combinational path
+--    below).
 --
 --  - Each request must be paired with exactly one response.
 --