Types.hs

{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016-2017, Myrtle Software Ltd
                    2018     , Google Inc.
                    2021     , QBayLogic B.V.
                    2022     , Google Inc.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

  Type and instance definitions for Primitive
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Primitives.Types
  ( TemplateSource(..)
  , TemplateKind(..)
  , TemplateFormat(..)
  , BlackBoxFunctionName(..)
  , Primitive(..)
  , UsedArguments(..)
  , GuardedCompiledPrimitive
  , GuardedResolvedPrimitive
  , PrimMap
  , UnresolvedPrimitive
  , ResolvedPrimitive
  , ResolvedPrimMap
  , CompiledPrimitive
  , CompiledPrimMap
  ) where

import {-# SOURCE #-} Clash.Netlist.Types (BlackBox, Usage(..))
import           Clash.Annotations.Primitive  (PrimitiveGuard)
import           Clash.Core.Term (WorkInfo (..))
import           Clash.Netlist.BlackBox.Types
  (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..), RenderVoid(..))
import           Control.Applicative          ((<|>))
import           Control.DeepSeq              (NFData)
import           Control.Monad                (when)
import           Data.Aeson
  (FromJSON (..), Value (..), (.:), (.:?), (.!=))
import           Data.Aeson.Types             (Parser)
import           Data.Binary                  (Binary)
import           Data.Char                    (isUpper, isLower, isAlphaNum)
import           Data.Either                  (lefts)
import           Data.Hashable                (Hashable)
import qualified Data.HashMap.Strict          as H
import           Data.List                    (intercalate)
import           Data.Maybe                   (isJust)
import qualified Data.Text                    as S
import           Data.Text.Lazy               (Text)
import           GHC.Generics                 (Generic)
import           GHC.Stack                    (HasCallStack)
import           Text.Read                    (readMaybe)

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif

-- | An unresolved primitive still contains pointers to files.
type UnresolvedPrimitive = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe TemplateSource) (Maybe S.Text) (Maybe TemplateSource)

-- | A parsed primitive does not contain pointers to filesystem files anymore,
-- but holds uncompiled @BlackBoxTemplate@s and @BlackBoxFunction@s.
type ResolvedPrimitive        = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe Text) () (Maybe Text)
type GuardedResolvedPrimitive = PrimitiveGuard ResolvedPrimitive
type ResolvedPrimMap          = PrimMap GuardedResolvedPrimitive

-- | A compiled primitive has compiled all templates and functions from its
-- @ResolvedPrimitive@ counterpart. The Int in the tuple is a hash of the
-- (uncompiled) BlackBoxFunction.
type CompiledPrimitive        = Primitive BlackBoxTemplate BlackBox () (Int, BlackBoxFunction)
type GuardedCompiledPrimitive = PrimitiveGuard CompiledPrimitive
type CompiledPrimMap          = PrimMap GuardedCompiledPrimitive

-- | A @PrimMap@ maps primitive names to a @Primitive@
type PrimMap a = H.HashMap S.Text a

-- | A BBFN is a parsed version of a fully qualified function name. It is
-- guaranteed to have at least one module name which is not /Main/.
data BlackBoxFunctionName =
  BlackBoxFunctionName [String] String
    deriving (Eq, Generic, NFData, Binary, Hashable)

instance Show BlackBoxFunctionName where
  show (BlackBoxFunctionName mods funcName) =
    "BBFN<" ++ intercalate "." mods ++ "." ++ funcName ++ ">"

-- | Quick and dirty implementation of Text.splitOn for Strings
splitOn :: String -> String -> [String]
splitOn (S.pack -> sep) (S.pack -> str) =
  map S.unpack $ S.splitOn sep str

