{-|
  Copyright   :  (C) 2023, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Blackbox template functions for
  Clash.Xilinx.ClockGen.{clockWizard,clockWizardDifferential}
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}

module Clash.Primitives.Xilinx.ClockGen
  ( clockWizardTF
  , clockWizardTclTF
  , clockWizardDifferentialTF
  , clockWizardDifferentialTclTF
  ) where

import Control.Monad.State (State)
import Data.List.Infinite (Infinite(..), (...))
import Data.Maybe (fromMaybe)
import Data.String.Interpolate (i)
import qualified Data.Text as T
import Prettyprinter.Interpolate (__di)
import Text.Show.Pretty (ppShow)

import Clash.Signal (periodToHz)

import Clash.Backend (Backend)
import qualified Clash.Netlist.Id as Id
import Clash.Netlist.Types
import Clash.Netlist.Util (stripVoid)
import qualified Clash.Primitives.DSL as DSL
import Data.Text.Extra (showt)
import Data.Text.Prettyprint.Doc.Extra (Doc)

usedArguments :: [Int]
usedArguments :: [Int]
usedArguments = [Int
knownDomIn, Int
clocksCxt, Int
clk, Int
rst]
 where
  Int
knownDomIn
    :< Int
_clocksClass
    :< Int
clocksCxt
    :< Int
_numOutClocks
    :< Int
clk
    :< Int
rst
    :< Infinite Int
_ = (Int
0Int -> Infinite Int
forall a. Enum a => a -> Infinite a
...)

clockWizardTF :: TemplateFunction
clockWizardTF :: TemplateFunction
clockWizardTF =
  [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
usedArguments BlackBoxContext -> Bool
forall b. b -> Bool
valid (Bool -> BlackBoxContext -> State s Doc
forall s. Backend s => Bool -> BlackBoxContext -> State s Doc
clockWizardTemplate Bool
False)
 where
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

clockWizardDifferentialTF :: TemplateFunction
clockWizardDifferentialTF :: TemplateFunction
clockWizardDifferentialTF =
  [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
usedArguments BlackBoxContext -> Bool
forall b. b -> Bool
valid (Bool -> BlackBoxContext -> State s Doc
forall s. Backend s => Bool -> BlackBoxContext -> State s Doc
clockWizardTemplate Bool
True)
 where
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

clockWizardTemplate
  :: Backend s
  => Bool
  -> BlackBoxContext
  -> State s Doc
clockWizardTemplate :: Bool -> BlackBoxContext -> State s Doc
clockWizardTemplate Bool
isDifferential BlackBoxContext
bbCtx
  | [ TExpr
_knownDomIn
    , TExpr
_clocksClass
    , TExpr
_clocksCxt
    , TExpr
_numOutClocks
    , TExpr
clk
    , TExpr
rst
    ] <- ((TExpr, HWType) -> TExpr) -> [(TExpr, HWType)] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (TExpr, HWType) -> TExpr
forall a b. (a, b) -> a
fst (BlackBoxContext -> [(TExpr, HWType)]
DSL.tInputs BlackBoxContext
bbCtx)
  , [TExpr -> HWType
DSL.ety -> HWType
resultTy] <- BlackBoxContext -> [TExpr]
DSL.tResults BlackBoxContext
bbCtx
  , Product Text
_ Maybe [Text]
_ ([HWType] -> [HWType]
forall a. [a] -> [a]
init -> [HWType]
pllOutTys) <- HWType
resultTy
  , [Text
compName] <- BlackBoxContext -> [Text]
bbQsysIncName BlackBoxContext
bbCtx
  = do
      Identifier
clkWizInstName <- Text -> StateT s Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic (Text -> StateT s Identity Identifier)
-> Text -> StateT s Identity Identifier
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"clk_wiz" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ BlackBoxContext -> Maybe Text
bbCtxName BlackBoxContext
bbCtx
      BlackBoxContext
-> Text -> State (BlockState s) [TExpr] -> State s Doc
forall backend.
Backend backend =>
BlackBoxContext
-> Text -> State (BlockState backend) [TExpr] -> State backend Doc
DSL.declarationReturn BlackBoxContext
bbCtx Text
blockName (State (BlockState s) [TExpr] -> State s Doc)
-> State (BlockState s) [TExpr] -> State s Doc
forall a b. (a -> b) -> a -> b
$ do

        TExpr
rstHigh <- Text -> TExpr -> State (BlockState s) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
DSL.unsafeToActiveHigh Text
"reset" TExpr
rst
        [TExpr]
pllOuts <- Text -> [HWType] -> State (BlockState s) [TExpr]
forall backend.
Backend backend =>
Text -> [HWType] -> State (BlockState backend) [TExpr]
DSL.declareN Text
"pllOut" [HWType]
pllOutTys
        TExpr
locked <- Text -> HWType -> State (BlockState s) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
DSL.declare Text
"locked" HWType
Bit
        TExpr
pllLock <- Text -> TExpr -> State (BlockState s) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) TExpr
DSL.boolFromBit Text
"pllLock" TExpr
locked

        let pllOutNames :: [Text]
pllOutNames =
              (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
n -> Text
"clk_out" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
n) [Int
1 .. [HWType] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [HWType]
pllOutTys]
            compInps :: [(Text, HWType)]
compInps = [(Text, HWType)]
compClkInps [(Text, HWType)] -> [(Text, HWType)] -> [(Text, HWType)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"reset", HWType
Bit) ]
            compOuts :: [(Text, HWType)]
