{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 806
#define FIELD ^
#endif
module Clash.Netlist.Types
( Declaration (..,NetDecl)
, module Clash.Netlist.Types
)
where
import Control.DeepSeq
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.Reader (ReaderT, MonadReader)
import Control.Monad.State as Lazy (State)
import Control.Monad.State.Strict as Strict
(State,MonadIO, MonadState, StateT)
import Data.Bits (testBit)
import Data.Binary (Binary(..))
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import Data.IntMap (IntMap, empty)
import qualified Data.Set as Set
import Data.Text (Text, pack)
import Data.Typeable (Typeable)
import Data.Text.Prettyprint.Doc.Extra (Doc)
import GHC.Generics (Generic)
import Language.Haskell.TH.Syntax (Lift)
import SrcLoc (SrcSpan)
import Clash.Annotations.TopEntity (TopEntity)
import Clash.Backend (Backend)
import Clash.Core.Type (Type)
import Clash.Core.Var (Attr')
import Clash.Core.TyCon (TyConMap)
import Clash.Core.VarEnv (VarEnv)
import Clash.Driver.Types (BindingMap, ClashOpts)
import Clash.Netlist.BlackBox.Types (BlackBoxTemplate)
import Clash.Netlist.Id (IdType)
import Clash.Primitives.Types (CompiledPrimMap)
import Clash.Signal.Internal
(ResetPolarity, ActiveEdge, ResetKind, InitBehavior)
import Clash.Util (makeLenses)
import Clash.Annotations.BitRepresentation.Internal
(CustomReprs, DataRepr', ConstrRepr')
newtype NetlistMonad a =
NetlistMonad { runNetlist :: StateT NetlistState (ReaderT NetlistEnv IO) a }
deriving newtype (Functor, Monad, Applicative, MonadReader NetlistEnv,
MonadState NetlistState, MonadIO, MonadFail)
type HWMap = HashMap Type (Either String FilteredHWType)
data NetlistEnv
= NetlistEnv
{ _prefixName :: Identifier
, _suffixName :: Identifier
, _setName :: Maybe Identifier
}
data NetlistState
= NetlistState
{ _bindings :: BindingMap
, _varCount :: !Int
, _components :: VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component)
, _primitives :: CompiledPrimMap
, _typeTranslator :: CustomReprs -> TyConMap -> Type
-> Strict.State HWMap (Maybe (Either String FilteredHWType))
, _tcCache :: TyConMap
, _curCompNm :: !(Identifier,SrcSpan)
, _intWidth :: Int
, _mkIdentifierFn :: IdType -> Identifier -> Identifier
, _extendIdentifierFn :: IdType -> Identifier -> Identifier -> Identifier
, _seenIds :: HashMap Identifier Word
, _seenComps :: HashMap Identifier Word
, _seenPrimitives :: Set.Set Text
, _componentNames :: VarEnv Identifier
, _topEntityAnns :: VarEnv (Type, Maybe TopEntity)
, _hdlDir :: FilePath
, _curBBlvl :: Int
, _componentPrefix :: (Maybe Identifier,Maybe Identifier)
, _customReprs :: CustomReprs
, _clashOpts :: ClashOpts
, _isTestBench :: Bool
, _backEndITE :: Bool
, _htyCache :: HWMap
}
type Identifier = Text
type Comment = Text
data Component
= Component
{ componentName :: !Identifier
, inputs :: [(Identifier,HWType)]
, outputs :: [(WireOrReg,(Identifier,HWType))]
, declarations :: [Declaration]
}
deriving Show
instance NFData Component where
rnf c = case c of
Component nm inps outps decls -> rnf nm `seq` rnf inps `seq`
rnf outps `seq` rnf decls
type Size = Int
type IsVoid = Bool
data FilteredHWType =
FilteredHWType HWType [[(IsVoid, FilteredHWType)]]
deriving (Eq, Show)
data HWType
= Void (Maybe HWType)
| String
| Integer
| Bool
| Bit
| BitVector !Size
| Index !Integer
| Signed !Size
| Unsigned !Size
| Vector !Size !HWType
| RTree !Size !HWType
| Sum !Identifier [Identifier]
| Product !Identifier (Maybe [Text]) [HWType]
| SP !Identifier [(Identifier,[HWType])]
| Clock !Identifier
| Reset !Identifier
| BiDirectional !PortDirection !HWType
| CustomSP !Identifier !DataRepr' !Size [(ConstrRepr', Identifier, [HWType])]
| CustomSum !Identifier !DataRepr' !Size [(ConstrRepr', Identifier)]
| Annotated [Attr'] !HWType
| KnownDomain !Identifier !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity
deriving (Eq, Ord, Show, Generic, NFData, Hashable)
hwTypeAttrs :: HWType -> [Attr']
hwTypeAttrs (Annotated attrs _type) = attrs
hwTypeAttrs _ = []
data Declaration
= Assignment
!Identifier
!Expr
| CondAssignment
!Identifier
!HWType
!Expr
!HWType
[(Maybe Literal,Expr)]
| InstDecl
EntityOrComponent
(Maybe Comment)
!Identifier
!Identifier
[(Expr,HWType,Expr)]
[(Expr,PortDirection,HWType,Expr)]
| BlackBoxD
!Text
[BlackBoxTemplate]
[BlackBoxTemplate]
[((Text,Text),BlackBox)]
!BlackBox
BlackBoxContext
| NetDecl'
(Maybe Comment)
WireOrReg
!Identifier
(Either Identifier HWType)
| TickDecl Comment
deriving Show
data EntityOrComponent = Entity | Comp | Empty
deriving Show
data WireOrReg = Wire | Reg
deriving (Show,Generic)
instance NFData WireOrReg
pattern NetDecl
:: Maybe Comment
-> Identifier
-> HWType
-> Declaration
pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty)
where
NetDecl note d ty = NetDecl' note Wire d (Right ty)
data PortDirection = In | Out
deriving (Eq,Ord,Show,Generic,NFData,Hashable)
instance NFData Declaration where
rnf a = a `seq` ()
data Modifier
= Indexed (HWType,Int,Int)
| DC (HWType,Int)
| VecAppend
| RTreeAppend
| Sliced (HWType,Int,Int)
| Nested Modifier Modifier
deriving Show
data Expr
= Literal !(Maybe (HWType,Size)) !Literal
| DataCon !HWType !Modifier [Expr]
| Identifier !Identifier !(Maybe Modifier)
| DataTag !HWType !(Either Identifier Identifier)
| BlackBoxE
!Text
[BlackBoxTemplate]
[BlackBoxTemplate]
[((Text,Text),BlackBox)]
!BlackBox
!BlackBoxContext
!Bool
| ConvBV (Maybe Identifier) HWType Bool Expr
| IfThenElse Expr Expr Expr
deriving Show
data Literal
= NumLit !Integer
| BitLit !Bit
| BitVecLit !Integer !Integer
| BoolLit !Bool
| VecLit [Literal]
| StringLit !String
deriving (Eq,Show)
data Bit
= H
| L
| U
| Z
deriving (Eq,Show,Typeable,Lift)
toBit :: Integer
-> Integer
-> Bit
toBit m i = if testBit m 0
then U
else if testBit i 0 then H else L
data BlackBoxContext
= Context
{ bbName :: Text
, bbResult :: (Expr,HWType)
, bbInputs :: [(Expr,HWType,Bool)]
, bbFunctions :: IntMap (Either BlackBox (Identifier,[Declaration])
,WireOrReg
,[BlackBoxTemplate]
,[BlackBoxTemplate]
,[((Text,Text),BlackBox)]
,BlackBoxContext)
, bbQsysIncName :: [Identifier]
, bbLevel :: Int
, bbCompName :: Identifier
}
deriving Show
type BBName = String
type BBHash = Int
data BlackBox
= BBTemplate BlackBoxTemplate
| BBFunction BBName BBHash TemplateFunction
deriving (Generic, NFData, Binary)
data TemplateFunction where
TemplateFunction
:: [Int]
-> (BlackBoxContext -> Bool)
-> (forall s . Backend s => BlackBoxContext -> Lazy.State s Doc)
-> TemplateFunction
instance Show BlackBox where
show (BBTemplate t) = show t
show (BBFunction nm hsh _) =
"<TemplateFunction(nm=" ++ show nm ++ ", hash=" ++ show hsh ++ ")>"
instance NFData TemplateFunction where
rnf (TemplateFunction is f _) = rnf is `seq` f `seq` ()
instance Binary TemplateFunction where
put (TemplateFunction is _ _ ) = put is
get = (\is -> TemplateFunction is err err) <$> get
where err = const $ error "TemplateFunction functions can't be preserved by serialisation"
emptyBBContext :: Text -> BlackBoxContext
emptyBBContext n
= Context
{ bbName = n
, bbResult = (Identifier (pack "__EMPTY__") Nothing, Void Nothing)
, bbInputs = []
, bbFunctions = empty
, bbQsysIncName = []
, bbLevel = (-1)
, bbCompName = pack "__NOCOMPNAME__"
}
makeLenses ''NetlistEnv
makeLenses ''NetlistState