Add Xilinx dual clock FIFO

Co-authored-by: Martijn Bastiaan <[email protected]>

.ci/bindist/linux/debian/focal/buildinfo.json

@@ -17,6 +17,14 @@
       "name": "generic-lens-core",
       "src": {"type": "hackage", "version": "2.0.0.0"}
     },
+    {
+      "name": "hedgehog",
+      "src": {"type": "hackage", "version": "1.0.5"}
+    },
+    {
+      "name": "tasty-hedgehog",
+      "src": {"type": "hackage", "version": "1.2.0.0"}
+    },
     {
       "name": "generic-lens",
       "src": {"type": "hackage", "version": "2.0.0.0"}
@@ -85,6 +93,11 @@
       ],
       "src": {"type": "local", "dir": "../../../../../clash-ghc"}
     },
+    {
+      "name": "clash-cores",
+      "cabal_debian_options": ["--disable-haddock", "--disable-tests"],
+      "src": {"type": "local", "dir": "../../../../../clash-cores"}
+    },
     {
       "name": "clash-testsuite",
       "src": {"type": "local", "dir": "../../../../../tests"},

.ci/gitlab/test.yml

@@ -80,6 +80,7 @@ prelude:doctests:
     - cabal v2-run -- clash-prelude:doctests -j${THREADS}
 
 # Tests run on local fast machines:
+
 suite:vhdl:
   extends: .test-common-local
   script:

clash-cores/clash-cores.cabal

@@ -68,13 +68,19 @@ common basic-config
     ghc-typelits-knownnat     >= 0.6,
     interpolate               >= 0.2,
     QuickCheck,
-    template-haskell
+    template-haskell,
+    containers                >=0.5    && <0.7
 
 library
   import: basic-config
   hs-source-dirs: src
 
   exposed-modules:
+    Clash.Cores.Xilinx.Common
+    Clash.Cores.Xilinx.DcFifo
+    Clash.Cores.Xilinx.DcFifo.BlackBoxes
+    Clash.Cores.Xilinx.DcFifo.Explicit
+    Clash.Cores.Xilinx.DcFifo.Instances
     Clash.Cores.Xilinx.Floating
     Clash.Cores.Xilinx.Floating.Annotations
     Clash.Cores.Xilinx.Floating.BlackBoxes
@@ -112,9 +118,13 @@ test-suite unittests
     Test.Cores.SPI
     Test.Cores.UART
     Test.Cores.SPI.MultiSlave
+    Test.Cores.Xilinx.DcFifo
 
   build-depends:
     clash-cores,
+    clash-lib,
     tasty        >= 1.2 && < 1.5,
     tasty-hunit,
-    tasty-quickcheck
+    tasty-quickcheck,
+    hedgehog,
+    tasty-hedgehog >= 1.2.0

clash-cores/src/Clash/Cores/Xilinx/Common.hs

@@ -0,0 +1,91 @@
+{-|
+  Copyright   :  (C) 2022 Google Inc
+  License     :  BSD2 (see the file LICENSE)
+  Maintainer  :  QBayLogic B.V. <[email protected]>
+
+  Common utilities for defining Xilinx IP primitives.
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Clash.Cores.Xilinx.Common where
+
+import Prelude
+
+import Clash.Netlist.Id (Identifier)
+import Data.String (fromString)
+import Data.String.Interpolate (i)
+import Data.Text.Prettyprint.Doc.Extra (Doc)
+
+import qualified Clash.Netlist.Id as Id
+import qualified Data.Text as Text
+import Data.List (intercalate)
+
+type PropName = String
+type PropValue = String
+type Property = (PropName, PropValue)
+
+data IpConfig = IpConfig
+  { name :: String
+  , vendor :: String
+  , library :: String
+  , version :: String
+  , moduleName :: Identifier
+  , properties :: [Property]
+  }
+
+defIpConfig ::
+  -- | Name of IP core. For example: \"fifo_generator\".
+  String ->
+  -- | Version of IP core. For example: \"13.2\".
+  String ->
+  -- | Name of module the IP core should be generated as. For example: \"dcfifo\". This
+  -- name should be unique. See "Clash.Netlist.Id" for more information on how to
+  -- generate unique identifiers.
+  Identifier ->
+  -- | Configuration with sensible defaults.
+  IpConfig
+defIpConfig name_ version_ moduleName_ = IpConfig
+  { name = name_
+  , version = version_
+  , moduleName = moduleName_
+  , vendor = "xilinx.com"
+  , library = "ip"
+  , properties = []
+  }
+
+renderTcl :: IpConfig -> Doc
+renderTcl IpConfig{..} =
+  fromString [i|
+proc createNamespace ns {
+  namespace eval $ns {
+    variable api {1}
+    variable ipName {#{moduleNameString}}
+    variable scriptPurpose {createIp}
+    proc createIp {ipName0 args} {
+      create_ip \\
+        -name #{name} \\
+        -vendor #{vendor} \\
+        -library #{library} \\
+        -version #{version} \\
+        -module_name $ipName0 \\
+        {*}$args
+
+      set_property -dict [list \\
+#{renderedProperties}
+                         ] \\
+                        [get_ips {#{moduleNameString}}]
+    }
+  }
+}|]
+
+ where
+  moduleNameString = Text.unpack (Id.toText moduleName)
+  renderedProperties = intercalate "\n" (map prop properties)
+  prop (name_, value) = [i|#{indent}CONFIG.#{name_} {#{value}} \\|]
+  indent = replicate 25 ' '
+
+toTclBool :: Bool -> String
+toTclBool True = "true"
+toTclBool False = "false"

clash-cores/src/Clash/Cores/Xilinx/DcFifo.hs

@@ -0,0 +1,8 @@
+module Clash.Cores.Xilinx.DcFifo
+  ( module Clash.Cores.Xilinx.DcFifo.BlackBoxes
+  , module Clash.Cores.Xilinx.DcFifo.Explicit
+  ) where
+
+import Clash.Cores.Xilinx.DcFifo.BlackBoxes
+import Clash.Cores.Xilinx.DcFifo.Instances ()
+import Clash.Cores.Xilinx.DcFifo.Explicit

clash-cores/src/Clash/Cores/Xilinx/DcFifo/BlackBoxes.hs

@@ -0,0 +1,226 @@
+{-|
+  Copyright   :  (C) 2022 Google Inc
+  License     :  BSD2 (see the file LICENSE)
+  Maintainer  :  QBayLogic B.V. <[email protected]>
+
+  Blackbox implementation for primitives in "Clash.Cores.Xilinx.DcFifo.Explicit".
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Clash.Cores.Xilinx.DcFifo.BlackBoxes where
+
+import Prelude
+
+import Clash.Core.Literal (Literal(NaturalLiteral))
+import Clash.Core.TermLiteral (termToDataError, TermLiteralSNat(..))
+import Clash.Core.Term (Term(Literal))
+import qualified Clash.Primitives.DSL as DSL
+import Clash.Netlist.BlackBox.Types (BlackBoxFunction, emptyBlackBoxMeta)
+import Clash.Netlist.Types (TemplateFunction(..), BlackBox(BBFunction))
+import Clash.Netlist.Util (orNothing)
+
+import Clash.Netlist.Id (Identifier)
+import qualified Clash.Netlist.Id as Id
+import qualified Clash.Netlist.Types as N
+import qualified Clash.Netlist.BlackBox.Types as N
+
+import Control.Monad (unless)
+import Data.Either (lefts)
+import Data.Maybe (catMaybes)
+import GHC.Stack (HasCallStack)
+
+import Clash.Cores.Xilinx.DcFifo.Explicit (DcConfig(..))
+import Clash.Cores.Xilinx.DcFifo.Instances ()
+import Clash.Cores.Xilinx.Common (toTclBool, renderTcl, defIpConfig, IpConfig (properties))
+
+-- | Blackbox function for 'Clash.Cores.Xilinx.Fifo.dcFifo'. It parses the "DcConfig"
+-- supplied to 'dcFifo' from its Term representation, and passes them to two
+-- template functions:
+--
+--   * 'dcFifoTclTF': renders TCL file calling Xilinx's `create_ip`
+--   * 'dcFifoTF': instantiates IP generated in 'dcFifoTclTF'
+--
+-- Additionally, it generates an unique module name for the Xilinx IP.
+--
+dcFifoBBF :: HasCallStack => BlackBoxFunction
+dcFifoBBF _isD _primName args _resTys = do
+  let
+    [  knownNatN, _knownDomainWrite, _knownDomainRead, _knownNatDepth
+     , _constraint1, _constraint2
+     , either error id . termToDataError -> dcConfig
+     , _wClk, _rClk, _rst, _wData
+     , _rEnable
+
+    -- TODO: Make this blackbox return multiple results, instead of a tuple. See:
+    --       https://github.com/clash-lang/clash-compiler/pull/1560
+    --  , _, _, _, _, _, _, _
+     ] = lefts args
+
+  dcFifoName <- Id.makeBasic "dcfifo"
+
+  let depth =
+        case knownNatN of
+          Literal (NaturalLiteral n) -> fromInteger n
+          _ -> error "Unexpected type of knownNatN!"
+
+  pure (Right (bbMeta depth dcFifoName dcConfig, bb dcFifoName dcConfig))
+ where
+  bbMeta width dcFifoName dcConfig = emptyBlackBoxMeta
+    { N.bbKind = N.TDecl
+    , N.bbIncludes =
+      [ ( ("dcfifo", "tcl")
+        , BBFunction (show 'dcFifoTclTF) 0 (dcFifoTclTF width dcFifoName dcConfig))
+      ]
+    -- TODO: Make this blackbox return multiple results, instead of a tuple. See:
+    --       https://github.com/clash-lang/clash-compiler/pull/1560
+    -- , N.bbResultNames =
+    --   [ N.BBTemplate [N.Text "wr_reset_busy"]
+    --   , N.BBTemplate [N.Text "wr_full"]
+    --   , N.BBTemplate [N.Text "wr_data_count"]
+
+    --   , N.BBTemplate [N.Text "rd_reset_busy"]
+    --   , N.BBTemplate [N.Text "rd_empty"]
+    --   , N.BBTemplate [N.Text "rd_data_count"]
+    --   , N.BBTemplate [N.Text "rd_dout"]
+    --   ]
+    }
+
+  bb :: Identifier -> DcConfig TermLiteralSNat -> BlackBox
+  bb dcFifoName dcConfig = BBFunction (show 'dcFifoTF) 0 (dcFifoTF dcFifoName dcConfig)
+
+-- | Instantiate IP generate with 'dcFifoTclTF'.
+dcFifoTF :: Identifier -> DcConfig TermLiteralSNat -> TemplateFunction
+dcFifoTF dcFifoName DcConfig{..} = TemplateFunction [] (const True) $ \bbCtx -> do
+  let
+    TermLiteralSNat (fromIntegral -> depth) = dcDepth
+
+    [  _knownNatN, _knownDomainWrite, _knownDomainRead, _knownNatDepth
+     , _constraint1, _constraint2
+     , _dcConfig
+     , wClk, rClk, rst, wDataM
+     , rEnable
+     ] = map fst (DSL.tInputs bbCtx)
+
+    [tResult] = map DSL.ety (DSL.tResults bbCtx)
+
+  dcFifoInstName <- Id.makeBasic "dcfifo_inst"
+
+  -- -1 for maybe
+  let dataTy = N.BitVector (DSL.tySize (DSL.ety wDataM) - 1)
+  let
+    blockInps =
+      [ ("rst", N.Bit)
+      , ("wr_clk", N.Bit)
+      , ("rd_clk", N.Bit)
+      , ("din", dataTy)
+      , ("wr_en", N.Bit)
+      , ("rd_en", N.Bit)
+      ]
+    blockOuts = catMaybes
+      [ Just ("dout", dataTy)
+      , Just ("full", N.Bit)
+      , Just ("empty", N.Bit)
+      , Just ("wr_rst_busy", N.Bit)
+      , Just ("rd_rst_busy", N.Bit)
+      , dcReadDataCount `orNothing` ("rd_data_count", N.BitVector depth)
+      , dcWriteDataCount `orNothing` ("wr_data_count", N.BitVector depth)
+      , dcUnderflow `orNothing` ("underflow", N.Bit)
+      , dcOverflow `orNothing` ("overflow", N.Bit)
+      ]
+
+  DSL.declarationReturn bbCtx "dcfifo_inst_block" $ do
+
+    DSL.compInBlock "dcfifo" blockInps blockOuts
+
+    (wEna, wData) <- DSL.deconstructMaybe wDataM ("wr_ena", "rd_din")
+
+    wrResetBusy <- DSL.declare "wr_reset_busy" N.Bit
+    wrFull      <- DSL.declare "wr_full"       N.Bit
+    wrOver      <- DSL.declare "wr_overflow"   N.Bit
+    wrDataCount <- DSL.declare "wr_data_count" (N.BitVector depth)
+    rdResetBusy <- DSL.declare "rd_reset_busy" N.Bit
+    rdEmpty     <- DSL.declare "rd_empty"      N.Bit
+    rdDataCount <- DSL.declare "rd_data_count" (N.BitVector depth)
+    rdUnder     <- DSL.declare "rd_underflow"  N.Bit
+    rdDout      <- DSL.declare "rd_dout"       (DSL.ety wData)
+
+    wrFullBool  <- DSL.boolFromBit "wr_full_bool" wrFull
+    rdEmptyBool <- DSL.boolFromBit "rd_empty_bool" rdEmpty
+    wrOverBool  <- DSL.boolFromBit "wr_over_bool" wrOver
+    rdUnderBool <- DSL.boolFromBit "rd_under_bool" rdUnder
+
+    rEnableBit <- DSL.boolToBit "rd_enable" rEnable
+
+    wrDataCountUnsigned <- DSL.unsignedFromBitVector "wr_data_count_unsigned" wrDataCount
+    rdDataCountUnsigned <- DSL.unsignedFromBitVector "rd_data_count_unsigned" rdDataCount
+
+    wrResetBusyBool <- DSL.boolFromBit "wr_reset_busy_bool" wrResetBusy
+    rdResetBusyBool <- DSL.boolFromBit "rd_reset_busy_bool" rdResetBusy
+
+    let
+      inps =
+        [ ("rst", rst)
+        , ("wr_clk", wClk)
+        , ("rd_clk", rClk)
+        , ("din", wData)
+        , ("wr_en", wEna)
+        , ("rd_en", rEnableBit)
+        ]
+
+      outs = catMaybes
+        [ Just ("wr_rst_busy", wrResetBusy)
+        , Just ("rd_rst_busy", rdResetBusy)
+        , Just ("full", wrFull)
+        , Just ("empty", rdEmpty)
+        , Just ("dout", rdDout)
+        , dcReadDataCount  `orNothing` ("rd_data_count", rdDataCount)
+        , dcWriteDataCount `orNothing` ("wr_data_count", wrDataCount)
+        , dcUnderflow      `orNothing` ("underflow", rdUnder)
+        , dcOverflow       `orNothing` ("overflow", wrOver)
+        ]
+
+      DSL.TExpr _ (N.Identifier rdDataCountId Nothing) = rdDataCount
+      DSL.TExpr _ (N.Identifier wrDataCountId Nothing) = wrDataCount
+
+    unless dcReadDataCount $
+      DSL.addDeclaration (N.Assignment rdDataCountId N.Cont (DSL.eex (DSL.bvLit depth 0)))
+
+    unless dcWriteDataCount $
+      DSL.addDeclaration (N.Assignment wrDataCountId N.Cont (DSL.eex (DSL.bvLit depth 0)))
+
+    DSL.instDecl N.Empty dcFifoName dcFifoInstName [] inps outs
+
+    pure [DSL.constructProduct
+      tResult
+      [ wrResetBusyBool, wrFullBool,  wrOverBool, wrDataCountUnsigned
+      , rdResetBusyBool, rdEmptyBool, rdUnderBool, rdDataCountUnsigned, rdDout
+      ]]
+
+-- | Generate TCL file that calls Xilinx's `create_ip` with the options supplied
+-- in the second argument.
+dcFifoTclTF :: Int -> Identifier -> DcConfig TermLiteralSNat -> TemplateFunction
+dcFifoTclTF width dcFifoName DcConfig{..} =
+  TemplateFunction [] (const True) (const (pure (renderTcl ipConfig)))
+ where
+  ipConfig = (defIpConfig "fifo_generator" "13.2" dcFifoName){properties = props}
+  TermLiteralSNat depth = dcDepth
+
+  props =
+    [ ("Fifo_Implementation",    show dcImplementation)
+    , ("Performance_Options",    show dcReadMode)
+    , ("Reset_Type",             "Asynchronous_Reset")
+    , ("Full_Flags_Reset_Value", "1")
+    , ("Input_Data_Width",       show width)
+    , ("Output_Data_Width",      show width)
+    , ("Write_Data_Count",       toTclBool dcWriteDataCount)
+    , ("Overflow_Flag",          toTclBool dcOverflow)
+    , ("Write_Data_Count_Width", show depth)
+    , ("Read_Data_Count",        toTclBool dcReadDataCount)
+    , ("Underflow_Flag",         toTclBool dcUnderflow)
+    , ("Read_Data_Count_Width",  show depth)
+    , ("Enable_Safety_Circuit",  toTclBool True)
+    ]