compOuts = [Text] -> [HWType] -> [(Text, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
pllOutNames [HWType]
pllOutTys [(Text, HWType)] -> [(Text, HWType)] -> [(Text, HWType)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"locked", HWType
Bit)]
            inps :: [(Text, TExpr)]
inps = TExpr -> [(Text, TExpr)]
forall a. IsString a => TExpr -> [(a, TExpr)]
clkInps TExpr
clk [(Text, TExpr)] -> [(Text, TExpr)] -> [(Text, TExpr)]
forall a. Semigroup a => a -> a -> a
<> [ (Text
"reset", TExpr
rstHigh) ]
            outs :: [(Text, TExpr)]
outs = [Text] -> [TExpr] -> [(Text, TExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
pllOutNames [TExpr]
pllOuts [(Text, TExpr)] -> [(Text, TExpr)] -> [(Text, TExpr)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"locked", TExpr
locked)]

        Text
-> [(Text, HWType)] -> [(Text, HWType)] -> State (BlockState s) ()
forall backend.
Backend backend =>
Text
-> [(Text, HWType)]
-> [(Text, HWType)]
-> State (BlockState backend) ()
DSL.compInBlock Text
compName [(Text, HWType)]
compInps [(Text, HWType)]
compOuts
        EntityOrComponent
-> Identifier
-> Identifier
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState s) ()
forall backend.
Backend backend =>
EntityOrComponent
-> Identifier
-> Identifier
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState backend) ()
DSL.instDecl EntityOrComponent
Empty (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
compName) Identifier
clkWizInstName [] [(Text, TExpr)]
inps [(Text, TExpr)]
outs

        [TExpr] -> State (BlockState s) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [HWType -> [TExpr] -> TExpr
DSL.constructProduct HWType
resultTy ([TExpr]
pllOuts [TExpr] -> [TExpr] -> [TExpr]
forall a. Semigroup a => a -> a -> a
<> [TExpr
pllLock])]
  | Bool
otherwise
  = [Char] -> State s Doc
forall a. HasCallStack => [Char] -> a
error ([Char] -> State s Doc) -> [Char] -> State s Doc
forall a b. (a -> b) -> a -> b
$ BlackBoxContext -> [Char]
forall a. Show a => a -> [Char]
ppShow BlackBoxContext
bbCtx
 where
  blockName :: Text
blockName | Bool
isDifferential = Text
"clockWizardDifferential"
            | Bool
otherwise      = Text
"clockWizard"
  compClkInps :: [(Text, HWType)]
compClkInps | Bool
isDifferential = [ (Text
"clk_in1_p", HWType
Bit)
                                 , (Text
"clk_in1_n", HWType
Bit)
                                 ]
              | Bool
otherwise      = [ (Text
"clk_in1", HWType
Bit) ]
  clkInps :: TExpr -> [(a, TExpr)]
clkInps TExpr
clk
    | Bool
isDifferential
    , DataCon (Product Text
"Clash.Signal.Internal.DiffClock" Maybe [Text]
_ [HWType]
clkTys) Modifier
_ [Expr]
clkEs
      <- TExpr -> Expr
DSL.eex TExpr
clk
    , [clkP :: Expr
clkP@(Identifier Identifier
_ Maybe Modifier
Nothing), clkN :: Expr
clkN@(Identifier Identifier
_ Maybe Modifier
Nothing)] <- [Expr]
clkEs
    , [HWType
clkPTy, HWType
clkNTy] <- [HWType]
clkTys
    = [ (a
"clk_in1_p", HWType -> Expr -> TExpr
DSL.TExpr HWType
clkPTy Expr
clkP)
      , (a
"clk_in1_n", HWType -> Expr -> TExpr
DSL.TExpr HWType
clkNTy Expr
clkN)
      ]
    | Bool -> Bool
not Bool
isDifferential
    = [ (a
"clk_in1", TExpr
clk) ]
    | Bool
otherwise
    = [Char] -> [(a, TExpr)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(a, TExpr)]) -> [Char] -> [(a, TExpr)]
