{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Verismith.Verilog.AST
(
SourceInfo(..)
, infoTop
, infoSrc
, Verilog(..)
, Identifier(..)
, Delay(..)
, Event(..)
, BinaryOperator(..)
, UnaryOperator(..)
, Task(..)
, taskName
, taskExpr
, LVal(..)
, regId
, regExprId
, regExpr
, regSizeId
, regSizeRange
, regConc
, PortDir(..)
, PortType(..)
, Port(..)
, portType
, portSigned
, portSize
, portName
, Expr(..)
, ConstExpr(..)
, ConstExprF(..)
, constToExpr
, exprToConst
, Range(..)
, constNum
, constParamId
, constConcat
, constUnOp
, constPrim
, constLhs
, constBinOp
, constRhs
, constCond
, constTrue
, constFalse
, constStr
, Assign(..)
, assignReg
, assignDelay
, assignExpr
, ContAssign(..)
, contAssignNetLVal
, contAssignExpr
, Parameter(..)
, paramIdent
, paramValue
, LocalParam(..)
, localParamIdent
, localParamValue
, Statement(..)
, statDelay
, statDStat
, statEvent
, statEStat
, statements
, stmntBA
, stmntNBA
, stmntTask
, stmntSysTask
, stmntCondExpr
, stmntCondTrue
, stmntCondFalse
, forAssign
, forExpr
, forIncr
, forStmnt
, ModDecl(..)
, modId
, modOutPorts
, modInPorts
, modItems
, modParams
, ModItem(..)
, modContAssign
, modInstId
, modInstName
, modInstConns
, _Initial
, _Always
, paramDecl
, localParamDecl
, traverseModItem
, declDir
, declPort
, declVal
, ModConn(..)
, modConnName
, modExpr
, aModule
, getModule
, getSourceId
, mainModule
)
where
import Control.DeepSeq (NFData)
import Control.Lens hiding ((<|))
import Data.Data
import Data.Data.Lens
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.String (IsString, fromString)
import Data.Text (Text, pack)
import Data.Traversable (sequenceA)
import GHC.Generics (Generic)
import Verismith.Verilog.BitVec
newtype Identifier = Identifier { getIdentifier :: Text }
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance IsString Identifier where
fromString = Identifier . pack
instance Semigroup Identifier where
Identifier a <> Identifier b = Identifier $ a <> b
instance Monoid Identifier where
mempty = Identifier mempty
newtype Delay = Delay { _getDelay :: Int }
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Num Delay where
Delay a + Delay b = Delay $ a + b
Delay a - Delay b = Delay $ a - b
Delay a * Delay b = Delay $ a * b
negate (Delay a) = Delay $ negate a
abs (Delay a) = Delay $ abs a
signum (Delay a) = Delay $ signum a
fromInteger = Delay . fromInteger
data Event = EId {-# UNPACK #-} !Identifier
| EExpr !Expr
| EAll
| EPosEdge {-# UNPACK #-} !Identifier
| ENegEdge {-# UNPACK #-} !Identifier
| EOr !Event !Event
| EComb !Event !Event
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Plated Event where
plate = uniplate
data BinaryOperator = BinPlus
| BinMinus
| BinTimes
| BinDiv
| BinMod
| BinEq
| BinNEq
| BinCEq
| BinCNEq
| BinLAnd
| BinLOr
| BinLT
| BinLEq
| BinGT
| BinGEq
| BinAnd
| BinOr
| BinXor
| BinXNor
| BinXNorInv
| BinPower
| BinLSL
| BinLSR
| BinASL
| BinASR
deriving (Eq, Show, Ord, Data, Generic, NFData)
data UnaryOperator = UnPlus
| UnMinus
| UnLNot
| UnNot
| UnAnd
| UnNand
| UnOr
| UnNor
| UnXor
| UnNxor
| UnNxorInv
deriving (Eq, Show, Ord, Data, Generic, NFData)
data Expr = Number {-# UNPACK #-} !BitVec
| Id {-# UNPACK #-} !Identifier
| VecSelect {-# UNPACK #-} !Identifier !Expr
| RangeSelect {-# UNPACK #-} !Identifier !Range
| Concat !(NonEmpty Expr)
| UnOp !UnaryOperator !Expr
| BinOp !Expr !BinaryOperator !Expr
| Cond !Expr !Expr !Expr
| Appl !Identifier !Expr
| Str {-# UNPACK #-} !Text
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Num Expr where
a + b = BinOp a BinPlus b
a - b = BinOp a BinMinus b
a * b = BinOp a BinTimes b
negate = UnOp UnMinus
abs = undefined
signum = undefined
fromInteger = Number . fromInteger
instance Semigroup Expr where
(Concat a) <> (Concat b) = Concat $ a <> b
(Concat a) <> b = Concat $ a <> (b :| [])
a <> (Concat b) = Concat $ a <| b
a <> b = Concat $ a <| b :| []
instance Monoid Expr where
mempty = Number 0
instance IsString Expr where
fromString = Str . fromString
instance Plated Expr where
plate = uniplate
data ConstExpr = ConstNum { _constNum :: {-# UNPACK #-} !BitVec }
| ParamId { _constParamId :: {-# UNPACK #-} !Identifier }
| ConstConcat { _constConcat :: !(NonEmpty ConstExpr) }
| ConstUnOp { _constUnOp :: !UnaryOperator
, _constPrim :: !ConstExpr
}
| ConstBinOp { _constLhs :: !ConstExpr
, _constBinOp :: !BinaryOperator
, _constRhs :: !ConstExpr
}
| ConstCond { _constCond :: !ConstExpr
, _constTrue :: !ConstExpr
, _constFalse :: !ConstExpr
}
| ConstStr { _constStr :: {-# UNPACK #-} !Text }
deriving (Eq, Show, Ord, Data, Generic, NFData)
constToExpr :: ConstExpr -> Expr
constToExpr (ConstNum a ) = Number a
constToExpr (ParamId a ) = Id a
constToExpr (ConstConcat a ) = Concat $ fmap constToExpr a
constToExpr (ConstUnOp a b ) = UnOp a $ constToExpr b
constToExpr (ConstBinOp a b c) = BinOp (constToExpr a) b $ constToExpr c
constToExpr (ConstCond a b c) =
Cond (constToExpr a) (constToExpr b) $ constToExpr c
constToExpr (ConstStr a) = Str a
exprToConst :: Expr -> ConstExpr
exprToConst (Number a ) = ConstNum a
exprToConst (Id a ) = ParamId a
exprToConst (Concat a ) = ConstConcat $ fmap exprToConst a
exprToConst (UnOp a b ) = ConstUnOp a $ exprToConst b
exprToConst (BinOp a b c) = ConstBinOp (exprToConst a) b $ exprToConst c
exprToConst (Cond a b c) =
ConstCond (exprToConst a) (exprToConst b) $ exprToConst c
exprToConst (Str a) = ConstStr a
exprToConst _ = error "Not a constant expression"
instance Num ConstExpr where
a + b = ConstBinOp a BinPlus b
a - b = ConstBinOp a BinMinus b
a * b = ConstBinOp a BinTimes b
negate = ConstUnOp UnMinus
abs = undefined
signum = undefined
fromInteger = ConstNum . fromInteger
instance Semigroup ConstExpr where
(ConstConcat a) <> (ConstConcat b) = ConstConcat $ a <> b
(ConstConcat a) <> b = ConstConcat $ a <> (b :| [])
a <> (ConstConcat b) = ConstConcat $ a <| b
a <> b = ConstConcat $ a <| b :| []
instance Monoid ConstExpr where
mempty = ConstNum 0
instance IsString ConstExpr where
fromString = ConstStr . fromString
instance Plated ConstExpr where
plate = uniplate
data Task = Task { _taskName :: {-# UNPACK #-} !Identifier
, _taskExpr :: [Expr]
} deriving (Eq, Show, Ord, Data, Generic, NFData)
data LVal = RegId { _regId :: {-# UNPACK #-} !Identifier }
| RegExpr { _regExprId :: {-# UNPACK #-} !Identifier
, _regExpr :: !Expr
}
| RegSize { _regSizeId :: {-# UNPACK #-} !Identifier
, _regSizeRange :: {-# UNPACK #-} !Range
}
| RegConcat { _regConc :: [Expr] }
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance IsString LVal where
fromString = RegId . fromString
data PortDir = PortIn
| PortOut
| PortInOut
deriving (Eq, Show, Ord, Data, Generic, NFData)
data PortType = Wire
| Reg
deriving (Eq, Show, Ord, Data, Generic, NFData)
data Range = Range { rangeMSB :: !ConstExpr
, rangeLSB :: !ConstExpr
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Num Range where
(Range s1 a) + (Range s2 b) = Range (s1 + s2) $ a + b
(Range s1 a) - (Range s2 b) = Range (s1 - s2) . max 0 $ a - b
(Range s1 a) * (Range s2 b) = Range (s1 * s2) $ a * b
negate = undefined
abs = id
signum _ = 1
fromInteger = flip Range 0 . fromInteger . (-) 1
data Port = Port { _portType :: !PortType
, _portSigned :: !Bool
, _portSize :: {-# UNPACK #-} !Range
, _portName :: {-# UNPACK #-} !Identifier
} deriving (Eq, Show, Ord, Data, Generic, NFData)
data ModConn = ModConn { _modExpr :: !Expr }
| ModConnNamed { _modConnName :: {-# UNPACK #-} !Identifier
, _modExpr :: !Expr
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
data Assign = Assign { _assignReg :: !LVal
, _assignDelay :: !(Maybe Delay)
, _assignExpr :: !Expr
} deriving (Eq, Show, Ord, Data, Generic, NFData)
data ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier
, _contAssignExpr :: !Expr
} deriving (Eq, Show, Ord, Data, Generic, NFData)
data Statement = TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay
, _statDStat :: Maybe Statement
}
| EventCtrl { _statEvent :: !Event
, _statEStat :: Maybe Statement
}
| SeqBlock { _statements :: [Statement] }
| BlockAssign { _stmntBA :: !Assign }
| NonBlockAssign { _stmntNBA :: !Assign }
| TaskEnable { _stmntTask :: !Task }
| SysTaskEnable { _stmntSysTask :: !Task }
| CondStmnt { _stmntCondExpr :: Expr
, _stmntCondTrue :: Maybe Statement
, _stmntCondFalse :: Maybe Statement
}
| ForLoop { _forAssign :: !Assign
, _forExpr :: Expr
, _forIncr :: !Assign
, _forStmnt :: Statement
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Plated Statement where
plate = uniplate
instance Semigroup Statement where
(SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b
(SeqBlock a) <> b = SeqBlock $ a <> [b]
a <> (SeqBlock b) = SeqBlock $ a : b
a <> b = SeqBlock [a, b]
instance Monoid Statement where
mempty = SeqBlock []
data Parameter = Parameter { _paramIdent :: {-# UNPACK #-} !Identifier
, _paramValue :: ConstExpr
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
data LocalParam = LocalParam { _localParamIdent :: {-# UNPACK #-} !Identifier
, _localParamValue :: ConstExpr
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
data ModItem = ModCA { _modContAssign :: !ContAssign }
| ModInst { _modInstId :: {-# UNPACK #-} !Identifier
, _modInstName :: {-# UNPACK #-} !Identifier
, _modInstConns :: [ModConn]
}
| Initial !Statement
| Always !Statement
| Decl { _declDir :: !(Maybe PortDir)
, _declPort :: !Port
, _declVal :: Maybe ConstExpr
}
| ParamDecl { _paramDecl :: NonEmpty Parameter }
| LocalParamDecl { _localParamDecl :: NonEmpty LocalParam }
deriving (Eq, Show, Ord, Data, Generic, NFData)
data ModDecl = ModDecl { _modId :: {-# UNPACK #-} !Identifier
, _modOutPorts :: ![Port]
, _modInPorts :: ![Port]
, _modItems :: ![ModItem]
, _modParams :: ![Parameter]
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn
traverseModConn f (ModConn e ) = ModConn <$> f e
traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e
traverseModItem :: (Applicative f) => (Expr -> f Expr) -> ModItem -> f ModItem
traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e
traverseModItem f (ModInst a b e) =
ModInst a b <$> sequenceA (traverseModConn f <$> e)
traverseModItem _ e = pure e
newtype Verilog = Verilog { getVerilog :: [ModDecl] }
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Semigroup Verilog where
Verilog a <> Verilog b = Verilog $ a <> b
instance Monoid Verilog where
mempty = Verilog mempty
data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text
, _infoSrc :: !Verilog
}
deriving (Eq, Show, Ord, Data, Generic, NFData)
instance Semigroup SourceInfo where
(SourceInfo t v) <> (SourceInfo _ v2) = SourceInfo t $ v <> v2
instance Monoid SourceInfo where
mempty = SourceInfo mempty mempty
$(makeLenses ''Expr)
$(makeLenses ''ConstExpr)
$(makeLenses ''Task)
$(makeLenses ''LVal)
$(makeLenses ''PortType)
$(makeLenses ''Port)
$(makeLenses ''ModConn)
$(makeLenses ''Assign)
$(makeLenses ''ContAssign)
$(makeLenses ''Statement)
$(makeLenses ''ModItem)
$(makeLenses ''Parameter)
$(makeLenses ''LocalParam)
$(makeLenses ''ModDecl)
$(makeLenses ''SourceInfo)
$(makeWrapped ''Verilog)
$(makeWrapped ''Identifier)
$(makeWrapped ''Delay)
$(makePrisms ''ModItem)
$(makeBaseFunctor ''Event)
$(makeBaseFunctor ''Expr)
$(makeBaseFunctor ''ConstExpr)
getModule :: Traversal' Verilog ModDecl
getModule = _Wrapped . traverse
{-# INLINE getModule #-}
getSourceId :: Traversal' Verilog Text
getSourceId = getModule . modId . _Wrapped
{-# INLINE getSourceId #-}
aModule :: Identifier -> Lens' SourceInfo ModDecl
aModule t = lens get_ set_
where
set_ (SourceInfo top main) v =
SourceInfo top (main & getModule %~ update (getIdentifier t) v)
update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v
| otherwise = m
get_ (SourceInfo _ main) =
head . filter (f $ getIdentifier t) $ main ^.. getModule
f top (ModDecl (Identifier i) _ _ _ _) = i == top
mainModule :: Lens' SourceInfo ModDecl
mainModule = lens get_ set_
where
set_ (SourceInfo top main) v =
SourceInfo top (main & getModule %~ update top v)
update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v
| otherwise = m
get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule
f top (ModDecl (Identifier i) _ _ _ _) = i == top