SynthesisAttributes.hs

{-# 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 = [attrs, signal]
 where
  attrs :< signal :< _ = (0...)

annotateBBF :: HasCallStack => BlackBoxFunction
annotateBBF _isD _primName args _resTys = Lens.view tcCache >>= go
 where
  go tcm
    | ((coreView tcm -> LitTy (NumTy n)) : _) <- rights args
    , Just (SomeNat (Proxy :: Proxy n)) <- someNatVal n
    , (attrs0 : _) <- lefts args
    = case termToDataError attrs0 of
        Left msg -> error msg
        Right attrs1 -> pure $ Right (bbMeta, bb @n (fmap T.pack <$> attrs1))
  go _ = error $ "Unexpected args:\n " <> ppShow args

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

  bb :: KnownNat n => Vec n (Attr Text) -> BlackBox
  bb attrs = BBFunction (show 'annotateTF) 0 (annotateTF attrs)

annotateTF :: HasCallStack => KnownNat n => Vec n (Attr Text) -> TemplateFunction
annotateTF attrs = TemplateFunction usedArguments (const True) (annotateBBTF attrs)

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

annotateBBTF _attrs bbCtx = error $ "Unexpected context:\n " <> ppShow bbCtx