diff options
Diffstat (limited to 'src/Verismith/Verilog')
| -rw-r--r-- | src/Verismith/Verilog/AST.hs | 906 | ||||
| -rw-r--r-- | src/Verismith/Verilog/BitVec.hs | 148 | ||||
| -rw-r--r-- | src/Verismith/Verilog/CodeGen.hs | 328 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Eval.hs | 154 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Internal.hs | 83 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Mutate.hs | 346 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Parser.hs | 527 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Preprocess.hs | 163 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Quote.hs | 61 | ||||
| -rw-r--r-- | src/Verismith/Verilog/Token.hs | 36 |
10 files changed, 1461 insertions, 1291 deletions
diff --git a/src/Verismith/Verilog/AST.hs b/src/Verismith/Verilog/AST.hs index 5826a34..d870cfb 100644 --- a/src/Verismith/Verilog/AST.hs +++ b/src/Verismith/Verilog/AST.hs @@ -1,91 +1,176 @@ -{-| -Module : Verismith.Verilog.AST -Description : Definition of the Verilog AST types. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Poratbility : POSIX - -Defines the types to build a Verilog AST. --} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Verismith.Verilog.AST +-- Description : Definition of the Verilog AST types. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Poratbility : POSIX +-- +-- Defines the types to build a Verilog AST. module Verismith.Verilog.AST - ( -- * Top level types - SourceInfo(..), infoTop, infoSrc - , Verilog(..) + ( -- * Top level types + SourceInfo (..), + infoTop, + infoSrc, + Verilog (..), + -- * Primitives + -- ** Identifier - , Identifier(..) + Identifier (..), + -- ** Control - , Delay(..) - , Event(..) + Delay (..), + Event (..), + -- ** Operators - , BinaryOperator(..) - , UnaryOperator(..) + BinaryOperator (..), + UnaryOperator (..), + -- ** Task - , Task(..), taskName, taskExpr + Task (..), + taskName, + taskExpr, + -- ** Left hand side value - , LVal(..), regId, regExprId, regExpr, regSizeId, regSizeRange, regConc + LVal (..), + regId, + regExprId, + regExpr, + regSizeId, + regSizeRange, + regConc, + -- ** Ports - , PortDir(..) - , PortType(..) - , Port(..), portType, portSigned, portSize, portName + PortDir (..), + PortType (..), + Port (..), + portType, + portSigned, + portSize, + portName, + -- * Expression - , Expr(..) - , ConstExpr(..) - , ConstExprF(..), constToExpr, exprToConst - , Range(..), constNum, constParamId, constConcat, constUnOp, constPrim, constLhs - , constBinOp, constRhs, constCond, constTrue, constFalse, constStr + Expr (..), + ConstExpr (..), + ConstExprF (..), + constToExpr, + exprToConst, + Range (..), + constNum, + constParamId, + constConcat, + constUnOp, + constPrim, + constLhs, + constBinOp, + constRhs, + constCond, + constTrue, + constFalse, + constStr, + -- * Assignment - , Assign(..), assignReg, assignDelay, assignExpr - , ContAssign(..), contAssignNetLVal, contAssignExpr + Assign (..), + assignReg, + assignDelay, + assignExpr, + ContAssign (..), + contAssignNetLVal, + contAssignExpr, + -- ** Parameters - , Parameter(..), paramIdent, paramValue - , LocalParam(..), localParamIdent, localParamValue + Parameter (..), + paramIdent, + paramValue, + LocalParam (..), + localParamIdent, + localParamValue, + -- * Statment - , CaseType(..) - , CasePair(..) - , Statement(..), statDelay, statDStat, statEvent, statEStat, statements, stmntBA - , stmntNBA, stmntTask, stmntSysTask, stmntCondExpr, stmntCondTrue, stmntCondFalse - , stmntCaseType, stmntCaseExpr, stmntCasePair, stmntCaseDefault, forAssign, forExpr - , forIncr, forStmnt + CaseType (..), + CasePair (..), + Statement (..), + statDelay, + statDStat, + statEvent, + statEStat, + statements, + stmntBA, + stmntNBA, + stmntTask, + stmntSysTask, + stmntCondExpr, + stmntCondTrue, + stmntCondFalse, + stmntCaseType, + stmntCaseExpr, + stmntCasePair, + stmntCaseDefault, + forAssign, + forExpr, + forIncr, + forStmnt, + -- * Module - , ModDecl(..), modId, modOutPorts, modInPorts, modItems, modParams - , ModItem(..), modContAssign, modInstId, modInstName, modInstConns, _Initial, _Always - , paramDecl, localParamDecl, traverseModItem, declDir, declPort, declVal, ModConn(..) - , modConnName, modExpr + ModDecl (..), + modId, + modOutPorts, + modInPorts, + modItems, + modParams, + ModItem (..), + modContAssign, + modInstId, + modInstName, + modInstConns, + _Initial, + _Always, + paramDecl, + localParamDecl, + traverseModItem, + declDir, + declPort, + declVal, + ModConn (..), + modConnName, + modExpr, + -- * Useful Lenses and Traversals - , aModule, getModule, getSourceId, mainModule - , Annotations(..) - ) + aModule, + getModule, + getSourceId, + mainModule, + Annotations (..), + ) 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 Data.Void (Void) -import GHC.Generics (Generic) -import Verismith.Verilog.BitVec +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 Data.Void (Void) +import GHC.Generics (Generic) +import Verismith.Verilog.BitVec class Functor m => Annotations m where removeAnn :: m a -> m a @@ -97,112 +182,128 @@ class Functor m => Annotations m where -- @ -- (* synthesis *) -- @ -data Attribute = AttrAssign Identifier ConstExpr - | AttrName Identifier - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Attribute + = AttrAssign Identifier ConstExpr + | AttrName Identifier + deriving (Eq, Show, Ord, Data, Generic, NFData) -- | Annotations which can be added to the AST. These are supported in all the -- nodes of the AST and a custom type can be declared for them. -data Annotation a = Ann a - | AnnAttrs [Attribute] - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Annotation a + = Ann a + | AnnAttrs [Attribute] + deriving (Eq, Show, Ord, Data, Generic, NFData) -- | Identifier in Verilog. This is just a string of characters that can either -- be lowercase and uppercase for now. This might change in the future though, -- as Verilog supports many more characters in Identifiers. -newtype Identifier = Identifier { getIdentifier :: Text } - deriving (Eq, Show, Ord, Data, Generic, NFData) +newtype Identifier = Identifier {getIdentifier :: Text} + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeWrapped ''Identifier) instance IsString Identifier where - fromString = Identifier . pack + fromString = Identifier . pack instance Semigroup Identifier where - Identifier a <> Identifier b = Identifier $ a <> b + Identifier a <> Identifier b = Identifier $ a <> b instance Monoid Identifier where - mempty = Identifier mempty + mempty = Identifier mempty -- | Verilog syntax for adding a delay, which is represented as @#num@. -newtype Delay = Delay { _getDelay :: Int } - deriving (Eq, Show, Ord, Data, Generic, NFData) +newtype Delay = Delay {_getDelay :: Int} + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeWrapped ''Delay) 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 + 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 -- | Verilog syntax for an event, such as @\@x@, which is used for always blocks -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) +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) + +$(makeBaseFunctor ''Event) instance Plated Event where - plate = uniplate + plate = uniplate -- | Binary operators that are currently supported in the verilog generation. -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 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) -- | Unary operators that are currently supported by the generator. -data UnaryOperator = UnPlus - | UnMinus - | UnLNot - | UnNot - | UnAnd - | UnNand - | UnOr - | UnNor - | UnXor - | UnNxor - | UnNxorInv - 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) -- | Verilog expression, which can either be a primary expression, unary -- expression, binary operator expression or a conditional expression. -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) +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) + +$(makeLenses ''Expr) + +$(makeBaseFunctor ''Expr) instance Num Expr where a + b = BinOp a BinPlus b @@ -229,54 +330,59 @@ instance Plated Expr where plate = uniplate -- | Constant expression, which are known before simulation at compile time. -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) +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) + +$(makeLenses ''ConstExpr) + +$(makeBaseFunctor ''ConstExpr) 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 (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 + 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 (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 + ConstCond (exprToConst a) (exprToConst b) $ exprToConst c exprToConst (Str a) = ConstStr a -exprToConst _ = error "Not a constant expression" +exprToConst _ = error "Not a constant expression" instance Num ConstExpr where a + b = ConstBinOp a BinPlus b @@ -303,11 +409,14 @@ instance Plated ConstExpr where plate = uniplate -- | Task call, which is similar to function calls. -data Task = Task - { _taskName :: {-# UNPACK #-} !Identifier - , _taskExpr :: [Expr] - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Task + = Task + { _taskName :: {-# UNPACK #-} !Identifier, + _taskExpr :: [Expr] + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Task) -- | Type that represents the left hand side of an assignment, which can be a -- concatenation such as in: @@ -315,54 +424,62 @@ data Task = Task -- @ -- {a, b, c} = 32'h94238; -- @ -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) +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) + +$(makeLenses ''LVal) instance IsString LVal where fromString = RegId . fromString -- | Different port direction that are supported in Verilog. -data PortDir = PortIn - | PortOut - | PortInOut - deriving (Eq, Show, Ord, Data, Generic, NFData) +data PortDir + = PortIn + | PortOut + | PortInOut + deriving (Eq, Show, Ord, Data, Generic, NFData) -- | Currently, only @wire@ and @reg@ are supported, as the other net types are -- not that common and not a priority. -data PortType = Wire - | Reg - deriving (Eq, Show, Ord, Data, Generic, NFData) +data PortType + = Wire + | Reg + deriving (Eq, Show, Ord, Data, Generic, NFData) -- | Range that can be associated with any port or left hand side. Contains the -- msb and lsb bits as 'ConstExpr'. This means that they can be generated using -- parameters, which can in turn be changed at synthesis time. -data Range = Range - { rangeMSB :: !ConstExpr - , rangeLSB :: !ConstExpr - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Range + = Range + { rangeMSB :: !ConstExpr, + rangeLSB :: !ConstExpr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''PortType) 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 + (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 -- | Port declaration. It contains information about the type of the port, the -- size, and the port name. It used to also contain information about if it was @@ -372,13 +489,16 @@ instance Num Range where -- -- This is now implemented inside '(ModDecl ann)' itself, which uses a list of output -- and input ports. -data Port = Port - { _portType :: !PortType - , _portSigned :: !Bool - , _portSize :: {-# UNPACK #-} !Range - , _portName :: {-# UNPACK #-} !Identifier - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Port + = Port + { _portType :: !PortType, + _portSigned :: !Bool, + _portSize :: {-# UNPACK #-} !Range, + _portName :: {-# UNPACK #-} !Identifier + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Port) -- | This is currently a type because direct module declaration should also be -- added: @@ -386,40 +506,50 @@ data Port = Port -- @ -- mod a(.y(y1), .x1(x11), .x2(x22)); -- @ -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 ModConn + = ModConn + { _modExpr :: !Expr + } + | ModConnNamed + { _modConnName :: {-# UNPACK #-} !Identifier, + _modExpr :: !Expr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''ModConn) + +data Assign + = Assign + { _assignReg :: !LVal, + _assignDelay :: !(Maybe Delay), + _assignExpr :: !Expr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Assign) -- | Type for continuous assignment. -- -- @ -- assign x = 2'b1; -- @ -data ContAssign = ContAssign - { _contAssignNetLVal :: {-# UNPACK #-} !Identifier - , _contAssignExpr :: !Expr - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data ContAssign + = ContAssign + { _contAssignNetLVal :: {-# UNPACK #-} !Identifier, + _contAssignExpr :: !Expr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''ContAssign) -- | Case pair which contains an expression followed by a statement which will -- get executed if the expression matches the expression in the case statement. -data CasePair a = CasePair - { _casePairExpr :: !Expr - , _casePairStmnt :: !(Statement a) - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data CasePair a + = CasePair + { _casePairExpr :: !Expr, + _casePairStmnt :: !(Statement a) + } + deriving (Eq, Show, Ord, Data, Generic, NFData) instance Functor CasePair where fmap f (CasePair e s) = CasePair e $ fmap f s @@ -427,62 +557,72 @@ instance Functor CasePair where instance Annotations CasePair where removeAnn (CasePair e s) = CasePair e $ removeAnn s -traverseStmntCasePair :: Functor f => - (Statement a1 -> f (Statement a2)) -> CasePair a1 -> f (CasePair a2) +traverseStmntCasePair :: + Functor f => + (Statement a1 -> f (Statement a2)) -> + CasePair a1 -> + f (CasePair a2) traverseStmntCasePair f (CasePair a s) = CasePair a <$> f s -- | Type of case statement, which determines how it is interpreted. -data CaseType = CaseStandard - | CaseX - | CaseZ - deriving (Eq, Show, Ord, Data, Generic, NFData) +data CaseType + = CaseStandard + | CaseX + | CaseZ + deriving (Eq, Show, Ord, Data, Generic, NFData) -- | Statements in Verilog. -data Statement a = - TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay - , _statDStat :: Maybe (Statement a) - -- ^ Time control (@#NUM@) - } - | EventCtrl { _statEvent :: !Event - , _statEStat :: Maybe (Statement a) - } - | SeqBlock { _statements :: [Statement a] -- ^ Sequential block (@begin ... end@) - -- ^ blocking assignment (@=@) - } - | BlockAssign { _stmntBA :: !Assign -- ^ blocking assignment (@=@) - -- ^ Non blocking assignment (@<=@) - } - | NonBlockAssign { _stmntNBA :: !Assign } -- ^ Non blocking assignment (@<=@) - | TaskEnable { _stmntTask :: !Task } - | SysTaskEnable { _stmntSysTask :: !Task } - | CondStmnt { _stmntCondExpr :: Expr - , _stmntCondTrue :: Maybe (Statement a) - , _stmntCondFalse :: Maybe (Statement a) - } - | StmntCase { _stmntCaseType :: !CaseType - , _stmntCaseExpr :: !Expr - , _stmntCasePair :: ![CasePair a] - , _stmntCaseDefault :: !(Maybe (Statement a)) - } - | ForLoop { _forAssign :: !Assign - , _forExpr :: Expr - , _forIncr :: !Assign - , _forStmnt :: Statement a - -- ^ Loop bounds shall be statically computable for a for loop. - } +data Statement a + = -- | Time control (@#NUM@) + TimeCtrl + { _statDelay :: {-# UNPACK #-} !Delay, + _statDStat :: Maybe (Statement a) + } + | EventCtrl + { _statEvent :: !Event, + _statEStat :: Maybe (Statement a) + } + | -- | Sequential block (@begin ... end@) + SeqBlock {_statements :: [Statement a]} + | -- | blocking assignment (@=@) + BlockAssign {_stmntBA :: !Assign} + | -- | Non blocking assignment (@<=@) + NonBlockAssign {_stmntNBA :: !Assign} + | TaskEnable {_stmntTask :: !Task} + | SysTaskEnable {_stmntSysTask :: !Task} + | CondStmnt + { _stmntCondExpr :: Expr, + _stmntCondTrue :: Maybe (Statement a), + _stmntCondFalse :: Maybe (Statement a) + } + | StmntCase + { _stmntCaseType :: !CaseType, + _stmntCaseExpr :: !Expr, + _stmntCasePair :: ![CasePair a], + _stmntCaseDefault :: !(Maybe (Statement a)) + } + | -- | Loop bounds shall be statically computable for a for loop. + ForLoop + { _forAssign :: !Assign, + _forExpr :: Expr, + _forIncr :: !Assign, + _forStmnt :: Statement a + } | StmntAnn a (Statement a) deriving (Eq, Show, Ord, Data, Generic, NFData) +$(makeLenses ''Statement) + instance Plated (Statement a) where - plate f (TimeCtrl d s) = TimeCtrl d <$> traverse f s - plate f (EventCtrl d s) = EventCtrl d <$> traverse f s - plate f (SeqBlock s) = SeqBlock <$> traverse f s - plate f (CondStmnt e s1 s2) = CondStmnt e <$> traverse f s1 <*> traverse f s2 - plate f (StmntCase a b c d) = - StmntCase a b <$> traverse (traverseStmntCasePair f) c - <*> traverse f d - plate f (ForLoop a b c d) = ForLoop a b c <$> f d - plate f a = pure a + plate f (TimeCtrl d s) = TimeCtrl d <$> traverse f s + plate f (EventCtrl d s) = EventCtrl d <$> traverse f s + plate f (SeqBlock s) = SeqBlock <$> traverse f s + plate f (CondStmnt e s1 s2) = CondStmnt e <$> traverse f s1 <*> traverse f s2 + plate f (StmntCase a b c d) = + StmntCase a b <$> traverse (traverseStmntCasePair f) c + <*> traverse f d + plate f (ForLoop a b c d) = ForLoop a b c <$> f d + plate f a = pure a instance Semigroup (Statement a) where (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b @@ -517,36 +657,49 @@ instance Annotations Statement where removeAnn s = s -- | Parameter that can be assigned in blocks or modules using @parameter@. -data Parameter = Parameter - { _paramIdent :: {-# UNPACK #-} !Identifier - , _paramValue :: ConstExpr - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data Parameter + = Parameter + { _paramIdent :: {-# UNPACK #-} !Identifier, + _paramValue :: ConstExpr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Parameter) -- | Local parameter that can be assigned anywhere using @localparam@. It cannot -- be changed by initialising the module. -data LocalParam = LocalParam - { _localParamIdent :: {-# UNPACK #-} !Identifier - , _localParamValue :: ConstExpr - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data LocalParam + = LocalParam + { _localParamIdent :: {-# UNPACK #-} !Identifier, + _localParamValue :: ConstExpr + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''LocalParam) -- | Module item which is the body of the module expression. -data ModItem a = ModCA { _modContAssign :: !ContAssign } - | ModInst { _modInstId :: {-# UNPACK #-} !Identifier - , _modInstName :: {-# UNPACK #-} !Identifier - , _modInstConns :: [ModConn] - } - | Initial !(Statement a) - | Always !(Statement a) - | Decl { _declDir :: !(Maybe PortDir) - , _declPort :: !Port - , _declVal :: Maybe ConstExpr - } - | ParamDecl { _paramDecl :: NonEmpty Parameter } - | LocalParamDecl { _localParamDecl :: NonEmpty LocalParam } - | ModItemAnn a (ModItem a) - deriving (Eq, Show, Ord, Data, Generic, NFData) +data ModItem a + = ModCA {_modContAssign :: !ContAssign} + | ModInst + { _modInstId :: {-# UNPACK #-} !Identifier, + _modInstName :: {-# UNPACK #-} !Identifier, + _modInstConns :: [ModConn] + } + | Initial !(Statement a) + | Always !(Statement a) + | Decl + { _declDir :: !(Maybe PortDir), + _declPort :: !Port, + _declVal :: Maybe ConstExpr + } + | ParamDecl {_paramDecl :: NonEmpty Parameter} + | LocalParamDecl {_localParamDecl :: NonEmpty LocalParam} + | ModItemAnn a (ModItem a) + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makePrisms ''ModItem) + +$(makeLenses ''ModItem) instance Functor ModItem where fmap f (ModItemAnn a mi) = ModItemAnn (f a) $ fmap f mi @@ -565,15 +718,18 @@ instance Annotations ModItem where removeAnn mi = mi -- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module' -data ModDecl a = ModDecl - { _modId :: {-# UNPACK #-} !Identifier - , _modOutPorts :: ![Port] - , _modInPorts :: ![Port] - , _modItems :: ![ModItem a] - , _modParams :: ![Parameter] - } - | ModDeclAnn a (ModDecl a) - deriving (Eq, Show, Ord, Data, Generic, NFData) +data ModDecl a + = ModDecl + { _modId :: {-# UNPACK #-} !Identifier, + _modOutPorts :: ![Port], + _modInPorts :: ![Port], + _modItems :: ![ModItem a], + _modParams :: ![Parameter] + } + | ModDeclAnn a (ModDecl a) + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''ModDecl) instance Functor ModDecl where fmap f (ModDecl i out inp mis params) = ModDecl i out inp (fmap f <$> mis) params @@ -582,24 +738,26 @@ instance Annotations ModDecl where removeAnn (ModDecl i out inp mis params) = ModDecl i out inp (fmap removeAnn mis) params traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn -traverseModConn f (ModConn e ) = ModConn <$> f e +traverseModConn f (ModConn e) = ModConn <$> f e traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e traverseModItem :: (Applicative f) => (Expr -> f Expr) -> (ModItem ann) -> f (ModItem ann) traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e traverseModItem f (ModInst a b e) = - ModInst a b <$> sequenceA (traverseModConn f <$> e) + ModInst a b <$> sequenceA (traverseModConn f <$> e) traverseModItem _ e = pure e -- | The complete sourcetext for the Verilog module. -newtype Verilog a = Verilog { getVerilog :: [ModDecl a] } - deriving (Eq, Show, Ord, Data, Generic, NFData) +newtype Verilog a = Verilog {getVerilog :: [ModDecl a]} + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeWrapped ''Verilog) instance Semigroup (Verilog a) where - Verilog a <> Verilog b = Verilog $ a <> b + Verilog a <> Verilog b = Verilog $ a <> b instance Monoid (Verilog a) where - mempty = Verilog mempty + mempty = Verilog mempty instance Functor Verilog where fmap f (Verilog v) = Verilog $ fmap f <$> v @@ -609,17 +767,20 @@ instance Annotations Verilog where -- | Top level type which contains all the source code and associated -- information. -data SourceInfo a = SourceInfo - { _infoTop :: {-# UNPACK #-} !Text - , _infoSrc :: !(Verilog a) - } - deriving (Eq, Show, Ord, Data, Generic, NFData) +data SourceInfo a + = SourceInfo + { _infoTop :: {-# UNPACK #-} !Text, + _infoSrc :: !(Verilog a) + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''SourceInfo) instance Semigroup (SourceInfo a) where - (SourceInfo t v) <> (SourceInfo _ v2) = SourceInfo t $ v <> v2 + (SourceInfo t v) <> (SourceInfo _ v2) = SourceInfo t $ v <> v2 instance Monoid (SourceInfo a) where - mempty = SourceInfo mempty mempty + mempty = SourceInfo mempty mempty instance Functor SourceInfo where fmap f (SourceInfo t v) = SourceInfo t $ fmap f v @@ -627,30 +788,6 @@ instance Functor SourceInfo where instance Annotations SourceInfo where removeAnn (SourceInfo t v) = SourceInfo t $ removeAnn v -$(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 a) (ModDecl a) getModule = _Wrapped . traverse {-# INLINE getModule #-} @@ -665,25 +802,26 @@ aModule :: Identifier -> Lens' (SourceInfo a) (ModDecl a) 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 + SourceInfo top (main & getModule %~ update (getIdentifier t) v) + update top v m@(ModDecl (Identifier i) _ _ _ _) + | i == top = v + | otherwise = m update top v (ModDeclAnn _ m) = update top v m get_ (SourceInfo _ main) = - head . filter (f $ getIdentifier t) $ main ^.. getModule + head . filter (f $ getIdentifier t) $ main ^.. getModule f top (ModDecl (Identifier i) _ _ _ _) = i == top f top (ModDeclAnn _ m) = f top m - -- | May need to change this to Traversal to be safe. For now it will fail when -- the main has not been properly set with. mainModule :: Lens' (SourceInfo a) (ModDecl a) 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 + SourceInfo top (main & getModule %~ update top v) + update top v m@(ModDecl (Identifier i) _ _ _ _) + | i == top = v + | otherwise = m update top v (ModDeclAnn _ m) = update top v m get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule f top (ModDecl (Identifier i) _ _ _ _) = i == top diff --git a/src/Verismith/Verilog/BitVec.hs b/src/Verismith/Verilog/BitVec.hs index bc594a3..f5d9af1 100644 --- a/src/Verismith/Verilog/BitVec.hs +++ b/src/Verismith/Verilog/BitVec.hs @@ -1,119 +1,123 @@ -{-| -Module : Verismith.Verilog.BitVec -Description : Unsigned BitVec implementation. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Unsigned BitVec implementation. --} - -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} - +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +-- | +-- Module : Verismith.Verilog.BitVec +-- Description : Unsigned BitVec implementation. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Unsigned BitVec implementation. module Verismith.Verilog.BitVec - ( BitVecF(..) - , BitVec - , bitVec - , select - ) + ( BitVecF (..), + BitVec, + bitVec, + select, + ) where -import Control.DeepSeq (NFData) -import Data.Bits -import Data.Data -import Data.Ratio -import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Bits +import Data.Data +import Data.Ratio +import GHC.Generics (Generic) -- | Bit Vector that stores the bits in an arbitrary container together with the -- size. -data BitVecF a = BitVec { width :: {-# UNPACK #-} !Int - , value :: !a - } - deriving (Show, Eq, Ord, Data, Functor, Foldable, Traversable, Generic, NFData) +data BitVecF a + = BitVec + { width :: {-# UNPACK #-} !Int, + value :: !a + } + deriving (Show, Eq, Ord, Data, Functor, Foldable, Traversable, Generic, NFData) -- | Specialisation of the above with Integer, so that infinitely large bit -- vectors can be stored. type BitVec = BitVecF Integer instance (Enum a) => Enum (BitVecF a) where - toEnum i = BitVec (width' $ fromIntegral i) $ toEnum i - fromEnum (BitVec _ v) = fromEnum v + toEnum i = BitVec (width' $ fromIntegral i) $ toEnum i + fromEnum (BitVec _ v) = fromEnum v instance (Num a, Bits a) => Num (BitVecF a) where - BitVec w1 v1 + BitVec w2 v2 = bitVec (max w1 w2) (v1 + v2) - BitVec w1 v1 - BitVec w2 v2 = bitVec (max w1 w2) (v1 - v2) - BitVec w1 v1 * BitVec w2 v2 = bitVec (max w1 w2) (v1 * v2) - abs = id - signum (BitVec _ v) = if v == 0 then bitVec 1 0 else bitVec 1 1 - fromInteger i = bitVec (width' i) $ fromInteger i + BitVec w1 v1 + BitVec w2 v2 = bitVec (max w1 w2) (v1 + v2) + BitVec w1 v1 - BitVec w2 v2 = bitVec (max w1 w2) (v1 - v2) + BitVec w1 v1 * BitVec w2 v2 = bitVec (max w1 w2) (v1 * v2) + abs = id + signum (BitVec _ v) = if v == 0 then bitVec 1 0 else bitVec 1 1 + fromInteger i = bitVec (width' i) $ fromInteger i instance (Integral a, Bits a) => Real (BitVecF a) where - toRational (BitVec _ n) = fromIntegral n % 1 + toRational (BitVec _ n) = fromIntegral n % 1 instance (Integral a, Bits a) => Integral (BitVecF a) where - quotRem (BitVec w1 v1) (BitVec w2 v2) = both (BitVec $ max w1 w2) $ quotRem v1 v2 - toInteger (BitVec _ v) = toInteger v + quotRem (BitVec w1 v1) (BitVec w2 v2) = both (BitVec $ max w1 w2) $ quotRem v1 v2 + toInteger (BitVec _ v) = toInteger v instance (Num a, Bits a) => Bits (BitVecF a) where - BitVec w1 v1 .&. BitVec w2 v2 = bitVec (max w1 w2) (v1 .&. v2) - BitVec w1 v1 .|. BitVec w2 v2 = bitVec (max w1 w2) (v1 .|. v2) - BitVec w1 v1 `xor` BitVec w2 v2 = bitVec (max w1 w2) (v1 `xor` v2) - complement (BitVec w v) = bitVec w $ complement v - shift (BitVec w v) i = bitVec w $ shift v i - rotate = rotateBitVec - bit i = fromInteger $ bit i - testBit (BitVec _ v) = testBit v - bitSize (BitVec w _) = w - bitSizeMaybe (BitVec w _) = Just w - isSigned _ = False - popCount (BitVec _ v) = popCount v + BitVec w1 v1 .&. BitVec w2 v2 = bitVec (max w1 w2) (v1 .&. v2) + BitVec w1 v1 .|. BitVec w2 v2 = bitVec (max w1 w2) (v1 .|. v2) + BitVec w1 v1 `xor` BitVec w2 v2 = bitVec (max w1 w2) (v1 `xor` v2) + complement (BitVec w v) = bitVec w $ complement v + shift (BitVec w v) i = bitVec w $ shift v i + rotate = rotateBitVec + bit i = fromInteger $ bit i + testBit (BitVec _ v) = testBit v + bitSize (BitVec w _) = w + bitSizeMaybe (BitVec w _) = Just w + isSigned _ = False + popCount (BitVec _ v) = popCount v instance (Num a, Bits a) => FiniteBits (BitVecF a) where - finiteBitSize (BitVec w _) = w + finiteBitSize (BitVec w _) = w instance Bits a => Semigroup (BitVecF a) where - (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) + (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) instance Bits a => Monoid (BitVecF a) where - mempty = BitVec 0 zeroBits + mempty = BitVec 0 zeroBits -- | BitVecF construction, given width and value. bitVec :: (Num a, Bits a) => Int -> a -> BitVecF a bitVec w v = BitVec w' $ v .&. ((2 ^ w') - 1) where w' = max w 0 -- | Bit selection. LSB is 0. -select - :: (Integral a, Bits a, Integral b, Bits b) - => BitVecF a - -> (BitVecF b, BitVecF b) - -> BitVecF a +select :: + (Integral a, Bits a, Integral b, Bits b) => + BitVecF a -> + (BitVecF b, BitVecF b) -> + BitVecF a select (BitVec _ v) (msb, lsb) = - bitVec (from $ msb - lsb + 1) . shiftR (fromIntegral v) $ from lsb - where from = fromIntegral . value + bitVec (from $ msb - lsb + 1) . shiftR (fromIntegral v) $ from lsb + where + from = fromIntegral . value -- | Rotate bits in a 'BitVec'. rotateBitVec :: (Num a, Bits a) => BitVecF a -> Int -> BitVecF a -rotateBitVec b@(BitVec s _) n | n >= 0 = iterate rotateL1 b !! n - | otherwise = iterate rotateR1 b !! abs n +rotateBitVec b@(BitVec s _) n + | n >= 0 = iterate rotateL1 b !! n + | otherwise = iterate rotateR1 b !! abs n where rotateR1 n' = testBits 0 (s - 1) n' .|. shiftR n' 1 rotateL1 n' = testBits (s - 1) 0 n' .|. shiftL n' 1 testBits a b' n' = if testBit n' a then bit b' else zeroBits width' :: Integer -> Int -width' a | a == 0 = 1 - | otherwise = width'' a +width' a + | a == 0 = 1 + | otherwise = width'' a where - width'' a' | a' == 0 = 0 - | a' == -1 = 1 - | otherwise = 1 + width'' (shiftR a' 1) + width'' a' + | a' == 0 = 0 + | a' == -1 = 1 + | otherwise = 1 + width'' (shiftR a' 1) both :: (a -> b) -> (a, a) -> (b, b) both f (a, b) = (f a, f b) diff --git a/src/Verismith/Verilog/CodeGen.hs b/src/Verismith/Verilog/CodeGen.hs index 39301e4..3c5d4c5 100644 --- a/src/Verismith/Verilog/CodeGen.hs +++ b/src/Verismith/Verilog/CodeGen.hs @@ -1,36 +1,34 @@ -{-| -Module : Verismith.Verilog.CodeGen -Description : Code generation for Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -This module generates the code from the Verilog AST defined in -"Verismith.Verilog.AST". --} - {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Verismith.Verilog.CodeGen +-- Description : Code generation for Verilog AST. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- This module generates the code from the Verilog AST defined in +-- "Verismith.Verilog.AST". module Verismith.Verilog.CodeGen - ( -- * Code Generation - GenVerilog(..) - , Source(..) - , render - ) + ( -- * Code Generation + GenVerilog (..), + Source (..), + render, + ) where -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..), toList) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import Numeric (showHex) -import Verismith.Internal hiding (comma) -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc +import Numeric (showHex) +import Verismith.Internal hiding (comma) +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec -- | 'Source' class which determines that source code is able to be generated -- from the data structure using 'genSource'. This will be stored in 'Text' and @@ -49,18 +47,19 @@ verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules -- | Generate the 'ModDecl ann' for a module and convert it to 'Text'. moduleDecl :: Show ann => ModDecl ann -> Doc a -moduleDecl (ModDecl i outP inP items ps) = vsep - [ sep ["module" <+> identifier i, params ps, ports <> semi] - , indent 2 modI - , "endmodule" +moduleDecl (ModDecl i outP inP items ps) = + vsep + [ sep ["module" <+> identifier i, params ps, ports <> semi], + indent 2 modI, + "endmodule" ] where ports - | null outP && null inP = "" - | otherwise = parens . align . sep . punctuate comma $ modPort <$> outIn - modI = vsep $ moduleItem <$> items + | null outP && null inP = "" + | otherwise = parens . align . sep . punctuate comma $ modPort <$> outIn + modI = vsep $ moduleItem <$> items outIn = outP ++ inP - params [] = "" + params [] = "" params (p : pps) = hcat ["#", paramList (p :| pps)] moduleDecl (ModDeclAnn a m) = sep [hsep ["/*", pretty $ show a, "*/"], moduleDecl m] @@ -75,12 +74,12 @@ localParamList ps = tupled . toList $ localParam <$> ps -- | Generates the assignment for a 'Parameter'. parameter :: Parameter -> Doc a parameter (Parameter name val) = - hsep ["parameter", identifier name, "=", constExpr val] + hsep ["parameter", identifier name, "=", constExpr val] -- | Generates the assignment for a 'LocalParam'. localParam :: LocalParam -> Doc a localParam (LocalParam name val) = - hsep ["localparameter", identifier name, "=", constExpr val] + hsep ["localparameter", identifier name, "=", constExpr val] identifier :: Identifier -> Doc a identifier (Identifier i) = pretty i @@ -100,117 +99,124 @@ addMay (Just a) = (a :) -- | Generate the 'Port' description. port :: Port -> Doc a port (Port tp sgn r name) = - hsep $ pType tp : addOpt sgn "signed" [range r, identifier name] + hsep $ pType tp : addOpt sgn "signed" [range r, identifier name] range :: Range -> Doc a range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] -- | Convert the 'PortDir' type to 'Text'. portDir :: PortDir -> Doc a -portDir PortIn = "input" -portDir PortOut = "output" +portDir PortIn = "input" +portDir PortOut = "output" portDir PortInOut = "inout" -- | Generate a '(ModItem ann)'. moduleItem :: Show ann => ModItem ann -> Doc a moduleItem (ModCA ca) = contAssign ca -moduleItem (ModInst i name conn) = (<> semi) $ hsep - [ identifier i - , identifier name - , parens . hsep $ punctuate comma (mConn <$> conn) - ] -moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat] -moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat] -moduleItem (Decl dir p ini) = (<> semi) . hsep . - addMay (portDir <$> dir) . (port p :) $ addMay (makeIni <$> ini) [] +moduleItem (ModInst i name conn) = + (<> semi) $ + hsep + [ identifier i, + identifier name, + parens . hsep $ punctuate comma (mConn <$> conn) + ] +moduleItem (Initial stat) = nest 2 $ vsep ["initial", statement stat] +moduleItem (Always stat) = nest 2 $ vsep ["always", statement stat] +moduleItem (Decl dir p ini) = + (<> semi) . hsep + . addMay (portDir <$> dir) + . (port p :) + $ addMay (makeIni <$> ini) [] where - makeIni = ("=" <+>) . constExpr -moduleItem (ParamDecl p) = hcat [paramList p, semi] + makeIni = ("=" <+>) . constExpr +moduleItem (ParamDecl p) = hcat [paramList p, semi] moduleItem (LocalParamDecl p) = hcat [localParamList p, semi] moduleItem (ModItemAnn a mi) = sep [hsep ["/*", pretty $ show a, "*/"], moduleItem mi] mConn :: ModConn -> Doc a -mConn (ModConn c ) = expr c +mConn (ModConn c) = expr c mConn (ModConnNamed n c) = hcat [dot, identifier n, parens $ expr c] -- | Generate continuous assignment contAssign :: ContAssign -> Doc a contAssign (ContAssign val e) = - (<> semi) $ hsep ["assign", identifier val, "=", align $ expr e] + (<> semi) $ hsep ["assign", identifier val, "=", align $ expr e] -- | Generate 'Expr' to 'Text'. expr :: Expr -> Doc a expr (BinOp eRhs bin eLhs) = parens $ hsep [expr eRhs, binaryOp bin, expr eLhs] -expr (Number b ) = showNum b -expr (Id i ) = identifier i -expr (VecSelect i e ) = hcat [identifier i, brackets $ expr e] -expr (RangeSelect i r ) = hcat [identifier i, range r] +expr (Number b) = showNum b +expr (Id i) = identifier i +expr (VecSelect i e) = hcat [identifier i, brackets $ expr e] +expr (RangeSelect i r) = hcat [identifier i, range r] expr (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c) -expr (UnOp u e ) = parens $ hcat [unaryOp u, expr e] +expr (UnOp u e) = parens $ hcat [unaryOp u, expr e] expr (Cond l t f) = - parens . nest 4 $ sep [expr l <+> "?", hsep [expr t, colon, expr f]] + parens . nest 4 $ sep [expr l <+> "?", hsep [expr t, colon, expr f]] expr (Appl f e) = hcat [identifier f, parens $ expr e] -expr (Str t ) = dquotes $ pretty t +expr (Str t) = dquotes $ pretty t showNum :: BitVec -> Doc a -showNum (BitVec s n) = parens - $ hcat [minus, pretty $ showT s, "'h", pretty $ T.pack (showHex (abs n) "")] +showNum (BitVec s n) = + parens $ + hcat [minus, pretty $ showT s, "'h", pretty $ T.pack (showHex (abs n) "")] where - minus | signum n >= 0 = mempty - | otherwise = "-" + minus + | signum n >= 0 = mempty + | otherwise = "-" constExpr :: ConstExpr -> Doc a constExpr (ConstNum b) = showNum b -constExpr (ParamId i) = identifier i +constExpr (ParamId i) = identifier i constExpr (ConstConcat c) = - braces . hsep . punctuate comma $ toList (constExpr <$> c) + braces . hsep . punctuate comma $ toList (constExpr <$> c) constExpr (ConstUnOp u e) = parens $ hcat [unaryOp u, constExpr e] constExpr (ConstBinOp eRhs bin eLhs) = - parens $ hsep [constExpr eRhs, binaryOp bin, constExpr eLhs] + parens $ hsep [constExpr eRhs, binaryOp bin, constExpr eLhs] constExpr (ConstCond l t f) = - parens $ hsep [constExpr l, "?", constExpr t, colon, constExpr f] + parens $ hsep [constExpr l, "?", constExpr t, colon, constExpr f] constExpr (ConstStr t) = dquotes $ pretty t -- | Convert 'BinaryOperator' to 'Text'. binaryOp :: BinaryOperator -> Doc a -binaryOp BinPlus = "+" -binaryOp BinMinus = "-" -binaryOp BinTimes = "*" -binaryOp BinDiv = "/" -binaryOp BinMod = "%" -binaryOp BinEq = "==" -binaryOp BinNEq = "!=" -binaryOp BinCEq = "===" -binaryOp BinCNEq = "!==" -binaryOp BinLAnd = "&&" -binaryOp BinLOr = "||" -binaryOp BinLT = "<" -binaryOp BinLEq = "<=" -binaryOp BinGT = ">" -binaryOp BinGEq = ">=" -binaryOp BinAnd = "&" -binaryOp BinOr = "|" -binaryOp BinXor = "^" -binaryOp BinXNor = "^~" +binaryOp BinPlus = "+" +binaryOp BinMinus = "-" +binaryOp BinTimes = "*" +binaryOp BinDiv = "/" +binaryOp BinMod = "%" +binaryOp BinEq = "==" +binaryOp BinNEq = "!=" +binaryOp BinCEq = "===" +binaryOp BinCNEq = "!==" +binaryOp BinLAnd = "&&" +binaryOp BinLOr = "||" +binaryOp BinLT = "<" +binaryOp BinLEq = "<=" +binaryOp BinGT = ">" +binaryOp BinGEq = ">=" +binaryOp BinAnd = "&" +binaryOp BinOr = "|" +binaryOp BinXor = "^" +binaryOp BinXNor = "^~" binaryOp BinXNorInv = "~^" -binaryOp BinPower = "**" -binaryOp BinLSL = "<<" -binaryOp BinLSR = ">>" -binaryOp BinASL = "<<<" -binaryOp BinASR = ">>>" +binaryOp BinPower = "**" +binaryOp BinLSL = "<<" +binaryOp BinLSR = ">>" +binaryOp BinASL = "<<<" +binaryOp BinASR = ">>>" -- | Convert 'UnaryOperator' to 'Text'. unaryOp :: UnaryOperator -> Doc a -unaryOp UnPlus = "+" -unaryOp UnMinus = "-" -unaryOp UnLNot = "!" -unaryOp UnNot = "~" -unaryOp UnAnd = "&" -unaryOp UnNand = "~&" -unaryOp UnOr = "|" -unaryOp UnNor = "~|" -unaryOp UnXor = "^" -unaryOp UnNxor = "~^" +unaryOp UnPlus = "+" +unaryOp UnMinus = "-" +unaryOp UnLNot = "!" +unaryOp UnNot = "~" +unaryOp UnAnd = "&" +unaryOp UnNand = "~&" +unaryOp UnOr = "|" +unaryOp UnNor = "~|" +unaryOp UnXor = "^" +unaryOp UnNxor = "~^" unaryOp UnNxorInv = "^~" event :: Event -> Doc a @@ -218,13 +224,13 @@ event a = hcat ["@", parens $ eventRec a] -- | Generate verilog code for an 'Event'. eventRec :: Event -> Doc a -eventRec (EId i) = identifier i -eventRec (EExpr e) = expr e -eventRec EAll = "*" +eventRec (EId i) = identifier i +eventRec (EExpr e) = expr e +eventRec EAll = "*" eventRec (EPosEdge i) = hsep ["posedge", identifier i] eventRec (ENegEdge i) = hsep ["negedge", identifier i] -eventRec (EOr a b ) = hsep [eventRec a, "or", eventRec b] -eventRec (EComb a b ) = hsep $ punctuate comma [eventRec a, eventRec b] +eventRec (EOr a b) = hsep [eventRec a, "or", eventRec b] +eventRec (EComb a b) = hsep $ punctuate comma [eventRec a, eventRec b] -- | Generates verilog code for a 'Delay'. delay :: Delay -> Doc a @@ -232,18 +238,18 @@ delay (Delay i) = "#" <> pretty i -- | Generate the verilog code for an 'LVal'. lVal :: LVal -> Doc a -lVal (RegId i ) = identifier i +lVal (RegId i) = identifier i lVal (RegExpr i e) = hsep [identifier i, expr e] lVal (RegSize i r) = hsep [identifier i, range r] lVal (RegConcat e) = braces . hsep $ punctuate comma (expr <$> e) pType :: PortType -> Doc a pType Wire = "wire" -pType Reg = "reg" +pType Reg = "reg" genAssign :: Text -> Assign -> Doc a genAssign op (Assign r d e) = - hsep . (lVal r : ) . (pretty op :) $ addMay (delay <$> d) [expr e] + hsep . (lVal r :) . (pretty op :) $ addMay (delay <$> d) [expr e] caseType :: CaseType -> Doc a caseType CaseStandard = "case" @@ -252,46 +258,52 @@ caseType CaseZ = "casez" casePair :: Show ann => (CasePair ann) -> Doc a casePair (CasePair e s) = - vsep [hsep [expr e, colon], indent 2 $ statement s] + vsep [hsep [expr e, colon], indent 2 $ statement s] statement :: Show ann => Statement ann -> Doc a -statement (TimeCtrl d stat) = hsep [delay d, defMap stat] +statement (TimeCtrl d stat) = hsep [delay d, defMap stat] statement (EventCtrl e stat) = hsep [event e, defMap stat] statement (SeqBlock s) = - vsep ["begin", indent 2 . vsep $ statement <$> s, "end"] -statement (BlockAssign a) = hcat [genAssign "=" a, semi] + vsep ["begin", indent 2 . vsep $ statement <$> s, "end"] +statement (BlockAssign a) = hcat [genAssign "=" a, semi] statement (NonBlockAssign a) = hcat [genAssign "<=" a, semi] -statement (TaskEnable t) = hcat [task t, semi] -statement (SysTaskEnable t) = hcat ["$", task t, semi] +statement (TaskEnable t) = hcat [task t, semi] +statement (SysTaskEnable t) = hcat ["$", task t, semi] statement (CondStmnt e t Nothing) = - vsep [hsep ["if", parens $ expr e], indent 2 $ defMap t] + vsep [hsep ["if", parens $ expr e], indent 2 $ defMap t] statement (StmntCase t e ls d) = - vcat [hcat [caseType t, parens $ expr e], - vcat $ casePair <$> ls, - indent 2 $ vsep ["default:", indent 2 $ defMap d], - "endcase"] -statement (CondStmnt e t f) = vsep - [ hsep ["if", parens $ expr e] - , indent 2 $ defMap t - , "else" - , indent 2 $ defMap f + vcat + [ hcat [caseType t, parens $ expr e], + vcat $ casePair <$> ls, + indent 2 $ vsep ["default:", indent 2 $ defMap d], + "endcase" + ] +statement (CondStmnt e t f) = + vsep + [ hsep ["if", parens $ expr e], + indent 2 $ defMap t, + "else", + indent 2 $ defMap f ] -statement (ForLoop a e incr stmnt) = vsep +statement (ForLoop a e incr stmnt) = + vsep [ hsep - [ "for" - , parens . hsep $ punctuate - semi - [genAssign "=" a, expr e, genAssign "=" incr] - ] - , indent 2 $ statement stmnt + [ "for", + parens . hsep $ + punctuate + semi + [genAssign "=" a, expr e, genAssign "=" incr] + ], + indent 2 $ statement stmnt ] statement (StmntAnn a s) = sep [hsep ["/*", pretty $ show a, "*/"], statement s] task :: Task -> Doc a task (Task i e) - | null e = identifier i - | otherwise = hsep - [identifier i, parens . hsep $ punctuate comma (expr <$> e)] + | null e = identifier i + | otherwise = + hsep + [identifier i, parens . hsep $ punctuate comma (expr <$> e)] -- | Render the 'Text' to 'IO'. This is equivalent to 'putStrLn'. render :: (Source a) => a -> IO () @@ -300,58 +312,58 @@ render = print . genSource -- Instances instance Source Identifier where - genSource = showT . identifier + genSource = showT . identifier instance Source Task where - genSource = showT . task + genSource = showT . task instance Show ann => Source (Statement ann) where - genSource = showT . statement + genSource = showT . statement instance Source PortType where - genSource = showT . pType + genSource = showT . pType instance Source ConstExpr where - genSource = showT . constExpr + genSource = showT . constExpr instance Source LVal where - genSource = showT . lVal + genSource = showT . lVal instance Source Delay where - genSource = showT . delay + genSource = showT . delay instance Source Event where - genSource = showT . event + genSource = showT . event instance Source UnaryOperator where - genSource = showT . unaryOp + genSource = showT . unaryOp instance Source Expr where - genSource = showT . expr + genSource = showT . expr instance Source ContAssign where - genSource = showT . contAssign + genSource = showT . contAssign instance Show ann => Source (ModItem ann) where - genSource = showT . moduleItem + genSource = showT . moduleItem instance Source PortDir where - genSource = showT . portDir + genSource = showT . portDir instance Source Port where - genSource = showT . port + genSource = showT . port instance Show ann => Source (ModDecl ann) where - genSource = showT . moduleDecl + genSource = showT . moduleDecl instance Show ann => Source (Verilog ann) where - genSource = showT . verilogSrc + genSource = showT . verilogSrc instance Show ann => Source (SourceInfo ann) where - genSource (SourceInfo _ src) = genSource src + genSource (SourceInfo _ src) = genSource src -newtype GenVerilog a = GenVerilog { unGenVerilog :: a } - deriving (Eq, Ord, Data) +newtype GenVerilog a = GenVerilog {unGenVerilog :: a} + deriving (Eq, Ord, Data) instance (Source a) => Show (GenVerilog a) where - show = T.unpack . genSource . unGenVerilog + show = T.unpack . genSource . unGenVerilog diff --git a/src/Verismith/Verilog/Eval.hs b/src/Verismith/Verilog/Eval.hs index cbc2563..eb65029 100644 --- a/src/Verismith/Verilog/Eval.hs +++ b/src/Verismith/Verilog/Eval.hs @@ -1,27 +1,25 @@ -{-| -Module : Verismith.Verilog.Eval -Description : Evaluation of Verilog expressions and statements. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Evaluation of Verilog expressions and statements. --} - +-- | +-- Module : Verismith.Verilog.Eval +-- Description : Evaluation of Verilog expressions and statements. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Evaluation of Verilog expressions and statements. module Verismith.Verilog.Eval - ( evaluateConst - , resize - ) + ( evaluateConst, + resize, + ) where -import Data.Bits -import Data.Foldable (fold) -import Data.Functor.Foldable hiding (fold) -import Data.Maybe (listToMaybe) -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec +import Data.Bits +import Data.Foldable (fold) +import Data.Functor.Foldable hiding (fold) +import Data.Maybe (listToMaybe) +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec type Bindings = [Parameter] @@ -32,25 +30,33 @@ paramValue_ :: Parameter -> ConstExpr paramValue_ (Parameter _ v) = v applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a -applyUnary UnPlus a = a +applyUnary UnPlus a = a applyUnary UnMinus a = negate a -applyUnary UnLNot a | a == 0 = 0 - | otherwise = 1 +applyUnary UnLNot a + | a == 0 = 0 + | otherwise = 1 applyUnary UnNot a = complement a -applyUnary UnAnd a | finiteBitSize a == popCount a = 1 - | otherwise = 0 -applyUnary UnNand a | finiteBitSize a == popCount a = 0 - | otherwise = 1 -applyUnary UnOr a | popCount a == 0 = 0 - | otherwise = 1 -applyUnary UnNor a | popCount a == 0 = 1 - | otherwise = 0 -applyUnary UnXor a | popCount a `mod` 2 == 0 = 0 - | otherwise = 1 -applyUnary UnNxor a | popCount a `mod` 2 == 0 = 1 - | otherwise = 0 -applyUnary UnNxorInv a | popCount a `mod` 2 == 0 = 1 - | otherwise = 0 +applyUnary UnAnd a + | finiteBitSize a == popCount a = 1 + | otherwise = 0 +applyUnary UnNand a + | finiteBitSize a == popCount a = 0 + | otherwise = 1 +applyUnary UnOr a + | popCount a == 0 = 0 + | otherwise = 1 +applyUnary UnNor a + | popCount a == 0 = 1 + | otherwise = 0 +applyUnary UnXor a + | popCount a `mod` 2 == 0 = 0 + | otherwise = 1 +applyUnary UnNxor a + | popCount a `mod` 2 == 0 = 1 + | otherwise = 0 +applyUnary UnNxorInv a + | popCount a `mod` 2 == 0 = 1 + | otherwise = 0 compXor :: Bits c => c -> c -> c compXor a = complement . xor a @@ -62,55 +68,57 @@ toInt :: (Integral a, Num t1) => (t2 -> t1 -> t3) -> t2 -> a -> t3 toInt a b c = a b $ fromIntegral c applyBinary :: (Integral a, Bits a) => BinaryOperator -> a -> a -> a -applyBinary BinPlus = (+) -applyBinary BinMinus = (-) -applyBinary BinTimes = (*) -applyBinary BinDiv = quot -applyBinary BinMod = rem -applyBinary BinEq = toIntegral (==) -applyBinary BinNEq = toIntegral (/=) -applyBinary BinCEq = toIntegral (==) -applyBinary BinCNEq = toIntegral (/=) -applyBinary BinLAnd = undefined -applyBinary BinLOr = undefined -applyBinary BinLT = toIntegral (<) -applyBinary BinLEq = toIntegral (<=) -applyBinary BinGT = toIntegral (>) -applyBinary BinGEq = toIntegral (>=) -applyBinary BinAnd = (.&.) -applyBinary BinOr = (.|.) -applyBinary BinXor = xor -applyBinary BinXNor = compXor +applyBinary BinPlus = (+) +applyBinary BinMinus = (-) +applyBinary BinTimes = (*) +applyBinary BinDiv = quot +applyBinary BinMod = rem +applyBinary BinEq = toIntegral (==) +applyBinary BinNEq = toIntegral (/=) +applyBinary BinCEq = toIntegral (==) +applyBinary BinCNEq = toIntegral (/=) +applyBinary BinLAnd = undefined +applyBinary BinLOr = undefined +applyBinary BinLT = toIntegral (<) +applyBinary BinLEq = toIntegral (<=) +applyBinary BinGT = toIntegral (>) +applyBinary BinGEq = toIntegral (>=) +applyBinary BinAnd = (.&.) +applyBinary BinOr = (.|.) +applyBinary BinXor = xor +applyBinary BinXNor = compXor applyBinary BinXNorInv = compXor -applyBinary BinPower = undefined -applyBinary BinLSL = toInt shiftL -applyBinary BinLSR = toInt shiftR -applyBinary BinASL = toInt shiftL -applyBinary BinASR = toInt shiftR +applyBinary BinPower = undefined +applyBinary BinLSL = toInt shiftL +applyBinary BinLSR = toInt shiftR +applyBinary BinASL = toInt shiftL +applyBinary BinASR = toInt shiftR -- | Evaluates a 'ConstExpr' using a context of 'Bindings' as input. evaluateConst :: Bindings -> ConstExprF BitVec -> BitVec evaluateConst _ (ConstNumF b) = b evaluateConst p (ParamIdF i) = - cata (evaluateConst p) . maybe 0 paramValue_ . listToMaybe $ filter - ((== i) . paramIdent_) - p -evaluateConst _ (ConstConcatF c ) = fold c -evaluateConst _ (ConstUnOpF unop c ) = applyUnary unop c + cata (evaluateConst p) . maybe 0 paramValue_ . listToMaybe $ + filter + ((== i) . paramIdent_) + p +evaluateConst _ (ConstConcatF c) = fold c +evaluateConst _ (ConstUnOpF unop c) = applyUnary unop c evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b -evaluateConst _ (ConstCondF a b c) = if a > 0 then b else c -evaluateConst _ (ConstStrF _ ) = 0 +evaluateConst _ (ConstCondF a b c) = if a > 0 then b else c +evaluateConst _ (ConstStrF _) = 0 -- | Apply a function to all the bitvectors. Would be fixed by having a -- 'Functor' instance for a polymorphic 'ConstExpr'. applyBitVec :: (BitVec -> BitVec) -> ConstExpr -> ConstExpr -applyBitVec f (ConstNum b ) = ConstNum $ f b -applyBitVec f (ConstConcat c ) = ConstConcat $ fmap (applyBitVec f) c +applyBitVec f (ConstNum b) = ConstNum $ f b +applyBitVec f (ConstConcat c) = ConstConcat $ fmap (applyBitVec f) c applyBitVec f (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c applyBitVec f (ConstBinOp a binop b) = - ConstBinOp (applyBitVec f a) binop (applyBitVec f b) + ConstBinOp (applyBitVec f a) binop (applyBitVec f b) applyBitVec f (ConstCond a b c) = ConstCond (abv a) (abv b) (abv c) - where abv = applyBitVec f + where + abv = applyBitVec f applyBitVec _ a = a -- | This probably could be implemented using some recursion scheme in the diff --git a/src/Verismith/Verilog/Internal.hs b/src/Verismith/Verilog/Internal.hs index 0ebc626..d06fc5f 100644 --- a/src/Verismith/Verilog/Internal.hs +++ b/src/Verismith/Verilog/Internal.hs @@ -1,36 +1,34 @@ -{-| -Module : Verismith.Verilog.Internal -Description : Defaults and common functions. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Defaults and common functions. --} - +-- | +-- Module : Verismith.Verilog.Internal +-- Description : Defaults and common functions. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Defaults and common functions. module Verismith.Verilog.Internal - ( regDecl - , wireDecl - , emptyMod - , setModName - , addModPort - , addModDecl - , testBench - , addTestBench - , defaultPort - , portToExpr - , modName - , yPort - , wire - , reg - ) + ( regDecl, + wireDecl, + emptyMod, + setModName, + addModPort, + addModDecl, + testBench, + addTestBench, + defaultPort, + portToExpr, + modName, + yPort, + wire, + reg, + ) where -import Control.Lens -import Data.Text (Text) -import Verismith.Verilog.AST +import Control.Lens +import Data.Text (Text) +import Verismith.Verilog.AST regDecl :: Identifier -> (ModItem ann) regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing @@ -54,20 +52,23 @@ addModDecl :: (ModDecl ann) -> (Verilog ann) -> (Verilog ann) addModDecl desc = _Wrapped %~ (:) desc testBench :: (ModDecl ann) -testBench = ModDecl +testBench = + ModDecl "main" [] [] - [ regDecl "a" - , regDecl "b" - , wireDecl "c" - , ModInst "and" - "and_gate" - [ModConn $ Id "c", ModConn $ Id "a", ModConn $ Id "b"] - , Initial $ SeqBlock - [ BlockAssign . Assign (RegId "a") Nothing $ Number 1 - , BlockAssign . Assign (RegId "b") Nothing $ Number 1 - ] + [ regDecl "a", + regDecl "b", + wireDecl "c", + ModInst + "and" + "and_gate" + [ModConn $ Id "c", ModConn $ Id "a", ModConn $ Id "b"], + Initial $ + SeqBlock + [ BlockAssign . Assign (RegId "a") Nothing $ Number 1, + BlockAssign . Assign (RegId "b") Nothing $ Number 1 + ] ] [] diff --git a/src/Verismith/Verilog/Mutate.hs b/src/Verismith/Verilog/Mutate.hs index b48ab11..0855000 100644 --- a/src/Verismith/Verilog/Mutate.hs +++ b/src/Verismith/Verilog/Mutate.hs @@ -1,185 +1,185 @@ -{-| -Module : Verismith.Verilog.Mutate -Description : Functions to mutate the Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Functions to mutate the Verilog AST from "Verismith.Verilog.AST" to generate more -random patterns, such as nesting wires instead of creating new ones. --} - {-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : Verismith.Verilog.Mutate +-- Description : Functions to mutate the Verilog AST. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Functions to mutate the Verilog AST from "Verismith.Verilog.AST" to generate more +-- random patterns, such as nesting wires instead of creating new ones. module Verismith.Verilog.Mutate - ( Mutate(..) - , inPort - , findAssign - , idTrans - , replace - , nestId - , nestSource - , nestUpTo - , allVars - , instantiateMod - , instantiateMod_ - , instantiateModSpec_ - , filterChar - , initMod - , makeIdFrom - , makeTop - , makeTopAssert - , simplify - , removeId - , combineAssigns - , combineAssigns_ - , declareMod - , fromPort - ) + ( Mutate (..), + inPort, + findAssign, + idTrans, + replace, + nestId, + nestSource, + nestUpTo, + allVars, + instantiateMod, + instantiateMod_, + instantiateModSpec_, + filterChar, + initMod, + makeIdFrom, + makeTop, + makeTopAssert, + simplify, + removeId, + combineAssigns, + combineAssigns_, + declareMod, + fromPort, + ) where -import Control.Lens -import Data.Foldable (fold) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Verismith.Circuit.Internal -import Verismith.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec -import Verismith.Verilog.CodeGen -import Verismith.Verilog.Internal +import Control.Lens +import Data.Foldable (fold) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Verismith.Circuit.Internal +import Verismith.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Internal class Mutate a where - mutExpr :: (Expr -> Expr) -> a -> a + mutExpr :: (Expr -> Expr) -> a -> a instance Mutate Identifier where - mutExpr _ = id + mutExpr _ = id instance Mutate Delay where - mutExpr _ = id + mutExpr _ = id instance Mutate Event where - mutExpr f (EExpr e) = EExpr $ f e - mutExpr _ a = a + mutExpr f (EExpr e) = EExpr $ f e + mutExpr _ a = a instance Mutate BinaryOperator where - mutExpr _ = id + mutExpr _ = id instance Mutate UnaryOperator where - mutExpr _ = id + mutExpr _ = id instance Mutate Expr where - mutExpr f = f + mutExpr f = f instance Mutate ConstExpr where - mutExpr _ = id + mutExpr _ = id instance Mutate Task where - mutExpr f (Task i e) = Task i $ fmap f e + mutExpr f (Task i e) = Task i $ fmap f e instance Mutate LVal where - mutExpr f (RegExpr a e) = RegExpr a $ f e - mutExpr _ a = a + mutExpr f (RegExpr a e) = RegExpr a $ f e + mutExpr _ a = a instance Mutate PortDir where - mutExpr _ = id + mutExpr _ = id instance Mutate PortType where - mutExpr _ = id + mutExpr _ = id instance Mutate Range where - mutExpr _ = id + mutExpr _ = id instance Mutate Port where - mutExpr _ = id + mutExpr _ = id instance Mutate ModConn where - mutExpr f (ModConn e) = ModConn $ f e - mutExpr f (ModConnNamed a e) = ModConnNamed a $ f e + mutExpr f (ModConn e) = ModConn $ f e + mutExpr f (ModConnNamed a e) = ModConnNamed a $ f e instance Mutate Assign where - mutExpr f (Assign a b c) = Assign a b $ f c + mutExpr f (Assign a b c) = Assign a b $ f c instance Mutate ContAssign where - mutExpr f (ContAssign a e) = ContAssign a $ f e + mutExpr f (ContAssign a e) = ContAssign a $ f e instance Mutate (CasePair ann) where mutExpr f (CasePair e s) = CasePair (f e) $ mutExpr f s instance Mutate (Statement ann) where - mutExpr f (TimeCtrl d s) = TimeCtrl d $ mutExpr f <$> s - mutExpr f (EventCtrl e s) = EventCtrl e $ mutExpr f <$> s - mutExpr f (SeqBlock s) = SeqBlock $ mutExpr f <$> s - mutExpr f (BlockAssign a) = BlockAssign $ mutExpr f a - mutExpr f (NonBlockAssign a) = NonBlockAssign $ mutExpr f a - mutExpr f (TaskEnable a) = TaskEnable $ mutExpr f a - mutExpr f (SysTaskEnable a) = SysTaskEnable $ mutExpr f a - mutExpr f (CondStmnt a b c) = CondStmnt (f a) (mutExpr f <$> b) $ mutExpr f <$> c - mutExpr f (ForLoop a1 e a2 s) = ForLoop a1 e a2 $ mutExpr f s - mutExpr f (StmntAnn a s) = StmntAnn a $ mutExpr f s - mutExpr f (StmntCase t e cp cd) = StmntCase t (f e) (mutExpr f cp) $ mutExpr f cd + mutExpr f (TimeCtrl d s) = TimeCtrl d $ mutExpr f <$> s + mutExpr f (EventCtrl e s) = EventCtrl e $ mutExpr f <$> s + mutExpr f (SeqBlock s) = SeqBlock $ mutExpr f <$> s + mutExpr f (BlockAssign a) = BlockAssign $ mutExpr f a + mutExpr f (NonBlockAssign a) = NonBlockAssign $ mutExpr f a + mutExpr f (TaskEnable a) = TaskEnable $ mutExpr f a + mutExpr f (SysTaskEnable a) = SysTaskEnable $ mutExpr f a + mutExpr f (CondStmnt a b c) = CondStmnt (f a) (mutExpr f <$> b) $ mutExpr f <$> c + mutExpr f (ForLoop a1 e a2 s) = ForLoop a1 e a2 $ mutExpr f s + mutExpr f (StmntAnn a s) = StmntAnn a $ mutExpr f s + mutExpr f (StmntCase t e cp cd) = StmntCase t (f e) (mutExpr f cp) $ mutExpr f cd instance Mutate Parameter where - mutExpr _ = id + mutExpr _ = id instance Mutate LocalParam where - mutExpr _ = id + mutExpr _ = id instance Mutate (ModItem ann) where - mutExpr f (ModCA (ContAssign a e)) = ModCA . ContAssign a $ f e - mutExpr f (ModInst a b conns) = ModInst a b $ mutExpr f conns - mutExpr f (Initial s) = Initial $ mutExpr f s - mutExpr f (Always s) = Always $ mutExpr f s - mutExpr f (ModItemAnn a s) = ModItemAnn a $ mutExpr f s - mutExpr _ d@Decl{} = d - mutExpr _ p@ParamDecl{} = p - mutExpr _ l@LocalParamDecl{} = l + mutExpr f (ModCA (ContAssign a e)) = ModCA . ContAssign a $ f e + mutExpr f (ModInst a b conns) = ModInst a b $ mutExpr f conns + mutExpr f (Initial s) = Initial $ mutExpr f s + mutExpr f (Always s) = Always $ mutExpr f s + mutExpr f (ModItemAnn a s) = ModItemAnn a $ mutExpr f s + mutExpr _ d@Decl {} = d + mutExpr _ p@ParamDecl {} = p + mutExpr _ l@LocalParamDecl {} = l instance Mutate (ModDecl ann) where - mutExpr f (ModDecl a b c d e) = - ModDecl (mutExpr f a) (mutExpr f b) (mutExpr f c) (mutExpr f d) (mutExpr f e) - mutExpr f (ModDeclAnn a m) = ModDeclAnn a $ mutExpr f m + mutExpr f (ModDecl a b c d e) = + ModDecl (mutExpr f a) (mutExpr f b) (mutExpr f c) (mutExpr f d) (mutExpr f e) + mutExpr f (ModDeclAnn a m) = ModDeclAnn a $ mutExpr f m instance Mutate (Verilog ann) where - mutExpr f (Verilog a) = Verilog $ mutExpr f a + mutExpr f (Verilog a) = Verilog $ mutExpr f a instance Mutate (SourceInfo ann) where - mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b + mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b instance Mutate a => Mutate [a] where - mutExpr f a = mutExpr f <$> a + mutExpr f a = mutExpr f <$> a instance Mutate a => Mutate (Maybe a) where - mutExpr f a = mutExpr f <$> a + mutExpr f a = mutExpr f <$> a instance Mutate a => Mutate (GenVerilog a) where - mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a + mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a -- | Return if the 'Identifier' is in a '(ModDecl ann)'. inPort :: Identifier -> (ModDecl ann) -> Bool inPort i m = inInput where inInput = - any (\a -> a ^. portName == i) $ m ^. modInPorts ++ m ^. modOutPorts + any (\a -> a ^. portName == i) $ m ^. modInPorts ++ m ^. modOutPorts -- | Find the last assignment of a specific wire/reg to an expression, and -- returns that expression. findAssign :: Identifier -> [ModItem ann] -> Maybe Expr findAssign i items = safe last . catMaybes $ isAssign <$> items where - isAssign (ModCA (ContAssign val expr)) | val == i = Just expr - | otherwise = Nothing + isAssign (ModCA (ContAssign val expr)) + | val == i = Just expr + | otherwise = Nothing isAssign _ = Nothing -- | Transforms an expression by replacing an Identifier with an -- expression. This is used inside 'transformOf' and 'traverseExpr' to replace -- the 'Identifier' recursively. idTrans :: Identifier -> Expr -> Expr -> Expr -idTrans i expr (Id id') | id' == i = expr - | otherwise = Id id' +idTrans i expr (Id id') + | id' == i = expr + | otherwise = Id id' idTrans _ _ e = e -- | Replaces the identifier recursively in an expression. @@ -194,11 +194,11 @@ replace = (transform .) . idTrans -- expression. This would require a different approach though. nestId :: Identifier -> (ModDecl ann) -> (ModDecl ann) nestId i m - | not $ inPort i m - = let expr = fromMaybe def . findAssign i $ m ^. modItems - in m & get %~ replace i expr - | otherwise - = m + | not $ inPort i m = + let expr = fromMaybe def . findAssign i $ m ^. modItems + in m & get %~ replace i expr + | otherwise = + m where get = modItems . traverse . modContAssign . contAssignExpr def = Id i @@ -210,12 +210,12 @@ nestSource i src = src & getModule %~ nestId i -- | Nest variables in the format @w[0-9]*@ up to a certain number. nestUpTo :: Int -> (Verilog ann) -> (Verilog ann) nestUpTo i src = - foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] + foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] allVars :: (ModDecl ann) -> [Identifier] allVars m = - (m ^.. modOutPorts . traverse . portName) - <> (m ^.. modInPorts . traverse . portName) + (m ^.. modOutPorts . traverse . portName) + <> (m ^.. modInPorts . traverse . portName) -- $setup -- >>> import Verismith.Verilog.CodeGen @@ -239,19 +239,21 @@ instantiateMod m main = main & modItems %~ ((out ++ regIn ++ [inst]) ++) where out = Decl Nothing <$> m ^. modOutPorts <*> pure Nothing regIn = - Decl Nothing - <$> (m ^. modInPorts & traverse . portType .~ Reg) - <*> pure Nothing - inst = ModInst (m ^. modId) - (m ^. modId <> (Identifier . showT $ count + 1)) - conns + Decl Nothing + <$> (m ^. modInPorts & traverse . portType .~ Reg) + <*> pure Nothing + inst = + ModInst + (m ^. modId) + (m ^. modId <> (Identifier . showT $ count + 1)) + conns count = - length - . filter (== m ^. modId) - $ main - ^.. modItems - . traverse - . modInstId + length + . filter (== m ^. modId) + $ main + ^.. modItems + . traverse + . modInstId conns = uncurry ModConnNamed . fmap Id <$> zip (allVars m) (allVars m) -- | Instantiate without adding wire declarations. It also does not count the @@ -264,10 +266,10 @@ instantiateMod_ :: (ModDecl ann) -> (ModItem ann) instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns where conns = - ModConn - . Id - <$> (m ^.. modOutPorts . traverse . portName) - ++ (m ^.. modInPorts . traverse . portName) + ModConn + . Id + <$> (m ^.. modOutPorts . traverse . portName) + ++ (m ^.. modInPorts . traverse . portName) -- | Instantiate without adding wire declarations. It also does not count the -- current instantiations of the same module. @@ -278,14 +280,14 @@ instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns instantiateModSpec_ :: Text -> (ModDecl ann) -> (ModItem ann) instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns where - conns = zipWith ModConnNamed ids (Id <$> instIds) - ids = filterChar outChar (name modOutPorts) <> name modInPorts + conns = zipWith ModConnNamed ids (Id <$> instIds) + ids = filterChar outChar (name modOutPorts) <> name modInPorts instIds = name modOutPorts <> name modInPorts name v = m ^.. v . traverse . portName filterChar :: Text -> [Identifier] -> [Identifier] filterChar t ids = - ids & traverse . _Wrapped %~ (\x -> fromMaybe x . safe head $ T.splitOn t x) + ids & traverse . _Wrapped %~ (\x -> fromMaybe x . safe head $ T.splitOn t x) -- | Initialise all the inputs and outputs to a module. -- @@ -312,18 +314,20 @@ makeIdFrom a i = (i <>) . Identifier . ("_" <>) $ showT a makeTop :: Int -> (ModDecl ann) -> (ModDecl ann) makeTop i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] where - ys = yPort . flip makeIdFrom "y" <$> [1 .. i] + ys = yPort . flip makeIdFrom "y" <$> [1 .. i] modIt = instantiateModSpec_ "_" . modN <$> [1 .. i] modN n = - m & modId %~ makeIdFrom n & modOutPorts .~ [yPort (makeIdFrom n "y")] + m & modId %~ makeIdFrom n & modOutPorts .~ [yPort (makeIdFrom n "y")] -- | Make a top module with an assert that requires @y_1@ to always be equal to -- @y_2@, which can then be proven using a formal verification tool. makeTopAssert :: (ModDecl ann) -> (ModDecl ann) makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2 where - assert = Always . EventCtrl e . Just $ SeqBlock - [TaskEnable $ Task "assert" [BinOp (Id "y_1") BinEq (Id "y_2")]] + assert = + Always . EventCtrl e . Just $ + SeqBlock + [TaskEnable $ Task "assert" [BinOp (Id "y_1") BinEq (Id "y_2")]] e = EPosEdge "clk" -- | Provide declarations for all the ports that are passed to it. If they are @@ -332,7 +336,7 @@ declareMod :: [Port] -> (ModDecl ann) -> (ModDecl ann) declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) where decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0) - decl p = Decl Nothing p Nothing + decl p = Decl Nothing p Nothing -- | Simplify an 'Expr' by using constants to remove 'BinaryOperator' and -- simplify expressions. To make this work effectively, it should be run until @@ -344,30 +348,30 @@ declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) -- >>> GenVerilog . simplify $ (Id "y") + (Id "x") -- (y + x) simplify :: Expr -> Expr -simplify (BinOp (Number (BitVec _ 1)) BinAnd e) = e -simplify (BinOp e BinAnd (Number (BitVec _ 1))) = e -simplify (BinOp (Number (BitVec _ 0)) BinAnd _) = Number 0 -simplify (BinOp _ BinAnd (Number (BitVec _ 0))) = Number 0 -simplify (BinOp e BinPlus (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinPlus e) = e +simplify (BinOp (Number (BitVec _ 1)) BinAnd e) = e +simplify (BinOp e BinAnd (Number (BitVec _ 1))) = e +simplify (BinOp (Number (BitVec _ 0)) BinAnd _) = Number 0 +simplify (BinOp _ BinAnd (Number (BitVec _ 0))) = Number 0 +simplify (BinOp e BinPlus (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinPlus e) = e simplify (BinOp e BinMinus (Number (BitVec _ 0))) = e simplify (BinOp (Number (BitVec _ 0)) BinMinus e) = e simplify (BinOp e BinTimes (Number (BitVec _ 1))) = e simplify (BinOp (Number (BitVec _ 1)) BinTimes e) = e simplify (BinOp _ BinTimes (Number (BitVec _ 0))) = Number 0 simplify (BinOp (Number (BitVec _ 0)) BinTimes _) = Number 0 -simplify (BinOp e BinOr (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinOr e) = e -simplify (BinOp e BinLSL (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinLSL e) = e -simplify (BinOp e BinLSR (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinLSR e) = e -simplify (BinOp e BinASL (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinASL e) = e -simplify (BinOp e BinASR (Number (BitVec _ 0))) = e -simplify (BinOp (Number (BitVec _ 0)) BinASR e) = e -simplify (UnOp UnPlus e) = e -simplify e = e +simplify (BinOp e BinOr (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinOr e) = e +simplify (BinOp e BinLSL (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinLSL e) = e +simplify (BinOp e BinLSR (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinLSR e) = e +simplify (BinOp e BinASL (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinASL e) = e +simplify (BinOp e BinASR (Number (BitVec _ 0))) = e +simplify (BinOp (Number (BitVec _ 0)) BinASR e) = e +simplify (UnOp UnPlus e) = e +simplify e = e -- | Remove all 'Identifier' that do not appeare in the input list from an -- 'Expr'. The identifier will be replaced by @1'b0@, which can then later be @@ -378,32 +382,34 @@ simplify e = e removeId :: [Identifier] -> Expr -> Expr removeId i = transform trans where - trans (Id ident) | ident `notElem` i = Number 0 - | otherwise = Id ident + trans (Id ident) + | ident `notElem` i = Number 0 + | otherwise = Id ident trans e = e combineAssigns :: Port -> [ModItem ann] -> [ModItem ann] combineAssigns p a = - a - <> [ ModCA - . ContAssign (p ^. portName) - . UnOp UnXor - . fold - $ Id + a + <> [ ModCA + . ContAssign (p ^. portName) + . UnOp UnXor + . fold + $ Id <$> assigns - ] - where assigns = a ^.. traverse . modContAssign . contAssignNetLVal + ] + where + assigns = a ^.. traverse . modContAssign . contAssignNetLVal combineAssigns_ :: Bool -> Port -> [Port] -> (ModItem ann) combineAssigns_ comb p ps = - ModCA - . ContAssign (p ^. portName) - . (if comb then UnOp UnXor else id) - . fold - $ Id - <$> ps - ^.. traverse - . portName + ModCA + . ContAssign (p ^. portName) + . (if comb then UnOp UnXor else id) + . fold + $ Id + <$> ps + ^.. traverse + . portName fromPort :: Port -> Identifier fromPort (Port _ _ _ i) = i diff --git a/src/Verismith/Verilog/Parser.hs b/src/Verismith/Verilog/Parser.hs index 70dc973..3a42c3c 100644 --- a/src/Verismith/Verilog/Parser.hs +++ b/src/Verismith/Verilog/Parser.hs @@ -1,50 +1,49 @@ -{-| -Module : Verismith.Verilog.Parser -Description : Minimal Verilog parser to reconstruct the AST. -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Minimal Verilog parser to reconstruct the AST. This parser does not support the -whole Verilog syntax, as the AST does not support it either. --} - +-- | +-- Module : Verismith.Verilog.Parser +-- Description : Minimal Verilog parser to reconstruct the AST. +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Minimal Verilog parser to reconstruct the AST. This parser does not support the +-- whole Verilog syntax, as the AST does not support it either. module Verismith.Verilog.Parser - ( -- * Parser - parseVerilog - , parseVerilogFile - , parseSourceInfoFile + ( -- * Parser + parseVerilog, + parseVerilogFile, + parseSourceInfoFile, + -- ** Internal parsers - , parseEvent - , parseStatement - , parseModItem - , parseModDecl - , Parser - ) + parseEvent, + parseStatement, + parseModItem, + parseModDecl, + Parser, + ) where -import Control.Lens -import Control.Monad (void) -import Data.Bifunctor (bimap) -import Data.Bits -import Data.Functor (($>)) -import Data.Functor.Identity (Identity) -import Data.List (isInfixOf, isPrefixOf, null) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Text.Parsec hiding (satisfy) -import Text.Parsec.Expr -import Verismith.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec -import Verismith.Verilog.Internal -import Verismith.Verilog.Lex -import Verismith.Verilog.Preprocess -import Verismith.Verilog.Token +import Control.Lens +import Control.Monad (void) +import Data.Bifunctor (bimap) +import Data.Bits +import Data.Functor (($>)) +import Data.Functor.Identity (Identity) +import Data.List (isInfixOf, isPrefixOf, null) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Text.Parsec hiding (satisfy) +import Text.Parsec.Expr +import Verismith.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec +import Verismith.Verilog.Internal +import Verismith.Verilog.Lex +import Verismith.Verilog.Preprocess +import Verismith.Verilog.Token type Parser = Parsec [Token] () @@ -53,13 +52,13 @@ type ParseOperator = Operator [Token] () Identity data Decimal = Decimal Int Integer instance Num Decimal where - (Decimal sa na) + (Decimal sb nb) = Decimal (max sa sb) (na + nb) - (Decimal sa na) - (Decimal sb nb) = Decimal (max sa sb) (na - nb) - (Decimal sa na) * (Decimal sb nb) = Decimal (max sa sb) (na * nb) - negate (Decimal s n) = Decimal s $ negate n - abs (Decimal s n) = Decimal s $ abs n - signum (Decimal s n) = Decimal s $ signum n - fromInteger = Decimal 32 . fromInteger + (Decimal sa na) + (Decimal sb nb) = Decimal (max sa sb) (na + nb) + (Decimal sa na) - (Decimal sb nb) = Decimal (max sa sb) (na - nb) + (Decimal sa na) * (Decimal sb nb) = Decimal (max sa sb) (na * nb) + negate (Decimal s n) = Decimal s $ negate n + abs (Decimal s n) = Decimal s $ abs n + signum (Decimal s n) = Decimal s $ signum n + fromInteger = Decimal 32 . fromInteger -- | This parser succeeds whenever the given predicate returns true when called -- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'. @@ -74,7 +73,7 @@ satisfy' = tokenPrim show nextPos nextPos :: SourcePos -> Token -> [Token] -> SourcePos nextPos pos _ (Token _ _ (Position _ l c) : _) = - setSourceColumn (setSourceLine pos l) c + setSourceColumn (setSourceLine pos l) c nextPos pos _ [] = pos -- | Parses given `TokenName`. @@ -113,56 +112,56 @@ parseVar = Id <$> identifier parseVecSelect :: Parser Expr parseVecSelect = do - i <- identifier - expr <- brackets parseExpr - return $ VecSelect i expr + i <- identifier + expr <- brackets parseExpr + return $ VecSelect i expr parseRangeSelect :: Parser Expr parseRangeSelect = do - i <- identifier - range <- parseRange - return $ RangeSelect i range + i <- identifier + range <- parseRange + return $ RangeSelect i range systemFunc :: Parser String systemFunc = satisfy' matchId where matchId (Token IdSystem s _) = Just s - matchId _ = Nothing + matchId _ = Nothing parseFun :: Parser Expr parseFun = do - f <- systemFunc - expr <- parens parseExpr - return $ Appl (Identifier $ T.pack f) expr + f <- systemFunc + expr <- parens parseExpr + return $ Appl (Identifier $ T.pack f) expr parserNonEmpty :: [a] -> Parser (NonEmpty a) parserNonEmpty (a : b) = return $ a :| b -parserNonEmpty [] = fail "Concatenation cannot be empty." +parserNonEmpty [] = fail "Concatenation cannot be empty." parseTerm :: Parser Expr parseTerm = - parens parseExpr - <|> (Concat <$> (braces (commaSep parseExpr) >>= parserNonEmpty)) - <|> parseFun - <|> parseNum - <|> try parseVecSelect - <|> try parseRangeSelect - <|> parseVar - <?> "simple expr" + parens parseExpr + <|> (Concat <$> (braces (commaSep parseExpr) >>= parserNonEmpty)) + <|> parseFun + <|> parseNum + <|> try parseVecSelect + <|> try parseRangeSelect + <|> parseVar + <?> "simple expr" -- | Parses the ternary conditional operator. It will behave in a right -- associative way. parseCond :: Expr -> Parser Expr parseCond e = do - tok' SymQuestion - expr <- parseExpr - tok' SymColon - Cond e expr <$> parseExpr + tok' SymQuestion + expr <- parseExpr + tok' SymColon + Cond e expr <$> parseExpr parseExpr :: Parser Expr parseExpr = do - e <- parseExpr' - option e . try $ parseCond e + e <- parseExpr' + option e . try $ parseCond e parseConstExpr :: Parser ConstExpr parseConstExpr = fmap exprToConst parseExpr @@ -171,50 +170,50 @@ parseConstExpr = fmap exprToConst parseExpr -- each. parseTable :: [[ParseOperator Expr]] parseTable = - [ [prefix SymBang (UnOp UnLNot), prefix SymTildy (UnOp UnNot)] - , [ prefix SymAmp (UnOp UnAnd) - , prefix SymBar (UnOp UnOr) - , prefix SymTildyAmp (UnOp UnNand) - , prefix SymTildyBar (UnOp UnNor) - , prefix SymHat (UnOp UnXor) - , prefix SymTildyHat (UnOp UnNxor) - , prefix SymHatTildy (UnOp UnNxorInv) - ] - , [prefix SymPlus (UnOp UnPlus), prefix SymDash (UnOp UnMinus)] - , [binary SymAsterAster (sBinOp BinPower) AssocRight] - , [ binary SymAster (sBinOp BinTimes) AssocLeft - , binary SymSlash (sBinOp BinDiv) AssocLeft - , binary SymPercent (sBinOp BinMod) AssocLeft - ] - , [ binary SymPlus (sBinOp BinPlus) AssocLeft - , binary SymDash (sBinOp BinPlus) AssocLeft - ] - , [ binary SymLtLt (sBinOp BinLSL) AssocLeft - , binary SymGtGt (sBinOp BinLSR) AssocLeft - ] - , [ binary SymLtLtLt (sBinOp BinASL) AssocLeft - , binary SymGtGtGt (sBinOp BinASR) AssocLeft - ] - , [ binary SymLt (sBinOp BinLT) AssocNone - , binary SymGt (sBinOp BinGT) AssocNone - , binary SymLtEq (sBinOp BinLEq) AssocNone - , binary SymGtEq (sBinOp BinLEq) AssocNone - ] - , [ binary SymEqEq (sBinOp BinEq) AssocNone - , binary SymBangEq (sBinOp BinNEq) AssocNone - ] - , [ binary SymEqEqEq (sBinOp BinEq) AssocNone - , binary SymBangEqEq (sBinOp BinNEq) AssocNone - ] - , [binary SymAmp (sBinOp BinAnd) AssocLeft] - , [ binary SymHat (sBinOp BinXor) AssocLeft - , binary SymHatTildy (sBinOp BinXNor) AssocLeft - , binary SymTildyHat (sBinOp BinXNorInv) AssocLeft - ] - , [binary SymBar (sBinOp BinOr) AssocLeft] - , [binary SymAmpAmp (sBinOp BinLAnd) AssocLeft] - , [binary SymBarBar (sBinOp BinLOr) AssocLeft] - ] + [ [prefix SymBang (UnOp UnLNot), prefix SymTildy (UnOp UnNot)], + [ prefix SymAmp (UnOp UnAnd), + prefix SymBar (UnOp UnOr), + prefix SymTildyAmp (UnOp UnNand), + prefix SymTildyBar (UnOp UnNor), + prefix SymHat (UnOp UnXor), + prefix SymTildyHat (UnOp UnNxor), + prefix SymHatTildy (UnOp UnNxorInv) + ], + [prefix SymPlus (UnOp UnPlus), prefix SymDash (UnOp UnMinus)], + [binary SymAsterAster (sBinOp BinPower) AssocRight], + [ binary SymAster (sBinOp BinTimes) AssocLeft, + binary SymSlash (sBinOp BinDiv) AssocLeft, + binary SymPercent (sBinOp BinMod) AssocLeft + ], + [ binary SymPlus (sBinOp BinPlus) AssocLeft, + binary SymDash (sBinOp BinPlus) AssocLeft + ], + [ binary SymLtLt (sBinOp BinLSL) AssocLeft, + binary SymGtGt (sBinOp BinLSR) AssocLeft + ], + [ binary SymLtLtLt (sBinOp BinASL) AssocLeft, + binary SymGtGtGt (sBinOp BinASR) AssocLeft + ], + [ binary SymLt (sBinOp BinLT) AssocNone, + binary SymGt (sBinOp BinGT) AssocNone, + binary SymLtEq (sBinOp BinLEq) AssocNone, + binary SymGtEq (sBinOp BinLEq) AssocNone + ], + [ binary SymEqEq (sBinOp BinEq) AssocNone, + binary SymBangEq (sBinOp BinNEq) AssocNone + ], + [ binary SymEqEqEq (sBinOp BinEq) AssocNone, + binary SymBangEqEq (sBinOp BinNEq) AssocNone + ], + [binary SymAmp (sBinOp BinAnd) AssocLeft], + [ binary SymHat (sBinOp BinXor) AssocLeft, + binary SymHatTildy (sBinOp BinXNor) AssocLeft, + binary SymTildyHat (sBinOp BinXNorInv) AssocLeft + ], + [binary SymBar (sBinOp BinOr) AssocLeft], + [binary SymAmpAmp (sBinOp BinLAnd) AssocLeft], + [binary SymBarBar (sBinOp BinLOr) AssocLeft] + ] binary :: TokenName -> (a -> a -> a) -> Assoc -> ParseOperator a binary name fun = Infix ((tok name <?> "binary") >> return fun) @@ -227,36 +226,38 @@ commaSep = flip sepBy $ tok SymComma parseContAssign :: Parser ContAssign parseContAssign = do - var <- tok KWAssign *> identifier - expr <- tok SymEq *> parseExpr - tok' SymSemi - return $ ContAssign var expr + var <- tok KWAssign *> identifier + expr <- tok SymEq *> parseExpr + tok' SymSemi + return $ ContAssign var expr numLit :: Parser String numLit = satisfy' matchId where matchId (Token LitNumber s _) = Just s - matchId _ = Nothing + matchId _ = Nothing number :: Parser Decimal number = number' <$> numLit where number' :: String -> Decimal - number' a | all (`elem` ['0' .. '9']) a = fromInteger $ read a - | head a == '\'' = fromInteger $ f a - | "'" `isInfixOf` a = Decimal (read w) (f b) - | otherwise = error $ "Invalid number format: " ++ a + number' a + | all (`elem` ['0' .. '9']) a = fromInteger $ read a + | head a == '\'' = fromInteger $ f a + | "'" `isInfixOf` a = Decimal (read w) (f b) + | otherwise = error $ "Invalid number format: " ++ a where w = takeWhile (/= '\'') a b = dropWhile (/= '\'') a f a' - | "'d" `isPrefixOf` a' = read $ drop 2 a' - | "'h" `isPrefixOf` a' = read $ "0x" ++ drop 2 a' - | "'b" `isPrefixOf` a' = foldl - (\n b' -> shiftL n 1 .|. (if b' == '1' then 1 else 0)) - 0 - (drop 2 a') - | otherwise = error $ "Invalid number format: " ++ a' + | "'d" `isPrefixOf` a' = read $ drop 2 a' + | "'h" `isPrefixOf` a' = read $ "0x" ++ drop 2 a' + | "'b" `isPrefixOf` a' = + foldl + (\n b' -> shiftL n 1 .|. (if b' == '1' then 1 else 0)) + 0 + (drop 2 a') + | otherwise = error $ "Invalid number format: " ++ a' -- toInteger' :: Decimal -> Integer -- toInteger' (Decimal _ n) = n @@ -268,61 +269,62 @@ toInt' (Decimal _ n) = fromInteger n -- added to the difference. parseRange :: Parser Range parseRange = do - rangeH <- tok SymBrackL *> parseConstExpr - rangeL <- tok SymColon *> parseConstExpr - tok' SymBrackR - return $ Range rangeH rangeL + rangeH <- tok SymBrackL *> parseConstExpr + rangeL <- tok SymColon *> parseConstExpr + tok' SymBrackR + return $ Range rangeH rangeL strId :: Parser String strId = satisfy' matchId where - matchId (Token IdSimple s _) = Just s + matchId (Token IdSimple s _) = Just s matchId (Token IdEscaped s _) = Just s - matchId _ = Nothing + matchId _ = Nothing identifier :: Parser Identifier identifier = Identifier . T.pack <$> strId parseNetDecl :: Maybe PortDir -> Parser (ModItem ann) parseNetDecl pd = do - t <- option Wire type_ - sign <- option False (tok KWSigned $> True) - range <- option 1 parseRange - name <- identifier - i <- option Nothing (fmap Just (tok' SymEq *> parseConstExpr)) - tok' SymSemi - return $ Decl pd (Port t sign range name) i - where type_ = tok KWWire $> Wire <|> tok KWReg $> Reg + t <- option Wire type_ + sign <- option False (tok KWSigned $> True) + range <- option 1 parseRange + name <- identifier + i <- option Nothing (fmap Just (tok' SymEq *> parseConstExpr)) + tok' SymSemi + return $ Decl pd (Port t sign range name) i + where + type_ = tok KWWire $> Wire <|> tok KWReg $> Reg parsePortDir :: Parser PortDir parsePortDir = - tok KWOutput - $> PortOut - <|> tok KWInput - $> PortIn - <|> tok KWInout - $> PortInOut + tok KWOutput + $> PortOut + <|> tok KWInput + $> PortIn + <|> tok KWInout + $> PortInOut parseDecl :: Parser (ModItem ann) parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing parseConditional :: Parser (Statement ann) parseConditional = do - expr <- tok' KWIf *> parens parseExpr - true <- maybeEmptyStatement - false <- option Nothing (tok' KWElse *> maybeEmptyStatement) - return $ CondStmnt expr true false + expr <- tok' KWIf *> parens parseExpr + true <- maybeEmptyStatement + false <- option Nothing (tok' KWElse *> maybeEmptyStatement) + return $ CondStmnt expr true false parseLVal :: Parser LVal parseLVal = fmap RegConcat (braces $ commaSep parseExpr) <|> ident where ident = do - i <- identifier - (try (ex i) <|> try (sz i) <|> return (RegId i)) + i <- identifier + (try (ex i) <|> try (sz i) <|> return (RegId i)) ex i = do - e <- tok' SymBrackL *> parseExpr - tok' SymBrackR - return $ RegExpr i e + e <- tok' SymBrackL *> parseExpr + tok' SymBrackR + return $ RegExpr i e sz i = RegSize i <$> parseRange parseDelay :: Parser Delay @@ -330,92 +332,92 @@ parseDelay = Delay . toInt' <$> (tok' SymPound *> number) parseAssign :: TokenName -> Parser Assign parseAssign t = do - lval <- parseLVal - tok' t - delay <- option Nothing (fmap Just parseDelay) - expr <- parseExpr - return $ Assign lval delay expr + lval <- parseLVal + tok' t + delay <- option Nothing (fmap Just parseDelay) + expr <- parseExpr + return $ Assign lval delay expr parseLoop :: Parser (Statement ann) parseLoop = do - a <- tok' KWFor *> tok' SymParenL *> parseAssign SymEq - expr <- tok' SymSemi *> parseExpr - incr <- tok' SymSemi *> parseAssign SymEq - tok' SymParenR - statement <- parseStatement - return $ ForLoop a expr incr statement + a <- tok' KWFor *> tok' SymParenL *> parseAssign SymEq + expr <- tok' SymSemi *> parseExpr + incr <- tok' SymSemi *> parseAssign SymEq + tok' SymParenR + statement <- parseStatement + return $ ForLoop a expr incr statement eventList :: TokenName -> Parser [Event] eventList t = do - l <- sepBy parseEvent' (tok t) - if null l then fail "Could not parse list" else return l + l <- sepBy parseEvent' (tok t) + if null l then fail "Could not parse list" else return l parseEvent :: Parser Event parseEvent = - tok' SymAtAster - $> EAll - <|> try (tok' SymAt *> tok' SymParenLAsterParenR $> EAll) - <|> try - ( tok' SymAt - *> tok' SymParenL - *> tok' SymAster - *> tok' SymParenR - $> EAll - ) - <|> try (tok' SymAt *> parens parseEvent') - <|> try (tok' SymAt *> parens (foldr1 EOr <$> eventList KWOr)) - <|> try (tok' SymAt *> parens (foldr1 EComb <$> eventList SymComma)) + tok' SymAtAster + $> EAll + <|> try (tok' SymAt *> tok' SymParenLAsterParenR $> EAll) + <|> try + ( tok' SymAt + *> tok' SymParenL + *> tok' SymAster + *> tok' SymParenR + $> EAll + ) + <|> try (tok' SymAt *> parens parseEvent') + <|> try (tok' SymAt *> parens (foldr1 EOr <$> eventList KWOr)) + <|> try (tok' SymAt *> parens (foldr1 EComb <$> eventList SymComma)) parseEvent' :: Parser Event parseEvent' = - try (tok' KWPosedge *> fmap EPosEdge identifier) - <|> try (tok' KWNegedge *> fmap ENegEdge identifier) - <|> try (fmap EId identifier) - <|> try (fmap EExpr parseExpr) + try (tok' KWPosedge *> fmap EPosEdge identifier) + <|> try (tok' KWNegedge *> fmap ENegEdge identifier) + <|> try (fmap EId identifier) + <|> try (fmap EExpr parseExpr) parseEventCtrl :: Parser (Statement ann) parseEventCtrl = do - event <- parseEvent - statement <- option Nothing maybeEmptyStatement - return $ EventCtrl event statement + event <- parseEvent + statement <- option Nothing maybeEmptyStatement + return $ EventCtrl event statement parseDelayCtrl :: Parser (Statement ann) parseDelayCtrl = do - delay <- parseDelay - statement <- option Nothing maybeEmptyStatement - return $ TimeCtrl delay statement + delay <- parseDelay + statement <- option Nothing maybeEmptyStatement + return $ TimeCtrl delay statement parseBlocking :: Parser (Statement ann) parseBlocking = do - a <- parseAssign SymEq - tok' SymSemi - return $ BlockAssign a + a <- parseAssign SymEq + tok' SymSemi + return $ BlockAssign a parseNonBlocking :: Parser (Statement ann) parseNonBlocking = do - a <- parseAssign SymLtEq - tok' SymSemi - return $ NonBlockAssign a + a <- parseAssign SymLtEq + tok' SymSemi + return $ NonBlockAssign a parseSeq :: Parser (Statement ann) parseSeq = do - seq' <- tok' KWBegin *> many parseStatement - tok' KWEnd - return $ SeqBlock seq' + seq' <- tok' KWBegin *> many parseStatement + tok' KWEnd + return $ SeqBlock seq' parseStatement :: Parser (Statement ann) parseStatement = - parseSeq - <|> parseConditional - <|> parseLoop - <|> parseEventCtrl - <|> parseDelayCtrl - <|> try parseBlocking - <|> parseNonBlocking + parseSeq + <|> parseConditional + <|> parseLoop + <|> parseEventCtrl + <|> parseDelayCtrl + <|> try parseBlocking + <|> parseNonBlocking maybeEmptyStatement :: Parser (Maybe (Statement ann)) maybeEmptyStatement = - (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) + (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) parseAlways :: Parser (ModItem ann) parseAlways = tok' KWAlways *> (Always <$> parseStatement) @@ -425,61 +427,63 @@ parseInitial = tok' KWInitial *> (Initial <$> parseStatement) namedModConn :: Parser ModConn namedModConn = do - target <- tok' SymDot *> identifier - expr <- parens parseExpr - return $ ModConnNamed target expr + target <- tok' SymDot *> identifier + expr <- parens parseExpr + return $ ModConnNamed target expr parseModConn :: Parser ModConn parseModConn = try (fmap ModConn parseExpr) <|> namedModConn parseModInst :: Parser (ModItem ann) parseModInst = do - m <- identifier - name <- identifier - modconns <- parens (commaSep parseModConn) - tok' SymSemi - return $ ModInst m name modconns + m <- identifier + name <- identifier + modconns <- parens (commaSep parseModConn) + tok' SymSemi + return $ ModInst m name modconns parseModItem :: Parser (ModItem ann) parseModItem = - try (ModCA <$> parseContAssign) - <|> try parseDecl - <|> parseAlways - <|> parseInitial - <|> parseModInst + try (ModCA <$> parseContAssign) + <|> try parseDecl + <|> parseAlways + <|> parseInitial + <|> parseModInst parseModList :: Parser [Identifier] parseModList = list <|> return [] where list = parens $ commaSep identifier filterDecl :: PortDir -> (ModItem ann) -> Bool filterDecl p (Decl (Just p') _ _) = p == p' -filterDecl _ _ = False +filterDecl _ _ = False modPorts :: PortDir -> [ModItem ann] -> [Port] modPorts p mis = filter (filterDecl p) mis ^.. traverse . declPort parseParam :: Parser Parameter parseParam = do - i <- tok' KWParameter *> identifier - expr <- tok' SymEq *> parseConstExpr - return $ Parameter i expr + i <- tok' KWParameter *> identifier + expr <- tok' SymEq *> parseConstExpr + return $ Parameter i expr parseParams :: Parser [Parameter] parseParams = tok' SymPound *> parens (commaSep parseParam) parseModDecl :: Parser (ModDecl ann) parseModDecl = do - name <- tok KWModule *> identifier - paramList <- option [] $ try parseParams - _ <- fmap defaultPort <$> parseModList - tok' SymSemi - modItem <- option [] . try $ many1 parseModItem - tok' KWEndmodule - return $ ModDecl name - (modPorts PortOut modItem) - (modPorts PortIn modItem) - modItem - paramList + name <- tok KWModule *> identifier + paramList <- option [] $ try parseParams + _ <- fmap defaultPort <$> parseModList + tok' SymSemi + modItem <- option [] . try $ many1 parseModItem + tok' KWEndmodule + return $ + ModDecl + name + (modPorts PortOut modItem) + (modPorts PortIn modItem) + modItem + paramList -- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace -- and then parsing multiple Verilog source. @@ -488,24 +492,27 @@ parseVerilogSrc = Verilog <$> many parseModDecl -- | Parse a 'String' containing verilog code. The parser currently only supports -- the subset of Verilog that is being generated randomly. -parseVerilog - :: Text -- ^ Name of parsed object. - -> Text -- ^ Content to be parsed. - -> Either Text (Verilog ann) -- ^ Returns 'String' with error - -- message if parse fails. +parseVerilog :: + -- | Name of parsed object. + Text -> + -- | Content to be parsed. + Text -> + -- | Returns 'String' with error + -- message if parse fails. + Either Text (Verilog ann) parseVerilog s = - bimap showT id - . parse parseVerilogSrc (T.unpack s) - . alexScanTokens - . preprocess [] (T.unpack s) - . T.unpack + bimap showT id + . parse parseVerilogSrc (T.unpack s) + . alexScanTokens + . preprocess [] (T.unpack s) + . T.unpack parseVerilogFile :: Text -> IO (Verilog ann) parseVerilogFile file = do - src <- T.readFile $ T.unpack file - case parseVerilog file src of - Left s -> error $ T.unpack s - Right r -> return r + src <- T.readFile $ T.unpack file + case parseVerilog file src of + Left s -> error $ T.unpack s + Right r -> return r parseSourceInfoFile :: Text -> Text -> IO (SourceInfo ann) parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile diff --git a/src/Verismith/Verilog/Preprocess.hs b/src/Verismith/Verilog/Preprocess.hs index 91356f1..909334b 100644 --- a/src/Verismith/Verilog/Preprocess.hs +++ b/src/Verismith/Verilog/Preprocess.hs @@ -1,23 +1,21 @@ -{-| -Module : Verismith.Verilog.Preprocess -Description : Simple preprocessor for `define and comments. -Copyright : (c) 2011-2015 Tom Hawkins, 2019 Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Simple preprocessor for `define and comments. - -The code is from https://github.com/tomahawkins/verilog. - -Edits to the original code are warning fixes and formatting changes. --} - +-- | +-- Module : Verismith.Verilog.Preprocess +-- Description : Simple preprocessor for `define and comments. +-- Copyright : (c) 2011-2015 Tom Hawkins, 2019 Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Simple preprocessor for `define and comments. +-- +-- The code is from https://github.com/tomahawkins/verilog. +-- +-- Edits to the original code are warning fixes and formatting changes. module Verismith.Verilog.Preprocess - ( uncomment - , preprocess - ) + ( uncomment, + preprocess, + ) where -- | Remove comments from code. There is no difference between @(* *)@ and @@ -27,84 +25,83 @@ uncomment :: FilePath -> String -> String uncomment file = uncomment' where uncomment' a = case a of - "" -> "" - '/' : '/' : rest -> " " ++ removeEOL rest - '/' : '*' : rest -> " " ++ remove rest - '(' : '*' : rest -> " " ++ remove rest - '"' : rest -> '"' : ignoreString rest - b : rest -> b : uncomment' rest - + "" -> "" + '/' : '/' : rest -> " " ++ removeEOL rest + '/' : '*' : rest -> " " ++ remove rest + '(' : '*' : rest -> " " ++ remove rest + '"' : rest -> '"' : ignoreString rest + b : rest -> b : uncomment' rest removeEOL a = case a of - "" -> "" - '\n' : rest -> '\n' : uncomment' rest - '\t' : rest -> '\t' : removeEOL rest - _ : rest -> ' ' : removeEOL rest - + "" -> "" + '\n' : rest -> '\n' : uncomment' rest + '\t' : rest -> '\t' : removeEOL rest + _ : rest -> ' ' : removeEOL rest remove a = case a of - "" -> error $ "File ended without closing comment (*/): " ++ file - '"' : rest -> removeString rest - '\n' : rest -> '\n' : remove rest - '\t' : rest -> '\t' : remove rest - '*' : '/' : rest -> " " ++ uncomment' rest - '*' : ')' : rest -> " " ++ uncomment' rest - _ : rest -> " " ++ remove rest - + "" -> error $ "File ended without closing comment (*/): " ++ file + '"' : rest -> removeString rest + '\n' : rest -> '\n' : remove rest + '\t' : rest -> '\t' : remove rest + '*' : '/' : rest -> " " ++ uncomment' rest + '*' : ')' : rest -> " " ++ uncomment' rest + _ : rest -> " " ++ remove rest removeString a = case a of - "" -> error $ "File ended without closing string: " ++ file - '"' : rest -> " " ++ remove rest - '\\' : '"' : rest -> " " ++ removeString rest - '\n' : rest -> '\n' : removeString rest - '\t' : rest -> '\t' : removeString rest - _ : rest -> ' ' : removeString rest - + "" -> error $ "File ended without closing string: " ++ file + '"' : rest -> " " ++ remove rest + '\\' : '"' : rest -> " " ++ removeString rest + '\n' : rest -> '\n' : removeString rest + '\t' : rest -> '\t' : removeString rest + _ : rest -> ' ' : removeString rest ignoreString a = case a of - "" -> error $ "File ended without closing string: " ++ file - '"' : rest -> '"' : uncomment' rest - '\\' : '"' : rest -> "\\\"" ++ ignoreString rest - b : rest -> b : ignoreString rest + "" -> error $ "File ended without closing string: " ++ file + '"' : rest -> '"' : uncomment' rest + '\\' : '"' : rest -> "\\\"" ++ ignoreString rest + b : rest -> b : ignoreString rest -- | A simple `define preprocessor. preprocess :: [(String, String)] -> FilePath -> String -> String -preprocess env file content = unlines $ pp True [] env $ lines $ uncomment - file - content +preprocess env file content = + unlines $ pp True [] env $ lines $ + uncomment + file + content where pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String] - pp _ _ _ [] = [] + pp _ _ _ [] = [] pp on stack env_ (a : rest) = case words a of - "`define" : name : value -> - "" - : pp - on - stack - (if on - then (name, ppLine env_ $ unwords value) : env_ - else env_ - ) - rest - "`ifdef" : name : _ -> - "" : pp (on && elem name (map fst env_)) (on : stack) env_ rest - "`ifndef" : name : _ -> - "" : pp (on && notElem name (map fst env_)) (on : stack) env_ rest - "`else" : _ - | not $ null stack - -> "" : pp (head stack && not on) stack env_ rest - | otherwise - -> error $ "`else without associated `ifdef/`ifndef: " ++ file - "`endif" : _ - | not $ null stack - -> "" : pp (head stack) (tail stack) env_ rest - | otherwise - -> error $ "`endif without associated `ifdef/`ifndef: " ++ file - _ -> (if on then ppLine env_ a else "") : pp on stack env_ rest + "`define" : name : value -> + "" + : pp + on + stack + ( if on + then (name, ppLine env_ $ unwords value) : env_ + else env_ + ) + rest + "`ifdef" : name : _ -> + "" : pp (on && elem name (map fst env_)) (on : stack) env_ rest + "`ifndef" : name : _ -> + "" : pp (on && notElem name (map fst env_)) (on : stack) env_ rest + "`else" : _ + | not $ null stack -> + "" : pp (head stack && not on) stack env_ rest + | otherwise -> + error $ "`else without associated `ifdef/`ifndef: " ++ file + "`endif" : _ + | not $ null stack -> + "" : pp (head stack) (tail stack) env_ rest + | otherwise -> + error $ "`endif without associated `ifdef/`ifndef: " ++ file + _ -> (if on then ppLine env_ a else "") : pp on stack env_ rest ppLine :: [(String, String)] -> String -> String -ppLine _ "" = "" +ppLine _ "" = "" ppLine env ('`' : a) = case lookup name env of - Just value -> value ++ ppLine env rest - Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env + Just value -> value ++ ppLine env rest + Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env where - name = takeWhile + name = + takeWhile (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) a rest = drop (length name) a diff --git a/src/Verismith/Verilog/Quote.hs b/src/Verismith/Verilog/Quote.hs index 5e1e5dc..beb2d73 100644 --- a/src/Verismith/Verilog/Quote.hs +++ b/src/Verismith/Verilog/Quote.hs @@ -1,29 +1,27 @@ -{-| -Module : Verismith.Verilog.Quote -Description : QuasiQuotation for verilog code in Haskell. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -QuasiQuotation for verilog code in Haskell. --} - {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Verismith.Verilog.Quote +-- Description : QuasiQuotation for verilog code in Haskell. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- QuasiQuotation for verilog code in Haskell. module Verismith.Verilog.Quote - ( verilog - ) + ( verilog, + ) where -import Data.Data -import qualified Data.Text as T -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Verismith.Verilog.Parser +import Data.Data +import qualified Data.Text as T +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax import Verismith.Verilog.AST (Verilog) +import Verismith.Verilog.Parser liftDataWithText :: Data a => a -> Q Exp liftDataWithText = dataToExpQ $ fmap liftText . cast @@ -34,18 +32,19 @@ liftText txt = AppE (VarE 'T.pack) <$> lift (T.unpack txt) -- | Quasiquoter for verilog, so that verilog can be written inline and be -- parsed to an AST at compile time. verilog :: QuasiQuoter -verilog = QuasiQuoter - { quoteExp = quoteVerilog - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined +verilog = + QuasiQuoter + { quoteExp = quoteVerilog, + quotePat = undefined, + quoteType = undefined, + quoteDec = undefined } quoteVerilog :: String -> TH.Q TH.Exp quoteVerilog s = do - loc <- TH.location - let pos = T.pack $ TH.loc_filename loc - v <- case parseVerilog pos (T.pack s) of - Right e -> return e - Left e -> fail $ show e - liftDataWithText (v :: Verilog ()) + loc <- TH.location + let pos = T.pack $ TH.loc_filename loc + v <- case parseVerilog pos (T.pack s) of + Right e -> return e + Left e -> fail $ show e + liftDataWithText (v :: Verilog ()) diff --git a/src/Verismith/Verilog/Token.hs b/src/Verismith/Verilog/Token.hs index b303e18..3445bb4 100644 --- a/src/Verismith/Verilog/Token.hs +++ b/src/Verismith/Verilog/Token.hs @@ -1,29 +1,27 @@ -{-| -Module : Verismith.Verilog.Token -Description : Tokens for Verilog parsing. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Tokens for Verilog parsing. --} - +-- | +-- Module : Verismith.Verilog.Token +-- Description : Tokens for Verilog parsing. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Tokens for Verilog parsing. module Verismith.Verilog.Token - ( Token(..) - , TokenName(..) - , Position(..) - , tokenString - ) + ( Token (..), + TokenName (..), + Position (..), + tokenString, + ) where -import Text.Printf +import Text.Printf tokenString :: Token -> String tokenString (Token _ s _) = s -data Position = Position String Int Int deriving Eq +data Position = Position String Int Int deriving (Eq) instance Show Position where show (Position f l c) = printf "%s:%d:%d" f l c |