{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Primitives.Annotations.SynthesisAttributes where

import Prelude

import Control.Monad.State (State)
import Data.Either (lefts, rights)
import Data.List.Infinite((...), Infinite((:<)))
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc.Extra (Doc)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (someNatVal)
import GHC.TypeNats (KnownNat, SomeNat(..))
import Text.Show.Pretty (ppShow)

import qualified Control.Lens as Lens
import qualified Data.Text as T

import Clash.Annotations.SynthesisAttributes
import Clash.Backend (Backend)
import Clash.Core.TermLiteral (termToDataError)
import Clash.Core.Type (Type(LitTy), LitTy(NumTy), coreView)
import Clash.Netlist.BlackBox.Types
import Clash.Netlist.Types
import Clash.Sized.Vector (Vec, toList)

import qualified Clash.Primitives.DSL as DSL

usedArguments :: [Int]
usedArguments :: [Int]
usedArguments = [Int
attrs, Int
signal]
 where
  Int
attrs :< Int
signal :< Infinite Int
_ = (Int
0Int -> Infinite Int
forall a. Enum a => a -> Infinite a
...)

annotateBBF :: HasCallStack => BlackBoxFunction
annotateBBF :: BlackBoxFunction
annotateBBF Bool
_isD Text
_primName [Either Term Type]
args [Type]
_resTys = Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap NetlistEnv TyConMap
Getter NetlistEnv TyConMap
tcCache NetlistMonad TyConMap
-> (TyConMap
    -> NetlistMonad (Either String (BlackBoxMeta, BlackBox)))
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= TyConMap -> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (f :: Type -> Type) a.
Applicative f =>
TyConMap -> f (Either a (BlackBoxMeta, BlackBox))
go
 where
  go :: TyConMap -> f (Either a (BlackBoxMeta, BlackBox))
go TyConMap
tcm
    | ((TyConMap -> Type -> Type
coreView TyConMap
tcm -> LitTy (NumTy Integer
n)) : [Type]
_) <- [Either Term Type] -> [Type]
forall a b. [Either a b] -> [b]
rights [Either Term Type]
args
    , Just (SomeNat (Proxy n
Proxy :: Proxy n)) <- Integer -> Maybe SomeNat
someNatVal Integer
n
    , (Term
attrs0 : [Term]
_) <- [Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args
    = case Term -> Either String (Vec n (Attr String))
forall a. TermLiteral a => Term -> Either String a
termToDataError Term
attrs0 of
        Left String
msg -> String -> f (Either a (BlackBoxMeta, BlackBox))
forall a. HasCallStack => String -> a
error String
msg
        Right Vec n (Attr String)
attrs1 -> Either a (BlackBoxMeta, BlackBox)
-> f (Either a (BlackBoxMeta, BlackBox))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either a (BlackBoxMeta, BlackBox)
 -> f (Either a (BlackBoxMeta, BlackBox)))
-> Either a (BlackBoxMeta, BlackBox)
-> f (Either a (BlackBoxMeta, BlackBox))
forall a b. (a -> b) -> a -> b
$ (BlackBoxMeta, BlackBox) -> Either a (BlackBoxMeta, BlackBox)
forall a b. b -> Either a b
Right (BlackBoxMeta
bbMeta, Vec n (Attr Text) -> BlackBox
forall (n :: Nat). KnownNat n => Vec n (Attr Text) -> BlackBox
bb @n ((String -> Text) -> Attr String -> Attr Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack (Attr String -> Attr Text)
-> Vec n (Attr String) -> Vec n (Attr Text)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vec n (Attr String)
attrs1))
  go TyConMap
_ = String -> f (Either a (BlackBoxMeta, BlackBox))
forall a. HasCallStack => String -> a
error (String -> f (Either a (BlackBoxMeta, BlackBox)))
-> String -> f (Either a (BlackBoxMeta, BlackBox))
forall a b. (a -> b) -> a -> b
$ String
"Unexpected args:\n " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Either Term Type] -> String
forall a. Show a => a -> String
ppShow [Either Term Type]
args

  bbMeta :: BlackBoxMeta
  bbMeta :: BlackBoxMeta