forall a b. (a -> b) -> a -> b
$ BlackBoxContext -> [Char]
forall a. Show a => a -> [Char]
ppShow BlackBoxContext
bbCtx

clockWizardTclTF :: TemplateFunction
clockWizardTclTF :: TemplateFunction
clockWizardTclTF =
  [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
usedArguments BlackBoxContext -> Bool
forall b. b -> Bool
valid (Bool -> BlackBoxContext -> State s Doc
forall s. Backend s => Bool -> BlackBoxContext -> State s Doc
clockWizardTclTemplate Bool
False)
 where
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

clockWizardDifferentialTclTF :: TemplateFunction
clockWizardDifferentialTclTF :: TemplateFunction
clockWizardDifferentialTclTF =
  [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
usedArguments BlackBoxContext -> Bool
forall b. b -> Bool
valid (Bool -> BlackBoxContext -> State s Doc
forall s. Backend s => Bool -> BlackBoxContext -> State s Doc
clockWizardTclTemplate Bool
True)
 where
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

clockWizardTclTemplate
  :: Backend s
  => Bool
  -> BlackBoxContext
  -> State s Doc
clockWizardTclTemplate :: Bool -> BlackBoxContext -> State s Doc
clockWizardTclTemplate Bool
isDifferential BlackBoxContext
bbCtx
  |   (Expr
_,HWType -> HWType
stripVoid -> HWType
kdIn,Bool
_)
    : (Expr, HWType, Bool)
_clocksClass
    : (Expr
_,HWType -> HWType
stripVoid -> Product Text
_ Maybe [Text]
_ ([HWType] -> [HWType]
forall a. [a] -> [a]
init -> [HWType]
kdOuts),Bool
_)
    : [(Expr, HWType, Bool)]
_ <- BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx
  , [Text
compName] <- BlackBoxContext -> [Text]
bbQsysIncName BlackBoxContext
bbCtx
  = let
    clkFreq :: HWType -> Double
clkFreq (KnownDomain Text
_ Integer
p ActiveEdge
_ ResetKind
_ InitBehavior
_ ResetPolarity
_) =
      Natural -> Double
forall a. (HasCallStack, Fractional a) => Natural -> a
periodToHz (Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
p) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6 :: Double
    clkFreq HWType
_ =
      [Char] -> Double
forall a. HasCallStack => [Char] -> a
error ([Char] -> Double) -> [Char] -> Double
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error: not a KnownDomain\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BlackBoxContext -> [Char]
forall a. Show a => a -> [Char]
ppShow BlackBoxContext
bbCtx

    clkInFreq :: Double
clkInFreq = HWType -> Double
clkFreq HWType
kdIn
    clkOutFreqs :: [Double]
clkOutFreqs = (HWType -> Double) -> [HWType] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Double
clkFreq [HWType]
kdOuts

    clkOutProps :: [Text]
clkOutProps = [[Text]] -> [Text]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
      [ [ [i|CONFIG.CLKOUT#{n}_USED true \\|]
        , [i|CONFIG.CLKOUT#{n}_REQUESTED_OUT_FREQ #{clkOutFreq} \\|]
        ]
      | (Double
clkOutFreq, Word
n) <- [Double] -> [Word] -> [(Double, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
clkOutFreqs [(Word
1::Word)..]
      ]

    differentialPinString :: T.Text
    differentialPinString :: Text
differentialPinString = if Bool
isDifferential
      then Text
"Differential_clock_capable_pin"
      else Text
"Single_ended_clock_capable_pin"

    propIndent :: Text
propIndent = Int -> Text -> Text
T.replicate Int
18 Text
" "
    props :: Text
props = Text -> [Text] -> Text
T.intercalate Text
"\n"  ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
propIndent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [ [i|CONFIG.PRIM_SOURCE #{differentialPinString} \\|]
      , [i|CONFIG.PRIM_IN_FREQ #{clkInFreq} \\|]
      ] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
clkOutProps

    bbText :: Doc ann
bbText = [__di|
      namespace eval $tclIface {
        variable api 1
        variable scriptPurpose createIp
        variable ipName {#{compName}}

        proc createIp {ipName0 args} {
          create_ip \\
            -name clk_wiz \\
            -vendor xilinx.com \\
            -library ip \\
            -version 6.0 \\
            -module_name $ipName0 \\
            {*}$args

          set_property \\
            -dict [list \\
      #{props}
                  ] [get_ips $ipName0]
          return
        }
      }|]
    in Doc -> State s Doc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Doc
forall ann. Doc ann
bbText
  | Bool
otherwise
  = [Char] -> State s Doc
forall a. HasCallStack => [Char] -> a
error ([Char]
"clockWizardTclTemplate: bad bbContext: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BlackBoxContext -> [Char]
forall a. Show a => a -> [Char]
show BlackBoxContext
bbCtx)