-- | Parses a string into a list of modules and a function name. I.e., it parses
-- the string 'Clash.Primitives.Types.parseBBFN' to
-- @["Clash", "Primitives",Types"]@ and @"parseBBFN"@.
-- The result is stored as a BlackBoxFunctionName.
parseBBFN
  :: HasCallStack
  => String
  -> Either String BlackBoxFunctionName
parseBBFN bbfn =
  case splitOn "." bbfn of
    []  -> Left $ "Empty function name: " ++ bbfn
    [_] -> Left $ "No module or function defined: " ++ bbfn
    nms ->
      let (mods, func) = (init nms, last nms) in
      let errs = lefts $ checkFunc func : map checkMod mods in
      case errs of
        [] -> Right $ BlackBoxFunctionName mods func
        e:_ -> Left $ "Error while parsing " ++ show bbfn ++ ": " ++ e
  where
    checkMod mod'
      | m':_ <- mod'
      , isLower m' =
          Left $ "Module name cannot start with lowercase: " ++ mod'
      | any (not . isAlphaNum) mod' =
          Left $ "Module name must be alphanumerical: " ++ mod'
      | otherwise =
          Right mod'

    checkFunc func
      | f:_ <- func
      , isUpper f =
          Left $ "Function name must start with lowercase: " ++ func
      | otherwise =
          Right func

data TemplateSource
  = TFile FilePath
  -- ^ Template source stored in file on filesystem
  | TInline Text
  -- ^ Template stored inline
  deriving (Show, Eq, Hashable, Generic, NFData)


data TemplateFormat
  = TTemplate
  | THaskell
  deriving (Show, Generic, Eq, Hashable, NFData)

-- | Data type to indicate what arguments are in use by a BlackBox
data UsedArguments
  = UsedArguments [Int]
  -- ^ Only these are used
  | IgnoredArguments [Int]
  -- ^ All but these are used
  deriving (Show, Generic, Eq, Hashable, NFData, Binary)

-- | Externally defined primitive
data Primitive a b c d
  -- | Primitive template written in a Clash specific templating language
  = BlackBox
  { name      :: !S.Text
    -- ^ Name of the primitive
  , workInfo  :: WorkInfo
    -- ^ Whether the primitive does any work, i.e. takes chip area
  , renderVoid :: RenderVoid
    -- ^ Whether this primitive should be rendered when its result type is
    -- void. Defaults to 'NoRenderVoid'.
  , multiResult :: Bool
    -- ^ Wether this blackbox assigns its results to multiple variables. See
    -- 'Clash.Normalize.Transformations.setupMultiResultPrim'
  , kind      :: TemplateKind
    -- ^ Whether this results in an expression or a declaration
  , warning  :: c
    -- ^ A warning to be outputted when the primitive is instantiated.
    -- This is intended to be used as a warning for primitives that are not
    -- synthesizable, but may also be used for other purposes.
  , outputUsage :: Usage
    -- ^ How the result is assigned in HDL. This is used to determine the
    -- type of declaration used to render the result (wire/reg or
    -- signal/variable). The default usage is continuous assignment.
  , libraries :: [a]
    -- ^ VHDL only: add /library/ declarations for the given names
  , imports   :: [a]
    -- ^ VHDL only: add /use/ declarations for the given names
  , functionPlurality :: [(Int, Int)]  -- Using map ruins Hashable instance
    -- ^ Indicates how often a function will be instantiated in a blackbox. For
    -- example, consider the following higher-order function that creates a tree
    -- structure:
    --
    --   fold :: (a -> a -> a) -> Vec n a -> a
    --
    -- In order to generate HDL for an instance of fold we need log2(n) calls
    -- to the first argument, `a -> a -> a` (plus a few more if n is not a
    -- power of two). Note that this only targets multiple textual instances
    -- of the function. If you can generate the HDL using a for-loop and only
    -- need to call ~INST once, you don't have to worry about this option. See
    -- the blackbox for 'Clash.Sized.Vector.map' for an example of this.
    --
    -- Right now, option can only be generated by BlackBoxHaskell. It cannot be
    -- used within JSON primitives. To see how to use this, see the Haskell
    -- blackbox for 'Clash.Sized.Vector.fold'.
  , includes  :: [((S.Text,S.Text),b)]
    -- ^ Create files to be included with the generated primitive. The fields
    -- are ((name, extension), content), where content is a template of the file
    -- Defaults to @[]@ when not specified in the /.primitives/ file
  , resultNames :: [b]
    -- ^ (Maybe) Control the generated name of the result
  , resultInits :: [b]
    -- ^ (Maybe) Control the initial/power-up value of the result
  , template :: b
    -- ^ Used to indiciate type of template (declaration or expression). Will be
    -- filled with @Template@ or an @Either decl expr@.
  }
  -- | Primitive template rendered by a Haskell function (given as raw source code)
  | BlackBoxHaskell
  { name :: !S.Text
    -- ^ Name of the primitive
  , workInfo  :: WorkInfo
    -- ^ Whether the primitive does any work, i.e. takes chip area
  , usedArguments :: UsedArguments
  -- ^ Arguments used by blackbox. Used to remove arguments during normalization.
  , multiResult :: Bool
  -- ^ Wether this blackbox assigns its results to multiple variables. See
  -- 'Clash.Normalize.Transformations.setupMultiResultPrim'
  , functionName :: BlackBoxFunctionName
  , function :: d
  -- ^ Holds blackbox function and its hash, (Int, BlackBoxFunction), in a
  -- CompiledPrimitive.
  }
  -- | A primitive that carries additional information. These are "real"
  -- primitives, hardcoded in the compiler. For example: 'mapSignal' in
  -- @GHC2Core.coreToTerm@.
  | Primitive
  { name     :: !S.Text
    -- ^ Name of the primitive
  , workInfo  :: WorkInfo
    -- ^ Whether the primitive does any work, i.e. takes chip area
  , primSort :: !Text
    -- ^ Additional information
  }
  deriving (Show, Generic, NFData, Binary, Eq, Hashable, Functor)

instance FromJSON UnresolvedPrimitive where
  parseJSON (Object v) =
#if MIN_VERSION_aeson(2,0,0)
    case KeyMap.toList v of
#else
    case H.toList v of
#endif
      [(conKey,Object conVal)] ->
        case conKey of
          "BlackBoxHaskell"  -> do
            usedArgs <- conVal .:? "usedArguments"
            ignoredArgs <- conVal .:? "ignoredArguments"
            args <-
              case (usedArgs, ignoredArgs) of
                (Nothing, Nothing) -> pure (IgnoredArguments [])
                (Just a, Nothing) -> pure (UsedArguments a)
                (Nothing, Just a) -> pure (IgnoredArguments a)
                (Just _, Just _) ->
                  fail "[8] Don't use both 'usedArguments' and 'ignoredArguments'"

            name' <- conVal .: "name"
            wf    <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable)
            fName <- conVal .: "templateFunction"
            isMultiResult <- conVal .:? "multiResult" .!= False
            templ <- (Just . TInline <$> conVal .: "template")
                 <|> (Just . TFile   <$> conVal .: "file")
                 <|> (pure Nothing)
            fName' <- either fail return (parseBBFN fName)
            return (BlackBoxHaskell name' wf args isMultiResult fName' templ)
          "BlackBox"  -> do
            outReg <- conVal .:? "outputReg" :: Parser (Maybe Bool)

            when (isJust outReg) .
              fail $ mconcat
                [ "[9] 'outputReg' is no longer a recognized key.\n"
                , "Use 'outputUsage: Continuous|NonBlocking|Blocking' instead."
                ]

            BlackBox <$> conVal .: "name"
                     <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable
                     <*> conVal .:? "renderVoid" .!= NoRenderVoid
                     <*> conVal .:? "multiResult" .!= False
                     <*> (conVal .: "kind" >>= parseTemplateKind)
                     <*> conVal .:? "warning"
                     <*> conVal .:? "outputUsage" .!= Cont
                     <*> conVal .:? "libraries" .!= []
                     <*> conVal .:? "imports" .!= []
                     <*> pure [] -- functionPlurality not supported in json
                     <*> (conVal .:? "includes" .!= [] >>= traverse parseInclude)
                     <*> (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= []
                     <*> (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= []
                     <*> parseTemplate conVal
          "Primitive" ->
            Primitive <$> conVal .: "name"
                      <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable
                      <*> conVal .: "primType"

          e -> fail $ "[1] Expected: BlackBox or Primitive object, got: " ++ show e
      e -> fail $ "[2] Expected: BlackBox or Primitive object, got: " ++ show e
    where
      parseTemplate c =
        (,) <$> ((,) <$> (c .:? "format" >>= traverse parseTemplateFormat) .!= TTemplate
                     <*> (c .:? "templateFunction" >>= traverse parseBBFN') .!= defTemplateFunction)
            <*> (Just . TInline <$> c .: "template" <|>
                 Just . TFile   <$> c .: "file" <|>
                 pure Nothing)

      parseInclude c =
        (,) <$> ((,) <$> c .: "name" <*> c .: "extension")
            <*> parseTemplate c

      parseTemplateKind (String "Declaration") = pure TDecl
      parseTemplateKind (String "Expression")  = pure TExpr
      parseTemplateKind c = fail ("[4] Expected: Declaration or Expression, got " ++ show c)

      parseTemplateFormat (String "Template") = pure TTemplate
      parseTemplateFormat (String "Haskell")  = pure THaskell
      parseTemplateFormat c = fail ("[5] unexpected format: " ++ show c)

      parseWorkInfo (String "Constant") = pure (Just WorkConstant)
      parseWorkInfo (String "Never")    = pure (Just WorkNever)
      parseWorkInfo (String "Variable") = pure (Just WorkVariable)
      parseWorkInfo (String "Always")   = pure (Just WorkAlways)
      parseWorkInfo (parseWorkIdentity -> wi@Just{}) = pure wi
      parseWorkInfo c = fail ("[6] unexpected workInfo: " ++ show c)

      parseWorkIdentity arg = do
        String str   <- return arg
        [iStr,xsStr] <- words . S.unpack <$> S.stripPrefix "Identity" str
        WorkIdentity <$> readMaybe iStr <*> readMaybe xsStr

      parseBBFN' = either fail return . parseBBFN

      defTemplateFunction = BlackBoxFunctionName ["Template"] "template"

      parseResult (Object c) =
        Just . pure <$> parseTemplate c
      parseResult e = fail $ "[7] unexpected result: " ++ show e

  parseJSON unexpected =
    fail $ "[3] Expected: BlackBox or Primitive object, got: " ++ show unexpected