bbMeta = BlackBoxMeta
emptyBlackBoxMeta{bbKind :: TemplateKind
bbKind = TemplateKind
TDecl}

  bb :: KnownNat n => Vec n (Attr Text) -> BlackBox
  bb :: Vec n (Attr Text) -> BlackBox
bb Vec n (Attr Text)
attrs = String -> Int -> TemplateFunction -> BlackBox
BBFunction (Name -> String
forall a. Show a => a -> String
show 'annotateTF) Int
0 (Vec n (Attr Text) -> TemplateFunction
forall (n :: Nat).
(HasCallStack, KnownNat n) =>
Vec n (Attr Text) -> TemplateFunction
annotateTF Vec n (Attr Text)
attrs)

annotateTF :: HasCallStack => KnownNat n => Vec n (Attr Text) -> TemplateFunction
annotateTF :: Vec n (Attr Text) -> TemplateFunction
annotateTF Vec n (Attr Text)
attrs = [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
usedArguments (Bool -> BlackBoxContext -> Bool
forall a b. a -> b -> a
const Bool
True) (Vec n (Attr Text) -> BlackBoxContext -> State s Doc
forall s (n :: Nat).
(Backend s, KnownNat n, HasCallStack) =>
Vec n (Attr Text) -> BlackBoxContext -> State s Doc
annotateBBTF Vec n (Attr Text)
attrs)

annotateBBTF ::
  (Backend s, KnownNat n, HasCallStack) =>
  Vec n (Attr Text) ->
  BlackBoxContext ->
  State s Doc
annotateBBTF :: Vec n (Attr Text) -> BlackBoxContext -> State s Doc
annotateBBTF Vec n (Attr Text)
attrs0 BlackBoxContext
bbCtx
  | (TExpr
_attrs : TExpr
signal0 : [TExpr]
_) <- ((TExpr, HWType) -> TExpr) -> [(TExpr, HWType)] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (TExpr, HWType) -> TExpr
forall a b. (a, b) -> a
fst ([(TExpr, HWType)] -> [TExpr]) -> [(TExpr, HWType)] -> [TExpr]
forall a b. (a -> b) -> a -> b
$ BlackBoxContext -> [(TExpr, HWType)]
DSL.tInputs 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
"annotate_block" (State (BlockState s) [TExpr] -> State s Doc)
-> State (BlockState s) [TExpr] -> State s Doc
forall a b. (a -> b) -> a -> b
$ do
      let
        attrs1 :: [Attr Text]
attrs1 = Vec n (Attr Text) -> [Attr Text]
forall (n :: Nat) a. Vec n a -> [a]
toList Vec n (Attr Text)
attrs0
        signal1ty :: HWType
signal1ty = [Attr Text] -> HWType -> HWType
Annotated [Attr Text]
attrs1 (TExpr -> HWType
DSL.ety TExpr
signal0)
        signal1 :: TExpr
signal1 = TExpr :: HWType -> Expr -> TExpr
DSL.TExpr{eex :: Expr
DSL.eex=TExpr -> Expr
DSL.eex TExpr
signal0, ety :: HWType
DSL.ety=HWType
signal1ty}
      TExpr
resultExpr <- Text -> TExpr -> State (BlockState s) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
DSL.assign (Maybe Text -> Text
getSignalName (BlackBoxContext -> Maybe Text
bbCtxName BlackBoxContext
bbCtx)) TExpr
signal1
      [TExpr] -> State (BlockState s) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [TExpr
resultExpr]
 where
  -- Return user-friendly name given a context name hint.
  getSignalName :: Maybe T.Text -> T.Text
  getSignalName :: Maybe Text -> Text
getSignalName Maybe Text
Nothing = Text
"result"
  getSignalName (Just Text
"__VOID_TDECL_NOOP__") = Maybe Text -> Text
getSignalName Maybe Text
forall a. Maybe a
Nothing
  getSignalName (Just Text
s) = Text
s

annotateBBTF Vec n (Attr Text)
_attrs BlackBoxContext
bbCtx = String -> State s Doc
forall a. HasCallStack => String -> a
error (String -> State s Doc) -> String -> State s Doc
forall a b. (a -> b) -> a -> b
$ String
"Unexpected context:\n " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BlackBoxContext -> String
forall a. Show a => a -> String
ppShow BlackBoxContext
bbCtx