diff options
| author | Yann Herklotz <git@yannherklotz.com> | 2020-05-12 12:21:36 +0100 |
|---|---|---|
| committer | Yann Herklotz <git@yannherklotz.com> | 2020-05-12 12:21:42 +0100 |
| commit | 7124a4f00e536b4d5323a7488c1f65469dddb102 (patch) | |
| tree | 150ccfd9bf1549c930a12ee5200826cedfa37fa3 | |
| parent | d1b04fc068b1484f8bd0020598d3a2f023772f46 (diff) | |
| download | verismith-7124a4f00e536b4d5323a7488c1f65469dddb102.tar.gz verismith-7124a4f00e536b4d5323a7488c1f65469dddb102.zip | |
Format with ormolu
44 files changed, 5683 insertions, 5032 deletions
diff --git a/src/Verismith.hs b/src/Verismith.hs index e709ff4..4fb52ac 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -1,133 +1,137 @@ -{-| -Module : Verismith -Description : Verismith -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX --} - {-# OPTIONS_GHC -Wno-unused-top-binds #-} +-- | +-- Module : Verismith +-- Description : Verismith +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX module Verismith - ( defaultMain + ( defaultMain, + -- * Types - , Opts(..) - , SourceInfo(..) + Opts (..), + SourceInfo (..), + -- * Run functions - , runEquivalence - , runSimulation - , runReduce - , draw + runEquivalence, + runSimulation, + runReduce, + draw, + -- * Verilog generation functions - , procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod + procedural, + proceduralIO, + proceduralSrc, + proceduralSrcIO, + randomMod, + -- * Extra modules - , module Verismith.Verilog - , module Verismith.Config - , module Verismith.Circuit - , module Verismith.Tool - , module Verismith.Fuzz - , module Verismith.Report - ) + module Verismith.Verilog, + module Verismith.Config, + module Verismith.Circuit, + module Verismith.Tool, + module Verismith.Fuzz, + module Verismith.Report, + ) where -import Control.Concurrent -import Control.Lens hiding ((<.>)) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (byteStringHex, toLazyByteString) -import qualified Data.ByteString.Lazy as L -import qualified Data.Graph.Inductive as G +import Control.Concurrent +import Control.Lens hiding ((<.>)) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteStringHex, toLazyByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.Graph.Inductive as G import qualified Data.Graph.Inductive.Dot as G -import Data.Maybe (isNothing) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import qualified Data.Text.IO as T -import Hedgehog (Gen) -import qualified Hedgehog.Gen as Hog -import Hedgehog.Internal.Seed (Seed) -import Options.Applicative -import Paths_verismith (getDataDir) -import Prelude hiding (FilePath) -import Shelly hiding (command) -import Shelly.Lifted (liftSh) -import System.Random (randomIO) -import Verismith.Circuit -import Verismith.Config -import Verismith.Fuzz -import Verismith.Generate -import Verismith.OptParser -import Verismith.Reduce -import Verismith.Report -import Verismith.Result -import Verismith.Tool -import Verismith.Tool.Internal -import Verismith.Verilog -import Verismith.Verilog.Parser (parseSourceInfoFile) +import Data.Maybe (isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.IO as T +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Hog +import Hedgehog.Internal.Seed (Seed) +import Options.Applicative +import Paths_verismith (getDataDir) +import Shelly hiding (command) +import Shelly.Lifted (liftSh) +import System.Random (randomIO) +import Verismith.Circuit +import Verismith.Config +import Verismith.Fuzz +import Verismith.Generate +import Verismith.OptParser +import Verismith.Reduce +import Verismith.Report +import Verismith.Result +import Verismith.Tool +import Verismith.Tool.Internal import Verismith.Utils (generateByteString) +import Verismith.Verilog +import Verismith.Verilog.Parser (parseSourceInfoFile) +import Prelude hiding (FilePath) toFP :: String -> FilePath toFP = fromText . T.pack myForkIO :: IO () -> IO (MVar ()) myForkIO io = do - mvar <- newEmptyMVar - _ <- forkFinally io (\_ -> putMVar mvar ()) - return mvar + mvar <- newEmptyMVar + _ <- forkFinally io (\_ -> putMVar mvar ()) + return mvar getConfig :: Maybe FilePath -> IO Config getConfig s = - maybe (return defaultConfig) parseConfigFile $ T.unpack . toTextIgnore <$> s + maybe (return defaultConfig) parseConfigFile $ T.unpack . toTextIgnore <$> s getGenerator :: Config -> Text -> Maybe FilePath -> IO (Gen (SourceInfo ())) getGenerator config top s = - maybe (return $ proceduralSrc top config) (fmap return . parseSourceInfoFile top) - $ toTextIgnore <$> s + maybe (return $ proceduralSrc top config) (fmap return . parseSourceInfoFile top) $ + toTextIgnore <$> s -- | Randomly remove an option by setting it to 0. randDelete :: Int -> IO Int randDelete i = do - r <- randomIO - return $ if r then i else 0 + r <- randomIO + return $ if r then i else 0 randomise :: Config -> IO Config randomise config@(Config a _ c d e) = do - mia <- return $ cm ^. probModItemAssign - misa <- return $ cm ^. probModItemSeqAlways - mica <- return $ cm ^. probModItemCombAlways - mii <- return $ cm ^. probModItemInst - ssb <- return $ cs ^. probStmntBlock - ssnb <- return $ cs ^. probStmntNonBlock - ssc <- return $ cs ^. probStmntCond - ssf <- return $ cs ^. probStmntFor - en <- return $ ce ^. probExprNum - keep_out <- return $ cmo ^. probModDropOutput - drop_out <- randDelete $ cmo ^. probModDropOutput - ei <- randDelete $ ce ^. probExprId - ers <- randDelete $ ce ^. probExprRangeSelect - euo <- randDelete $ ce ^. probExprUnOp - ebo <- randDelete $ ce ^. probExprBinOp - ec <- randDelete $ ce ^. probExprCond - eco <- randDelete $ ce ^. probExprConcat - estr <- randDelete $ ce ^. probExprStr - esgn <- randDelete $ ce ^. probExprSigned - eus <- randDelete $ ce ^. probExprUnsigned - return $ Config - a - (Probability (ProbModItem mia misa mica mii) - (ProbStatement ssb ssnb ssc ssf) - (ProbExpr en ei ers euo ebo ec eco estr esgn eus) - (ProbMod drop_out keep_out) - ) - c - d - e + mia <- return $ cm ^. probModItemAssign + misa <- return $ cm ^. probModItemSeqAlways + mica <- return $ cm ^. probModItemCombAlways + mii <- return $ cm ^. probModItemInst + ssb <- return $ cs ^. probStmntBlock + ssnb <- return $ cs ^. probStmntNonBlock + ssc <- return $ cs ^. probStmntCond + ssf <- return $ cs ^. probStmntFor + en <- return $ ce ^. probExprNum + keep_out <- return $ cmo ^. probModDropOutput + drop_out <- randDelete $ cmo ^. probModDropOutput + ei <- randDelete $ ce ^. probExprId + ers <- randDelete $ ce ^. probExprRangeSelect + euo <- randDelete $ ce ^. probExprUnOp + ebo <- randDelete $ ce ^. probExprBinOp + ec <- randDelete $ ce ^. probExprCond + eco <- randDelete $ ce ^. probExprConcat + estr <- randDelete $ ce ^. probExprStr + esgn <- randDelete $ ce ^. probExprSigned + eus <- randDelete $ ce ^. probExprUnsigned + return $ + Config + a + ( Probability + (ProbModItem mia misa mica mii) + (ProbStatement ssb ssnb ssc ssf) + (ProbExpr en ei ers euo ebo ec eco estr esgn eus) + (ProbMod drop_out keep_out) + ) + c + d + e where cm = config ^. configProbability . probModItem cs = config ^. configProbability . probStmnt @@ -136,91 +140,107 @@ randomise config@(Config a _ c d e) = do handleOpts :: Opts -> IO () handleOpts (Fuzz o configF f k n nosim noequiv noreduction file top cc checker) = do - config <- getConfig configF - gen <- getGenerator config top file - datadir <- getDataDir - _ <- runFuzz - (FuzzOpts (Just $ fromText o) - f k n nosim noequiv noreduction config (toFP datadir) cc checker) - defaultYosys - (fuzzMultiple gen) - return () + config <- getConfig configF + gen <- getGenerator config top file + datadir <- getDataDir + _ <- + runFuzz + ( FuzzOpts + (Just $ fromText o) + f + k + n + nosim + noequiv + noreduction + config + (toFP datadir) + cc + checker + ) + defaultYosys + (fuzzMultiple gen) + return () handleOpts (Generate f c) = do - config <- getConfig c - source <- proceduralIO "top" config :: IO (Verilog ()) - maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) - $ T.unpack - . toTextIgnore - <$> f + config <- getConfig c + source <- proceduralIO "top" config :: IO (Verilog ()) + maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) $ + T.unpack + . toTextIgnore + <$> f handleOpts (Parse f t o rc) = do - verilogSrc <- T.readFile file - case parseVerilog (T.pack file) verilogSrc of - Left l -> print l - Right v -> - case (o, GenVerilog - . mapply rc (takeReplace . removeConstInConcat) - $ SourceInfo t v) of - (Nothing, a) -> print a - (Just o', a) -> writeFile (T.unpack $ toTextIgnore o') $ show a + verilogSrc <- T.readFile file + case parseVerilog (T.pack file) verilogSrc of + Left l -> print l + Right v -> + case ( o, + GenVerilog + . mapply rc (takeReplace . removeConstInConcat) + $ SourceInfo t v + ) of + (Nothing, a) -> print a + (Just o', a) -> writeFile (T.unpack $ toTextIgnore o') $ show a where file = T.unpack . toTextIgnore $ f mapply i f = if i then f else id handleOpts (Reduce f t _ ls' False) = do - src <- parseSourceInfoFile t (toTextIgnore f) - datadir <- getDataDir - case descriptionToSynth <$> ls' of - a : b : _ -> do - putStrLn "Reduce with equivalence check" - shelly $ do - make dir - pop dir $ do - src' <- reduceSynth Nothing (toFP datadir) a b src :: Sh (SourceInfo ()) - writefile (fromText ".." </> dir <.> "v") $ genSource src' - a : _ -> do - putStrLn "Reduce with synthesis failure" - shelly $ do - make dir - pop dir $ do - src' <- reduceSynthesis a src - writefile (fromText ".." </> dir <.> "v") $ genSource src' - _ -> do - putStrLn "Not reducing because no synthesiser was specified" - return () - where dir = fromText "reduce" + src <- parseSourceInfoFile t (toTextIgnore f) + datadir <- getDataDir + case descriptionToSynth <$> ls' of + a : b : _ -> do + putStrLn "Reduce with equivalence check" + shelly $ do + make dir + pop dir $ do + src' <- reduceSynth Nothing (toFP datadir) a b src :: Sh (SourceInfo ()) + writefile (fromText ".." </> dir <.> "v") $ genSource src' + a : _ -> do + putStrLn "Reduce with synthesis failure" + shelly $ do + make dir + pop dir $ do + src' <- reduceSynthesis a src + writefile (fromText ".." </> dir <.> "v") $ genSource src' + _ -> do + putStrLn "Not reducing because no synthesiser was specified" + return () + where + dir = fromText "reduce" handleOpts (Reduce f t _ ls' True) = do - src <- parseSourceInfoFile t (toTextIgnore f) :: IO (SourceInfo ()) - datadir <- getDataDir - case descriptionToSynth <$> ls' of - a : b : _ -> do - putStrLn "Starting equivalence check" - res <- shelly . runResultT $ do - make dir - pop dir $ do - runSynth a src - runSynth b src - runEquiv Nothing (toFP datadir) a b src - case res of - Pass _ -> putStrLn "Equivalence check passed" - Fail (EquivFail _) -> putStrLn "Equivalence check failed" - Fail TimeoutError -> putStrLn "Equivalence check timed out" - Fail _ -> putStrLn "Equivalence check error" - return () - as -> do - putStrLn "Synthesis check" - _ <- shelly . runResultT $ mapM (flip runSynth src) as - return () - where dir = fromText "equiv" + src <- parseSourceInfoFile t (toTextIgnore f) :: IO (SourceInfo ()) + datadir <- getDataDir + case descriptionToSynth <$> ls' of + a : b : _ -> do + putStrLn "Starting equivalence check" + res <- shelly . runResultT $ do + make dir + pop dir $ do + runSynth a src + runSynth b src + runEquiv Nothing (toFP datadir) a b src + case res of + Pass _ -> putStrLn "Equivalence check passed" + Fail (EquivFail _) -> putStrLn "Equivalence check failed" + Fail TimeoutError -> putStrLn "Equivalence check timed out" + Fail _ -> putStrLn "Equivalence check error" + return () + as -> do + putStrLn "Synthesis check" + _ <- shelly . runResultT $ mapM (flip runSynth src) as + return () + where + dir = fromText "equiv" handleOpts (ConfigOpt c conf r) = do - config <- if r then getConfig conf >>= randomise else getConfig conf - maybe (T.putStrLn . encodeConfig $ config) (`encodeConfigFile` config) - $ T.unpack - . toTextIgnore - <$> c + config <- if r then getConfig conf >>= randomise else getConfig conf + maybe (T.putStrLn . encodeConfig $ config) (`encodeConfigFile` config) $ + T.unpack + . toTextIgnore + <$> c defaultMain :: IO () defaultMain = do - optsparsed <- execParser opts - handleOpts optsparsed + optsparsed <- execParser opts + handleOpts optsparsed makeSrcInfo :: (ModDecl ann) -> (SourceInfo ann) makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) @@ -229,10 +249,10 @@ makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) -- can be seen. draw :: IO () draw = do - gr <- Hog.sample $ rDups . getCircuit <$> Hog.resize 10 randomDAG - let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr - writeFile "file.dot" dot - shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] + gr <- Hog.sample $ rDups . getCircuit <$> Hog.resize 10 randomDAG + let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr + writeFile "file.dot" dot + shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] -- | Function to show a bytestring in a hex format. showBS :: ByteString -> Text @@ -247,80 +267,85 @@ runSimulation = do -- shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] -- let circ = -- head $ (nestUpTo 30 . generateAST $ Circuit gr) ^.. getVerilog . traverse . getDescription - rand <- generateByteString Nothing 32 20 - rand2 <- Hog.sample (randomMod 10 100) :: IO (ModDecl ()) - val <- shelly . runResultT $ runSim defaultIcarus (makeSrcInfo rand2) rand - case val of - Pass a -> T.putStrLn $ showBS a - _ -> T.putStrLn "Test failed" - + rand <- generateByteString Nothing 32 20 + rand2 <- Hog.sample (randomMod 10 100) :: IO (ModDecl ()) + val <- shelly . runResultT $ runSim defaultIcarus (makeSrcInfo rand2) rand + case val of + Pass a -> T.putStrLn $ showBS a + _ -> T.putStrLn "Test failed" -- | Code to be executed on a failure. Also checks if the failure was a timeout, -- as the timeout command will return the 124 error code if that was the -- case. In that case, the error will be moved to a different directory. onFailure :: Text -> RunFailed -> Sh (Result Failed ()) onFailure t _ = do - ex <- lastExitCode - case ex of - 124 -> do - logger "Test TIMEOUT" - chdir ".." $ cp_r (fromText t) $ fromText (t <> "_timeout") - return $ Fail EmptyFail - _ -> do - logger "Test FAIL" - chdir ".." $ cp_r (fromText t) $ fromText (t <> "_failed") - return $ Fail EmptyFail + ex <- lastExitCode + case ex of + 124 -> do + logger "Test TIMEOUT" + chdir ".." $ cp_r (fromText t) $ fromText (t <> "_timeout") + return $ Fail EmptyFail + _ -> do + logger "Test FAIL" + chdir ".." $ cp_r (fromText t) $ fromText (t <> "_failed") + return $ Fail EmptyFail checkEquivalence :: Show ann => SourceInfo ann -> Text -> IO Bool checkEquivalence src dir = shellyFailDir $ do - mkdir_p (fromText dir) - curr <- toTextIgnore <$> pwd - datadir <- liftIO getDataDir - setenv "VERISMITH_ROOT" curr - cd (fromText dir) - catch_sh - ((runResultT $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado src) >> return True) - ((\_ -> return False) :: RunFailed -> Sh Bool) + mkdir_p (fromText dir) + curr <- toTextIgnore <$> pwd + datadir <- liftIO getDataDir + setenv "VERISMITH_ROOT" curr + cd (fromText dir) + catch_sh + ((runResultT $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado src) >> return True) + ((\_ -> return False) :: RunFailed -> Sh Bool) -- | Run a fuzz run and check if all of the simulators passed by checking if the -- generated Verilog files are equivalent. -runEquivalence - :: Maybe Seed - -> Gen (Verilog ()) -- ^ Generator for the Verilog file. - -> Text -- ^ Name of the folder on each thread. - -> Text -- ^ Name of the general folder being used. - -> Bool -- ^ Keep flag. - -> Int -- ^ Used to track the recursion. - -> IO () +runEquivalence :: + Maybe Seed -> + -- | Generator for the Verilog file. + Gen (Verilog ()) -> + -- | Name of the folder on each thread. + Text -> + -- | Name of the general folder being used. + Text -> + -- | Keep flag. + Bool -> + -- | Used to track the recursion. + Int -> + IO () runEquivalence seed gm t d k i = do - (_, m) <- shelly $ sampleSeed seed gm - let srcInfo = SourceInfo "top" m - rand <- generateByteString Nothing 32 20 - datadir <- getDataDir - shellyFailDir $ do - mkdir_p (fromText d </> fromText n) - curr <- toTextIgnore <$> pwd - setenv "VERISMITH_ROOT" curr - cd (fromText "output" </> fromText n) - _ <- - catch_sh - ( runResultT - $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado srcInfo - >> liftSh (logger "Test OK") - ) - $ onFailure n - _ <- - catch_sh - ( runResultT - $ runSim (Icarus "iverilog" "vvp") srcInfo rand - >>= (\b -> liftSh $ logger ("RTL Sim: " <> showBS b)) - ) - $ onFailure n - cd ".." - unless k . rm_rf $ fromText n - when (i < 5 && isNothing seed) (runEquivalence seed gm t d k $ i + 1) - where n = t <> "_" <> T.pack (show i) + (_, m) <- shelly $ sampleSeed seed gm + let srcInfo = SourceInfo "top" m + rand <- generateByteString Nothing 32 20 + datadir <- getDataDir + shellyFailDir $ do + mkdir_p (fromText d </> fromText n) + curr <- toTextIgnore <$> pwd + setenv "VERISMITH_ROOT" curr + cd (fromText "output" </> fromText n) + _ <- + catch_sh + ( runResultT $ + runEquiv Nothing (toFP datadir) defaultYosys defaultVivado srcInfo + >> liftSh (logger "Test OK") + ) + $ onFailure n + _ <- + catch_sh + ( runResultT $ + runSim (Icarus "iverilog" "vvp") srcInfo rand + >>= (\b -> liftSh $ logger ("RTL Sim: " <> showBS b)) + ) + $ onFailure n + cd ".." + unless k . rm_rf $ fromText n + when (i < 5 && isNothing seed) (runEquivalence seed gm t d k $ i + 1) + where + n = t <> "_" <> T.pack (show i) runReduce :: (SourceInfo ()) -> IO (SourceInfo ()) runReduce s = - shelly $ reduce "reduce.v" (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s + shelly $ reduce "reduce.v" (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s diff --git a/src/Verismith/Circuit.hs b/src/Verismith/Circuit.hs index cda2f4f..c91991d 100644 --- a/src/Verismith/Circuit.hs +++ b/src/Verismith/Circuit.hs @@ -1,45 +1,43 @@ -{-| -Module : Verismith.Circuit -Description : Definition of the circuit graph. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Definition of the circuit graph. --} - +-- | +-- Module : Verismith.Circuit +-- Description : Definition of the circuit graph. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Definition of the circuit graph. module Verismith.Circuit - ( -- * Circuit - Gate(..) - , Circuit(..) - , CNode(..) - , CEdge(..) - , fromGraph - , generateAST - , rDups - , rDupsCirc - , randomDAG - , genRandomDAG - ) + ( -- * Circuit + Gate (..), + Circuit (..), + CNode (..), + CEdge (..), + fromGraph, + generateAST, + rDups, + rDupsCirc, + randomDAG, + genRandomDAG, + ) where -import Control.Lens -import Hedgehog (Gen) -import qualified Hedgehog.Gen as Hog -import Verismith.Circuit.Base -import Verismith.Circuit.Gen -import Verismith.Circuit.Random -import Verismith.Verilog.AST -import Verismith.Verilog.Mutate +import Control.Lens +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Hog +import Verismith.Circuit.Base +import Verismith.Circuit.Gen +import Verismith.Circuit.Random +import Verismith.Verilog.AST +import Verismith.Verilog.Mutate fromGraph :: Gen (ModDecl ann) fromGraph = do - gr <- rDupsCirc <$> Hog.resize 100 randomDAG - return - $ initMod - . head - $ nestUpTo 5 (generateAST gr) - ^.. _Wrapped - . traverse + gr <- rDupsCirc <$> Hog.resize 100 randomDAG + return + $ initMod + . head + $ nestUpTo 5 (generateAST gr) + ^.. _Wrapped + . traverse diff --git a/src/Verismith/Circuit/Base.hs b/src/Verismith/Circuit/Base.hs index 9a5ab34..804fbfd 100644 --- a/src/Verismith/Circuit/Base.hs +++ b/src/Verismith/Circuit/Base.hs @@ -1,40 +1,39 @@ -{-| -Module : Verismith.Circuit.Base -Description : Base types for the circuit module. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Base types for the circuit module. --} - +-- | +-- Module : Verismith.Circuit.Base +-- Description : Base types for the circuit module. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Base types for the circuit module. module Verismith.Circuit.Base - ( Gate(..) - , Circuit(..) - , CNode(..) - , CEdge(..) - ) + ( Gate (..), + Circuit (..), + CNode (..), + CEdge (..), + ) where -import Data.Graph.Inductive (Gr, LEdge, LNode) -import System.Random +import Data.Graph.Inductive (Gr, LEdge, LNode) +import System.Random -- | The types for all the gates. -data Gate = And - | Or - | Xor - deriving (Show, Eq, Enum, Bounded, Ord) +data Gate + = And + | Or + | Xor + deriving (Show, Eq, Enum, Bounded, Ord) -- | Newtype for the Circuit which implements a Graph from fgl. -newtype Circuit = Circuit { getCircuit :: Gr Gate () } +newtype Circuit = Circuit {getCircuit :: Gr Gate ()} -- | Newtype for a node in the circuit, which is an 'LNode Gate'. -newtype CNode = CNode { getCNode :: LNode Gate } +newtype CNode = CNode {getCNode :: LNode Gate} -- | Newtype for a named edge which is empty, as it does not need a label. -newtype CEdge = CEdge { getCEdge :: LEdge () } +newtype CEdge = CEdge {getCEdge :: LEdge ()} instance Random Gate where randomR (a, b) g = diff --git a/src/Verismith/Circuit/Gen.hs b/src/Verismith/Circuit/Gen.hs index 07b6c06..7b3f072 100644 --- a/src/Verismith/Circuit/Gen.hs +++ b/src/Verismith/Circuit/Gen.hs @@ -1,27 +1,25 @@ -{-| -Module : Verilog.Circuit.Gen -Description : Generate verilog from circuit. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Generate verilog from circuit. --} - +-- | +-- Module : Verilog.Circuit.Gen +-- Description : Generate verilog from circuit. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Generate verilog from circuit. module Verismith.Circuit.Gen - ( generateAST - ) + ( generateAST, + ) where -import Data.Graph.Inductive (LNode, Node) -import qualified Data.Graph.Inductive as G -import Data.Maybe (catMaybes) -import Verismith.Circuit.Base -import Verismith.Circuit.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.Mutate +import Data.Graph.Inductive (LNode, Node) +import qualified Data.Graph.Inductive as G +import Data.Maybe (catMaybes) +import Verismith.Circuit.Base +import Verismith.Circuit.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.Mutate -- | Converts a 'CNode' to an 'Identifier'. frNode :: Node -> Identifier @@ -31,7 +29,7 @@ frNode = Identifier . fromNode -- mapping. fromGate :: Gate -> BinaryOperator fromGate And = BinAnd -fromGate Or = BinOr +fromGate Or = BinOr fromGate Xor = BinXor inputsC :: Circuit -> [Node] @@ -43,8 +41,8 @@ genPortsAST f c = port . frNode <$> f c where port = Port Wire False 4 -- | Generates the nested expression AST, so that it can then generate the -- assignment expressions. genAssignExpr :: Gate -> [Node] -> Maybe Expr -genAssignExpr _ [] = Nothing -genAssignExpr _ [n ] = Just . Id $ frNode n +genAssignExpr _ [] = Nothing +genAssignExpr _ [n] = Just . Id $ frNode n genAssignExpr g (n : ns) = BinOp wire oper <$> genAssignExpr g ns where wire = Id $ frNode n @@ -56,24 +54,24 @@ genAssignExpr g (n : ns) = BinOp wire oper <$> genAssignExpr g ns genContAssignAST :: Circuit -> LNode Gate -> Maybe (ModItem ann) genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes where - gr = getCircuit c + gr = getCircuit c nodes = G.pre gr n - name = frNode n + name = frNode n genAssignAST :: Circuit -> [ModItem ann] genAssignAST c = catMaybes $ genContAssignAST c <$> nodes where - gr = getCircuit c + gr = getCircuit c nodes = G.labNodes gr genModuleDeclAST :: Circuit -> (ModDecl ann) genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] where - i = Identifier "gen_module" - ports = genPortsAST inputsC c + i = Identifier "gen_module" + ports = genPortsAST inputsC c output = [] - a = genAssignAST c - yPort = Port Wire False 90 "y" + a = genAssignAST c + yPort = Port Wire False 90 "y" generateAST :: Circuit -> (Verilog ann) generateAST c = Verilog [genModuleDeclAST c] diff --git a/src/Verismith/Circuit/Internal.hs b/src/Verismith/Circuit/Internal.hs index f727630..ead1de8 100644 --- a/src/Verismith/Circuit/Internal.hs +++ b/src/Verismith/Circuit/Internal.hs @@ -1,27 +1,25 @@ -{-| -Module : Verismith.Circuit.Internal -Description : Internal helpers for generation. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Internal helpers for generation. --} - +-- | +-- Module : Verismith.Circuit.Internal +-- Description : Internal helpers for generation. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Internal helpers for generation. module Verismith.Circuit.Internal - ( fromNode - , filterGr - , only - , inputs - , outputs - ) + ( fromNode, + filterGr, + only, + inputs, + outputs, + ) where -import Data.Graph.Inductive (Graph, Node) +import Data.Graph.Inductive (Graph, Node) import qualified Data.Graph.Inductive as G -import qualified Data.Text as T +import qualified Data.Text as T -- | Convert an integer into a label. -- @@ -36,13 +34,13 @@ filterGr graph f = filter f $ G.nodes graph -- | Takes two functions that return an 'Int', and compares there results to 0 -- and not 0 respectively. This result is returned. -only - :: (Graph gr) - => gr n e - -> (gr n e -> Node -> Int) - -> (gr n e -> Node -> Int) - -> Node - -> Bool +only :: + (Graph gr) => + gr n e -> + (gr n e -> Node -> Int) -> + (gr n e -> Node -> Int) -> + Node -> + Bool only graph fun1 fun2 n = fun1 graph n == 0 && fun2 graph n /= 0 -- | Returns all the input nodes to a graph, which means nodes that do not have diff --git a/src/Verismith/Circuit/Random.hs b/src/Verismith/Circuit/Random.hs index 5389df8..4d00c24 100644 --- a/src/Verismith/Circuit/Random.hs +++ b/src/Verismith/Circuit/Random.hs @@ -1,35 +1,34 @@ -{-| -Module : Verismith.Circuit.Random -Description : Random generation for DAG -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Define the random generation for the directed acyclic graph. --} - +-- | +-- Module : Verismith.Circuit.Random +-- Description : Random generation for DAG +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Define the random generation for the directed acyclic graph. module Verismith.Circuit.Random - ( rDups - , rDupsCirc - , randomDAG - , genRandomDAG - ) + ( rDups, + rDupsCirc, + randomDAG, + genRandomDAG, + ) where -import Data.Graph.Inductive (Context) -import qualified Data.Graph.Inductive as G -import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.List (nub) -import Hedgehog (Gen) -import qualified Hedgehog.Gen as Hog -import qualified Hedgehog.Range as Hog -import Verismith.Circuit.Base +import Data.Graph.Inductive (Context) +import qualified Data.Graph.Inductive as G +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.List (nub) +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Hog +import qualified Hedgehog.Range as Hog +import Verismith.Circuit.Base dupFolder :: (Eq a, Eq b) => Context a b -> [Context a b] -> [Context a b] dupFolder cont ns = unique cont : ns - where unique (a, b, c, d) = (nub a, b, c, nub d) + where + unique (a, b, c, d) = (nub a, b, c, nub d) -- | Remove duplicates. rDups :: (Eq a, Eq b) => Gr a b -> Gr a b @@ -43,21 +42,26 @@ rDupsCirc = Circuit . rDups . getCircuit -- `n` that is passed to it. arbitraryEdge :: Hog.Size -> Gen CEdge arbitraryEdge n = do - x <- with $ \a -> a < n && a > 0 && a /= n - 1 - y <- with $ \a -> x < a && a < n && a > 0 - return $ CEdge (fromIntegral x, fromIntegral y, ()) + x <- with $ \a -> a < n && a > 0 && a /= n - 1 + y <- with $ \a -> x < a && a < n && a > 0 + return $ CEdge (fromIntegral x, fromIntegral y, ()) where - with = flip Hog.filter $ fromIntegral <$> Hog.resize - n - (Hog.int (Hog.linear 0 100)) + with = + flip Hog.filter $ + fromIntegral + <$> Hog.resize + n + (Hog.int (Hog.linear 0 100)) -- | Gen instance for a random acyclic DAG. -randomDAG :: Gen Circuit -- ^ The generated graph. It uses Arbitrary to generate - -- random instances of each node +randomDAG :: + -- | The generated graph. It uses Arbitrary to generate + -- random instances of each node + Gen Circuit randomDAG = do - list <- Hog.list (Hog.linear 1 100) $ Hog.enum minBound maxBound - l <- Hog.list (Hog.linear 10 1000) aE - return . Circuit $ G.mkGraph (nodes list) l + list <- Hog.list (Hog.linear 1 100) $ Hog.enum minBound maxBound + l <- Hog.list (Hog.linear 10 1000) aE + return . Circuit $ G.mkGraph (nodes list) l where nodes l = zip [0 .. length l - 1] l aE = getCEdge <$> Hog.sized arbitraryEdge diff --git a/src/Verismith/Config.hs b/src/Verismith/Config.hs index df684b7..8a8f90c 100644 --- a/src/Verismith/Config.hs +++ b/src/Verismith/Config.hs @@ -1,109 +1,116 @@ -{-| -Module : Verismith.Config -Description : Configuration file format and parser. -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -TOML Configuration file format and parser. --} - {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Verismith.Config +-- Description : Configuration file format and parser. +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- TOML Configuration file format and parser. module Verismith.Config - ( -- * TOML Configuration - -- $conf - Config(..) - , defaultConfig + ( -- * TOML Configuration + -- $conf + Config (..), + defaultConfig, + -- ** Probabilities - , Probability(..) + Probability (..), + -- *** Expression - , ProbExpr(..) + ProbExpr (..), + -- *** Module Item - , ProbModItem(..) + ProbModItem (..), + -- *** Statement - , ProbStatement(..) + ProbStatement (..), + -- *** Module - , ProbMod (..) + ProbMod (..), + -- ** ConfProperty - , ConfProperty(..) + ConfProperty (..), + -- ** Simulator Description - , SimDescription(..) + SimDescription (..), + -- ** Synthesiser Description - , SynthDescription(..) + SynthDescription (..), + -- * Useful Lenses - , fromXST - , fromYosys - , fromVivado - , fromQuartus - , fromQuartusLight - , configProbability - , configProperty - , configSimulators - , configSynthesisers - , probModItem - , probMod - , probModDropOutput - , probModKeepOutput - , probStmnt - , probExpr - , probExprNum - , probExprId - , probExprRangeSelect - , probExprUnOp - , probExprBinOp - , probExprCond - , probExprConcat - , probExprStr - , probExprSigned - , probExprUnsigned - , probModItemAssign - , probModItemSeqAlways - , probModItemCombAlways - , probModItemInst - , probStmntBlock - , probStmntNonBlock - , probStmntCond - , probStmntFor - , propSampleSize - , propSampleMethod - , propSize - , propSeed - , propStmntDepth - , propModDepth - , propMaxModules - , propCombine - , propDeterminism - , propNonDeterminism - , propDefaultYosys - , parseConfigFile - , parseConfig - , encodeConfig - , encodeConfigFile - , versionInfo - ) + fromXST, + fromYosys, + fromVivado, + fromQuartus, + fromQuartusLight, + configProbability, + configProperty, + configSimulators, + configSynthesisers, + probModItem, + probMod, + probModDropOutput, + probModKeepOutput, + probStmnt, + probExpr, + probExprNum, + probExprId, + probExprRangeSelect, + probExprUnOp, + probExprBinOp, + probExprCond, + probExprConcat, + probExprStr, + probExprSigned, + probExprUnsigned, + probModItemAssign, + probModItemSeqAlways, + probModItemCombAlways, + probModItemInst, + probStmntBlock, + probStmntNonBlock, + probStmntCond, + probStmntFor, + propSampleSize, + propSampleMethod, + propSize, + propSeed, + propStmntDepth, + propModDepth, + propMaxModules, + propCombine, + propDeterminism, + propNonDeterminism, + propDefaultYosys, + parseConfigFile, + parseConfig, + encodeConfig, + encodeConfigFile, + versionInfo, + ) where -import Control.Applicative (Alternative) -import Control.Lens hiding ((.=)) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) -import qualified Data.Text.IO as T -import Data.Version (showVersion) -import Development.GitRev -import Hedgehog.Internal.Seed (Seed) -import Paths_verismith (version) -import Shelly (toTextIgnore) -import Toml (TomlCodec, (.=)) +import Control.Applicative (Alternative) +import Control.Lens hiding ((.=)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Development.GitRev +import Hedgehog.Internal.Seed (Seed) +import Paths_verismith (version) +import Shelly (toTextIgnore) +import Toml ((.=), TomlCodec) import qualified Toml -import Verismith.Tool.Quartus -import Verismith.Tool.QuartusLight -import Verismith.Tool.Vivado -import Verismith.Tool.XST -import Verismith.Tool.Yosys +import Verismith.Tool.Quartus +import Verismith.Tool.QuartusLight +import Verismith.Tool.Vivado +import Verismith.Tool.XST +import Verismith.Tool.Yosys -- $conf -- @@ -145,200 +152,234 @@ import Verismith.Tool.Yosys -- - <http://www.clifford.at/yosys/ Yosys Open SYnthesis Suite> -- | Probability of different expressions nodes. -data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int - -- ^ @expr.number@: probability of generation a number like - -- @4'ha@. This should never be set to 0, as it is used - -- as a fallback in case there are no viable - -- identifiers, such as none being in scope. - , _probExprId :: {-# UNPACK #-} !Int - -- ^ @expr.variable@: probability of generating an identifier that is in - -- scope and of the right type. - , _probExprRangeSelect :: {-# UNPACK #-} !Int - -- ^ @expr.rangeselect@: probability of generating a range - -- selection from a port (@reg1[2:0]@). - , _probExprUnOp :: {-# UNPACK #-} !Int - -- ^ @expr.unary@: probability of generating a unary operator. - , _probExprBinOp :: {-# UNPACK #-} !Int - -- ^ @expr.binary@: probability of generation a binary operator. - , _probExprCond :: {-# UNPACK #-} !Int - -- ^ @expr.ternary@: probability of generating a conditional ternary - -- operator. - , _probExprConcat :: {-# UNPACK #-} !Int - -- ^ @expr.concatenation@: probability of generating a concatenation. - , _probExprStr :: {-# UNPACK #-} !Int - -- ^ @expr.string@: probability of generating a string. This is not - -- fully supported therefore currently cannot be set. - , _probExprSigned :: {-# UNPACK #-} !Int - -- ^ @expr.signed@: probability of generating a signed function - -- @$signed(...)@. - , _probExprUnsigned :: {-# UNPACK #-} !Int - -- ^ @expr.unsigned@: probability of generating an unsigned function - -- @$unsigned(...)@. - } - deriving (Eq, Show) +data ProbExpr + = ProbExpr + { -- | @expr.number@: probability of generation a number like + -- @4'ha@. This should never be set to 0, as it is used + -- as a fallback in case there are no viable + -- identifiers, such as none being in scope. + _probExprNum :: {-# UNPACK #-} !Int, + -- | @expr.variable@: probability of generating an identifier that is in + -- scope and of the right type. + _probExprId :: {-# UNPACK #-} !Int, + -- | @expr.rangeselect@: probability of generating a range + -- selection from a port (@reg1[2:0]@). + _probExprRangeSelect :: {-# UNPACK #-} !Int, + -- | @expr.unary@: probability of generating a unary operator. + _probExprUnOp :: {-# UNPACK #-} !Int, + -- | @expr.binary@: probability of generation a binary operator. + _probExprBinOp :: {-# UNPACK #-} !Int, + -- | @expr.ternary@: probability of generating a conditional ternary + -- operator. + _probExprCond :: {-# UNPACK #-} !Int, + -- | @expr.concatenation@: probability of generating a concatenation. + _probExprConcat :: {-# UNPACK #-} !Int, + -- | @expr.string@: probability of generating a string. This is not + -- fully supported therefore currently cannot be set. + _probExprStr :: {-# UNPACK #-} !Int, + -- | @expr.signed@: probability of generating a signed function + -- @$signed(...)@. + _probExprSigned :: {-# UNPACK #-} !Int, + -- | @expr.unsigned@: probability of generating an unsigned function + -- @$unsigned(...)@. + _probExprUnsigned :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) -- | Probability of generating different nodes inside a module declaration. -data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int - -- ^ @moditem.assign@: probability of generating an @assign@. - , _probModItemSeqAlways :: {-# UNPACK #-} !Int - -- ^ @moditem.sequential@: probability of generating a sequential @always@ block. - , _probModItemCombAlways :: {-# UNPACK #-} !Int - -- ^ @moditem.combinational@: probability of generating an combinational @always@ - -- block. This is currently not implemented. - , _probModItemInst :: {-# UNPACK #-} !Int - -- ^ @moditem.instantiation@: probability of generating a module - -- instantiation. - } - deriving (Eq, Show) +data ProbModItem + = ProbModItem + { -- | @moditem.assign@: probability of generating an @assign@. + _probModItemAssign :: {-# UNPACK #-} !Int, + -- | @moditem.sequential@: probability of generating a sequential @always@ block. + _probModItemSeqAlways :: {-# UNPACK #-} !Int, + -- | @moditem.combinational@: probability of generating an combinational @always@ + -- block. This is currently not implemented. + _probModItemCombAlways :: {-# UNPACK #-} !Int, + -- | @moditem.instantiation@: probability of generating a module + -- instantiation. + _probModItemInst :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) -- | Probability of generating different statements. -data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int - -- ^ @statement.blocking@: probability of generating blocking assignments. - , _probStmntNonBlock :: {-# UNPACK #-} !Int - -- ^ @statement.nonblocking@: probability of generating nonblocking assignments. - , _probStmntCond :: {-# UNPACK #-} !Int - -- ^ @statement.conditional@: probability of generating conditional - -- statements (@if@ statements). - , _probStmntFor :: {-# UNPACK #-} !Int - -- ^ @statement.forloop@: probability of generating for loops. - } - deriving (Eq, Show) +data ProbStatement + = ProbStatement + { -- | @statement.blocking@: probability of generating blocking assignments. + _probStmntBlock :: {-# UNPACK #-} !Int, + -- | @statement.nonblocking@: probability of generating nonblocking assignments. + _probStmntNonBlock :: {-# UNPACK #-} !Int, + -- | @statement.conditional@: probability of generating conditional + -- statements (@if@ statements). + _probStmntCond :: {-# UNPACK #-} !Int, + -- | @statement.forloop@: probability of generating for loops. + _probStmntFor :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) -- | Probability of generating various properties of a module. -data ProbMod = ProbMod { _probModDropOutput :: {-# UNPACK #-} !Int - -- ^ "@module.drop_output@: frequency of a wire or register being dropped from the output." - , _probModKeepOutput :: {-# UNPACK #-} !Int - -- ^ "@module.keep_output@: frequency of a wire or register being kept in the output." - } - deriving (Eq, Show) +data ProbMod + = ProbMod + { -- | "@module.drop_output@: frequency of a wire or register being dropped from the output." + _probModDropOutput :: {-# UNPACK #-} !Int, + -- | "@module.keep_output@: frequency of a wire or register being kept in the output." + _probModKeepOutput :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) -- | @[probability]@: combined probabilities. -data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem - -- ^ Probabilities for module items. - , _probStmnt :: {-# UNPACK #-} !ProbStatement - -- ^ Probabilities for statements. - , _probExpr :: {-# UNPACK #-} !ProbExpr - -- ^ Probaiblities for expressions. - , _probMod :: {-# UNPACK #-} !ProbMod - } - deriving (Eq, Show) +data Probability + = Probability + { -- | Probabilities for module items. + _probModItem :: {-# UNPACK #-} !ProbModItem, + -- | Probabilities for statements. + _probStmnt :: {-# UNPACK #-} !ProbStatement, + -- | Probaiblities for expressions. + _probExpr :: {-# UNPACK #-} !ProbExpr, + _probMod :: {-# UNPACK #-} !ProbMod + } + deriving (Eq, Show) -- | @[property]@: properties for the generated Verilog file. -data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int - -- ^ @size@: the size of the generated Verilog. - , _propSeed :: !(Maybe Seed) - -- ^ @seed@: a possible seed that could be used to - -- generate the same Verilog. - , _propStmntDepth :: {-# UNPACK #-} !Int - -- ^ @statement.depth@: the maximum statement depth that should be - -- reached. - , _propModDepth :: {-# UNPACK #-} !Int - -- ^ @module.depth@: the maximium module depth that should be - -- reached. - , _propMaxModules :: {-# UNPACK #-} !Int - -- ^ @module.max@: the maximum number of modules that are - -- allowed to be created at each level. - , _propSampleMethod :: !Text - -- ^ @sample.method@: the sampling method that should be used to - -- generate specific distributions of random - -- programs. - , _propSampleSize :: {-# UNPACK #-} !Int - -- ^ @sample.size@: the number of samples to take for the - -- sampling method. - , _propCombine :: !Bool - -- ^ @output.combine@: if the output should be combined into one - -- bit or not. - , _propNonDeterminism :: {-# UNPACK #-} !Int - -- ^ @nondeterminism@: the frequency at which nondeterminism - -- should be generated (currently a work in progress). - , _propDeterminism :: {-# UNPACK #-} !Int - -- ^ @determinism@: the frequency at which determinism should - -- be generated (currently modules are always deterministic). - , _propDefaultYosys :: !(Maybe Text) - -- ^ @default.yosys@: Default location for Yosys, which will be used for - -- equivalence checking. - } - deriving (Eq, Show) - -data Info = Info { _infoCommit :: !Text - -- ^ @commit@: the hash of the commit that was compiled. - , _infoVersion :: !Text - -- ^ @version@: the version of Verismith that was compiled. - } - deriving (Eq, Show) +data ConfProperty + = ConfProperty + { -- | @size@: the size of the generated Verilog. + _propSize :: {-# UNPACK #-} !Int, + -- | @seed@: a possible seed that could be used to + -- generate the same Verilog. + _propSeed :: !(Maybe Seed), + -- | @statement.depth@: the maximum statement depth that should be + -- reached. + _propStmntDepth :: {-# UNPACK #-} !Int, + -- | @module.depth@: the maximium module depth that should be + -- reached. + _propModDepth :: {-# UNPACK #-} !Int, + -- | @module.max@: the maximum number of modules that are + -- allowed to be created at each level. + _propMaxModules :: {-# UNPACK #-} !Int, + -- | @sample.method@: the sampling method that should be used to + -- generate specific distributions of random + -- programs. + _propSampleMethod :: !Text, + -- | @sample.size@: the number of samples to take for the + -- sampling method. + _propSampleSize :: {-# UNPACK #-} !Int, + -- | @output.combine@: if the output should be combined into one + -- bit or not. + _propCombine :: !Bool, + -- | @nondeterminism@: the frequency at which nondeterminism + -- should be generated (currently a work in progress). + _propNonDeterminism :: {-# UNPACK #-} !Int, + -- | @determinism@: the frequency at which determinism should + -- be generated (currently modules are always deterministic). + _propDeterminism :: {-# UNPACK #-} !Int, + -- | @default.yosys@: Default location for Yosys, which will be used for + -- equivalence checking. + _propDefaultYosys :: !(Maybe Text) + } + deriving (Eq, Show) + +data Info + = Info + { -- | @commit@: the hash of the commit that was compiled. + _infoCommit :: !Text, + -- | @version@: the version of Verismith that was compiled. + _infoVersion :: !Text + } + deriving (Eq, Show) -- | Description of the simulator -data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text } - deriving (Eq, Show) +data SimDescription = SimDescription {simName :: {-# UNPACK #-} !Text} + deriving (Eq, Show) -- | @[[synthesiser]]@: description of the synthesis tool. There can be multiple of these sections in a config -- file. -data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text - -- ^ @name@: type of the synthesis tool. Can either be @yosys@, @quartus@, - -- @quartuslight@, @vivado@, @xst@. - , synthBin :: Maybe Text - -- ^ @bin@: location of the synthesis tool binary. - , synthDesc :: Maybe Text - -- ^ @description@: description that should be used for the synthesis tool. - , synthOut :: Maybe Text - -- ^ @output@: name of the output Verilog file. - } - deriving (Eq, Show) - -data Config = Config { _configInfo :: Info - , _configProbability :: {-# UNPACK #-} !Probability - , _configProperty :: {-# UNPACK #-} !ConfProperty - , _configSimulators :: [SimDescription] - , _configSynthesisers :: [SynthDescription] - } - deriving (Eq, Show) +data SynthDescription + = SynthDescription + { -- | @name@: type of the synthesis tool. Can either be @yosys@, @quartus@, + -- @quartuslight@, @vivado@, @xst@. + synthName :: {-# UNPACK #-} !Text, + -- | @bin@: location of the synthesis tool binary. + synthBin :: Maybe Text, + -- | @description@: description that should be used for the synthesis tool. + synthDesc :: Maybe Text, + -- | @output@: name of the output Verilog file. + synthOut :: Maybe Text + } + deriving (Eq, Show) + +data Config + = Config + { _configInfo :: Info, + _configProbability :: {-# UNPACK #-} !Probability, + _configProperty :: {-# UNPACK #-} !ConfProperty, + _configSimulators :: [SimDescription], + _configSynthesisers :: [SynthDescription] + } + deriving (Eq, Show) $(makeLenses ''ProbExpr) + $(makeLenses ''ProbModItem) + $(makeLenses ''ProbStatement) + $(makeLenses ''ProbMod) + $(makeLenses ''Probability) + $(makeLenses ''ConfProperty) + $(makeLenses ''Info) + $(makeLenses ''Config) -defaultValue - :: (Alternative r, Applicative w) - => b - -> Toml.Codec r w a b - -> Toml.Codec r w a b +defaultValue :: + (Alternative r, Applicative w) => + b -> + Toml.Codec r w a b -> + Toml.Codec r w a b defaultValue x = Toml.dimap Just (fromMaybe x) . Toml.dioptional fromXST :: XST -> SynthDescription fromXST (XST a b c) = - SynthDescription "xst" (toTextIgnore <$> a) (Just b) (Just $ toTextIgnore c) + SynthDescription "xst" (toTextIgnore <$> a) (Just b) (Just $ toTextIgnore c) fromYosys :: Yosys -> SynthDescription -fromYosys (Yosys a b c) = SynthDescription "yosys" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) +fromYosys (Yosys a b c) = + SynthDescription + "yosys" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) fromVivado :: Vivado -> SynthDescription -fromVivado (Vivado a b c) = SynthDescription "vivado" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) +fromVivado (Vivado a b c) = + SynthDescription + "vivado" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) fromQuartus :: Quartus -> SynthDescription -fromQuartus (Quartus a b c) = SynthDescription "quartus" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) +fromQuartus (Quartus a b c) = + SynthDescription + "quartus" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) fromQuartusLight :: QuartusLight -> SynthDescription -fromQuartusLight (QuartusLight a b c) = SynthDescription "quartuslight" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) +fromQuartusLight (QuartusLight a b c) = + SynthDescription + "quartuslight" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) defaultConfig :: Config -defaultConfig = Config +defaultConfig = + Config (Info (pack $(gitHash)) (pack $ showVersion version)) (Probability defModItem defStmnt defExpr defMod) (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1 Nothing) @@ -346,29 +387,33 @@ defaultConfig = Config [fromYosys defaultYosys, fromVivado defaultVivado] where defMod = - ProbMod 0 -- Drop Output - 1 -- Keep Output + ProbMod + 0 -- Drop Output + 1 -- Keep Output defModItem = - ProbModItem 5 -- Assign - 1 -- Sequential Always - 1 -- Combinational Always - 1 -- Instantiation + ProbModItem + 5 -- Assign + 1 -- Sequential Always + 1 -- Combinational Always + 1 -- Instantiation defStmnt = - ProbStatement 0 -- Blocking assignment - 3 -- Non-blocking assignment - 1 -- Conditional - 0 -- For loop + ProbStatement + 0 -- Blocking assignment + 3 -- Non-blocking assignment + 1 -- Conditional + 0 -- For loop defExpr = - ProbExpr 1 -- Number - 5 -- Identifier - 5 -- Range selection - 5 -- Unary operator - 5 -- Binary operator - 5 -- Ternary conditional - 3 -- Concatenation - 0 -- String - 5 -- Signed function - 5 -- Unsigned funtion + ProbExpr + 1 -- Number + 5 -- Identifier + 5 -- Range selection + 5 -- Unary operator + 5 -- Binary operator + 5 -- Ternary conditional + 3 -- Concatenation + 0 -- String + 5 -- Signed function + 5 -- Unsigned funtion twoKey :: Toml.Piece -> Toml.Piece -> Toml.Key twoKey a b = Toml.Key (a :| [b]) @@ -378,57 +423,57 @@ int a = Toml.int . twoKey a exprCodec :: TomlCodec ProbExpr exprCodec = - ProbExpr - <$> defaultValue (defProb probExprNum) (intE "number") - .= _probExprNum - <*> defaultValue (defProb probExprId) (intE "variable") - .= _probExprId - <*> defaultValue (defProb probExprRangeSelect) (intE "rangeselect") - .= _probExprRangeSelect - <*> defaultValue (defProb probExprUnOp) (intE "unary") - .= _probExprUnOp - <*> defaultValue (defProb probExprBinOp) (intE "binary") - .= _probExprBinOp - <*> defaultValue (defProb probExprCond) (intE "ternary") - .= _probExprCond - <*> defaultValue (defProb probExprConcat) (intE "concatenation") - .= _probExprConcat - <*> defaultValue (defProb probExprStr) (intE "string") - .= _probExprStr - <*> defaultValue (defProb probExprSigned) (intE "signed") - .= _probExprSigned - <*> defaultValue (defProb probExprUnsigned) (intE "unsigned") - .= _probExprUnsigned + ProbExpr + <$> defaultValue (defProb probExprNum) (intE "number") + .= _probExprNum + <*> defaultValue (defProb probExprId) (intE "variable") + .= _probExprId + <*> defaultValue (defProb probExprRangeSelect) (intE "rangeselect") + .= _probExprRangeSelect + <*> defaultValue (defProb probExprUnOp) (intE "unary") + .= _probExprUnOp + <*> defaultValue (defProb probExprBinOp) (intE "binary") + .= _probExprBinOp + <*> defaultValue (defProb probExprCond) (intE "ternary") + .= _probExprCond + <*> defaultValue (defProb probExprConcat) (intE "concatenation") + .= _probExprConcat + <*> defaultValue (defProb probExprStr) (intE "string") + .= _probExprStr + <*> defaultValue (defProb probExprSigned) (intE "signed") + .= _probExprSigned + <*> defaultValue (defProb probExprUnsigned) (intE "unsigned") + .= _probExprUnsigned where defProb i = defaultConfig ^. configProbability . probExpr . i intE = int "expr" stmntCodec :: TomlCodec ProbStatement stmntCodec = - ProbStatement - <$> defaultValue (defProb probStmntBlock) (intS "blocking") - .= _probStmntBlock - <*> defaultValue (defProb probStmntNonBlock) (intS "nonblocking") - .= _probStmntNonBlock - <*> defaultValue (defProb probStmntCond) (intS "conditional") - .= _probStmntCond - <*> defaultValue (defProb probStmntFor) (intS "forloop") - .= _probStmntFor + ProbStatement + <$> defaultValue (defProb probStmntBlock) (intS "blocking") + .= _probStmntBlock + <*> defaultValue (defProb probStmntNonBlock) (intS "nonblocking") + .= _probStmntNonBlock + <*> defaultValue (defProb probStmntCond) (intS "conditional") + .= _probStmntCond + <*> defaultValue (defProb probStmntFor) (intS "forloop") + .= _probStmntFor where defProb i = defaultConfig ^. configProbability . probStmnt . i intS = int "statement" modItemCodec :: TomlCodec ProbModItem modItemCodec = - ProbModItem - <$> defaultValue (defProb probModItemAssign) (intM "assign") - .= _probModItemAssign - <*> defaultValue (defProb probModItemSeqAlways) (intM "sequential") - .= _probModItemSeqAlways - <*> defaultValue (defProb probModItemCombAlways) (intM "combinational") - .= _probModItemCombAlways - <*> defaultValue (defProb probModItemInst) (intM "instantiation") - .= _probModItemInst + ProbModItem + <$> defaultValue (defProb probModItemAssign) (intM "assign") + .= _probModItemAssign + <*> defaultValue (defProb probModItemSeqAlways) (intM "sequential") + .= _probModItemSeqAlways + <*> defaultValue (defProb probModItemCombAlways) (intM "combinational") + .= _probModItemCombAlways + <*> defaultValue (defProb probModItemInst) (intM "instantiation") + .= _probModItemInst where defProb i = defaultConfig ^. configProbability . probModItem . i intM = int "moditem" @@ -436,54 +481,58 @@ modItemCodec = modCodec :: TomlCodec ProbMod modCodec = ProbMod <$> defaultValue (defProb probModDropOutput) (intM "drop_output") - .= _probModDropOutput - <*> defaultValue (defProb probModKeepOutput) (intM "keep_output") - .= _probModKeepOutput + .= _probModDropOutput + <*> defaultValue (defProb probModKeepOutput) (intM "keep_output") + .= _probModKeepOutput where defProb i = defaultConfig ^. configProbability . probMod . i intM = int "module" probCodec :: TomlCodec Probability probCodec = - Probability - <$> defaultValue (defProb probModItem) modItemCodec - .= _probModItem - <*> defaultValue (defProb probStmnt) stmntCodec - .= _probStmnt - <*> defaultValue (defProb probExpr) exprCodec - .= _probExpr - <*> defaultValue (defProb probMod) modCodec - .= _probMod - where defProb i = defaultConfig ^. configProbability . i + Probability + <$> defaultValue (defProb probModItem) modItemCodec + .= _probModItem + <*> defaultValue (defProb probStmnt) stmntCodec + .= _probStmnt + <*> defaultValue (defProb probExpr) exprCodec + .= _probExpr + <*> defaultValue (defProb probMod) modCodec + .= _probMod + where + defProb i = defaultConfig ^. configProbability . i propCodec :: TomlCodec ConfProperty propCodec = - ConfProperty - <$> defaultValue (defProp propSize) (Toml.int "size") - .= _propSize - <*> Toml.dioptional (Toml.read "seed") - .= _propSeed - <*> defaultValue (defProp propStmntDepth) (int "statement" "depth") - .= _propStmntDepth - <*> defaultValue (defProp propModDepth) (int "module" "depth") - .= _propModDepth - <*> defaultValue (defProp propMaxModules) (int "module" "max") - .= _propMaxModules - <*> defaultValue (defProp propSampleMethod) - (Toml.text (twoKey "sample" "method")) - .= _propSampleMethod - <*> defaultValue (defProp propSampleSize) (int "sample" "size") - .= _propSampleSize - <*> defaultValue (defProp propCombine) - (Toml.bool (twoKey "output" "combine")) - .= _propCombine - <*> defaultValue (defProp propNonDeterminism) (Toml.int "nondeterminism") - .= _propNonDeterminism - <*> defaultValue (defProp propDeterminism) (Toml.int "determinism") - .= _propDeterminism - <*> Toml.dioptional (Toml.text (twoKey "default" "yosys")) - .= _propDefaultYosys - where defProp i = defaultConfig ^. configProperty . i + ConfProperty + <$> defaultValue (defProp propSize) (Toml.int "size") + .= _propSize + <*> Toml.dioptional (Toml.read "seed") + .= _propSeed + <*> defaultValue (defProp propStmntDepth) (int "statement" "depth") + .= _propStmntDepth + <*> defaultValue (defProp propModDepth) (int "module" "depth") + .= _propModDepth + <*> defaultValue (defProp propMaxModules) (int "module" "max") + .= _propMaxModules + <*> defaultValue + (defProp propSampleMethod) + (Toml.text (twoKey "sample" "method")) + .= _propSampleMethod + <*> defaultValue (defProp propSampleSize) (int "sample" "size") + .= _propSampleSize + <*> defaultValue + (defProp propCombine) + (Toml.bool (twoKey "output" "combine")) + .= _propCombine + <*> defaultValue (defProp propNonDeterminism) (Toml.int "nondeterminism") + .= _propNonDeterminism + <*> defaultValue (defProp propDeterminism) (Toml.int "determinism") + .= _propDeterminism + <*> Toml.dioptional (Toml.text (twoKey "default" "yosys")) + .= _propDefaultYosys + where + defProp i = defaultConfig ^. configProperty . i simulator :: TomlCodec SimDescription simulator = Toml.textBy pprint parseIcarus "name" @@ -494,57 +543,64 @@ simulator = Toml.textBy pprint parseIcarus "name" synthesiser :: TomlCodec SynthDescription synthesiser = - SynthDescription - <$> Toml.text "name" - .= synthName - <*> Toml.dioptional (Toml.text "bin") - .= synthBin - <*> Toml.dioptional (Toml.text "description") - .= synthDesc - <*> Toml.dioptional (Toml.text "output") - .= synthOut + SynthDescription + <$> Toml.text "name" + .= synthName + <*> Toml.dioptional (Toml.text "bin") + .= synthBin + <*> Toml.dioptional (Toml.text "description") + .= synthDesc + <*> Toml.dioptional (Toml.text "output") + .= synthOut infoCodec :: TomlCodec Info infoCodec = - Info - <$> defaultValue (defaultConfig ^. configInfo . infoCommit) - (Toml.text "commit") - .= _infoCommit - <*> defaultValue (defaultConfig ^. configInfo . infoVersion) - (Toml.text "version") - .= _infoVersion + Info + <$> defaultValue + (defaultConfig ^. configInfo . infoCommit) + (Toml.text "commit") + .= _infoCommit + <*> defaultValue + (defaultConfig ^. configInfo . infoVersion) + (Toml.text "version") + .= _infoVersion configCodec :: TomlCodec Config configCodec = - Config - <$> defaultValue (defaultConfig ^. configInfo) - (Toml.table infoCodec "info") - .= _configInfo - <*> defaultValue (defaultConfig ^. configProbability) - (Toml.table probCodec "probability") - .= _configProbability - <*> defaultValue (defaultConfig ^. configProperty) - (Toml.table propCodec "property") - .= _configProperty - <*> defaultValue (defaultConfig ^. configSimulators) - (Toml.list simulator "simulator") - .= _configSimulators - <*> defaultValue (defaultConfig ^. configSynthesisers) - (Toml.list synthesiser "synthesiser") - .= _configSynthesisers + Config + <$> defaultValue + (defaultConfig ^. configInfo) + (Toml.table infoCodec "info") + .= _configInfo + <*> defaultValue + (defaultConfig ^. configProbability) + (Toml.table probCodec "probability") + .= _configProbability + <*> defaultValue + (defaultConfig ^. configProperty) + (Toml.table propCodec "property") + .= _configProperty + <*> defaultValue + (defaultConfig ^. configSimulators) + (Toml.list simulator "simulator") + .= _configSimulators + <*> defaultValue + (defaultConfig ^. configSynthesisers) + (Toml.list synthesiser "synthesiser") + .= _configSynthesisers parseConfigFile :: FilePath -> IO Config parseConfigFile = Toml.decodeFile configCodec parseConfig :: Text -> Config parseConfig t = case Toml.decode configCodec t of - Right c-> c - Left Toml.TrivialError -> error "Trivial error while parsing Toml config" - Left (Toml.KeyNotFound k) -> error $ "Key " ++ show k ++ " not found" - Left (Toml.TableNotFound k) -> error $ "Table " ++ show k ++ " not found" - Left (Toml.TypeMismatch k _ _) -> - error $ "Type mismatch with key " ++ show k - Left _ -> error "Config file parse error" + Right c -> c + Left Toml.TrivialError -> error "Trivial error while parsing Toml config" + Left (Toml.KeyNotFound k) -> error $ "Key " ++ show k ++ " not found" + Left (Toml.TableNotFound k) -> error $ "Table " ++ show k ++ " not found" + Left (Toml.TypeMismatch k _ _) -> + error $ "Type mismatch with key " ++ show k + Left _ -> error "Config file parse error" encodeConfig :: Config -> Text encodeConfig = Toml.encode configCodec @@ -554,10 +610,10 @@ encodeConfigFile f = T.writeFile f . encodeConfig versionInfo :: String versionInfo = - "Verismith " - <> showVersion version - <> " (" - <> $(gitCommitDate) - <> " " - <> $(gitHash) - <> ")" + "Verismith " + <> showVersion version + <> " (" + <> $(gitCommitDate) + <> " " + <> $(gitHash) + <> ")" diff --git a/src/Verismith/CounterEg.hs b/src/Verismith/CounterEg.hs index a2e1210..f378baf 100644 --- a/src/Verismith/CounterEg.hs +++ b/src/Verismith/CounterEg.hs @@ -1,44 +1,44 @@ -{-| -Module : Verismith.CounterEg -Description : Counter example parser to load the counter example -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX --} - +-- | +-- Module : Verismith.CounterEg +-- Description : Counter example parser to load the counter example +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX module Verismith.CounterEg - ( CounterEg(..) - , parseCounterEg - ) + ( CounterEg (..), + parseCounterEg, + ) where -import Control.Applicative ((<|>)) -import Data.Bifunctor (bimap) -import Data.Binary (encode) -import Data.Bits (shiftL, (.|.)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Control.Applicative ((<|>)) +import Data.Bifunctor (bimap) +import Data.Binary (encode) +import Data.Bits ((.|.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Char (digitToInt) -import Data.Functor (($>)) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Numeric (readInt) -import qualified Text.Parsec as P - -data CounterEg = CounterEg { _counterEgInitial :: ![(Text, Text)] - , _counterEgStates :: ![[(Text, Text)]] - } - deriving (Eq, Show) +import Data.Char (digitToInt) +import Data.Functor (($>)) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Numeric (readInt) +import qualified Text.Parsec as P + +data CounterEg + = CounterEg + { _counterEgInitial :: ![(Text, Text)], + _counterEgStates :: ![[(Text, Text)]] + } + deriving (Eq, Show) instance Semigroup CounterEg where - CounterEg a b <> CounterEg c d = CounterEg (a <> c) (b <> d) + CounterEg a b <> CounterEg c d = CounterEg (a <> c) (b <> d) instance Monoid CounterEg where - mempty = CounterEg mempty mempty + mempty = CounterEg mempty mempty type Parser = P.Parsec String () @@ -57,11 +57,12 @@ type Parser = P.Parsec String () -- convertBinary = fromBytes . convert lexme :: Parser a -> Parser a -lexme f = do { a <- f; _ <- P.spaces; return a } +lexme f = do a <- f; _ <- P.spaces; return a nameChar :: Parser Char -nameChar = P.alphaNum - <|> P.oneOf "$.:_" +nameChar = + P.alphaNum + <|> P.oneOf "$.:_" parens :: Parser a -> Parser a parens = lexme . P.between (P.char '(') (P.char ')') @@ -74,39 +75,41 @@ trueOrFalse = lexme $ (P.string "true" $> "1") <|> (P.string "false" $> "0") assumeBody :: Parser (String, String) assumeBody = lexme $ do - name <- P.char '=' *> P.spaces *> brackets (P.many1 nameChar) - num <- P.spaces *> ((P.string "#b" *> P.many1 P.digit) <|> trueOrFalse) - return (name, num) + name <- P.char '=' *> P.spaces *> brackets (P.many1 nameChar) + num <- P.spaces *> ((P.string "#b" *> P.many1 P.digit) <|> trueOrFalse) + return (name, num) parseAssume :: Parser (String, String) parseAssume = lexme $ P.string "assume" *> P.spaces *> parens assumeBody parseInitial :: Parser [(String, String)] parseInitial = lexme $ do - _ <- lexme $ P.string "initial" - P.many parseAssume + _ <- lexme $ P.string "initial" + P.many parseAssume parseState :: Parser (String, [(String, String)]) parseState = lexme $ do - n <- lexme $ P.string "state" *> P.spaces *> P.many1 P.digit - assumes <- P.many parseAssume - return (n, assumes) + n <- lexme $ P.string "state" *> P.spaces *> P.many1 P.digit + assumes <- P.many parseAssume + return (n, assumes) parseCE :: Parser [[(String, String)]] parseCE = lexme $ do - i <- parseInitial - other <- fmap snd <$> P.many parseState - return (i : other) + i <- parseInitial + other <- fmap snd <$> P.many parseState + return (i : other) cEtoCounterEg :: [[(String, String)]] -> CounterEg cEtoCounterEg [] = mempty -cEtoCounterEg (i : is) = CounterEg (bimap T.pack T.pack <$> i) - (fmap (bimap T.pack T.pack) <$> is) +cEtoCounterEg (i : is) = + CounterEg + (bimap T.pack T.pack <$> i) + (fmap (bimap T.pack T.pack) <$> is) parseCounterEg' :: Parser CounterEg parseCounterEg' = lexme $ do - _ <- P.spaces - cEtoCounterEg <$> parseCE + _ <- P.spaces + cEtoCounterEg <$> parseCE parseCounterEg :: Text -> Either String CounterEg parseCounterEg = bimap show id . P.parse parseCounterEg' "" . T.unpack diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index 7771f6a..2fb9f00 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -1,114 +1,121 @@ -{-| -Module : Verismith.Fuzz -Description : Environment to run the simulator and synthesisers in a matrix. -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Environment to run the simulator and synthesisers in a matrix. --} - -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Verismith.Fuzz +-- Description : Environment to run the simulator and synthesisers in a matrix. +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Environment to run the simulator and synthesisers in a matrix. module Verismith.Fuzz - ( Fuzz (..) - , FuzzOpts (..) - , fuzz - , fuzzInDir - , fuzzMultiple - , runFuzz - , sampleSeed + ( Fuzz (..), + FuzzOpts (..), + fuzz, + fuzzInDir, + fuzzMultiple, + runFuzz, + sampleSeed, + -- * Helpers - , make - , pop - ) + make, + pop, + ) where -import Control.DeepSeq (force) -import Control.Exception.Lifted (finally) -import Control.Lens hiding ((<.>)) -import Control.Monad (forM, replicateM) -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Trans.Control (MonadBaseControl) -import Data.ByteString (ByteString) -import Data.List (nubBy, sort) -import Data.Maybe (catMaybes, fromMaybe, isNothing) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time -import Data.Tuple (swap) -import Hedgehog (Gen) -import qualified Hedgehog.Internal.Gen as Hog -import Hedgehog.Internal.Seed (Seed) -import qualified Hedgehog.Internal.Seed as Hog -import qualified Hedgehog.Internal.Tree as Hog -import Prelude hiding (FilePath) -import Shelly hiding (get, sub) -import Shelly.Lifted (MonadSh, liftSh, sub) -import System.FilePath.Posix (takeBaseName) -import Verismith.Config -import Verismith.CounterEg (CounterEg (..)) -import Verismith.Internal -import Verismith.Reduce -import Verismith.Report -import Verismith.Result -import Verismith.Tool.Icarus -import Verismith.Tool.Internal -import Verismith.Tool.Yosys -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.DeepSeq (force) +import Control.Exception.Lifted (finally) +import Control.Lens hiding ((<.>)) +import Control.Monad (forM, replicateM) +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.ByteString (ByteString) +import Data.List (nubBy, sort) +import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Tuple (swap) +import Hedgehog (Gen) +import qualified Hedgehog.Internal.Gen as Hog +import Hedgehog.Internal.Seed (Seed) +import qualified Hedgehog.Internal.Seed as Hog +import qualified Hedgehog.Internal.Tree as Hog +import Shelly hiding (get, sub) +import Shelly.Lifted (MonadSh, liftSh, sub) +import System.FilePath.Posix (takeBaseName) +import Verismith.Config +import Verismith.CounterEg (CounterEg (..)) +import Verismith.Internal +import Verismith.Reduce +import Verismith.Report +import Verismith.Result +import Verismith.Tool.Icarus +import Verismith.Tool.Internal +import Verismith.Tool.Yosys import Verismith.Utils (generateByteString) - -data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath) - , _fuzzOptsForced :: !Bool - , _fuzzOptsKeepAll :: !Bool - , _fuzzOptsIterations :: {-# UNPACK #-} !Int - , _fuzzOptsNoSim :: !Bool - , _fuzzOptsNoEquiv :: !Bool - , _fuzzOptsNoReduction :: !Bool - , _fuzzOptsConfig :: {-# UNPACK #-} !Config - , _fuzzDataDir :: !FilePath - , _fuzzOptsCrossCheck :: !Bool - , _fuzzOptsChecker :: !(Maybe Text) - } - deriving (Show, Eq) +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) + +data FuzzOpts + = FuzzOpts + { _fuzzOptsOutput :: !(Maybe FilePath), + _fuzzOptsForced :: !Bool, + _fuzzOptsKeepAll :: !Bool, + _fuzzOptsIterations :: {-# UNPACK #-} !Int, + _fuzzOptsNoSim :: !Bool, + _fuzzOptsNoEquiv :: !Bool, + _fuzzOptsNoReduction :: !Bool, + _fuzzOptsConfig :: {-# UNPACK #-} !Config, + _fuzzDataDir :: !FilePath, + _fuzzOptsCrossCheck :: !Bool, + _fuzzOptsChecker :: !(Maybe Text) + } + deriving (Show, Eq) $(makeLenses ''FuzzOpts) defaultFuzzOpts :: FuzzOpts -defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing - , _fuzzOptsForced = False - , _fuzzOptsKeepAll = False - , _fuzzOptsIterations = 1 - , _fuzzOptsNoSim = False - , _fuzzOptsNoEquiv = False - , _fuzzOptsNoReduction = False - , _fuzzOptsConfig = defaultConfig - , _fuzzDataDir = fromText "." - , _fuzzOptsCrossCheck = False - , _fuzzOptsChecker = Nothing - } - -data FuzzEnv = FuzzEnv { _getSynthesisers :: ![SynthTool] - , _getSimulators :: ![SimTool] - , _yosysInstance :: {-# UNPACK #-} !Yosys - , _fuzzEnvOpts :: {-# UNPACK #-} !FuzzOpts - } - deriving (Eq, Show) +defaultFuzzOpts = + FuzzOpts + { _fuzzOptsOutput = Nothing, + _fuzzOptsForced = False, + _fuzzOptsKeepAll = False, + _fuzzOptsIterations = 1, + _fuzzOptsNoSim = False, + _fuzzOptsNoEquiv = False, + _fuzzOptsNoReduction = False, + _fuzzOptsConfig = defaultConfig, + _fuzzDataDir = fromText ".", + _fuzzOptsCrossCheck = False, + _fuzzOptsChecker = Nothing + } + +data FuzzEnv + = FuzzEnv + { _getSynthesisers :: ![SynthTool], + _getSimulators :: ![SimTool], + _yosysInstance :: {-# UNPACK #-} !Yosys, + _fuzzEnvOpts :: {-# UNPACK #-} !FuzzOpts + } + deriving (Eq, Show) $(makeLenses ''FuzzEnv) -data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult] - , _fuzzSimResults :: ![SimResult] - , _fuzzSynthStatus :: ![SynthStatus] - } - deriving (Eq, Show) +data FuzzState + = FuzzState + { _fuzzSynthResults :: ![SynthResult], + _fuzzSimResults :: ![SimResult], + _fuzzSynthStatus :: ![SynthStatus] + } + deriving (Eq, Show) $(makeLenses ''FuzzState) @@ -124,16 +131,19 @@ runFuzz :: MonadIO m => FuzzOpts -> Yosys -> Fuzz Sh a -> m a runFuzz fo yos m = shelly $ runFuzz' fo yos m runFuzz' :: Monad m => FuzzOpts -> Yosys -> Fuzz m b -> m b -runFuzz' fo yos m = runReaderT +runFuzz' fo yos m = + runReaderT (evalStateT m (FuzzState [] [] [])) - (FuzzEnv { _getSynthesisers = ( force - $ defaultIdentitySynth - : (descriptionToSynth <$> conf ^. configSynthesisers) - ) - , _getSimulators = (force $ descriptionToSim <$> conf ^. configSimulators) - , _yosysInstance = yos - , _fuzzEnvOpts = fo - } + ( FuzzEnv + { _getSynthesisers = + ( force $ + defaultIdentitySynth + : (descriptionToSynth <$> conf ^. configSynthesisers) + ), + _getSimulators = (force $ descriptionToSim <$> conf ^. configSimulators), + _yosysInstance = yos, + _fuzzEnvOpts = fo + } ) where conf = _fuzzOptsConfig fo @@ -145,42 +155,42 @@ askOpts :: Monad m => Fuzz m FuzzOpts askOpts = asks _fuzzEnvOpts genMethod conf seed gen = - case T.toLower $ conf ^. configProperty . propSampleMethod of - "hat" -> do - logT "Using the hat function" - sv hatFreqs - "mean" -> do - logT "Using the mean function" - sv meanFreqs - "median" -> do - logT "Using the median function" - sv medianFreqs - _ -> do - logT "Using first seed" - sampleSeed seed gen + case T.toLower $ conf ^. configProperty . propSampleMethod of + "hat" -> do + logT "Using the hat function" + sv hatFreqs + "mean" -> do + logT "Using the mean function" + sv meanFreqs + "median" -> do + logT "Using the median function" + sv medianFreqs + _ -> do + logT "Using first seed" + sampleSeed seed gen where sv a = sampleVerilog a (conf ^. configProperty . propSampleSize) seed gen relativeFuzzReport :: (MonadSh m) => FuzzReport -> m FuzzReport relativeFuzzReport fr@(FuzzReport dir _ _ _ _ _ _ _) = liftSh $ do - newPath <- relPath dir - return $ (fuzzDir .~ newPath) fr + newPath <- relPath dir + return $ (fuzzDir .~ newPath) fr filterSynth :: SynthResult -> Bool filterSynth (SynthResult _ _ (Pass _) _) = True -filterSynth _ = False +filterSynth _ = False filterSim :: SimResult -> Bool filterSim (SimResult _ _ _ (Pass _) _) = True -filterSim _ = False +filterSim _ = False filterSynthStat :: SynthStatus -> Bool filterSynthStat (SynthStatus _ (Pass _) _) = True -filterSynthStat _ = False +filterSynthStat _ = False passedFuzz :: FuzzReport -> Bool passedFuzz (FuzzReport _ synth sim synthstat _ _ _ _) = - (passedSynth + passedSim + passedSynthStat) == 0 + (passedSynth + passedSim + passedSynthStat) == 0 where passedSynth = length $ filter (not . filterSynth) synth passedSim = length $ filter (not . filterSim) sim @@ -193,42 +203,42 @@ synthesisers = lift $ asks _getSynthesisers --simulators = lift $ asks getSimulators combinations :: [a] -> [b] -> [(a, b)] -combinations l1 l2 = [ (x, y) | x <- l1, y <- l2 ] +combinations l1 l2 = [(x, y) | x <- l1, y <- l2] logT :: MonadSh m => Text -> m () logT = liftSh . logger timeit :: (MonadIO m, MonadSh m) => m a -> m (NominalDiffTime, a) timeit a = do - start <- liftIO getCurrentTime - result <- a - end <- liftIO getCurrentTime - return (diffUTCTime end start, result) + start <- liftIO getCurrentTime + result <- a + end <- liftIO getCurrentTime + return (diffUTCTime end start, result) synthesis :: (MonadBaseControl IO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () synthesis src = do - synth <- synthesisers - resTimes <- liftSh $ mapM exec synth - fuzzSynthStatus - .= applyList (uncurry . SynthStatus <$> synth) (fmap swap resTimes) - liftSh $ inspect resTimes + synth <- synthesisers + resTimes <- liftSh $ mapM exec synth + fuzzSynthStatus + .= applyList (uncurry . SynthStatus <$> synth) (fmap swap resTimes) + liftSh $ inspect resTimes where exec a = toolRun ("synthesis with " <> toText a) . runResultT $ do - liftSh . mkdir_p . fromText $ toText a - pop (fromText $ toText a) $ runSynth a src + liftSh . mkdir_p . fromText $ toText a + pop (fromText $ toText a) $ runSynth a src passedSynthesis :: MonadSh m => Fuzz m [SynthTool] passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get where passed (SynthStatus _ (Pass _) _) = True - passed _ = False + passed _ = False toSynth (SynthStatus s _ _) = s failedSynthesis :: MonadSh m => Fuzz m [SynthTool] failedSynthesis = fmap toSynth . filter failed . _fuzzSynthStatus <$> get where failed (SynthStatus _ (Fail SynthFail) _) = True - failed _ = False + failed _ = False toSynth (SynthStatus s _ _) = s make :: MonadSh m => FilePath -> m () @@ -236,8 +246,8 @@ make f = liftSh $ mkdir_p f pop :: (MonadBaseControl IO m, MonadSh m) => FilePath -> m a -> m a pop f a = do - dir <- liftSh pwd - finally (liftSh (cd f) >> a) . liftSh $ cd dir + dir <- liftSh pwd + finally (liftSh (cd f) >> a) . liftSh $ cd dir applyList :: [a -> b] -> [a] -> [b] applyList a b = apply' <$> zip a b where apply' (a', b') = a' b' @@ -245,156 +255,169 @@ applyList a b = apply' <$> zip a b where apply' (a', b') = a' b' applyLots :: (a -> b -> c -> d -> e) -> [(a, b)] -> [(c, d)] -> [e] applyLots func a b = applyList (uncurry . uncurry func <$> a) b -toSynthResult :: [(SynthTool, SynthTool)] - -> [(NominalDiffTime, Result Failed ())] - -> [SynthResult] +toSynthResult :: + [(SynthTool, SynthTool)] -> + [(NominalDiffTime, Result Failed ())] -> + [SynthResult] toSynthResult a b = applyLots SynthResult a $ fmap swap b -toSimResult :: SimTool - -> [ByteString] - -> [SynthTool] - -> [(NominalDiffTime, Result Failed ByteString)] - -> [SimResult] +toSimResult :: + SimTool -> + [ByteString] -> + [SynthTool] -> + [(NominalDiffTime, Result Failed ByteString)] -> + [SimResult] toSimResult sima bs as b = - applyList (applyList (repeat uncurry) - (applyList (applyList (SimResult <$> as) (repeat sima)) (repeat bs))) + applyList + ( applyList + (repeat uncurry) + (applyList (applyList (SimResult <$> as) (repeat sima)) (repeat bs)) + ) $ fmap swap b toolRun :: (MonadIO m, MonadSh m, Show a) => Text -> m a -> m (NominalDiffTime, a) toolRun t m = do - logT $ "Running " <> t - s <- timeit m - logT $ "Finished " <> t <> " " <> showT s - return s + logT $ "Running " <> t + s <- timeit m + logT $ "Finished " <> t <> " " <> showT s + return s equivalence :: (MonadBaseControl IO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () equivalence src = do - doCrossCheck <- fmap _fuzzOptsCrossCheck askOpts - datadir <- fmap _fuzzDataDir askOpts - checker <- fmap _fuzzOptsChecker askOpts - synth <- passedSynthesis - conf <- fmap _fuzzOptsConfig askOpts - let synthComb = - if doCrossCheck - then nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth - else nubBy tupEq . filter (uncurry (/=)) $ (,) defaultIdentitySynth <$> synth - resTimes <- liftSh $ mapM (uncurry (equiv (conf ^. configProperty . propDefaultYosys) checker datadir)) synthComb - fuzzSynthResults .= toSynthResult synthComb resTimes - liftSh $ inspect resTimes + doCrossCheck <- fmap _fuzzOptsCrossCheck askOpts + datadir <- fmap _fuzzDataDir askOpts + checker <- fmap _fuzzOptsChecker askOpts + synth <- passedSynthesis + conf <- fmap _fuzzOptsConfig askOpts + let synthComb = + if doCrossCheck + then nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth + else nubBy tupEq . filter (uncurry (/=)) $ (,) defaultIdentitySynth <$> synth + resTimes <- liftSh $ mapM (uncurry (equiv (conf ^. configProperty . propDefaultYosys) checker datadir)) synthComb + fuzzSynthResults .= toSynthResult synthComb resTimes + liftSh $ inspect resTimes where tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') equiv yosysloc checker datadir a b = - toolRun ("equivalence check for " <> toText a <> " and " <> toText b) - . runResultT - $ do make dir - pop dir $ do - liftSh $ do - cp ( fromText ".." - </> fromText (toText a) - </> synthOutput a - ) $ synthOutput a - cp ( fromText ".." - </> fromText (toText b) - </> synthOutput b - ) $ synthOutput b - writefile "rtl.v" $ genSource src - sub $ do - maybe (return ()) (liftSh . prependToPath . fromText) yosysloc - runEquiv checker datadir a b src - where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b + toolRun ("equivalence check for " <> toText a <> " and " <> toText b) + . runResultT + $ do + make dir + pop dir $ do + liftSh $ do + cp + ( fromText ".." + </> fromText (toText a) + </> synthOutput a + ) + $ synthOutput a + cp + ( fromText ".." + </> fromText (toText b) + </> synthOutput b + ) + $ synthOutput b + writefile "rtl.v" $ genSource src + sub $ do + maybe (return ()) (liftSh . prependToPath . fromText) yosysloc + runEquiv checker datadir a b src + where + dir = fromText $ "equiv_" <> toText a <> "_" <> toText b simulation :: (MonadIO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () simulation src = do - datadir <- fmap _fuzzDataDir askOpts - synth <- passedSynthesis - counterEgs <- failEquivWithIdentityCE - vals <- liftIO $ generateByteString Nothing 32 20 - ident <- liftSh $ sim datadir vals Nothing defaultIdentitySynth - resTimes <- liftSh $ mapM (sim datadir vals (justPass $ snd ident)) synth - resTimes2 <- liftSh $ mapM (simCounterEg datadir) counterEgs - fuzzSimResults .= toSimResult defaultIcarusSim vals synth resTimes - liftSh - . inspect - $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) - <$> (ident : resTimes) + datadir <- fmap _fuzzDataDir askOpts + synth <- passedSynthesis + counterEgs <- failEquivWithIdentityCE + vals <- liftIO $ generateByteString Nothing 32 20 + ident <- liftSh $ sim datadir vals Nothing defaultIdentitySynth + resTimes <- liftSh $ mapM (sim datadir vals (justPass $ snd ident)) synth + resTimes2 <- liftSh $ mapM (simCounterEg datadir) counterEgs + fuzzSimResults .= toSimResult defaultIcarusSim vals synth resTimes + liftSh + . inspect + $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) + <$> (ident : resTimes) where sim datadir b i a = toolRun ("simulation for " <> toText a) . runResultT $ do - make dir - pop dir $ do - liftSh $ do - cp (fromText ".." </> fromText (toText a) </> synthOutput a) - $ synthOutput a - writefile "rtl.v" $ genSource src - runSimIc datadir defaultIcarus a src b i - where dir = fromText $ "simulation_" <> toText a + make dir + pop dir $ do + liftSh $ do + cp (fromText ".." </> fromText (toText a) </> synthOutput a) $ + synthOutput a + writefile "rtl.v" $ genSource src + runSimIc datadir defaultIcarus a src b i + where + dir = fromText $ "simulation_" <> toText a simCounterEg datadir (a, Nothing) = toolRun ("counter-example simulation for " <> toText a) . return $ Fail EmptyFail simCounterEg datadir (a, Just b) = toolRun ("counter-example simulation for " <> toText a) . runResultT $ do - make dir - pop dir $ do - liftSh $ do - cp (fromText ".." </> fromText (toText a) </> synthOutput a) $ synthOutput a - writefile "syn_identity.v" $ genSource src - ident <- runSimIcEC datadir defaultIcarus defaultIdentitySynth src b Nothing - runSimIcEC datadir defaultIcarus a src b (Just ident) - where dir = fromText $ "countereg_sim_" <> toText a + make dir + pop dir $ do + liftSh $ do + cp (fromText ".." </> fromText (toText a) </> synthOutput a) $ synthOutput a + writefile "syn_identity.v" $ genSource src + ident <- runSimIcEC datadir defaultIcarus defaultIdentitySynth src b Nothing + runSimIcEC datadir defaultIcarus a src b (Just ident) + where + dir = fromText $ "countereg_sim_" <> toText a failEquivWithIdentity :: (MonadSh m) => Fuzz m [SynthResult] failEquivWithIdentity = filter withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult (IdentitySynth _) _ (Fail (EquivFail _)) _) = True withIdentity (SynthResult _ (IdentitySynth _) (Fail (EquivFail _)) _) = True - withIdentity _ = False + withIdentity _ = False failEquivWithIdentityCE :: (MonadSh m) => Fuzz m [(SynthTool, Maybe CounterEg)] failEquivWithIdentityCE = catMaybes . fmap withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult (IdentitySynth _) s (Fail (EquivFail c)) _) = Just (s, c) withIdentity (SynthResult s (IdentitySynth _) (Fail (EquivFail c)) _) = Just (s, c) - withIdentity _ = Nothing + withIdentity _ = Nothing failedSimulations :: (MonadSh m) => Fuzz m [SimResult] failedSimulations = filter failedSim . _fuzzSimResults <$> get where failedSim (SimResult _ _ _ (Fail (SimFail _)) _) = True - failedSim _ = False + failedSim _ = False passEquiv :: (MonadSh m) => Fuzz m [SynthResult] passEquiv = filter withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult _ _ (Pass _) _) = True - withIdentity _ = False + withIdentity _ = False -- | Always reduces with respect to 'Identity'. reduction :: (MonadSh m) => SourceInfo ann -> Fuzz m () reduction rsrc = do - datadir <- fmap _fuzzDataDir askOpts - checker <- fmap _fuzzOptsChecker askOpts - fails <- failEquivWithIdentity - synthFails <- failedSynthesis - simFails <- failedSimulations - _ <- liftSh $ mapM (red checker datadir) fails - _ <- liftSh $ mapM redSynth synthFails - _ <- liftSh $ mapM (redSim datadir) simFails - return () + datadir <- fmap _fuzzDataDir askOpts + checker <- fmap _fuzzOptsChecker askOpts + fails <- failEquivWithIdentity + synthFails <- failedSynthesis + simFails <- failedSimulations + _ <- liftSh $ mapM (red checker datadir) fails + _ <- liftSh $ mapM redSynth synthFails + _ <- liftSh $ mapM (redSim datadir) simFails + return () where red checker datadir (SynthResult a b _ _) = do - r <- reduceSynth checker datadir a b src - writefile (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") $ genSource r + r <- reduceSynth checker datadir a b src + writefile (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") $ genSource r redSynth a = do - r <- reduceSynthesis a src - writefile (fromText $ "reduce_" <> toText a <> ".v") $ genSource r + r <- reduceSynthesis a src + writefile (fromText $ "reduce_" <> toText a <> ".v") $ genSource r redSim datadir (SimResult t _ bs _ _) = do - r <- reduceSimIc datadir bs t src - writefile (fromText $ "reduce_sim_" <> toText t <> ".v") $ genSource r + r <- reduceSimIc datadir bs t src + writefile (fromText $ "reduce_sim_" <> toText t <> ".v") $ genSource r src = clearAnn rsrc -titleRun - :: (MonadIO m, MonadSh m) => Text -> Fuzz m a -> Fuzz m (NominalDiffTime, a) +titleRun :: + (MonadIO m, MonadSh m) => Text -> Fuzz m a -> Fuzz m (NominalDiffTime, a) titleRun t f = do - logT $ "### Starting " <> t <> " ###" - (diff, res) <- timeit f - logT $ "### Finished " <> t <> " (" <> showT diff <> ") ###" - return (diff, res) + logT $ "### Starting " <> t <> " ###" + (diff, res) <- timeit f + logT $ "### Finished " <> t <> " (" <> showT diff <> ") ###" + return (diff, res) whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) whenMaybe b x = if b then Just <$> x else pure Nothing @@ -402,39 +425,40 @@ whenMaybe b x = if b then Just <$> x else pure Nothing getTime :: (Num n) => Maybe (n, a) -> n getTime = maybe 0 fst -generateSample - :: (MonadIO m, MonadSh m, Show ann) - => Fuzz m (Seed, (SourceInfo ann)) - -> Fuzz m (Seed, (SourceInfo ann)) +generateSample :: + (MonadIO m, MonadSh m, Show ann) => + Fuzz m (Seed, (SourceInfo ann)) -> + Fuzz m (Seed, (SourceInfo ann)) generateSample f = do - logT "Sampling Verilog from generator" - (t, v@(s, _)) <- timeit f - logT $ "Chose " <> showT s - logT $ "Generated Verilog (" <> showT t <> ")" - return v + logT "Sampling Verilog from generator" + (t, v@(s, _)) <- timeit f + logT $ "Chose " <> showT s + logT $ "Generated Verilog (" <> showT t <> ")" + return v verilogSize :: (Source a) => a -> Int verilogSize = length . lines . T.unpack . genSource -sampleVerilog - :: (MonadSh m, MonadIO m, Source a, Ord a) - => Frequency a - -> Int - -> Maybe Seed - -> Gen a - -> m (Seed, a) -sampleVerilog _ _ seed@(Just _) gen = sampleSeed seed gen -sampleVerilog freq n Nothing gen = do - res <- replicateM n $ sampleSeed Nothing gen - let sizes = fmap getSize res - let samples = fmap snd . sort $ zip sizes res - liftIO $ Hog.sample . Hog.frequency $ freq samples - where getSize (_, s) = verilogSize s +sampleVerilog :: + (MonadSh m, MonadIO m, Source a, Ord a) => + Frequency a -> + Int -> + Maybe Seed -> + Gen a -> + m (Seed, a) +sampleVerilog _ _ seed@(Just _) gen = sampleSeed seed gen +sampleVerilog freq n Nothing gen = do + res <- replicateM n $ sampleSeed Nothing gen + let sizes = fmap getSize res + let samples = fmap snd . sort $ zip sizes res + liftIO $ Hog.sample . Hog.frequency $ freq samples + where + getSize (_, s) = verilogSize s hatFreqs :: Frequency a hatFreqs l = zip hat (return <$> l) where - h = length l `div` 2 + h = length l `div` 2 hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] meanFreqs :: Source a => Frequency a @@ -442,115 +466,127 @@ meanFreqs l = zip hat (return <$> l) where hat = calc <$> sizes calc i = if abs (mean - i) == min_ then 1 else 0 - mean = sum sizes `div` length l - min_ = minimum $ abs . (mean -) <$> sizes + mean = sum sizes `div` length l + min_ = minimum $ abs . (mean -) <$> sizes sizes = verilogSize . snd <$> l medianFreqs :: Frequency a medianFreqs l = zip hat (return <$> l) where - h = length l `div` 2 + h = length l `div` 2 hat = set_ <$> [1 .. length l] set_ n = if n == h then 1 else 0 fuzz :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo ann) -> Fuzz m FuzzReport fuzz gen = do - conf <- askConfig - opts <- askOpts - let seed = conf ^. configProperty . propSeed - (seed', src) <- generateSample $ genMethod conf seed gen - let size = length . lines . T.unpack $ genSource src - liftSh - . writefile "config.toml" - . encodeConfig - $ conf - & configProperty - . propSeed - ?~ seed' - (tsynth, _) <- titleRun "Synthesis" $ synthesis src - (tequiv, _) <- if (_fuzzOptsNoEquiv opts) - then return (0, mempty) - else titleRun "Equivalence Check" $ equivalence src - (_ , _) <- if (_fuzzOptsNoSim opts) - then return (0, mempty) - else titleRun "Simulation" $ simulation src - fails <- failEquivWithIdentity - failedSim <- failedSimulations - synthFails <- failedSynthesis - redResult <- - whenMaybe (not (null failedSim && null fails && null synthFails) - && not (_fuzzOptsNoReduction opts)) - . titleRun "Reduction" - $ reduction src - state_ <- get - currdir <- liftSh pwd - let vi = flip view state_ - let report = FuzzReport currdir - (vi fuzzSynthResults) - (vi fuzzSimResults) - (vi fuzzSynthStatus) - size - tsynth - tequiv - (getTime redResult) - return report + conf <- askConfig + opts <- askOpts + let seed = conf ^. configProperty . propSeed + (seed', src) <- generateSample $ genMethod conf seed gen + let size = length . lines . T.unpack $ genSource src + liftSh + . writefile "config.toml" + . encodeConfig + $ conf + & configProperty + . propSeed + ?~ seed' + (tsynth, _) <- titleRun "Synthesis" $ synthesis src + (tequiv, _) <- + if (_fuzzOptsNoEquiv opts) + then return (0, mempty) + else titleRun "Equivalence Check" $ equivalence src + (_, _) <- + if (_fuzzOptsNoSim opts) + then return (0, mempty) + else titleRun "Simulation" $ simulation src + fails <- failEquivWithIdentity + failedSim <- failedSimulations + synthFails <- failedSynthesis + redResult <- + whenMaybe + ( not (null failedSim && null fails && null synthFails) + && not (_fuzzOptsNoReduction opts) + ) + . titleRun "Reduction" + $ reduction src + state_ <- get + currdir <- liftSh pwd + let vi = flip view state_ + let report = + FuzzReport + currdir + (vi fuzzSynthResults) + (vi fuzzSimResults) + (vi fuzzSynthStatus) + size + tsynth + tequiv + (getTime redResult) + return report fuzzInDir :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo ann) -> Fuzz m FuzzReport fuzzInDir src = do - fuzzOpts <- askOpts - let fp = fromMaybe "fuzz" $ _fuzzOptsOutput fuzzOpts - make fp - res <- pop fp $ fuzz src - liftSh $ do - writefile (fp <.> "html") $ printResultReport (bname fp) res - when (passedFuzz res && not (_fuzzOptsKeepAll fuzzOpts)) $ rm_rf fp - relativeFuzzReport res + fuzzOpts <- askOpts + let fp = fromMaybe "fuzz" $ _fuzzOptsOutput fuzzOpts + make fp + res <- pop fp $ fuzz src + liftSh $ do + writefile (fp <.> "html") $ printResultReport (bname fp) res + when (passedFuzz res && not (_fuzzOptsKeepAll fuzzOpts)) $ rm_rf fp + relativeFuzzReport res where bname = T.pack . takeBaseName . T.unpack . toTextIgnore -fuzzMultiple - :: (MonadFuzz m, Ord ann, Show ann) - => Gen (SourceInfo ann) - -> Fuzz m [FuzzReport] +fuzzMultiple :: + (MonadFuzz m, Ord ann, Show ann) => + Gen (SourceInfo ann) -> + Fuzz m [FuzzReport] fuzzMultiple src = do - fuzzOpts <- askOpts - let seed = (_fuzzOptsConfig fuzzOpts) ^. configProperty . propSeed - x <- case _fuzzOptsOutput fuzzOpts of - Nothing -> do - ct <- liftIO getZonedTime - return - . fromText - . T.pack - $ "output_" - <> formatTime defaultTimeLocale "%Y-%m-%d_%H-%M-%S" ct - Just f -> return f - make x - pop x $ do - results <- if isNothing seed - then forM [1 .. (_fuzzOptsIterations fuzzOpts)] fuzzDir' - else (: []) <$> fuzzDir' (1 :: Int) - liftSh . writefile (fromText "index" <.> "html") $ printSummary - "Fuzz Summary" - results - return results + fuzzOpts <- askOpts + let seed = (_fuzzOptsConfig fuzzOpts) ^. configProperty . propSeed + x <- case _fuzzOptsOutput fuzzOpts of + Nothing -> do + ct <- liftIO getZonedTime + return + . fromText + . T.pack + $ "output_" + <> formatTime defaultTimeLocale "%Y-%m-%d_%H-%M-%S" ct + Just f -> return f + make x + pop x $ do + results <- + if isNothing seed + then forM [1 .. (_fuzzOptsIterations fuzzOpts)] fuzzDir' + else (: []) <$> fuzzDir' (1 :: Int) + liftSh . writefile (fromText "index" <.> "html") $ + printSummary + "Fuzz Summary" + results + return results where fuzzDir' :: (Show a, MonadFuzz m) => a -> Fuzz m FuzzReport - fuzzDir' n' = local (fuzzEnvOpts . fuzzOptsOutput .~ - (Just . fromText $ "fuzz_" <> showT n')) - $ fuzzInDir src + fuzzDir' n' = + local + ( fuzzEnvOpts . fuzzOptsOutput + .~ (Just . fromText $ "fuzz_" <> showT n') + ) + $ fuzzInDir src sampleSeed :: MonadSh m => Maybe Seed -> Gen a -> m (Seed, a) sampleSeed s gen = - liftSh - $ let loop n = if n <= 0 - then - error - "Hedgehog.Gen.sample: too many discards, could not generate a sample" - else do - seed <- maybe Hog.random return s - case Hog.evalGen 30 seed gen of - Nothing -> - loop (n - 1) - Just x -> - pure (seed, Hog.treeValue x) - in loop (100 :: Int) + liftSh $ + let loop n = + if n <= 0 + then + error + "Hedgehog.Gen.sample: too many discards, could not generate a sample" + else do + seed <- maybe Hog.random return s + case Hog.evalGen 30 seed gen of + Nothing -> + loop (n - 1) + Just x -> + pure (seed, Hog.treeValue x) + in loop (100 :: Int) diff --git a/src/Verismith/Generate.hs b/src/Verismith/Generate.hs index 52baf0d..000caa0 100644 --- a/src/Verismith/Generate.hs +++ b/src/Verismith/Generate.hs @@ -1,96 +1,98 @@ -{-| -Module : Verismith.Generate -Description : Various useful generators. -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Various useful generators. --} - {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-imports #-} +-- | +-- Module : Verismith.Generate +-- Description : Various useful generators. +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Various useful generators. module Verismith.Generate - ( -- * Generation methods - procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod + ( -- * Generation methods + procedural, + proceduralIO, + proceduralSrc, + proceduralSrcIO, + randomMod, + -- ** Generate Functions - , largeNum - , wireSize - , range - , genBitVec - , binOp - , unOp - , constExprWithContext - , exprSafeList - , exprRecList - , exprWithContext - , makeIdentifier - , nextPort - , newPort - , scopedExpr - , contAssign - , lvalFromPort - , assignment - , seqBlock - , conditional - , forLoop - , statement - , alwaysSeq - , instantiate - , modInst - , modItem - , constExpr - , parameter - , moduleDef + largeNum, + wireSize, + range, + genBitVec, + binOp, + unOp, + constExprWithContext, + exprSafeList, + exprRecList, + exprWithContext, + makeIdentifier, + nextPort, + newPort, + scopedExpr, + contAssign, + lvalFromPort, + assignment, + seqBlock, + conditional, + forLoop, + statement, + alwaysSeq, + instantiate, + modInst, + modItem, + constExpr, + parameter, + moduleDef, + -- ** Helpers - , someI - , probability - , askProbability - , resizePort - , moduleName - , evalRange - , calcRange - ) + someI, + probability, + askProbability, + resizePort, + moduleName, + evalRange, + calcRange, + ) where -import Control.Lens hiding (Context) -import Control.Monad (replicateM) -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Foldable (fold) -import Data.Functor.Foldable (cata) -import Data.List (foldl', partition) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Hedgehog (Gen, GenT, MonadGen) -import qualified Hedgehog as Hog -import qualified Hedgehog.Gen as Hog -import qualified Hedgehog.Range as Hog -import Verismith.Config -import Verismith.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec -import Verismith.Verilog.Eval -import Verismith.Verilog.Internal -import Verismith.Verilog.Mutate - -data Context a = Context { _variables :: [Port] - , _parameters :: [Parameter] - , _modules :: [ModDecl a] - , _nameCounter :: {-# UNPACK #-} !Int - , _stmntDepth :: {-# UNPACK #-} !Int - , _modDepth :: {-# UNPACK #-} !Int - , _determinism :: !Bool - } +import Control.Lens hiding (Context) +import Control.Monad (replicateM) +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Foldable (fold) +import Data.Functor.Foldable (cata) +import Data.List (foldl', partition) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Hedgehog (Gen, GenT, MonadGen) +import qualified Hedgehog as Hog +import qualified Hedgehog.Gen as Hog +import qualified Hedgehog.Range as Hog +import Verismith.Config +import Verismith.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec +import Verismith.Verilog.Eval +import Verismith.Verilog.Internal +import Verismith.Verilog.Mutate + +data Context a + = Context + { _variables :: [Port], + _parameters :: [Parameter], + _modules :: [ModDecl a], + _nameCounter :: {-# UNPACK #-} !Int, + _stmntDepth :: {-# UNPACK #-} !Int, + _modDepth :: {-# UNPACK #-} !Int, + _determinism :: !Bool + } makeLenses ''Context @@ -101,16 +103,16 @@ toId = Identifier . ("w" <>) . T.pack . show toPort :: (MonadGen m) => Identifier -> m Port toPort ident = do - i <- range - return $ wire i ident + i <- range + return $ wire i ident sumSize :: [Port] -> Range sumSize ps = sum $ ps ^.. traverse . portSize random :: (MonadGen m) => [Port] -> (Expr -> ContAssign) -> m (ModItem ann) random ctx fun = do - expr <- Hog.sized (exprWithContext (ProbExpr 1 1 0 1 1 1 1 0 1 1) [] ctx) - return . ModCA $ fun expr + expr <- Hog.sized (exprWithContext (ProbExpr 1 1 0 1 1 1 1 0 1 1) [] ctx) + return . ModCA $ fun expr --randomAssigns :: [Identifier] -> [Gen ModItem] --randomAssigns ids = random ids . ContAssign <$> ids @@ -122,20 +124,22 @@ randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids randomMod :: (MonadGen m) => Int -> Int -> m (ModDecl ann) randomMod inps total = do - ident <- sequence $ toPort <$> ids - x <- sequence $ randomOrdAssigns (start ident) (end ident) - let inputs_ = take inps ident - let other = drop inps ident - let y = ModCA . ContAssign "y" . fold $ Id <$> drop inps ids - let yport = [wire (sumSize other) "y"] - return . declareMod other $ ModDecl "test_module" - yport - inputs_ - (x ++ [y]) - [] + ident <- sequence $ toPort <$> ids + x <- sequence $ randomOrdAssigns (start ident) (end ident) + let inputs_ = take inps ident + let other = drop inps ident + let y = ModCA . ContAssign "y" . fold $ Id <$> drop inps ids + let yport = [wire (sumSize other) "y"] + return . declareMod other $ + ModDecl + "test_module" + yport + inputs_ + (x ++ [y]) + [] where - ids = toId <$> [1 .. total] - end = drop inps + ids = toId <$> [1 .. total] + end = drop inps start = take inps -- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the @@ -174,77 +178,82 @@ genBitVec = fmap fromIntegral largeNum -- because it can only be used in conjunction with base powers of 2 which is -- currently not enforced. binOp :: (MonadGen m) => m BinaryOperator -binOp = Hog.element - [ 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 +binOp = + Hog.element + [ 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 ] -- | Generate a random 'UnaryOperator'. unOp :: (MonadGen m) => m UnaryOperator -unOp = Hog.element - [ UnPlus - , UnMinus - , UnNot - , UnLNot - , UnAnd - , UnNand - , UnOr - , UnNor - , UnXor - , UnNxor - , UnNxorInv +unOp = + Hog.element + [ UnPlus, + UnMinus, + UnNot, + UnLNot, + UnAnd, + UnNand, + UnOr, + UnNor, + UnXor, + UnNxor, + UnNxorInv ] -- | Generate a random 'ConstExpr' by using the current context of 'Parameter'. constExprWithContext :: (MonadGen m) => [Parameter] -> ProbExpr -> Hog.Size -> m ConstExpr constExprWithContext ps prob size - | size == 0 = Hog.frequency - [ (prob ^. probExprNum, ConstNum <$> genBitVec) - , ( if null ps then 0 else prob ^. probExprId - , ParamId . view paramIdent <$> Hog.element ps - ) - ] - | size > 0 = Hog.frequency - [ (prob ^. probExprNum, ConstNum <$> genBitVec) - , ( if null ps then 0 else prob ^. probExprId - , ParamId . view paramIdent <$> Hog.element ps - ) - , (prob ^. probExprUnOp, ConstUnOp <$> unOp <*> subexpr 2) - , ( prob ^. probExprBinOp - , ConstBinOp <$> subexpr 2 <*> binOp <*> subexpr 2 - ) - , ( prob ^. probExprCond - , ConstCond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2 - ) - , ( prob ^. probExprConcat - , ConstConcat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2) - ) - ] - | otherwise = constExprWithContext ps prob 0 - where subexpr y = constExprWithContext ps prob $ size `div` y + | size == 0 = + Hog.frequency + [ (prob ^. probExprNum, ConstNum <$> genBitVec), + ( if null ps then 0 else prob ^. probExprId, + ParamId . view paramIdent <$> Hog.element ps + ) + ] + | size > 0 = + Hog.frequency + [ (prob ^. probExprNum, ConstNum <$> genBitVec), + ( if null ps then 0 else prob ^. probExprId, + ParamId . view paramIdent <$> Hog.element ps + ), + (prob ^. probExprUnOp, ConstUnOp <$> unOp <*> subexpr 2), + ( prob ^. probExprBinOp, + ConstBinOp <$> subexpr 2 <*> binOp <*> subexpr 2 + ), + ( prob ^. probExprCond, + ConstCond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2 + ), + ( prob ^. probExprConcat, + ConstConcat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2) + ) + ] + | otherwise = constExprWithContext ps prob 0 + where + subexpr y = constExprWithContext ps prob $ size `div` y -- | The list of safe 'Expr', meaning that these will not recurse and will end -- the 'Expr' generation. @@ -255,71 +264,77 @@ exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] -- used when the expression grows too large. exprRecList :: (MonadGen m) => ProbExpr -> (Hog.Size -> m Expr) -> [(Int, m Expr)] exprRecList prob subexpr = - [ (prob ^. probExprNum, Number <$> genBitVec) - , ( prob ^. probExprConcat - , Concat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2) - ) - , (prob ^. probExprUnOp , UnOp <$> unOp <*> subexpr 2) - , (prob ^. probExprStr, Str <$> Hog.text (Hog.linear 0 100) Hog.alphaNum) - , (prob ^. probExprBinOp , BinOp <$> subexpr 2 <*> binOp <*> subexpr 2) - , (prob ^. probExprCond , Cond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2) - , (prob ^. probExprSigned , Appl <$> pure "$signed" <*> subexpr 2) - , (prob ^. probExprUnsigned, Appl <$> pure "$unsigned" <*> subexpr 2) - ] + [ (prob ^. probExprNum, Number <$> genBitVec), + ( prob ^. probExprConcat, + Concat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2) + ), + (prob ^. probExprUnOp, UnOp <$> unOp <*> subexpr 2), + (prob ^. probExprStr, Str <$> Hog.text (Hog.linear 0 100) Hog.alphaNum), + (prob ^. probExprBinOp, BinOp <$> subexpr 2 <*> binOp <*> subexpr 2), + (prob ^. probExprCond, Cond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2), + (prob ^. probExprSigned, Appl <$> pure "$signed" <*> subexpr 2), + (prob ^. probExprUnsigned, Appl <$> pure "$unsigned" <*> subexpr 2) + ] -- | Select a random port from a list of ports and generate a safe bit selection -- for that port. rangeSelect :: (MonadGen m) => [Parameter] -> [Port] -> m Expr rangeSelect ps ports = do - p <- Hog.element ports - let s = calcRange ps (Just 32) $ _portSize p - msb <- Hog.int (Hog.constantFrom (s `div` 2) 0 (s - 1)) - lsb <- Hog.int (Hog.constantFrom (msb `div` 2) 0 msb) - return . RangeSelect (_portName p) $ Range (fromIntegral msb) - (fromIntegral lsb) + p <- Hog.element ports + let s = calcRange ps (Just 32) $ _portSize p + msb <- Hog.int (Hog.constantFrom (s `div` 2) 0 (s - 1)) + lsb <- Hog.int (Hog.constantFrom (msb `div` 2) 0 msb) + return . RangeSelect (_portName p) $ + Range + (fromIntegral msb) + (fromIntegral lsb) -- | Generate a random expression from the 'Context' with a guarantee that it -- will terminate using the list of safe 'Expr'. exprWithContext :: (MonadGen m) => ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> m Expr -exprWithContext prob ps [] n | n == 0 = Hog.frequency $ exprSafeList prob - | n > 0 = Hog.frequency $ exprRecList prob subexpr - | otherwise = exprWithContext prob ps [] 0 - where subexpr y = exprWithContext prob ps [] $ n `div` y +exprWithContext prob ps [] n + | n == 0 = Hog.frequency $ exprSafeList prob + | n > 0 = Hog.frequency $ exprRecList prob subexpr + | otherwise = exprWithContext prob ps [] 0 + where + subexpr y = exprWithContext prob ps [] $ n `div` y exprWithContext prob ps l n - | n == 0 - = Hog.frequency - $ (prob ^. probExprId, Id . fromPort <$> Hog.element l) + | n == 0 = + Hog.frequency $ + (prob ^. probExprId, Id . fromPort <$> Hog.element l) : exprSafeList prob - | n > 0 - = Hog.frequency - $ (prob ^. probExprId , Id . fromPort <$> Hog.element l) + | n > 0 = + Hog.frequency $ + (prob ^. probExprId, Id . fromPort <$> Hog.element l) : (prob ^. probExprRangeSelect, rangeSelect ps l) : exprRecList prob subexpr - | otherwise - = exprWithContext prob ps l 0 - where subexpr y = exprWithContext prob ps l $ n `div` y + | otherwise = + exprWithContext prob ps l 0 + where + subexpr y = exprWithContext prob ps l $ n `div` y -- | Runs a 'StateGen' for a random number of times, limited by an 'Int' that is -- passed to it. someI :: Int -> StateGen ann a -> StateGen ann [a] someI m f = do - amount <- Hog.int (Hog.linear 1 m) - replicateM amount f + amount <- Hog.int (Hog.linear 1 m) + replicateM amount f -- | Make a new name with a prefix and the current nameCounter. The nameCounter -- is then increased so that the label is unique. makeIdentifier :: Text -> StateGen ann Identifier makeIdentifier prefix = do - context <- get - let ident = Identifier $ prefix <> showT (context ^. nameCounter) - nameCounter += 1 - return ident + context <- get + let ident = Identifier $ prefix <> showT (context ^. nameCounter) + nameCounter += 1 + return ident getPort' :: PortType -> Identifier -> [Port] -> StateGen ann Port getPort' pt i c = case filter portId c of - x : _ -> return x - [] -> newPort i pt - where portId (Port pt' _ _ i') = i == i' && pt == pt' + x : _ -> return x + [] -> newPort i pt + where + portId (Port pt' _ _ i') = i == i' && pt == pt' -- | Makes a new 'Identifier' and then checks if the 'Port' already exists, if -- it does the existant 'Port' is returned, otherwise a new port is created with @@ -328,49 +343,49 @@ getPort' pt i c = case filter portId c of -- the generation is currently in the other branch of an if-statement. nextPort :: Maybe Text -> PortType -> StateGen ann Port nextPort i pt = do - context <- get - ident <- makeIdentifier $ fromMaybe (T.toLower $ showT pt) i - getPort' pt ident (_variables context) + context <- get + ident <- makeIdentifier $ fromMaybe (T.toLower $ showT pt) i + getPort' pt ident (_variables context) -- | Creates a new port based on the current name counter and adds it to the -- current context. newPort :: Identifier -> PortType -> StateGen ann Port newPort ident pt = do - p <- Port pt <$> Hog.bool <*> range <*> pure ident - variables %= (p :) - return p + p <- Port pt <$> Hog.bool <*> range <*> pure ident + variables %= (p :) + return p -- | Generates an expression from variables that are currently in scope. scopedExpr :: StateGen ann Expr scopedExpr = do - context <- get - prob <- askProbability - Hog.sized - . exprWithContext (_probExpr prob) (_parameters context) - $ _variables context + context <- get + prob <- askProbability + Hog.sized + . exprWithContext (_probExpr prob) (_parameters context) + $ _variables context -- | Generates a random continuous assignment and assigns it to a random wire -- that is created. contAssign :: StateGen ann ContAssign contAssign = do - expr <- scopedExpr - p <- nextPort Nothing Wire - return $ ContAssign (p ^. portName) expr + expr <- scopedExpr + p <- nextPort Nothing Wire + return $ ContAssign (p ^. portName) expr -- | Generate a random assignment and assign it to a random 'Reg'. assignment :: StateGen ann Assign assignment = do - expr <- scopedExpr - lval <- lvalFromPort <$> nextPort Nothing Reg - return $ Assign lval Nothing expr + expr <- scopedExpr + lval <- lvalFromPort <$> nextPort Nothing Reg + return $ Assign lval Nothing expr -- | Generate a random 'Statement' safely, by also increasing the depth counter. seqBlock :: StateGen ann (Statement ann) seqBlock = do - stmntDepth -= 1 - tstat <- SeqBlock <$> someI 20 statement - stmntDepth += 1 - return tstat + stmntDepth -= 1 + tstat <- SeqBlock <$> someI 20 statement + stmntDepth += 1 + return tstat -- | Generate a random conditional 'Statement'. The nameCounter is reset between -- branches so that port names can be reused. This is safe because if a 'Port' @@ -378,41 +393,44 @@ seqBlock = do -- start. conditional :: StateGen ann (Statement ann) conditional = do - expr <- scopedExpr - nc <- _nameCounter <$> get - tstat <- seqBlock - nc' <- _nameCounter <$> get - nameCounter .= nc - fstat <- seqBlock - nc'' <- _nameCounter <$> get - nameCounter .= max nc' nc'' - return $ CondStmnt expr (Just tstat) (Just fstat) + expr <- scopedExpr + nc <- _nameCounter <$> get + tstat <- seqBlock + nc' <- _nameCounter <$> get + nameCounter .= nc + fstat <- seqBlock + nc'' <- _nameCounter <$> get + nameCounter .= max nc' nc'' + return $ CondStmnt expr (Just tstat) (Just fstat) -- | Generate a random for loop by creating a new variable name for the counter -- and then generating random statements in the body. forLoop :: StateGen ann (Statement ann) forLoop = do - num <- Hog.int (Hog.linear 0 20) - var <- lvalFromPort <$> nextPort (Just "forvar") Reg - ForLoop (Assign var Nothing 0) - (BinOp (varId var) BinLT $ fromIntegral num) - (Assign var Nothing $ BinOp (varId var) BinPlus 1) - <$> seqBlock - where varId v = Id (v ^. regId) + num <- Hog.int (Hog.linear 0 20) + var <- lvalFromPort <$> nextPort (Just "forvar") Reg + ForLoop + (Assign var Nothing 0) + (BinOp (varId var) BinLT $ fromIntegral num) + (Assign var Nothing $ BinOp (varId var) BinPlus 1) + <$> seqBlock + where + varId v = Id (v ^. regId) -- | Choose a 'Statement' to generate. statement :: StateGen ann (Statement ann) statement = do - prob <- askProbability - cont <- get - let defProb i = prob ^. probStmnt . i - Hog.frequency - [ (defProb probStmntBlock , BlockAssign <$> assignment) - , (defProb probStmntNonBlock , NonBlockAssign <$> assignment) - , (onDepth cont (defProb probStmntCond), conditional) - , (onDepth cont (defProb probStmntFor) , forLoop) - ] - where onDepth c n = if c ^. stmntDepth > 0 then n else 0 + prob <- askProbability + cont <- get + let defProb i = prob ^. probStmnt . i + Hog.frequency + [ (defProb probStmntBlock, BlockAssign <$> assignment), + (defProb probStmntNonBlock, NonBlockAssign <$> assignment), + (onDepth cont (defProb probStmntCond), conditional), + (onDepth cont (defProb probStmntFor), forLoop) + ] + where + onDepth c n = if c ^. stmntDepth > 0 then n else 0 -- | Generate a sequential always block which is dependent on the clock. alwaysSeq :: StateGen ann (ModItem ann) @@ -423,11 +441,11 @@ alwaysSeq = Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock -- multiple times, and is resized multiple times, as it should only get larger. resizePort :: [Parameter] -> Identifier -> Range -> [Port] -> [Port] resizePort ps i ra = foldl' func [] - where - func l p@(Port t _ ri i') - | i' == i && calc ri < calc ra = (p & portSize .~ ra) : l - | otherwise = p : l - calc = calcRange ps $ Just 64 + where + func l p@(Port t _ ri i') + | i' == i && calc ri < calc ra = (p & portSize .~ ra) : l + | otherwise = p : l + calc = calcRange ps $ Just 64 -- | Instantiate a module, where the outputs are new nets that are created, and -- the inputs are taken from existing ports in the context. @@ -438,28 +456,32 @@ resizePort ps i ra = foldl' func [] -- representation for the clock. instantiate :: (ModDecl ann) -> StateGen ann (ModItem ann) instantiate (ModDecl i outP inP _ _) = do - context <- get - outs <- replicateM (length outP) (nextPort Nothing Wire) - ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) - insLit <- replicateM (length inpFixed - length ins) (Number <$> genBitVec) - mapM_ (uncurry process) . zip (ins ^.. traverse . portName) $ inpFixed ^.. traverse . portSize - ident <- makeIdentifier "modinst" - vs <- view variables <$> get - Hog.choice - [ return . ModInst i ident $ ModConn <$> (toE (outs <> clkPort <> ins) <> insLit) - , ModInst i ident <$> Hog.shuffle - (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) - (toE (outs <> clkPort <> ins) <> insLit)) - ] - where - toE ins = Id . view portName <$> ins - (inpFixed, clkPort) = partition filterFunc inP - filterFunc (Port _ _ _ n) - | n == "clk" = False - | otherwise = True - process p r = do - params <- view parameters <$> get - variables %= resizePort params p r + context <- get + outs <- replicateM (length outP) (nextPort Nothing Wire) + ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) + insLit <- replicateM (length inpFixed - length ins) (Number <$> genBitVec) + mapM_ (uncurry process) . zip (ins ^.. traverse . portName) $ inpFixed ^.. traverse . portSize + ident <- makeIdentifier "modinst" + vs <- view variables <$> get + Hog.choice + [ return . ModInst i ident $ ModConn <$> (toE (outs <> clkPort <> ins) <> insLit), + ModInst i ident + <$> Hog.shuffle + ( zipWith + ModConnNamed + (view portName <$> outP <> clkPort <> inpFixed) + (toE (outs <> clkPort <> ins) <> insLit) + ) + ] + where + toE ins = Id . view portName <$> ins + (inpFixed, clkPort) = partition filterFunc inP + filterFunc (Port _ _ _ n) + | n == "clk" = False + | otherwise = True + process p r = do + params <- view parameters <$> get + variables %= resizePort params p r -- | Generates a module instance by also generating a new module if there are -- not enough modules currently in the context. It keeps generating new modules @@ -482,74 +504,81 @@ instantiate (ModDecl i outP inP _ _) = do -- a module from a context or generating a new one. modInst :: StateGen ann (ModItem ann) modInst = do - prob <- ask - context <- get - let maxMods = prob ^. configProperty . propMaxModules - if length (context ^. modules) < maxMods - then do - let currMods = context ^. modules - let params = context ^. parameters - let vars = context ^. variables - modules .= [] - variables .= [] - parameters .= [] - modDepth -= 1 - chosenMod <- moduleDef Nothing - ncont <- get - let genMods = ncont ^. modules - modDepth += 1 - parameters .= params - variables .= vars - modules .= chosenMod : currMods <> genMods - instantiate chosenMod - else Hog.element (context ^. modules) >>= instantiate + prob <- ask + context <- get + let maxMods = prob ^. configProperty . propMaxModules + if length (context ^. modules) < maxMods + then do + let currMods = context ^. modules + let params = context ^. parameters + let vars = context ^. variables + modules .= [] + variables .= [] + parameters .= [] + modDepth -= 1 + chosenMod <- moduleDef Nothing + ncont <- get + let genMods = ncont ^. modules + modDepth += 1 + parameters .= params + variables .= vars + modules .= chosenMod : currMods <> genMods + instantiate chosenMod + else Hog.element (context ^. modules) >>= instantiate -- | Generate a random module item. modItem :: StateGen ann (ModItem ann) modItem = do - conf <- ask - let prob = conf ^. configProbability - context <- get - let defProb i = prob ^. probModItem . i - det <- Hog.frequency [ (conf ^. configProperty . propDeterminism, return True) - , (conf ^. configProperty . propNonDeterminism, return False) ] - determinism .= det + conf <- ask + let prob = conf ^. configProbability + context <- get + let defProb i = prob ^. probModItem . i + det <- Hog.frequency - [ (defProb probModItemAssign , ModCA <$> contAssign) - , (defProb probModItemSeqAlways, alwaysSeq) - , ( if context ^. modDepth > 0 then defProb probModItemInst else 0 - , modInst ) - ] + [ (conf ^. configProperty . propDeterminism, return True), + (conf ^. configProperty . propNonDeterminism, return False) + ] + determinism .= det + Hog.frequency + [ (defProb probModItemAssign, ModCA <$> contAssign), + (defProb probModItemSeqAlways, alwaysSeq), + ( if context ^. modDepth > 0 then defProb probModItemInst else 0, + modInst + ) + ] -- | Either return the 'Identifier' that was passed to it, or generate a new -- 'Identifier' based on the current 'nameCounter'. moduleName :: Maybe Identifier -> StateGen ann Identifier moduleName (Just t) = return t -moduleName Nothing = makeIdentifier "module" +moduleName Nothing = makeIdentifier "module" -- | Generate a random 'ConstExpr' by using the current context of 'Parameters'. constExpr :: StateGen ann ConstExpr constExpr = do - prob <- askProbability - context <- get - Hog.sized $ constExprWithContext (context ^. parameters) - (prob ^. probExpr) + prob <- askProbability + context <- get + Hog.sized $ + constExprWithContext + (context ^. parameters) + (prob ^. probExpr) -- | Generate a random 'Parameter' and assign it to a constant expression which -- it will be initialised to. The assumption is that this constant expression -- should always be able to be evaluated with the current context of parameters. parameter :: StateGen ann Parameter parameter = do - ident <- makeIdentifier "param" - cexpr <- constExpr - let param = Parameter ident cexpr - parameters %= (param :) - return param + ident <- makeIdentifier "param" + cexpr <- constExpr + let param = Parameter ident cexpr + parameters %= (param :) + return param -- | Evaluate a range to an integer, and cast it back to a range. evalRange :: [Parameter] -> Int -> Range -> Range evalRange ps n (Range l r) = Range (eval l) (eval r) - where eval = ConstNum . cata (evaluateConst ps) . resize n + where + eval = ConstNum . cata (evaluateConst ps) . resize n -- | Calculate a range to an int by maybe resizing the ranges to a value. calcRange :: [Parameter] -> Maybe Int -> Range -> Int @@ -574,11 +603,11 @@ identElem p = elem (p ^. portName) . toListOf (traverse . portName) -- registers are exposed. selectwfreq :: (MonadGen m) => Int -> Int -> [a] -> m [a] selectwfreq _ _ [] = return [] -selectwfreq s n a@(l:ls) +selectwfreq s n a@(l : ls) | s > 0 && n > 0 = - Hog.frequency - [ (s, (l:) <$> selectwfreq s n ls) - , (n, selectwfreq s n ls) + Hog.frequency + [ (s, (l :) <$> selectwfreq s n ls), + (n, selectwfreq s n ls) ] | otherwise = return a @@ -588,43 +617,44 @@ selectwfreq s n a@(l:ls) -- module. moduleDef :: Maybe Identifier -> StateGen ann (ModDecl ann) moduleDef top = do - name <- moduleName top - portList <- Hog.list (Hog.linear 4 10) $ nextPort Nothing Wire - mi <- Hog.list (Hog.linear 4 100) modItem - ps <- Hog.list (Hog.linear 0 10) parameter - context <- get - config <- ask - let (newPorts, local) = partition (`identElem` portList) $ _variables context - let - size = - evalRange (_parameters context) 32 - . sum - $ local - ^.. traverse - . portSize - let (ProbMod n s) = config ^. configProbability . probMod - newlocal <- selectwfreq s n local - let clock = Port Wire False 1 "clk" - let combine = config ^. configProperty . propCombine - let yport = - if combine then Port Wire False 1 "y" else Port Wire False size "y" - let comb = combineAssigns_ combine yport newlocal - return - . declareMod local - . ModDecl name [yport] (clock : newPorts) (comb : mi) - $ ps + name <- moduleName top + portList <- Hog.list (Hog.linear 4 10) $ nextPort Nothing Wire + mi <- Hog.list (Hog.linear 4 100) modItem + ps <- Hog.list (Hog.linear 0 10) parameter + context <- get + config <- ask + let (newPorts, local) = partition (`identElem` portList) $ _variables context + let size = + evalRange (_parameters context) 32 + . sum + $ local + ^.. traverse + . portSize + let (ProbMod n s) = config ^. configProbability . probMod + newlocal <- selectwfreq s n local + let clock = Port Wire False 1 "clk" + let combine = config ^. configProperty . propCombine + let yport = + if combine then Port Wire False 1 "y" else Port Wire False size "y" + let comb = combineAssigns_ combine yport newlocal + return + . declareMod local + . ModDecl name [yport] (clock : newPorts) (comb : mi) + $ ps -- | Procedural generation method for random Verilog. Uses internal 'Reader' and -- 'State' to keep track of the current Verilog code structure. procedural :: Text -> Config -> Gen (Verilog ann) procedural top config = do - (mainMod, st) <- Hog.resize num $ runStateT + (mainMod, st) <- + Hog.resize num $ + runStateT (Hog.distributeT (runReaderT (moduleDef (Just $ Identifier top)) config)) context - return . Verilog $ mainMod : st ^. modules + return . Verilog $ mainMod : st ^. modules where context = - Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True + Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True num = fromIntegral $ confProp propSize confProp i = config ^. configProperty . i diff --git a/src/Verismith/Internal.hs b/src/Verismith/Internal.hs index 02f73ce..77c5525 100644 --- a/src/Verismith/Internal.hs +++ b/src/Verismith/Internal.hs @@ -1,31 +1,29 @@ -{-| -Module : Verismith.Internal -Description : Shared high level code used in the other modules internally. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Shared high level code used in the other modules internally. --} - +-- | +-- Module : Verismith.Internal +-- Description : Shared high level code used in the other modules internally. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Shared high level code used in the other modules internally. module Verismith.Internal - ( -- * Useful functions - safe - , showT - , showBS - , comma - , commaNL - ) + ( -- * Useful functions + safe, + showT, + showBS, + comma, + commaNL, + ) where -import Data.ByteString (ByteString) -import Data.ByteString.Builder (byteStringHex, toLazyByteString) -import qualified Data.ByteString.Lazy as L -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteStringHex, toLazyByteString) +import qualified Data.ByteString.Lazy as L +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) -- | Function to show a bytestring in a hex format. showBS :: ByteString -> Text @@ -34,7 +32,7 @@ showBS = decodeUtf8 . L.toStrict . toLazyByteString . byteStringHex -- | Converts unsafe list functions in the Prelude to a safe version. safe :: ([a] -> b) -> [a] -> Maybe b safe _ [] = Nothing -safe f l = Just $ f l +safe f l = Just $ f l -- | Show function for 'Text' showT :: (Show a) => a -> Text diff --git a/src/Verismith/OptParser.hs b/src/Verismith/OptParser.hs index 592f9e9..108cf01 100644 --- a/src/Verismith/OptParser.hs +++ b/src/Verismith/OptParser.hs @@ -1,304 +1,356 @@ module Verismith.OptParser - ( OptTool (..) - , Opts (..) - , opts - ) + ( OptTool (..), + Opts (..), + opts, + ) where -import Control.Applicative ((<|>)) -import Data.Text (Text) -import qualified Data.Text as T -import Options.Applicative (Mod (..), OptionFields (..), Parser (..), - ParserInfo (..), ReadM (..), (<**>)) +import Control.Applicative ((<|>)) +import Data.Text (Text) +import qualified Data.Text as T +import Options.Applicative + ( (<**>), + Mod (..), + OptionFields (..), + Parser (..), + ParserInfo (..), + ReadM (..), + ) import qualified Options.Applicative as Opt -import Prelude hiding (FilePath (..)) -import Shelly (FilePath (..), fromText) -import Verismith.Config (SynthDescription (..), versionInfo) +import Shelly (FilePath (..), fromText) +import Verismith.Config (SynthDescription (..), versionInfo) +import Prelude hiding (FilePath (..)) -data OptTool = TYosys - | TXST - | TIcarus +data OptTool + = TYosys + | TXST + | TIcarus instance Show OptTool where - show TYosys = "yosys" - show TXST = "xst" + show TYosys = "yosys" + show TXST = "xst" show TIcarus = "icarus" -data Opts = Fuzz { fuzzOutput :: Text - , fuzzConfigFile :: !(Maybe FilePath) - , fuzzForced :: !Bool - , fuzzKeepAll :: !Bool - , fuzzNum :: {-# UNPACK #-} !Int - , fuzzNoSim :: !Bool - , fuzzNoEquiv :: !Bool - , fuzzNoReduction :: !Bool - , fuzzExistingFile :: !(Maybe FilePath) - , fuzzExistingFileTop :: !Text - , fuzzCrossCheck :: !Bool - , fuzzChecker :: !(Maybe Text) - } - | Generate { generateFilename :: !(Maybe FilePath) - , generateConfigFile :: !(Maybe FilePath) - } - | Parse { parseFilename :: !FilePath - , parseTop :: !Text - , parseOutput :: !(Maybe FilePath) - , parseRemoveConstInConcat :: !Bool - } - | Reduce { reduceFilename :: !FilePath - , reduceTop :: !Text - , reduceScript :: !(Maybe FilePath) - , reduceSynthesiserDesc :: ![SynthDescription] - , reduceRerun :: !Bool - } - | ConfigOpt { configOptWriteConfig :: !(Maybe FilePath) - , configOptConfigFile :: !(Maybe FilePath) - , configOptDoRandomise :: !Bool - } +data Opts + = Fuzz + { fuzzOutput :: Text, + fuzzConfigFile :: !(Maybe FilePath), + fuzzForced :: !Bool, + fuzzKeepAll :: !Bool, + fuzzNum :: {-# UNPACK #-} !Int, + fuzzNoSim :: !Bool, + fuzzNoEquiv :: !Bool, + fuzzNoReduction :: !Bool, + fuzzExistingFile :: !(Maybe FilePath), + fuzzExistingFileTop :: !Text, + fuzzCrossCheck :: !Bool, + fuzzChecker :: !(Maybe Text) + } + | Generate + { generateFilename :: !(Maybe FilePath), + generateConfigFile :: !(Maybe FilePath) + } + | Parse + { parseFilename :: !FilePath, + parseTop :: !Text, + parseOutput :: !(Maybe FilePath), + parseRemoveConstInConcat :: !Bool + } + | Reduce + { reduceFilename :: !FilePath, + reduceTop :: !Text, + reduceScript :: !(Maybe FilePath), + reduceSynthesiserDesc :: ![SynthDescription], + reduceRerun :: !Bool + } + | ConfigOpt + { configOptWriteConfig :: !(Maybe FilePath), + configOptConfigFile :: !(Maybe FilePath), + configOptDoRandomise :: !Bool + } textOption :: Mod OptionFields String -> Parser Text textOption = fmap T.pack . Opt.strOption optReader :: (String -> Maybe a) -> ReadM a optReader f = Opt.eitherReader $ \arg -> case f arg of - Just a -> Right a - Nothing -> Left $ "Cannot parse option: " <> arg + Just a -> Right a + Nothing -> Left $ "Cannot parse option: " <> arg parseSynth :: String -> Maybe OptTool -parseSynth val | val == "yosys" = Just TYosys - | val == "xst" = Just TXST - | otherwise = Nothing +parseSynth val + | val == "yosys" = Just TYosys + | val == "xst" = Just TXST + | otherwise = Nothing parseSynthDesc :: String -> Maybe SynthDescription parseSynthDesc val - | val == "yosys" = Just $ SynthDescription "yosys" Nothing Nothing Nothing - | val == "vivado" = Just $ SynthDescription "vivado" Nothing Nothing Nothing - | val == "xst" = Just $ SynthDescription "xst" Nothing Nothing Nothing - | val == "quartus" = Just - $ SynthDescription "quartus" Nothing Nothing Nothing - | val == "identity" = Just - $ SynthDescription "identity" Nothing Nothing Nothing - | otherwise = Nothing + | val == "yosys" = Just $ SynthDescription "yosys" Nothing Nothing Nothing + | val == "vivado" = Just $ SynthDescription "vivado" Nothing Nothing Nothing + | val == "xst" = Just $ SynthDescription "xst" Nothing Nothing Nothing + | val == "quartus" = + Just $ + SynthDescription "quartus" Nothing Nothing Nothing + | val == "identity" = + Just $ + SynthDescription "identity" Nothing Nothing Nothing + | otherwise = Nothing parseSim :: String -> Maybe OptTool -parseSim val | val == "icarus" = Just TIcarus - | otherwise = Nothing +parseSim val + | val == "icarus" = Just TIcarus + | otherwise = Nothing fuzzOpts :: Parser Opts fuzzOpts = - Fuzz - <$> textOption - ( Opt.long "output" - <> Opt.short 'o' - <> Opt.metavar "DIR" - <> Opt.help "Output directory that the fuzz run takes place in." - <> Opt.showDefault - <> Opt.value "output") - <*> ( Opt.optional - . Opt.strOption - $ Opt.long "config" - <> Opt.short 'c' - <> Opt.metavar "FILE" - <> Opt.help "Config file for the current fuzz run.") - <*> (Opt.switch $ Opt.long "force" <> Opt.short 'f' <> Opt.help - "Overwrite the specified directory.") - <*> (Opt.switch $ Opt.long "keep" <> Opt.short 'k' <> Opt.help - "Keep all the directories.") - <*> ( Opt.option Opt.auto - $ Opt.long "num" - <> Opt.short 'n' - <> Opt.help "The number of fuzz runs that should be performed." - <> Opt.showDefault - <> Opt.value 1 - <> Opt.metavar "INT") - <*> (Opt.switch $ Opt.long "no-sim" <> Opt.help - "Do not run simulation on the output netlist.") - <*> (Opt.switch $ Opt.long "no-equiv" <> Opt.help - "Do not run an equivalence check on the output netlist.") - <*> (Opt.switch $ Opt.long "no-reduction" <> Opt.help - "Do not run reduction on a failed testcase.") - <*> ( Opt.optional - . Opt.strOption - $ Opt.long "source" - <> Opt.short 's' - <> Opt.metavar "FILE" - <> Opt.help "Name of the top module.") - <*> textOption - ( Opt.long "source-top" - <> Opt.short 't' - <> Opt.metavar "TOP" - <> Opt.help "Define the top module for the source file." - <> Opt.showDefault - <> Opt.value "top") - <*> (Opt.switch $ Opt.long "crosscheck" <> Opt.help - "Do not only compare against the original design, but also against other netlists.") - <*> (Opt.optional . textOption $ - Opt.long "checker" - <> Opt.metavar "CHECKER" - <> Opt.help "Define the checker to use.") + Fuzz + <$> textOption + ( Opt.long "output" + <> Opt.short 'o' + <> Opt.metavar "DIR" + <> Opt.help "Output directory that the fuzz run takes place in." + <> Opt.showDefault + <> Opt.value "output" + ) + <*> ( Opt.optional + . Opt.strOption + $ Opt.long "config" + <> Opt.short 'c' + <> Opt.metavar "FILE" + <> Opt.help "Config file for the current fuzz run." + ) + <*> ( Opt.switch $ + Opt.long "force" <> Opt.short 'f' + <> Opt.help + "Overwrite the specified directory." + ) + <*> ( Opt.switch $ + Opt.long "keep" <> Opt.short 'k' + <> Opt.help + "Keep all the directories." + ) + <*> ( Opt.option Opt.auto $ + Opt.long "num" + <> Opt.short 'n' + <> Opt.help "The number of fuzz runs that should be performed." + <> Opt.showDefault + <> Opt.value 1 + <> Opt.metavar "INT" + ) + <*> ( Opt.switch $ + Opt.long "no-sim" + <> Opt.help + "Do not run simulation on the output netlist." + ) + <*> ( Opt.switch $ + Opt.long "no-equiv" + <> Opt.help + "Do not run an equivalence check on the output netlist." + ) + <*> ( Opt.switch $ + Opt.long "no-reduction" + <> Opt.help + "Do not run reduction on a failed testcase." + ) + <*> ( Opt.optional + . Opt.strOption + $ Opt.long "source" + <> Opt.short 's' + <> Opt.metavar "FILE" + <> Opt.help "Name of the top module." + ) + <*> textOption + ( Opt.long "source-top" + <> Opt.short 't' + <> Opt.metavar "TOP" + <> Opt.help "Define the top module for the source file." + <> Opt.showDefault + <> Opt.value "top" + ) + <*> ( Opt.switch $ + Opt.long "crosscheck" + <> Opt.help + "Do not only compare against the original design, but also against other netlists." + ) + <*> ( Opt.optional . textOption $ + Opt.long "checker" + <> Opt.metavar "CHECKER" + <> Opt.help "Define the checker to use." + ) genOpts :: Parser Opts genOpts = - Generate - <$> ( Opt.optional - . Opt.strOption - $ Opt.long "output" - <> Opt.short 'o' - <> Opt.metavar "FILE" - <> Opt.help "Output to a verilog file instead." - ) - <*> ( Opt.optional - . Opt.strOption - $ Opt.long "config" - <> Opt.short 'c' - <> Opt.metavar "FILE" - <> Opt.help "Config file for the generation run." - ) + Generate + <$> ( Opt.optional + . Opt.strOption + $ Opt.long "output" + <> Opt.short 'o' + <> Opt.metavar "FILE" + <> Opt.help "Output to a verilog file instead." + ) + <*> ( Opt.optional + . Opt.strOption + $ Opt.long "config" + <> Opt.short 'c' + <> Opt.metavar "FILE" + <> Opt.help "Config file for the generation run." + ) parseOpts :: Parser Opts -parseOpts = Parse - <$> (fromText . T.pack <$> Opt.strArgument - (Opt.metavar "FILE" <> Opt.help "Verilog input file.")) - <*> textOption ( Opt.short 't' - <> Opt.long "top" - <> Opt.metavar "TOP" - <> Opt.help "Name of top level module." - <> Opt.showDefault - <> Opt.value "top" - ) +parseOpts = + Parse + <$> ( fromText . T.pack + <$> Opt.strArgument + (Opt.metavar "FILE" <> Opt.help "Verilog input file.") + ) + <*> textOption + ( Opt.short 't' + <> Opt.long "top" + <> Opt.metavar "TOP" + <> Opt.help "Name of top level module." + <> Opt.showDefault + <> Opt.value "top" + ) <*> ( Opt.optional - . Opt.strOption - $ Opt.long "output" - <> Opt.short 'o' - <> Opt.metavar "FILE" - <> Opt.help "Output file to write the parsed file to.") - <*> (Opt.switch $ Opt.long "remove-const-in-concat" <> Opt.help - "Remove constants in concatenation to simplify the Verilog.") + . Opt.strOption + $ Opt.long "output" + <> Opt.short 'o' + <> Opt.metavar "FILE" + <> Opt.help "Output file to write the parsed file to." + ) + <*> ( Opt.switch $ + Opt.long "remove-const-in-concat" + <> Opt.help + "Remove constants in concatenation to simplify the Verilog." + ) reduceOpts :: Parser Opts reduceOpts = - Reduce - . fromText - . T.pack - <$> Opt.strArgument (Opt.metavar "FILE" <> Opt.help "Verilog input file.") - <*> textOption - ( Opt.short 't' - <> Opt.long "top" - <> Opt.metavar "TOP" - <> Opt.help "Name of top level module." - <> Opt.showDefault - <> Opt.value "top" - ) - <*> ( Opt.optional - . Opt.strOption - $ Opt.long "script" - <> Opt.metavar "SCRIPT" - <> Opt.help - "Script that determines if the current file is interesting, which is determined by the script returning 0." - ) - <*> ( Opt.many - . Opt.option (optReader parseSynthDesc) - $ Opt.short 's' - <> Opt.long "synth" - <> Opt.metavar "SYNTH" - <> Opt.help "Specify synthesiser to use." - ) - <*> ( Opt.switch - $ Opt.short 'r' - <> Opt.long "rerun" - <> Opt.help - "Only rerun the current synthesis file with all the synthesisers." - ) + Reduce + . fromText + . T.pack + <$> Opt.strArgument (Opt.metavar "FILE" <> Opt.help "Verilog input file.") + <*> textOption + ( Opt.short 't' + <> Opt.long "top" + <> Opt.metavar "TOP" + <> Opt.help "Name of top level module." + <> Opt.showDefault + <> Opt.value "top" + ) + <*> ( Opt.optional + . Opt.strOption + $ Opt.long "script" + <> Opt.metavar "SCRIPT" + <> Opt.help + "Script that determines if the current file is interesting, which is determined by the script returning 0." + ) + <*> ( Opt.many + . Opt.option (optReader parseSynthDesc) + $ Opt.short 's' + <> Opt.long "synth" + <> Opt.metavar "SYNTH" + <> Opt.help "Specify synthesiser to use." + ) + <*> ( Opt.switch $ + Opt.short 'r' + <> Opt.long "rerun" + <> Opt.help + "Only rerun the current synthesis file with all the synthesisers." + ) configOpts :: Parser Opts configOpts = - ConfigOpt - <$> ( Opt.optional - . Opt.strOption - $ Opt.long "output" - <> Opt.short 'o' - <> Opt.metavar "FILE" - <> Opt.help "Output to a TOML Config file." - ) - <*> ( Opt.optional - . Opt.strOption - $ Opt.long "config" - <> Opt.short 'c' - <> Opt.metavar "FILE" - <> Opt.help "Config file for the current fuzz run." - ) - <*> ( Opt.switch - $ Opt.long "randomise" - <> Opt.short 'r' - <> Opt.help - "Randomise the given default config, or the default config by randomly switchin on and off options." - ) + ConfigOpt + <$> ( Opt.optional + . Opt.strOption + $ Opt.long "output" + <> Opt.short 'o' + <> Opt.metavar "FILE" + <> Opt.help "Output to a TOML Config file." + ) + <*> ( Opt.optional + . Opt.strOption + $ Opt.long "config" + <> Opt.short 'c' + <> Opt.metavar "FILE" + <> Opt.help "Config file for the current fuzz run." + ) + <*> ( Opt.switch $ + Opt.long "randomise" + <> Opt.short 'r' + <> Opt.help + "Randomise the given default config, or the default config by randomly switchin on and off options." + ) argparse :: Parser Opts argparse = - Opt.hsubparser - ( Opt.command - "fuzz" - (Opt.info - fuzzOpts - (Opt.progDesc - "Run fuzzing on the specified simulators and synthesisers." - ) - ) - <> Opt.metavar "fuzz" + Opt.hsubparser + ( Opt.command + "fuzz" + ( Opt.info + fuzzOpts + ( Opt.progDesc + "Run fuzzing on the specified simulators and synthesisers." ) - <|> Opt.hsubparser - ( Opt.command - "generate" - (Opt.info - genOpts - (Opt.progDesc "Generate a random Verilog program.") - ) - <> Opt.metavar "generate" - ) - <|> Opt.hsubparser - ( Opt.command - "parse" - (Opt.info - parseOpts - (Opt.progDesc - "Parse a verilog file and output a pretty printed version." - ) - ) - <> Opt.metavar "parse" - ) - <|> Opt.hsubparser - ( Opt.command - "reduce" - (Opt.info - reduceOpts - (Opt.progDesc - "Reduce a Verilog file by rerunning the fuzzer on the file." - ) - ) - <> Opt.metavar "reduce" - ) - <|> Opt.hsubparser - ( Opt.command - "config" - (Opt.info - configOpts - (Opt.progDesc - "Print the current configuration of the fuzzer." - ) - ) - <> Opt.metavar "config" - ) + ) + <> Opt.metavar "fuzz" + ) + <|> Opt.hsubparser + ( Opt.command + "generate" + ( Opt.info + genOpts + (Opt.progDesc "Generate a random Verilog program.") + ) + <> Opt.metavar "generate" + ) + <|> Opt.hsubparser + ( Opt.command + "parse" + ( Opt.info + parseOpts + ( Opt.progDesc + "Parse a verilog file and output a pretty printed version." + ) + ) + <> Opt.metavar "parse" + ) + <|> Opt.hsubparser + ( Opt.command + "reduce" + ( Opt.info + reduceOpts + ( Opt.progDesc + "Reduce a Verilog file by rerunning the fuzzer on the file." + ) + ) + <> Opt.metavar "reduce" + ) + <|> Opt.hsubparser + ( Opt.command + "config" + ( Opt.info + configOpts + ( Opt.progDesc + "Print the current configuration of the fuzzer." + ) + ) + <> Opt.metavar "config" + ) version :: Parser (a -> a) -version = Opt.infoOption versionInfo $ mconcat - [Opt.long "version", Opt.short 'v', Opt.help "Show version information.", Opt.hidden] +version = + Opt.infoOption versionInfo $ + mconcat + [Opt.long "version", Opt.short 'v', Opt.help "Show version information.", Opt.hidden] opts :: ParserInfo Opts -opts = Opt.info +opts = + Opt.info (argparse <**> Opt.helper <**> version) - ( Opt.fullDesc - <> Opt.progDesc "Fuzz different simulators and synthesisers." - <> Opt.header - "Verismith - A hardware simulator and synthesiser Verilog fuzzer." + ( Opt.fullDesc + <> Opt.progDesc "Fuzz different simulators and synthesisers." + <> Opt.header + "Verismith - A hardware simulator and synthesiser Verilog fuzzer." ) diff --git a/src/Verismith/Reduce.hs b/src/Verismith/Reduce.hs index 6b18232..8a5bbbd 100644 --- a/src/Verismith/Reduce.hs +++ b/src/Verismith/Reduce.hs @@ -1,71 +1,68 @@ -{-| -Module : Verismith.Reduce -Description : Test case reducer implementation. -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Test case reducer implementation. --} - -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Verismith.Reduce +-- Description : Test case reducer implementation. +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Test case reducer implementation. module Verismith.Reduce - ( -- $strategy - reduceWithScript - , reduceSynth - , reduceSynthesis - , reduceSimIc - , reduce - , reduce_ - , Replacement(..) - , halveModules - , halveModItems - , halveStatements - , halveExpr - , halveAssigns - , findActiveWires - , clean - , cleanSourceInfo - , cleanSourceInfoAll - , removeDecl - , removeConstInConcat - , takeReplace - , filterExpr - , ReduceAnn(..) - , tagAlways - , untagAlways - ) + ( -- $strategy + reduceWithScript, + reduceSynth, + reduceSynthesis, + reduceSimIc, + reduce, + reduce_, + Replacement (..), + halveModules, + halveModItems, + halveStatements, + halveExpr, + halveAssigns, + findActiveWires, + clean, + cleanSourceInfo, + cleanSourceInfoAll, + removeDecl, + removeConstInConcat, + takeReplace, + filterExpr, + ReduceAnn (..), + tagAlways, + untagAlways, + ) where -import Control.Lens hiding ((<.>)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.ByteString (ByteString) -import Data.Foldable (foldrM) -import Data.List (nub) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import Shelly (fromText, (<.>)) +import Control.Lens hiding ((<.>)) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) +import Data.Foldable (foldrM) +import Data.List (nub) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Shelly ((<.>), fromText) import qualified Shelly -import Shelly.Lifted (MonadSh, liftSh, rm_rf, writefile) -import Verismith.Internal -import Verismith.Result -import Verismith.Tool -import Verismith.Tool.Icarus -import Verismith.Tool.Identity -import Verismith.Tool.Internal -import Verismith.Verilog -import Verismith.Verilog.AST -import Verismith.Verilog.Mutate -import Verismith.Verilog.Parser +import Shelly.Lifted (MonadSh, liftSh, rm_rf, writefile) +import Verismith.Internal +import Verismith.Result +import Verismith.Tool +import Verismith.Tool.Icarus +import Verismith.Tool.Identity +import Verismith.Tool.Internal +import Verismith.Verilog +import Verismith.Verilog.AST import Verismith.Verilog.CodeGen - +import Verismith.Verilog.Mutate +import Verismith.Verilog.Parser -- $strategy -- The reduction strategy has multiple different steps. 'reduce' will run these @@ -90,54 +87,56 @@ import Verismith.Verilog.CodeGen -- | Replacement type that supports returning different kinds of reduced -- replacements that could be tried. -data Replacement a = Dual a a - | Single a - | None - deriving (Show, Eq) - -data ReduceAnn = Active - | Reduced - | Idle - deriving (Show, Eq) +data Replacement a + = Dual a a + | Single a + | None + deriving (Show, Eq) + +data ReduceAnn + = Active + | Reduced + | Idle + deriving (Show, Eq) type Replace a = (a -> Replacement a) instance Functor Replacement where - fmap f (Dual a b) = Dual (f a) $ f b - fmap f (Single a) = Single $ f a - fmap _ None = None + fmap f (Dual a b) = Dual (f a) $ f b + fmap f (Single a) = Single $ f a + fmap _ None = None instance Applicative Replacement where - pure = Single - (Dual a b) <*> (Dual c d) = Dual (a c) $ b d - (Dual a b) <*> (Single c) = Dual (a c) $ b c - (Single a) <*> (Dual b c) = Dual (a b) $ a c - (Single a) <*> (Single b) = Single $ a b - None <*> _ = None - _ <*> None = None + pure = Single + (Dual a b) <*> (Dual c d) = Dual (a c) $ b d + (Dual a b) <*> (Single c) = Dual (a c) $ b c + (Single a) <*> (Dual b c) = Dual (a b) $ a c + (Single a) <*> (Single b) = Single $ a b + None <*> _ = None + _ <*> None = None instance Foldable Replacement where - foldMap _ None = mempty - foldMap f (Single a) = f a - foldMap f (Dual a b) = f a <> f b + foldMap _ None = mempty + foldMap f (Single a) = f a + foldMap f (Dual a b) = f a <> f b instance Traversable Replacement where - traverse _ None = pure None - traverse f (Single a) = Single <$> f a - traverse f (Dual a b) = Dual <$> f a <*> f b + traverse _ None = pure None + traverse f (Single a) = Single <$> f a + traverse f (Dual a b) = Dual <$> f a <*> f b -- | Split a list in two halves. halve :: Replace [a] -halve [] = Single [] +halve [] = Single [] halve [_] = Single [] -halve l = Dual a b where (a, b) = splitAt (length l `div` 2) l +halve l = Dual a b where (a, b) = splitAt (length l `div` 2) l halveNonEmpty :: Replace (NonEmpty a) halveNonEmpty l = case NonEmpty.splitAt (length l `div` 2) l of - ([] , [] ) -> None - ([] , a : b) -> Single $ a :| b - (a : b, [] ) -> Single $ a :| b - (a : b, c : d) -> Dual (a :| b) $ c :| d + ([], []) -> None + ([], a : b) -> Single $ a :| b + (a : b, []) -> Single $ a :| b + (a : b, c : d) -> Dual (a :| b) $ c :| d -- | When given a Lens and a function that works on a lower replacement, it will -- go down, apply the replacement, and return a replacement of the original @@ -156,22 +155,22 @@ combineL l f i = modify <$> f (i ^. l) where modify res = i & l .~ res filterExpr :: [Identifier] -> Expr -> Expr filterExpr ids (Id i) = if i `elem` ids then Id i else Number 0 filterExpr ids (VecSelect i e) = - if i `elem` ids then VecSelect i e else Number 0 + if i `elem` ids then VecSelect i e else Number 0 filterExpr ids (RangeSelect i r) = - if i `elem` ids then RangeSelect i r else Number 0 + if i `elem` ids then RangeSelect i r else Number 0 filterExpr _ e = e -- | Checks if a declaration is part of the current scope. If not, it returns -- 'False', otherwise 'True', as it should be kept. ---filterDecl :: [Identifier] -> (ModItem ReduceAnn) -> Bool ---filterDecl ids (Decl Nothing (Port _ _ _ i) _) = i `elem` ids ---filterDecl _ _ = True +-- filterDecl :: [Identifier] -> (ModItem ReduceAnn) -> Bool +-- filterDecl ids (Decl Nothing (Port _ _ _ i) _) = i `elem` ids +-- filterDecl _ _ = True -- | Checks if a continuous assignment is in the current scope, if not, it -- returns 'False'. filterAssigns :: [Port] -> (ModItem ReduceAnn) -> Bool filterAssigns out (ModCA (ContAssign i _)) = - elem i $ out ^.. traverse . portName + elem i $ out ^.. traverse . portName filterAssigns _ _ = True clean :: (Mutate a) => [Identifier] -> a -> a @@ -180,18 +179,19 @@ clean ids = mutExpr (transform $ filterExpr ids) takeReplace :: (Monoid a) => Replacement a -> a takeReplace (Single a) = a takeReplace (Dual a _) = a -takeReplace None = mempty +takeReplace None = mempty -- | Remove all the constants that are in the concatination. removeConstInConcat :: Replace (SourceInfo ReduceAnn) removeConstInConcat = Single . mutExpr replace where replace :: Expr -> Expr - replace (Concat expr) = maybe (Number 0) Concat . NonEmpty.nonEmpty - $ NonEmpty.filter notConstant expr - replace e = e + replace (Concat expr) = + maybe (Number 0) Concat . NonEmpty.nonEmpty $ + NonEmpty.filter notConstant expr + replace e = e notConstant (Number _) = False - notConstant _ = True + notConstant _ = True cleanUndefined :: [Identifier] -> [ModItem ReduceAnn] -> [ModItem ReduceAnn] cleanUndefined ids mis = clean usedWires mis @@ -210,41 +210,42 @@ cleanMod m newm = modify . change <$> newm mis = m ^. modItems modify l = m & modItems .~ l change l = - cleanUndefined (m ^.. modInPorts . traverse . portName) - . combineAssigns (head $ m ^. modOutPorts) - . (filter (not . filterAssigns []) mis <>) - $ l - ^. modItems + cleanUndefined (m ^.. modInPorts . traverse . portName) + . combineAssigns (head $ m ^. modOutPorts) + . (filter (not . filterAssigns []) mis <>) + $ l + ^. modItems halveIndExpr :: Replace Expr -halveIndExpr (Concat l ) = Concat <$> halveNonEmpty l -halveIndExpr (BinOp e1 _ e2) = Dual e1 e2 -halveIndExpr (Cond _ e1 e2) = Dual e1 e2 -halveIndExpr (UnOp _ e ) = Single e -halveIndExpr (Appl _ e ) = Single e -halveIndExpr e = Single e +halveIndExpr (Concat l) = Concat <$> halveNonEmpty l +halveIndExpr (BinOp e1 _ e2) = Dual e1 e2 +halveIndExpr (Cond _ e1 e2) = Dual e1 e2 +halveIndExpr (UnOp _ e) = Single e +halveIndExpr (Appl _ e) = Single e +halveIndExpr e = Single e halveModExpr :: Replace (ModItem ReduceAnn) halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca -halveModExpr a = Single a +halveModExpr a = Single a -- | Remove all the undefined mod instances. cleanModInst :: (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn) cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned where validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId - cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped + cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped -- | Clean all the undefined module instances in a specific module using a -- context. cleanModInst' :: [Identifier] -> (ModDecl ReduceAnn) -> (ModDecl ReduceAnn) cleanModInst' ids m = m & modItems .~ newModItem - where newModItem = filter (validModInst ids) $ m ^.. modItems . traverse + where + newModItem = filter (validModInst ids) $ m ^.. modItems . traverse -- | Check if a mod instance is in the current context. validModInst :: [Identifier] -> (ModItem ReduceAnn) -> Bool validModInst ids (ModInst i _ _) = i `elem` ids -validModInst _ _ = True +validModInst _ _ = True -- | Adds a '(ModDecl ReduceAnn)' to a '(SourceInfo ReduceAnn)'. addMod :: (ModDecl ReduceAnn) -> (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn) @@ -258,46 +259,46 @@ halveAssigns = combineL mainModule halveModAssign -- | Checks if a module item is needed in the module declaration. relevantModItem :: (ModDecl ReduceAnn) -> (ModItem ReduceAnn) -> Bool relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) = - i `elem` fmap _portName out -relevantModItem _ Decl{} = True -relevantModItem _ _ = False + i `elem` fmap _portName out +relevantModItem _ Decl {} = True +relevantModItem _ _ = False isAssign :: (Statement ReduceAnn) -> Bool -isAssign (BlockAssign _) = True +isAssign (BlockAssign _) = True isAssign (NonBlockAssign _) = True -isAssign _ = False +isAssign _ = False lValName :: LVal -> [Identifier] -lValName (RegId i ) = [i] +lValName (RegId i) = [i] lValName (RegExpr i _) = [i] lValName (RegSize i _) = [i] lValName (RegConcat e) = mapMaybe getId . concat $ universe <$> e where getId (Id i) = Just i - getId _ = Nothing + getId _ = Nothing -- | Pretending that expr is an LVal for the case that it is in a module -- instantiation. exprName :: Expr -> [Identifier] -exprName (Id i ) = [i] -exprName (VecSelect i _) = [i] +exprName (Id i) = [i] +exprName (VecSelect i _) = [i] exprName (RangeSelect i _) = [i] -exprName (Concat i ) = concat . NonEmpty.toList $ exprName <$> i -exprName _ = [] +exprName (Concat i) = concat . NonEmpty.toList $ exprName <$> i +exprName _ = [] -- | Returns the only identifiers that are directly tied to an expression. This -- is useful if one does not have to recurse deeper into the expressions. exprId :: Expr -> Maybe Identifier -exprId (Id i ) = Just i -exprId (VecSelect i _) = Just i +exprId (Id i) = Just i +exprId (VecSelect i _) = Just i exprId (RangeSelect i _) = Just i -exprId _ = Nothing +exprId _ = Nothing eventId :: Event -> Maybe Identifier -eventId (EId i) = Just i +eventId (EId i) = Just i eventId (EPosEdge i) = Just i eventId (ENegEdge i) = Just i -eventId _ = Nothing +eventId _ = Nothing portToId :: Port -> Identifier portToId (Port _ _ _ i) = i @@ -310,52 +311,53 @@ isModule i (ModDecl n _ _ _ _) = i == n modInstActive :: [(ModDecl ReduceAnn)] -> (ModItem ReduceAnn) -> [Identifier] modInstActive decl (ModInst n _ i) = case m of - Nothing -> [] - Just m' -> concat $ calcActive m' <$> zip i [0 ..] + Nothing -> [] + Just m' -> concat $ calcActive m' <$> zip i [0 ..] where m = safe head $ filter (isModule n) decl - calcActive (ModDecl _ o _ _ _) (ModConn e, n') | n' < length o = exprName e - | otherwise = [] + calcActive (ModDecl _ o _ _ _) (ModConn e, n') + | n' < length o = exprName e + | otherwise = [] calcActive (ModDecl _ o _ _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName o = exprName e - | otherwise = [] + | i' `elem` fmap _portName o = exprName e + | otherwise = [] modInstActive _ _ = [] fixModInst :: (SourceInfo ReduceAnn) -> (ModItem ReduceAnn) -> (ModItem ReduceAnn) fixModInst (SourceInfo _ (Verilog decl)) (ModInst n g i) = case m of - Nothing -> error "Moditem not found" - Just m' -> ModInst n g . mapMaybe (fixModInst' m') $ zip i [0 ..] + Nothing -> error "Moditem not found" + Just m' -> ModInst n g . mapMaybe (fixModInst' m') $ zip i [0 ..] where m = safe head $ filter (isModule n) decl fixModInst' (ModDecl _ o i' _ _) (ModConn e, n') - | n' < length o + length i' = Just $ ModConn e - | otherwise = Nothing + | n' < length o + length i' = Just $ ModConn e + | otherwise = Nothing fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e - | otherwise = Nothing + | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e + | otherwise = Nothing fixModInst _ a = a findActiveWires :: Identifier -> (SourceInfo ReduceAnn) -> [Identifier] findActiveWires t src = - nub - $ assignWires - <> assignStat - <> fmap portToId i - <> fmap portToId o - <> fmap paramToId p - <> modinstwires + nub $ + assignWires + <> assignStat + <> fmap portToId i + <> fmap portToId o + <> fmap paramToId p + <> modinstwires where assignWires = m ^.. modItems . traverse . modContAssign . contAssignNetLVal assignStat = - concatMap lValName - $ (allStat ^.. traverse . stmntBA . assignReg) - <> (allStat ^.. traverse . stmntNBA . assignReg) + concatMap lValName $ + (allStat ^.. traverse . stmntBA . assignReg) + <> (allStat ^.. traverse . stmntNBA . assignReg) allStat = filter isAssign . concat $ fmap universe stat stat = - (m ^.. modItems . traverse . _Initial) - <> (m ^.. modItems . traverse . _Always) + (m ^.. modItems . traverse . _Initial) + <> (m ^.. modItems . traverse . _Always) modinstwires = - concat $ modInstActive (src ^. infoSrc . _Wrapped) <$> m ^. modItems + concat $ modInstActive (src ^. infoSrc . _Wrapped) <$> m ^. modItems m@(ModDecl _ o i _ p) = src ^. aModule t -- | Clean a specific module. Have to be carful that the module is in the @@ -365,7 +367,8 @@ cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) cleanSourceInfoAll :: (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn) cleanSourceInfoAll src = foldr cleanSourceInfo src allMods - where allMods = src ^.. infoSrc . _Wrapped . traverse . modId + where + allMods = src ^.. infoSrc . _Wrapped . traverse . modId -- | Returns true if the text matches the name of a module. matchesModName :: Identifier -> (ModDecl ReduceAnn) -> Bool @@ -391,42 +394,43 @@ halveAlways a = Single a -- removing the instantiations from the main module body. halveModules :: Replace (SourceInfo ReduceAnn) halveModules srcInfo@(SourceInfo top _) = - cleanSourceInfoAll - . cleanModInst - . addMod main - <$> combine (infoSrc . _Wrapped) repl srcInfo + cleanSourceInfoAll + . cleanModInst + . addMod main + <$> combine (infoSrc . _Wrapped) repl srcInfo where repl = halve . filter (not . matchesModName (Identifier top)) main = srcInfo ^. mainModule moduleBot :: (SourceInfo ReduceAnn) -> Bool -moduleBot (SourceInfo _ (Verilog [] )) = True +moduleBot (SourceInfo _ (Verilog [])) = True moduleBot (SourceInfo _ (Verilog [_])) = True -moduleBot (SourceInfo _ (Verilog _ )) = False +moduleBot (SourceInfo _ (Verilog _)) = False -- | Reducer for module items. It does a binary search on all the module items, -- except assignments to outputs and input-output declarations. halveModItems :: Identifier -> Replace (SourceInfo ReduceAnn) halveModItems t srcInfo = cleanSourceInfo t . addRelevant <$> src where - repl = halve . filter (not . relevantModItem main) - relevant = filter (relevantModItem main) $ main ^. modItems - main = srcInfo ^. aModule t - src = combine (aModule t . modItems) repl srcInfo + repl = halve . filter (not . relevantModItem main) + relevant = filter (relevantModItem main) $ main ^. modItems + main = srcInfo ^. aModule t + src = combine (aModule t . modItems) repl srcInfo addRelevant = aModule t . modItems %~ (relevant ++) modItemBot :: Identifier -> (SourceInfo ReduceAnn) -> Bool -modItemBot t srcInfo | length modItemsNoDecl > 2 = False - | otherwise = True +modItemBot t srcInfo + | length modItemsNoDecl > 2 = False + | otherwise = True where modItemsNoDecl = - filter noDecl $ srcInfo ^.. aModule t . modItems . traverse - noDecl Decl{} = False - noDecl _ = True + filter noDecl $ srcInfo ^.. aModule t . modItems . traverse + noDecl Decl {} = False + noDecl _ = True halveStatements :: Identifier -> Replace (SourceInfo ReduceAnn) halveStatements t m = - cleanSourceInfo t <$> combine (aModule t . modItems) (traverse halveAlways) m + cleanSourceInfo t <$> combine (aModule t . modItems) (traverse halveAlways) m -- | Reduce expressions by splitting them in half and keeping the half that -- succeeds. @@ -446,12 +450,12 @@ allStatIds' :: (Statement ReduceAnn) -> [Identifier] allStatIds' s = nub $ assignIds <> otherExpr <> eventProcessedIds where assignIds = - toIds - $ (s ^.. stmntBA . assignExpr) - <> (s ^.. stmntNBA . assignExpr) - <> (s ^.. forAssign . assignExpr) - <> (s ^.. forIncr . assignExpr) - otherExpr = toIds $ (s ^.. forExpr) <> (s ^.. stmntCondExpr) + toIds $ + (s ^.. stmntBA . assignExpr) + <> (s ^.. stmntNBA . assignExpr) + <> (s ^.. forAssign . assignExpr) + <> (s ^.. forIncr . assignExpr) + otherExpr = toIds $ (s ^.. forExpr) <> (s ^.. stmntCondExpr) eventProcessedIds = toIdsEvent $ s ^.. statEvent allStatIds :: (Statement ReduceAnn) -> [Identifier] @@ -462,46 +466,46 @@ fromRange r = [rangeMSB r, rangeLSB r] allExprIds :: (ModDecl ReduceAnn) -> [Identifier] allExprIds m = - nub - $ contAssignIds - <> modInstIds - <> modInitialIds - <> modAlwaysIds - <> modPortIds - <> modDeclIds - <> paramIds + nub $ + contAssignIds + <> modInstIds + <> modInitialIds + <> modAlwaysIds + <> modPortIds + <> modDeclIds + <> paramIds where contAssignIds = - toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr + toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr modInstIds = - toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr + toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr modInitialIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial modAlwaysIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always modPortIds = - nub - . concatMap (toIdsConst . fromRange) - $ m - ^.. modItems - . traverse - . declPort - . portSize + nub + . concatMap (toIdsConst . fromRange) + $ m + ^.. modItems + . traverse + . declPort + . portSize modDeclIds = toIdsConst $ m ^.. modItems . traverse . declVal . _Just paramIds = - toIdsConst - $ (m ^.. modItems . traverse . paramDecl . traverse . paramValue) - <> ( m - ^.. modItems - . traverse - . localParamDecl - . traverse - . localParamValue - ) + toIdsConst $ + (m ^.. modItems . traverse . paramDecl . traverse . paramValue) + <> ( m + ^.. modItems + . traverse + . localParamDecl + . traverse + . localParamValue + ) isUsedDecl :: [Identifier] -> (ModItem ReduceAnn) -> Bool isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids -isUsedDecl _ _ = True +isUsedDecl _ _ = True isUsedParam :: [Identifier] -> Parameter -> Bool isUsedParam ids (Parameter i _) = i `elem` ids @@ -518,29 +522,30 @@ checkActiveTag m = (/= []) . filter hasActiveTag $ _modItems m tagAlwaysBlockMis :: [ModItem ReduceAnn] -> [ModItem ReduceAnn] tagAlwaysBlockMis [] = [] -tagAlwaysBlockMis (mi@(Always _):mis) = ModItemAnn Active mi : mis -tagAlwaysBlockMis (mi:mis) = mi : tagAlwaysBlockMis mis +tagAlwaysBlockMis (mi@(Always _) : mis) = ModItemAnn Active mi : mis +tagAlwaysBlockMis (mi : mis) = mi : tagAlwaysBlockMis mis -- | Tag an always block to be reduced if there are no active ones. tagAlwaysBlock :: ModDecl ReduceAnn -> ModDecl ReduceAnn tagAlwaysBlock m | checkActiveTag m = m - | otherwise = m { _modItems = tagAlwaysBlockMis (_modItems m) } + | otherwise = m {_modItems = tagAlwaysBlockMis (_modItems m)} tagAlwaysBlockReducedMis :: [ModItem ReduceAnn] -> [ModItem ReduceAnn] tagAlwaysBlockReducedMis [] = [] -tagAlwaysBlockReducedMis ((ModItemAnn Active mi):mis) = +tagAlwaysBlockReducedMis ((ModItemAnn Active mi) : mis) = ModItemAnn Reduced mi : tagAlwaysBlockReducedMis mis -tagAlwaysBlockReducedMis (mi:mis) = mi : tagAlwaysBlockReducedMis mis +tagAlwaysBlockReducedMis (mi : mis) = mi : tagAlwaysBlockReducedMis mis -- | Tag an always block to be reduced if there are no active ones. tagAlwaysBlockReduced :: ModDecl ReduceAnn -> ModDecl ReduceAnn -tagAlwaysBlockReduced m = m { _modItems = tagAlwaysBlockReducedMis (_modItems m) } +tagAlwaysBlockReduced m = m {_modItems = tagAlwaysBlockReducedMis (_modItems m)} -tAlways :: (ModDecl ReduceAnn -> ModDecl ReduceAnn) - -> Identifier - -> SourceInfo ReduceAnn - -> SourceInfo ReduceAnn +tAlways :: + (ModDecl ReduceAnn -> ModDecl ReduceAnn) -> + Identifier -> + SourceInfo ReduceAnn -> + SourceInfo ReduceAnn tAlways f t m = m & aModule t %~ f @@ -553,13 +558,16 @@ removeDecl :: SourceInfo ReduceAnn -> SourceInfo ReduceAnn removeDecl src = foldr fix removed allMods where removeDecl' t src' = - src' - & (\a -> a & aModule t . modItems %~ filter + src' + & ( \a -> + a & aModule t . modItems + %~ filter (isUsedDecl (used <> findActiveWires t a)) - ) - . (aModule t . modParams %~ filter (isUsedParam used)) - . (aModule t . modInPorts %~ filter (isUsedPort used)) - where used = nub $ allExprIds (src' ^. aModule t) + ) + . (aModule t . modParams %~ filter (isUsedParam used)) + . (aModule t . modInPorts %~ filter (isUsedPort used)) + where + used = nub $ allExprIds (src' ^. aModule t) allMods = src ^.. infoSrc . _Wrapped . traverse . modId fix t a = a & aModule t . modItems %~ fmap (fixModInst a) removed = foldr removeDecl' src allMods @@ -568,56 +576,63 @@ defaultBot :: (SourceInfo ReduceAnn) -> Bool defaultBot = const False -- | Reduction using custom reduction strategies. -reduce_ - :: (MonadSh m) - => Shelly.FilePath - -> (SourceInfo ReduceAnn -> m Bool) - -> Text - -> (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) - -> (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) - -> Replace (SourceInfo ReduceAnn) - -> (SourceInfo ReduceAnn -> Bool) - -> SourceInfo ReduceAnn - -> m (SourceInfo ReduceAnn) +reduce_ :: + (MonadSh m) => + Shelly.FilePath -> + (SourceInfo ReduceAnn -> m Bool) -> + Text -> + (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) -> + (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) -> + Replace (SourceInfo ReduceAnn) -> + (SourceInfo ReduceAnn -> Bool) -> + SourceInfo ReduceAnn -> + m (SourceInfo ReduceAnn) reduce_ out eval title tag untag repl bot usrc = do - writefile out $ genSource src - liftSh - . Shelly.echo $ "Reducing " <> title <> " (Modules: " - <> showT (length . getVerilog $ _infoSrc src) <> ", Module items: " - <> showT (length (src ^.. infoSrc . _Wrapped . traverse . modItems . traverse)) <> ")" - if bot src - then return $ untag src - else case repl src of - Single s -> do - red <- eval s - if red - then if s /= src then recReduction s else return $ untag src - else return $ untag src - Dual l r -> do - red <- eval l - if red - then if l /= src then recReduction l else return $ untag src - else do - red' <- eval r - if red' - then if r /= src then recReduction r else return $ untag src - else return $ untag src - None -> return $ untag src + writefile out $ genSource src + liftSh + . Shelly.echo + $ "Reducing " <> title <> " (Modules: " + <> showT (length . getVerilog $ _infoSrc src) + <> ", Module items: " + <> showT (length (src ^.. infoSrc . _Wrapped . traverse . modItems . traverse)) + <> ")" + if bot src + then return $ untag src + else case repl src of + Single s -> do + red <- eval s + if red + then if s /= src then recReduction s else return $ untag src + else return $ untag src + Dual l r -> do + red <- eval l + if red + then if l /= src then recReduction l else return $ untag src + else do + red' <- eval r + if red' + then if r /= src then recReduction r else return $ untag src + else return $ untag src + None -> return $ untag src where src = tag usrc recReduction = reduce_ out eval title tag untag repl bot -- | Reduce an input to a minimal representation. It follows the reduction -- strategy mentioned above. -reduce - :: (MonadSh m) - => Shelly.FilePath -- ^ Filepath for temporary file. - -> (SourceInfo ReduceAnn -> m Bool) -- ^ Failed or not. - -> SourceInfo () -- ^ Input verilog source to be reduced. - -> m (SourceInfo ()) -- ^ Reduced output. +reduce :: + (MonadSh m) => + -- | Filepath for temporary file. + Shelly.FilePath -> + -- | Failed or not. + (SourceInfo ReduceAnn -> m Bool) -> + -- | Input verilog source to be reduced. + SourceInfo () -> + -- | Reduced output. + m (SourceInfo ()) reduce fp eval rsrc = - fmap (clearAnn . removeDecl) - $ red "Modules" id id halveModules moduleBot src + fmap (clearAnn . removeDecl) $ + red "Modules" id id halveModules moduleBot src >>= redAll "Module items" idTag idTag halveModItems modItemBot >>= redAll "Statements" tagAlways untagAlways halveStatements (const defaultBot) -- >>= redAll "Expressions" halveExpr (const defaultBot) @@ -625,81 +640,93 @@ reduce fp eval rsrc = >>= red "Cleaning" id id (pure . removeDecl) defaultBot where red = reduce_ fp eval - redAll s tag untag halve' bot src' = foldrM + redAll s tag untag halve' bot src' = + foldrM (\t -> red (s <> " (" <> getIdentifier t <> ")") (tag t) (untag t) (halve' t) (bot t)) src' (src' ^.. infoSrc . _Wrapped . traverse . modId) src = fmap (\_ -> Idle) rsrc -runScript - :: (MonadSh m, Show ann) => Shelly.FilePath - -> Shelly.FilePath -> (SourceInfo ann) -> m Bool +runScript :: + (MonadSh m, Show ann) => + Shelly.FilePath -> + Shelly.FilePath -> + (SourceInfo ann) -> + m Bool runScript fp file src = do - e <- liftSh $ do - Shelly.writefile file $ genSource src - noPrint . Shelly.errExit False $ Shelly.run_ fp [] - Shelly.lastExitCode - return $ e == 0 + e <- liftSh $ do + Shelly.writefile file $ genSource src + noPrint . Shelly.errExit False $ Shelly.run_ fp [] + Shelly.lastExitCode + return $ e == 0 -- | Reduce using a script that is passed to it -reduceWithScript - :: (MonadSh m, MonadIO m) - => Text - -> Shelly.FilePath - -> Shelly.FilePath - -> m () +reduceWithScript :: + (MonadSh m, MonadIO m) => + Text -> + Shelly.FilePath -> + Shelly.FilePath -> + m () reduceWithScript top script file = do - liftSh . Shelly.cp file $ file <.> "original" - (srcInfo :: SourceInfo ()) <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file - void $ reduce (fromText "reduce_script.v") (runScript script file) srcInfo + liftSh . Shelly.cp file $ file <.> "original" + (srcInfo :: SourceInfo ()) <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file + void $ reduce (fromText "reduce_script.v") (runScript script file) srcInfo -- | Reduce a '(SourceInfo ReduceAnn)' using two 'Synthesiser' that are passed to it. -reduceSynth - :: (Synthesiser a, Synthesiser b, MonadSh m) - => Maybe Text - -> Shelly.FilePath - -> a - -> b - -> (SourceInfo ()) - -> m (SourceInfo ()) +reduceSynth :: + (Synthesiser a, Synthesiser b, MonadSh m) => + Maybe Text -> + Shelly.FilePath -> + a -> + b -> + (SourceInfo ()) -> + m (SourceInfo ()) reduceSynth mt datadir a b = reduce (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") synth where synth src' = liftSh $ do - r <- runResultT $ do - runSynth a src' - runSynth b src' - runEquiv mt datadir a b src' - return $ case r of - Fail (EquivFail _) -> True - _ -> False + r <- runResultT $ do + runSynth a src' + runSynth b src' + runEquiv mt datadir a b src' + return $ case r of + Fail (EquivFail _) -> True + _ -> False reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo () -> m (SourceInfo ()) reduceSynthesis a = reduce (fromText $ "reduce_" <> toText a <> ".v") synth where synth src = liftSh $ do - r <- runResultT $ runSynth a src - return $ case r of - Fail SynthFail -> True - _ -> False + r <- runResultT $ runSynth a src + return $ case r of + Fail SynthFail -> True + _ -> False runInTmp :: Shelly.Sh a -> Shelly.Sh a -runInTmp a = Shelly.withTmpDir $ (\f -> do - dir <- Shelly.pwd - Shelly.cd f - r <- a - Shelly.cd dir - return r) - -reduceSimIc :: (Synthesiser a, MonadSh m) => Shelly.FilePath -> [ByteString] - -> a -> SourceInfo () -> m (SourceInfo ()) +runInTmp a = + Shelly.withTmpDir $ + ( \f -> do + dir <- Shelly.pwd + Shelly.cd f + r <- a + Shelly.cd dir + return r + ) + +reduceSimIc :: + (Synthesiser a, MonadSh m) => + Shelly.FilePath -> + [ByteString] -> + a -> + SourceInfo () -> + m (SourceInfo ()) reduceSimIc fp bs a = reduce (fromText $ "reduce_sim_" <> toText a <> ".v") synth where synth src = liftSh . runInTmp $ do - r <- runResultT $ do - runSynth a src - runSynth defaultIdentity src - i <- runSimIc fp defaultIcarus defaultIdentity src bs Nothing - runSimIc fp defaultIcarus a src bs $ Just i - return $ case r of - Fail (SimFail _) -> True - _ -> False + r <- runResultT $ do + runSynth a src + runSynth defaultIdentity src + i <- runSimIc fp defaultIcarus defaultIdentity src bs Nothing + runSimIc fp defaultIcarus a src bs $ Just i + return $ case r of + Fail (SimFail _) -> True + _ -> False diff --git a/src/Verismith/Report.hs b/src/Verismith/Report.hs index a62dab5..6c0d537 100644 --- a/src/Verismith/Report.hs +++ b/src/Verismith/Report.hs @@ -1,69 +1,72 @@ -{-# LANGUAGE RankNTypes #-} -{-| -Module : Verismith.Report -Description : Generate a report from a fuzz run. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Generate a report from a fuzz run. --} - +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Verismith.Report +-- Description : Generate a report from a fuzz run. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Generate a report from a fuzz run. module Verismith.Report - ( SynthTool(..) - , SynthStatus(..) - , SynthResult(..) - , SimResult(..) - , SimTool(..) - , FuzzReport(..) - , printResultReport - , printSummary - , synthResults - , simResults - , synthStatus - , equivTime - , fuzzDir - , fileLines - , reducTime - , synthTime - , defaultIcarusSim - , defaultVivadoSynth - , defaultYosysSynth - , defaultXSTSynth - , defaultQuartusSynth - , defaultQuartusLightSynth - , defaultIdentitySynth - , descriptionToSim - , descriptionToSynth - ) + ( SynthTool (..), + SynthStatus (..), + SynthResult (..), + SimResult (..), + SimTool (..), + FuzzReport (..), + printResultReport, + printSummary, + synthResults, + simResults, + synthStatus, + equivTime, + fuzzDir, + fileLines, + reducTime, + synthTime, + defaultIcarusSim, + defaultVivadoSynth, + defaultYosysSynth, + defaultXSTSynth, + defaultQuartusSynth, + defaultQuartusLightSynth, + defaultIdentitySynth, + descriptionToSim, + descriptionToSynth, + ) where -import Control.DeepSeq (NFData, rnf) -import Control.Lens hiding (Identity, (<.>)) -import Data.Bifunctor (bimap) -import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) -import Data.Monoid (Endo) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Lazy (toStrict) -import Data.Time -import Prelude hiding (FilePath) -import Shelly (FilePath, fromText, - toTextIgnore, (<.>), (</>)) -import Text.Blaze.Html (Html, (!)) -import Text.Blaze.Html.Renderer.Text (renderHtml) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import Verismith.Config -import Verismith.Internal -import Verismith.Result -import Verismith.Tool -import Verismith.Tool.Internal +import Control.DeepSeq (NFData, rnf) +import Control.Lens hiding ((<.>), Identity) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import Data.Monoid (Endo) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Time +import Shelly + ( (<.>), + (</>), + FilePath, + fromText, + toTextIgnore, + ) +import Text.Blaze.Html ((!), Html) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Verismith.Config +import Verismith.Internal +import Verismith.Result +import Verismith.Tool +import Verismith.Tool.Internal +import Prelude hiding (FilePath) -- | Common type alias for synthesis results type UResult = Result Failed () @@ -71,59 +74,60 @@ type UResult = Result Failed () -- | Commont type alias for simulation results type BResult = Result Failed ByteString -data SynthTool = XSTSynth {-# UNPACK #-} !XST - | VivadoSynth {-# UNPACK #-} !Vivado - | YosysSynth {-# UNPACK #-} !Yosys - | QuartusSynth {-# UNPACK #-} !Quartus - | QuartusLightSynth {-# UNPACK #-} !QuartusLight - | IdentitySynth {-# UNPACK #-} !Identity - deriving (Eq) +data SynthTool + = XSTSynth {-# UNPACK #-} !XST + | VivadoSynth {-# UNPACK #-} !Vivado + | YosysSynth {-# UNPACK #-} !Yosys + | QuartusSynth {-# UNPACK #-} !Quartus + | QuartusLightSynth {-# UNPACK #-} !QuartusLight + | IdentitySynth {-# UNPACK #-} !Identity + deriving (Eq) instance NFData SynthTool where - rnf (XSTSynth a) = rnf a - rnf (VivadoSynth a) = rnf a - rnf (YosysSynth a) = rnf a - rnf (QuartusSynth a) = rnf a - rnf (QuartusLightSynth a) = rnf a - rnf (IdentitySynth a) = rnf a + rnf (XSTSynth a) = rnf a + rnf (VivadoSynth a) = rnf a + rnf (YosysSynth a) = rnf a + rnf (QuartusSynth a) = rnf a + rnf (QuartusLightSynth a) = rnf a + rnf (IdentitySynth a) = rnf a instance Show SynthTool where - show (XSTSynth xst) = show xst - show (VivadoSynth vivado) = show vivado - show (YosysSynth yosys) = show yosys - show (QuartusSynth quartus) = show quartus - show (QuartusLightSynth quartus) = show quartus - show (IdentitySynth identity) = show identity + show (XSTSynth xst) = show xst + show (VivadoSynth vivado) = show vivado + show (YosysSynth yosys) = show yosys + show (QuartusSynth quartus) = show quartus + show (QuartusLightSynth quartus) = show quartus + show (IdentitySynth identity) = show identity instance Tool SynthTool where - toText (XSTSynth xst) = toText xst - toText (VivadoSynth vivado) = toText vivado - toText (YosysSynth yosys) = toText yosys - toText (QuartusSynth quartus) = toText quartus - toText (QuartusLightSynth quartus) = toText quartus - toText (IdentitySynth identity) = toText identity + toText (XSTSynth xst) = toText xst + toText (VivadoSynth vivado) = toText vivado + toText (YosysSynth yosys) = toText yosys + toText (QuartusSynth quartus) = toText quartus + toText (QuartusLightSynth quartus) = toText quartus + toText (IdentitySynth identity) = toText identity instance Synthesiser SynthTool where - runSynth (XSTSynth xst) = runSynth xst - runSynth (VivadoSynth vivado) = runSynth vivado - runSynth (YosysSynth yosys) = runSynth yosys - runSynth (QuartusSynth quartus) = runSynth quartus - runSynth (QuartusLightSynth quartus) = runSynth quartus - runSynth (IdentitySynth identity) = runSynth identity - - synthOutput (XSTSynth xst) = synthOutput xst - synthOutput (VivadoSynth vivado) = synthOutput vivado - synthOutput (YosysSynth yosys) = synthOutput yosys - synthOutput (QuartusSynth quartus) = synthOutput quartus - synthOutput (QuartusLightSynth quartus) = synthOutput quartus - synthOutput (IdentitySynth identity) = synthOutput identity - - setSynthOutput (YosysSynth yosys) = YosysSynth . setSynthOutput yosys - setSynthOutput (XSTSynth xst) = XSTSynth . setSynthOutput xst - setSynthOutput (VivadoSynth vivado) = VivadoSynth . setSynthOutput vivado - setSynthOutput (QuartusSynth quartus) = QuartusSynth . setSynthOutput quartus - setSynthOutput (QuartusLightSynth quartus) = QuartusLightSynth . setSynthOutput quartus - setSynthOutput (IdentitySynth identity) = IdentitySynth . setSynthOutput identity + runSynth (XSTSynth xst) = runSynth xst + runSynth (VivadoSynth vivado) = runSynth vivado + runSynth (YosysSynth yosys) = runSynth yosys + runSynth (QuartusSynth quartus) = runSynth quartus + runSynth (QuartusLightSynth quartus) = runSynth quartus + runSynth (IdentitySynth identity) = runSynth identity + + synthOutput (XSTSynth xst) = synthOutput xst + synthOutput (VivadoSynth vivado) = synthOutput vivado + synthOutput (YosysSynth yosys) = synthOutput yosys + synthOutput (QuartusSynth quartus) = synthOutput quartus + synthOutput (QuartusLightSynth quartus) = synthOutput quartus + synthOutput (IdentitySynth identity) = synthOutput identity + + setSynthOutput (YosysSynth yosys) = YosysSynth . setSynthOutput yosys + setSynthOutput (XSTSynth xst) = XSTSynth . setSynthOutput xst + setSynthOutput (VivadoSynth vivado) = VivadoSynth . setSynthOutput vivado + setSynthOutput (QuartusSynth quartus) = QuartusSynth . setSynthOutput quartus + setSynthOutput (QuartusLightSynth quartus) = QuartusLightSynth . setSynthOutput quartus + setSynthOutput (IdentitySynth identity) = IdentitySynth . setSynthOutput identity defaultYosysSynth :: SynthTool defaultYosysSynth = YosysSynth defaultYosys @@ -144,20 +148,20 @@ defaultIdentitySynth :: SynthTool defaultIdentitySynth = IdentitySynth defaultIdentity newtype SimTool = IcarusSim Icarus - deriving (Eq) + deriving (Eq) instance NFData SimTool where - rnf (IcarusSim a) = rnf a + rnf (IcarusSim a) = rnf a instance Tool SimTool where - toText (IcarusSim icarus) = toText icarus + toText (IcarusSim icarus) = toText icarus instance Simulator SimTool where - runSim (IcarusSim icarus) = runSim icarus - runSimWithFile (IcarusSim icarus) = runSimWithFile icarus + runSim (IcarusSim icarus) = runSim icarus + runSimWithFile (IcarusSim icarus) = runSimWithFile icarus instance Show SimTool where - show (IcarusSim icarus) = show icarus + show (IcarusSim icarus) = show icarus defaultIcarusSim :: SimTool defaultIcarusSim = IcarusSim defaultIcarus @@ -165,10 +169,10 @@ defaultIcarusSim = IcarusSim defaultIcarus -- | The results from running a tool through a simulator. It can either fail or -- return a result, which is most likely a 'ByteString'. data SimResult = SimResult !SynthTool !SimTool ![ByteString] !BResult !NominalDiffTime - deriving (Eq) + deriving (Eq) instance Show SimResult where - show (SimResult synth sim _ r d) = show synth <> ", " <> show sim <> ": " <> show (bimap show (T.unpack . showBS) r) <> " (" <> show d <> ")" + show (SimResult synth sim _ r d) = show synth <> ", " <> show sim <> ": " <> show (bimap show (T.unpack . showBS) r) <> " (" <> show d <> ")" getSimResult :: SimResult -> UResult getSimResult (SimResult _ _ _ (Pass _) _) = Pass () @@ -178,10 +182,10 @@ getSimResult (SimResult _ _ _ (Fail b) _) = Fail b -- formal equivalence checker. This will either return a failure or an output -- which is most likely '()'. data SynthResult = SynthResult !SynthTool !SynthTool !UResult !NominalDiffTime - deriving (Eq) + deriving (Eq) instance Show SynthResult where - show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" + show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" getSynthResult :: SynthResult -> UResult getSynthResult (SynthResult _ _ a _) = a @@ -190,127 +194,134 @@ getSynthResult (SynthResult _ _ a _) = a -- attempting to run the equivalence checks on the simulator, as that would be -- unnecessary otherwise. data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime - deriving (Eq) + deriving (Eq) getSynthStatus :: SynthStatus -> UResult getSynthStatus (SynthStatus _ a _) = a instance Show SynthStatus where - show (SynthStatus synth r d) = "synthesis " <> show synth <> ": " <> show r <> " (" <> show d <> ")" + show (SynthStatus synth r d) = "synthesis " <> show synth <> ": " <> show r <> " (" <> show d <> ")" -- | The complete state that will be used during fuzzing, which contains the -- results from all the operations. -data FuzzReport = FuzzReport { _fuzzDir :: !FilePath - , _synthResults :: ![SynthResult] -- ^ Results of the equivalence check. - , _simResults :: ![SimResult] -- ^ Results of the simulation. - , _synthStatus :: ![SynthStatus] -- ^ Results of the synthesis step. - , _fileLines :: {-# UNPACK #-} !Int - , _synthTime :: !NominalDiffTime - , _equivTime :: !NominalDiffTime - , _reducTime :: !NominalDiffTime - } - deriving (Eq, Show) +data FuzzReport + = FuzzReport + { _fuzzDir :: !FilePath, + -- | Results of the equivalence check. + _synthResults :: ![SynthResult], + -- | Results of the simulation. + _simResults :: ![SimResult], + -- | Results of the synthesis step. + _synthStatus :: ![SynthStatus], + _fileLines :: {-# UNPACK #-} !Int, + _synthTime :: !NominalDiffTime, + _equivTime :: !NominalDiffTime, + _reducTime :: !NominalDiffTime + } + deriving (Eq, Show) $(makeLenses ''FuzzReport) descriptionToSim :: SimDescription -> SimTool descriptionToSim (SimDescription "icarus") = defaultIcarusSim descriptionToSim s = - error $ "Could not find implementation for simulator '" <> show s <> "'" + error $ "Could not find implementation for simulator '" <> show s <> "'" -- | Convert a description to a synthesiser. descriptionToSynth :: SynthDescription -> SynthTool descriptionToSynth (SynthDescription "yosys" bin desc out) = - YosysSynth - . Yosys (fromText <$> bin) (fromMaybe (yosysDesc defaultYosys) desc) - $ maybe (yosysOutput defaultYosys) fromText out + YosysSynth + . Yosys (fromText <$> bin) (fromMaybe (yosysDesc defaultYosys) desc) + $ maybe (yosysOutput defaultYosys) fromText out descriptionToSynth (SynthDescription "vivado" bin desc out) = - VivadoSynth - . Vivado (fromText <$> bin) (fromMaybe (vivadoDesc defaultVivado) desc) - $ maybe (vivadoOutput defaultVivado) fromText out + VivadoSynth + . Vivado (fromText <$> bin) (fromMaybe (vivadoDesc defaultVivado) desc) + $ maybe (vivadoOutput defaultVivado) fromText out descriptionToSynth (SynthDescription "xst" bin desc out) = - XSTSynth - . XST (fromText <$> bin) (fromMaybe (xstDesc defaultXST) desc) - $ maybe (xstOutput defaultXST) fromText out + XSTSynth + . XST (fromText <$> bin) (fromMaybe (xstDesc defaultXST) desc) + $ maybe (xstOutput defaultXST) fromText out descriptionToSynth (SynthDescription "quartus" bin desc out) = - QuartusSynth - . Quartus (fromText <$> bin) - (fromMaybe (quartusDesc defaultQuartus) desc) - $ maybe (quartusOutput defaultQuartus) fromText out + QuartusSynth + . Quartus + (fromText <$> bin) + (fromMaybe (quartusDesc defaultQuartus) desc) + $ maybe (quartusOutput defaultQuartus) fromText out descriptionToSynth (SynthDescription "quartuslight" bin desc out) = - QuartusLightSynth - . QuartusLight (fromText <$> bin) - (fromMaybe (quartusDesc defaultQuartus) desc) - $ maybe (quartusOutput defaultQuartus) fromText out + QuartusLightSynth + . QuartusLight + (fromText <$> bin) + (fromMaybe (quartusDesc defaultQuartus) desc) + $ maybe (quartusOutput defaultQuartus) fromText out descriptionToSynth (SynthDescription "identity" _ desc out) = - IdentitySynth - . Identity (fromMaybe (identityDesc defaultIdentity) desc) - $ maybe (identityOutput defaultIdentity) fromText out + IdentitySynth + . Identity (fromMaybe (identityDesc defaultIdentity) desc) + $ maybe (identityOutput defaultIdentity) fromText out descriptionToSynth s = - error $ "Could not find implementation for synthesiser '" <> show s <> "'" + error $ "Could not find implementation for synthesiser '" <> show s <> "'" status :: Result Failed () -> Html -status (Pass _ ) = H.td ! A.class_ "is-success" $ "Passed" -status (Fail EmptyFail ) = H.td ! A.class_ "is-danger" $ "Failed" +status (Pass _) = H.td ! A.class_ "is-success" $ "Passed" +status (Fail EmptyFail) = H.td ! A.class_ "is-danger" $ "Failed" status (Fail (EquivFail _)) = H.td ! A.class_ "is-danger" $ "Equivalence failed" -status (Fail (SimFail _)) = H.td ! A.class_ "is-danger" $ "Simulation failed" -status (Fail SynthFail ) = H.td ! A.class_ "is-danger" $ "Synthesis failed" -status (Fail EquivError ) = H.td ! A.class_ "is-danger" $ "Equivalence error" -status (Fail TimeoutError) = H.td ! A.class_ "is-warning" $ "Time out" +status (Fail (SimFail _)) = H.td ! A.class_ "is-danger" $ "Simulation failed" +status (Fail SynthFail) = H.td ! A.class_ "is-danger" $ "Synthesis failed" +status (Fail EquivError) = H.td ! A.class_ "is-danger" $ "Equivalence error" +status (Fail TimeoutError) = H.td ! A.class_ "is-warning" $ "Time out" synthStatusHtml :: SynthStatus -> Html synthStatusHtml (SynthStatus synth res diff) = H.tr $ do - H.td . H.toHtml $ toText synth - status res - H.td . H.toHtml $ showT diff + H.td . H.toHtml $ toText synth + status res + H.td . H.toHtml $ showT diff synthResultHtml :: SynthResult -> Html synthResultHtml (SynthResult synth1 synth2 res diff) = H.tr $ do - H.td . H.toHtml $ toText synth1 - H.td . H.toHtml $ toText synth2 - status res - H.td . H.toHtml $ showT diff + H.td . H.toHtml $ toText synth1 + H.td . H.toHtml $ toText synth2 + status res + H.td . H.toHtml $ showT diff resultHead :: Text -> Html resultHead name = H.head $ do - H.title $ "Fuzz Report - " <> H.toHtml name - H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1" - H.meta ! A.charset "utf8" - H.link - ! A.rel "stylesheet" - ! A.href - "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.4/css/bulma.min.css" + H.title $ "Fuzz Report - " <> H.toHtml name + H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1" + H.meta ! A.charset "utf8" + H.link + ! A.rel "stylesheet" + ! A.href + "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.4/css/bulma.min.css" resultReport :: Text -> FuzzReport -> Html resultReport name (FuzzReport _ synth _ stat _ _ _ _) = H.docTypeHtml $ do - resultHead name - H.body - . (H.section ! A.class_ "section") - . (H.div ! A.class_ "container") - $ do - H.h1 ! A.class_ "title is-1" $ "Fuzz Report - " <> H.toHtml name - H.h2 ! A.class_ "title is-2" $ "Synthesis" - H.table ! A.class_ "table" $ do - H.thead - . H.toHtml - $ ( H.tr - . H.toHtml - $ [H.th "Tool", H.th "Status", H.th "Run time"] - ) - H.tbody . H.toHtml $ fmap synthStatusHtml stat - H.h2 ! A.class_ "title is-2" $ "Equivalence Check" - H.table ! A.class_ "table" $ do - H.thead - . H.toHtml - $ ( H.tr - . H.toHtml - $ [ H.th "First tool" - , H.th "Second tool" - , H.th "Status" - , H.th "Run time" - ] - ) - H.tbody . H.toHtml $ fmap synthResultHtml synth + resultHead name + H.body + . (H.section ! A.class_ "section") + . (H.div ! A.class_ "container") + $ do + H.h1 ! A.class_ "title is-1" $ "Fuzz Report - " <> H.toHtml name + H.h2 ! A.class_ "title is-2" $ "Synthesis" + H.table ! A.class_ "table" $ do + H.thead + . H.toHtml + $ ( H.tr + . H.toHtml + $ [H.th "Tool", H.th "Status", H.th "Run time"] + ) + H.tbody . H.toHtml $ fmap synthStatusHtml stat + H.h2 ! A.class_ "title is-2" $ "Equivalence Check" + H.table ! A.class_ "table" $ do + H.thead + . H.toHtml + $ ( H.tr + . H.toHtml + $ [ H.th "First tool", + H.th "Second tool", + H.th "Status", + H.th "Run time" + ] + ) + H.tbody . H.toHtml $ fmap synthResultHtml synth resultStatus :: Result a b -> Html resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" @@ -324,94 +335,99 @@ meanVariance l = (mean, variance) squ x = x * x len = fromIntegral $ length l -fuzzStats - :: (Real a1, Traversable t) - => ((a1 -> Const (Endo [a1]) a1) -> a2 -> Const (Endo [a1]) a2) - -> t a2 - -> (Double, Double) +fuzzStats :: + (Real a1, Traversable t) => + ((a1 -> Const (Endo [a1]) a1) -> a2 -> Const (Endo [a1]) a2) -> + t a2 -> + (Double, Double) fuzzStats sel fr = meanVariance converted - where converted = fmap realToFrac $ fr ^.. traverse . sel + where + converted = fmap realToFrac $ fr ^.. traverse . sel fuzzStatus :: Text -> FuzzReport -> Html fuzzStatus name (FuzzReport dir s1 s2 s3 sz t1 t2 t3) = H.tr $ do - H.td - . ( H.a + H.td + . ( H.a ! A.href - ( H.textValue - $ toTextIgnore (dir <.> "html") - ) - ) - $ H.toHtml name - resultStatus - $ mconcat (fmap getSynthResult s1) - <> mconcat (fmap getSimResult s2) - <> mconcat (fmap getSynthStatus s3) - H.td . H.string $ show sz - H.td . H.string $ show t1 - H.td . H.string $ show t2 - H.td . H.string $ show t3 + ( H.textValue $ + toTextIgnore (dir <.> "html") + ) + ) + $ H.toHtml name + resultStatus $ + mconcat (fmap getSynthResult s1) + <> mconcat (fmap getSimResult s2) + <> mconcat (fmap getSynthStatus s3) + H.td . H.string $ show sz + H.td . H.string $ show t1 + H.td . H.string $ show t2 + H.td . H.string $ show t3 summary :: Text -> [FuzzReport] -> Html summary name fuzz = H.docTypeHtml $ do - resultHead name - H.body - . (H.section ! A.class_ "section") - . (H.div ! A.class_ "container") - $ do - H.h1 ! A.class_ "title is-1" $ "FuzzReport - " <> H.toHtml name - H.table ! A.class_ "table" $ do - H.thead . H.tr $ H.toHtml - [ H.th "Name" - , H.th "Status" - , H.th "Size (loc)" - , H.th "Synthesis time" - , H.th "Equivalence check time" - , H.th "Reduction time" - ] - H.tbody - . H.toHtml - . fmap - (\(i, r) -> - fuzzStatus ("Fuzz " <> showT (i :: Int)) r - ) - $ zip [1 ..] fuzz - H.tfoot . H.toHtml $ do - H.tr $ H.toHtml - [ H.td $ H.strong "Total" - , H.td mempty - , H.td - . H.string - . show - . sum - $ fuzz - ^.. traverse - . fileLines - , sumUp synthTime - , sumUp equivTime - , sumUp reducTime - ] - H.tr $ H.toHtml - [ H.td $ H.strong "Mean" - , H.td mempty - , fst $ bimap d2I d2I $ fuzzStats fileLines fuzz - , fst $ meanVar synthTime - , fst $ meanVar equivTime - , fst $ meanVar reducTime - ] - H.tr $ H.toHtml - [ H.td $ H.strong "Variance" - , H.td mempty - , snd $ bimap d2I d2I $ fuzzStats fileLines fuzz - , snd $ meanVar synthTime - , snd $ meanVar equivTime - , snd $ meanVar reducTime - ] + resultHead name + H.body + . (H.section ! A.class_ "section") + . (H.div ! A.class_ "container") + $ do + H.h1 ! A.class_ "title is-1" $ "FuzzReport - " <> H.toHtml name + H.table ! A.class_ "table" $ do + H.thead . H.tr $ + H.toHtml + [ H.th "Name", + H.th "Status", + H.th "Size (loc)", + H.th "Synthesis time", + H.th "Equivalence check time", + H.th "Reduction time" + ] + H.tbody + . H.toHtml + . fmap + ( \(i, r) -> + fuzzStatus ("Fuzz " <> showT (i :: Int)) r + ) + $ zip [1 ..] fuzz + H.tfoot . H.toHtml $ do + H.tr $ + H.toHtml + [ H.td $ H.strong "Total", + H.td mempty, + H.td + . H.string + . show + . sum + $ fuzz + ^.. traverse + . fileLines, + sumUp synthTime, + sumUp equivTime, + sumUp reducTime + ] + H.tr $ + H.toHtml + [ H.td $ H.strong "Mean", + H.td mempty, + fst $ bimap d2I d2I $ fuzzStats fileLines fuzz, + fst $ meanVar synthTime, + fst $ meanVar equivTime, + fst $ meanVar reducTime + ] + H.tr $ + H.toHtml + [ H.td $ H.strong "Variance", + H.td mempty, + snd $ bimap d2I d2I $ fuzzStats fileLines fuzz, + snd $ meanVar synthTime, + snd $ meanVar equivTime, + snd $ meanVar reducTime + ] where sumUp s = showHtml . sum $ fuzz ^.. traverse . s meanVar s = bimap d2T d2T $ fuzzStats s fuzz showHtml = H.td . H.string . show - d2T = showHtml . (realToFrac :: Double -> NominalDiffTime) - d2I = H.td . H.string . show + d2T = showHtml . (realToFrac :: Double -> NominalDiffTime) + d2I = H.td . H.string . show printResultReport :: Text -> FuzzReport -> Text printResultReport t f = toStrict . renderHtml $ resultReport t f diff --git a/src/Verismith/Result.hs b/src/Verismith/Result.hs index 78c8dd6..dd32582 100644 --- a/src/Verismith/Result.hs +++ b/src/Verismith/Result.hs @@ -1,50 +1,55 @@ -{-| -Module : Verismith.Result -Description : Result monadic type. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Result monadic type. This is nearly equivalent to the transformers 'Error' type, -but to have more control this is reimplemented with the instances that are -needed in "Verismith". --} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Verismith.Result +-- Description : Result monadic type. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Result monadic type. This is nearly equivalent to the transformers 'Error' type, +-- but to have more control this is reimplemented with the instances that are +-- needed in "Verismith". module Verismith.Result - ( Result(..) - , ResultT(..) - , justPass - , justFail - , (<?>) - , annotate - ) + ( Result (..), + ResultT (..), + justPass, + justFail, + (<?>), + annotate, + ) where -import Control.Monad (liftM) -import Control.Monad.Base -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Control -import Data.Bifunctor (Bifunctor (..)) -import Shelly (RunFailed (..), Sh, catch_sh) -import Shelly.Lifted (MonadSh, MonadShControl, ShM, - liftSh, liftShWith, restoreSh) +import Control.Monad (liftM) +import Control.Monad.Base +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Data.Bifunctor (Bifunctor (..)) +import Shelly (RunFailed (..), Sh, catch_sh) +import Shelly.Lifted + ( MonadSh, + MonadShControl, + ShM, + liftSh, + liftShWith, + restoreSh, + ) -- | Result type which is equivalent to 'Either' or 'Error'. This is -- reimplemented so that there is full control over the 'Monad' definition and -- definition of a 'Monad' transformer 'ResultT'. -data Result a b = Fail a - | Pass b - deriving (Eq, Show) +data Result a b + = Fail a + | Pass b + deriving (Eq, Show) justPass :: Result a b -> Maybe b justPass (Fail _) = Nothing @@ -55,105 +60,107 @@ justFail (Pass _) = Nothing justFail (Fail a) = Just a instance Semigroup (Result a b) where - Pass _ <> a = a - a <> _ = a + Pass _ <> a = a + a <> _ = a instance (Monoid b) => Monoid (Result a b) where - mempty = Pass mempty + mempty = Pass mempty instance Functor (Result a) where - fmap f (Pass a) = Pass $ f a - fmap _ (Fail b) = Fail b + fmap f (Pass a) = Pass $ f a + fmap _ (Fail b) = Fail b instance Applicative (Result a) where - pure = Pass - Fail e <*> _ = Fail e - Pass f <*> r = fmap f r + pure = Pass + Fail e <*> _ = Fail e + Pass f <*> r = fmap f r instance Monad (Result a) where - Pass a >>= f = f a - Fail b >>= _ = Fail b + Pass a >>= f = f a + Fail b >>= _ = Fail b instance MonadBase (Result a) (Result a) where - liftBase = id + liftBase = id instance Bifunctor Result where - bimap a _ (Fail c) = Fail $ a c - bimap _ b (Pass c) = Pass $ b c + bimap a _ (Fail c) = Fail $ a c + bimap _ b (Pass c) = Pass $ b c -- | The transformer for the 'Result' type. This -newtype ResultT a m b = ResultT { runResultT :: m (Result a b) } +newtype ResultT a m b = ResultT {runResultT :: m (Result a b)} instance Functor f => Functor (ResultT a f) where - fmap f = ResultT . fmap (fmap f) . runResultT + fmap f = ResultT . fmap (fmap f) . runResultT instance Monad m => Applicative (ResultT a m) where - pure = ResultT . pure . pure - f <*> a = ResultT $ do - f' <- runResultT f - case f' of - Fail e -> return (Fail e) - Pass k -> do - a' <- runResultT a - case a' of - Fail e -> return (Fail e) - Pass v -> return (Pass $ k v) + pure = ResultT . pure . pure + f <*> a = ResultT $ do + f' <- runResultT f + case f' of + Fail e -> return (Fail e) + Pass k -> do + a' <- runResultT a + case a' of + Fail e -> return (Fail e) + Pass v -> return (Pass $ k v) instance Monad m => Monad (ResultT a m) where - a >>= b = ResultT $ do - m <- runResultT a - case m of - Fail e -> return (Fail e) - Pass p -> runResultT (b p) + a >>= b = ResultT $ do + m <- runResultT a + case m of + Fail e -> return (Fail e) + Pass p -> runResultT (b p) instance (MonadSh m, Monoid a) => MonadSh (ResultT a m) where - liftSh s = - ResultT - . liftSh - . catch_sh (Pass <$> s) - $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b)) + liftSh s = + ResultT + . liftSh + . catch_sh (Pass <$> s) + $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b)) instance MonadIO m => MonadIO (ResultT a m) where - liftIO s = ResultT $ Pass <$> liftIO s + liftIO s = ResultT $ Pass <$> liftIO s instance MonadBase b m => MonadBase b (ResultT a m) where - liftBase = liftBaseDefault + liftBase = liftBaseDefault instance MonadTrans (ResultT e) where - lift m = ResultT $ Pass <$> m + lift m = ResultT $ Pass <$> m instance MonadTransControl (ResultT a) where - type StT (ResultT a) b = Result a b - liftWith f = ResultT $ return <$> f runResultT - restoreT = ResultT - {-# INLINABLE liftWith #-} - {-# INLINABLE restoreT #-} + type StT (ResultT a) b = Result a b + liftWith f = ResultT $ return <$> f runResultT + restoreT = ResultT + {-# INLINEABLE liftWith #-} + {-# INLINEABLE restoreT #-} instance MonadBaseControl IO m => MonadBaseControl IO (ResultT a m) where - type StM (ResultT a m) b = ComposeSt (ResultT a) m b - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - {-# INLINABLE liftBaseWith #-} - {-# INLINABLE restoreM #-} - -instance (MonadShControl m) - => MonadShControl (ResultT a m) where - newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b)) - liftShWith f = - ResultT $ liftM return $ liftShWith $ \runInSh -> f $ \k -> - liftM ResultTShM $ runInSh $ runResultT k - restoreSh (ResultTShM m) = ResultT . restoreSh $ m - {-# INLINE liftShWith #-} - {-# INLINE restoreSh #-} + type StM (ResultT a m) b = ComposeSt (ResultT a) m b + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINEABLE liftBaseWith #-} + {-# INLINEABLE restoreM #-} + +instance + (MonadShControl m) => + MonadShControl (ResultT a m) + where + newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b)) + liftShWith f = + ResultT $ liftM return $ liftShWith $ \runInSh -> f $ \k -> + liftM ResultTShM $ runInSh $ runResultT k + restoreSh (ResultTShM m) = ResultT . restoreSh $ m + {-# INLINE liftShWith #-} + {-# INLINE restoreSh #-} infix 0 <?> (<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b m <?> b = ResultT $ do - a <- runResultT m - case a of - Pass a' -> return $ Pass a' - Fail a' -> return . Fail $ a' <> b + a <- runResultT m + case a of + Pass a' -> return $ Pass a' + Fail a' -> return . Fail $ a' <> b annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b annotate = flip (<?>) diff --git a/src/Verismith/Tool.hs b/src/Verismith/Tool.hs index a9a153d..b5a2712 100644 --- a/src/Verismith/Tool.hs +++ b/src/Verismith/Tool.hs @@ -1,55 +1,63 @@ -{-| -Module : Verismith.Tool -Description : Simulator implementations. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Simulator implementations. --} - +-- | +-- Module : Verismith.Tool +-- Description : Simulator implementations. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Simulator implementations. module Verismith.Tool - ( - -- * Simulators + ( -- * Simulators + -- ** Icarus - Icarus(..) - , defaultIcarus + Icarus (..), + defaultIcarus, + -- * Synthesisers + -- ** Yosys - , Yosys(..) - , defaultYosys + Yosys (..), + defaultYosys, + -- ** Vivado - , Vivado(..) - , defaultVivado + Vivado (..), + defaultVivado, + -- ** XST - , XST(..) - , defaultXST + XST (..), + defaultXST, + -- ** Quartus - , Quartus(..) - , defaultQuartus + Quartus (..), + defaultQuartus, + -- ** Quartus Light - , QuartusLight(..) - , defaultQuartusLight + QuartusLight (..), + defaultQuartusLight, + -- ** Identity - , Identity(..) - , defaultIdentity + Identity (..), + defaultIdentity, + -- * Equivalence - , runEquiv + runEquiv, + -- * Simulation - , runSim + runSim, + -- * Synthesis - , runSynth - , logger - ) + runSynth, + logger, + ) where -import Verismith.Tool.Icarus -import Verismith.Tool.Identity -import Verismith.Tool.Internal -import Verismith.Tool.Quartus -import Verismith.Tool.QuartusLight -import Verismith.Tool.Vivado -import Verismith.Tool.XST -import Verismith.Tool.Yosys +import Verismith.Tool.Icarus +import Verismith.Tool.Identity +import Verismith.Tool.Internal +import Verismith.Tool.Quartus +import Verismith.Tool.QuartusLight +import Verismith.Tool.Vivado +import Verismith.Tool.XST +import Verismith.Tool.Yosys diff --git a/src/Verismith/Tool/Icarus.hs b/src/Verismith/Tool/Icarus.hs index 4b91652..8504640 100644 --- a/src/Verismith/Tool/Icarus.hs +++ b/src/Verismith/Tool/Icarus.hs @@ -1,62 +1,62 @@ -{-| -Module : Verismith.Tool.Icarus -Description : Icarus verilog module. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Icarus verilog module. --} - +-- | +-- Module : Verismith.Tool.Icarus +-- Description : Icarus verilog module. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Icarus verilog module. module Verismith.Tool.Icarus - ( Icarus(..) - , defaultIcarus - , runSimIc - , runSimIcEC - ) + ( Icarus (..), + defaultIcarus, + runSimIc, + runSimIcEC, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Control.Lens -import Control.Monad (void) -import Crypto.Hash (Digest, hash) -import Crypto.Hash.Algorithms (SHA256) -import Data.Binary (encode) -import Data.Bits -import qualified Data.ByteArray as BA (convert) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (toStrict) -import qualified Data.ByteString.Lazy as L (ByteString) -import Data.Char (digitToInt) -import Data.Foldable (fold) -import Data.List (transpose) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Numeric (readInt) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Verismith.CounterEg (CounterEg (..)) -import Verismith.Result -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.BitVec -import Verismith.Verilog.CodeGen -import Verismith.Verilog.Internal -import Verismith.Verilog.Mutate - -data Icarus = Icarus { icarusPath :: FilePath - , vvpPath :: FilePath - } - deriving (Eq) +import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.Lens +import Control.Monad (void) +import Crypto.Hash (Digest, hash) +import Crypto.Hash.Algorithms (SHA256) +import Data.Binary (encode) +import Data.Bits +import qualified Data.ByteArray as BA (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Lazy as L (ByteString) +import Data.Char (digitToInt) +import Data.Foldable (fold) +import Data.List (transpose) +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Numeric (readInt) +import Shelly +import Shelly.Lifted (liftSh) +import Verismith.CounterEg (CounterEg (..)) +import Verismith.Result +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.BitVec +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Internal +import Verismith.Verilog.Mutate +import Prelude hiding (FilePath) + +data Icarus + = Icarus + { icarusPath :: FilePath, + vvpPath :: FilePath + } + deriving (Eq) instance Show Icarus where - show _ = "iverilog" + show _ = "iverilog" instance Tool Icarus where toText _ = "iverilog" @@ -66,36 +66,40 @@ instance Simulator Icarus where runSimWithFile = runSimIcarusWithFile instance NFData Icarus where - rnf = rwhnf + rnf = rwhnf defaultIcarus :: Icarus defaultIcarus = Icarus "iverilog" "vvp" addDisplay :: [Statement ann] -> [Statement ann] -addDisplay s = concat $ transpose - [ s - , replicate l $ TimeCtrl 1 Nothing - , replicate l . SysTaskEnable $ Task "display" ["%b", Id "y"] - ] - where l = length s +addDisplay s = + concat $ + transpose + [ s, + replicate l $ TimeCtrl 1 Nothing, + replicate l . SysTaskEnable $ Task "display" ["%b", Id "y"] + ] + where + l = length s assignFunc :: [Port] -> ByteString -> Statement ann assignFunc inp bs = - NonBlockAssign - . Assign conc Nothing - . Number - . BitVec (B.length bs * 8) - $ bsToI bs - where conc = RegConcat (portToExpr <$> inp) + NonBlockAssign + . Assign conc Nothing + . Number + . BitVec (B.length bs * 8) + $ bsToI bs + where + conc = RegConcat (portToExpr <$> inp) convert :: Text -> ByteString convert = - toStrict - . (encode :: Integer -> L.ByteString) - . maybe 0 fst - . listToMaybe - . readInt 2 (`elem` ("01" :: String)) digitToInt - . T.unpack + toStrict + . (encode :: Integer -> L.ByteString) + . maybe 0 fst + . listToMaybe + . readInt 2 (`elem` ("01" :: String)) digitToInt + . T.unpack mask :: Text -> Text mask = T.replace "x" "0" @@ -105,52 +109,69 @@ callback b t = b <> convert (mask t) runSimIcarus :: Show ann => Icarus -> (SourceInfo ann) -> [ByteString] -> ResultSh ByteString runSimIcarus sim rinfo bss = do - let tb = ModDecl - "main" - [] - [] - [ Initial - $ fold (addDisplay $ assignFunc (_modInPorts m) <$> bss) - <> (SysTaskEnable $ Task "finish" []) - ] - [] - let newtb = instantiateMod m tb - let modWithTb = Verilog [newtb, m] - liftSh . writefile "main.v" $ genSource modWithTb - annotate (SimFail mempty) $ runSimWithFile sim "main.v" bss - where m = rinfo ^. mainModule - -runSimIcarusWithFile - :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString + let tb = + ModDecl + "main" + [] + [] + [ Initial $ + fold (addDisplay $ assignFunc (_modInPorts m) <$> bss) + <> (SysTaskEnable $ Task "finish" []) + ] + [] + let newtb = instantiateMod m tb + let modWithTb = Verilog [newtb, m] + liftSh . writefile "main.v" $ genSource modWithTb + annotate (SimFail mempty) $ runSimWithFile sim "main.v" bss + where + m = rinfo ^. mainModule + +runSimIcarusWithFile :: + Icarus -> FilePath -> [ByteString] -> ResultSh ByteString runSimIcarusWithFile sim f _ = annotate (SimFail mempty) . liftSh $ do - dir <- pwd - logCommand_ dir "icarus" - $ run (icarusPath sim) ["-o", "main", toTextIgnore f] - B.take 8 . BA.convert . (hash :: ByteString -> Digest SHA256) <$> logCommand - dir - "vvp" - (runFoldLines (mempty :: ByteString) callback (vvpPath sim) ["main"]) + dir <- pwd + logCommand_ dir "icarus" $ + run (icarusPath sim) ["-o", "main", toTextIgnore f] + B.take 8 . BA.convert . (hash :: ByteString -> Digest SHA256) + <$> logCommand + dir + "vvp" + (runFoldLines (mempty :: ByteString) callback (vvpPath sim) ["main"]) fromBytes :: ByteString -> Integer fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b tbModule :: [ByteString] -> (ModDecl ann) -> (Verilog ann) tbModule bss top = - Verilog [ instantiateMod top $ ModDecl "testbench" [] [] - [ Initial - $ fold [ BlockAssign (Assign "clk" Nothing 0) - , BlockAssign (Assign inConcat Nothing 0) - ] - <> fold ((\r -> TimeCtrl 10 - (Just $ BlockAssign (Assign inConcat Nothing r))) - . fromInteger . fromBytes <$> bss) - <> (TimeCtrl 10 . Just . SysTaskEnable $ Task "finish" []) - , Always . TimeCtrl 5 . Just $ BlockAssign - (Assign "clk" Nothing (UnOp UnNot (Id "clk"))) - , Always . EventCtrl (EPosEdge "clk") . Just . SysTaskEnable - $ Task "strobe" ["%b", Id "y"] - ] [] - ] + Verilog + [ instantiateMod top $ + ModDecl + "testbench" + [] + [] + [ Initial $ + fold + [ BlockAssign (Assign "clk" Nothing 0), + BlockAssign (Assign inConcat Nothing 0) + ] + <> fold + ( ( \r -> + TimeCtrl + 10 + (Just $ BlockAssign (Assign inConcat Nothing r)) + ) + . fromInteger + . fromBytes <$> bss + ) + <> (TimeCtrl 10 . Just . SysTaskEnable $ Task "finish" []), + Always . TimeCtrl 5 . Just $ + BlockAssign + (Assign "clk" Nothing (UnOp UnNot (Id "clk"))), + Always . EventCtrl (EPosEdge "clk") . Just . SysTaskEnable $ + Task "strobe" ["%b", Id "y"] + ] + [] + ] where inConcat = (RegConcat . filter (/= (Id "clk")) $ (Id . fromPort <$> (top ^. modInPorts))) @@ -159,54 +180,73 @@ counterTestBench (CounterEg _ states) m = tbModule filtered m where filtered = convert . fold . fmap snd . filter ((/= "clk") . fst) <$> states -runSimIc' :: (Synthesiser b, Show ann) - => ([ByteString] -> (ModDecl ann) -> (Verilog ann)) - -> FilePath - -> Icarus - -> b - -> (SourceInfo ann) - -> [ByteString] - -> Maybe ByteString - -> ResultSh ByteString +runSimIc' :: + (Synthesiser b, Show ann) => + ([ByteString] -> (ModDecl ann) -> (Verilog ann)) -> + FilePath -> + Icarus -> + b -> + (SourceInfo ann) -> + [ByteString] -> + Maybe ByteString -> + ResultSh ByteString runSimIc' fun datadir sim1 synth1 srcInfo bss bs = do - dir <- liftSh pwd - let top = srcInfo ^. mainModule - let tb = fun bss top - liftSh . writefile tbname $ icarusTestbench datadir tb synth1 - liftSh $ exe dir "icarus" "iverilog" ["-o", exename, toTextIgnore tbname] - s <- liftSh - $ B.take 8 - . BA.convert - . (hash :: ByteString -> Digest SHA256) + dir <- liftSh pwd + let top = srcInfo ^. mainModule + let tb = fun bss top + liftSh . writefile tbname $ icarusTestbench datadir tb synth1 + liftSh $ exe dir "icarus" "iverilog" ["-o", exename, toTextIgnore tbname] + s <- + liftSh $ + B.take 8 + . BA.convert + . (hash :: ByteString -> Digest SHA256) <$> logCommand - dir - "vvp" - (runFoldLines (mempty :: ByteString) - callback - (vvpPath sim1) - [exename]) - case (bs, s) of - (Nothing, s') -> ResultT . return $ Pass s' - (Just bs', s') -> if bs' == s' - then ResultT . return $ Pass s' - else ResultT . return $ Fail (SimFail s') + dir + "vvp" + ( runFoldLines + (mempty :: ByteString) + callback + (vvpPath sim1) + [exename] + ) + case (bs, s) of + (Nothing, s') -> ResultT . return $ Pass s' + (Just bs', s') -> + if bs' == s' + then ResultT . return $ Pass s' + else ResultT . return $ Fail (SimFail s') where exe dir name e = void . errExit False . logCommand dir name . timeout e tbname = fromText $ toText synth1 <> "_testbench.v" exename = toText synth1 <> "_main" -runSimIc :: (Synthesiser b, Show ann) - => FilePath -- ^ Data directory. - -> Icarus -- ^ Icarus simulator. - -> b -- ^ Synthesis tool to be tested. - -> (SourceInfo ann) -- ^ Original generated program to test. - -> [ByteString] -- ^ Test vectors to be passed as inputs to the generated Verilog. - -> Maybe ByteString -- ^ What the correct output should be. If - -- 'Nothing' is passed, then just return 'Pass - -- ByteString' with the answer. - -> ResultSh ByteString +runSimIc :: + (Synthesiser b, Show ann) => + -- | Data directory. + FilePath -> + -- | Icarus simulator. + Icarus -> + -- | Synthesis tool to be tested. + b -> + -- | Original generated program to test. + (SourceInfo ann) -> + -- | Test vectors to be passed as inputs to the generated Verilog. + [ByteString] -> + -- | What the correct output should be. If + -- 'Nothing' is passed, then just return 'Pass + -- ByteString' with the answer. + Maybe ByteString -> + ResultSh ByteString runSimIc = runSimIc' tbModule -runSimIcEC :: (Synthesiser b, Show ann) => FilePath -> Icarus -> b - -> (SourceInfo ann) -> CounterEg -> Maybe ByteString -> ResultSh ByteString +runSimIcEC :: + (Synthesiser b, Show ann) => + FilePath -> + Icarus -> + b -> + (SourceInfo ann) -> + CounterEg -> + Maybe ByteString -> + ResultSh ByteString runSimIcEC a b c d e = runSimIc' (const $ counterTestBench e) a b c d [] diff --git a/src/Verismith/Tool/Identity.hs b/src/Verismith/Tool/Identity.hs index 804f096..f8b9026 100644 --- a/src/Verismith/Tool/Identity.hs +++ b/src/Verismith/Tool/Identity.hs @@ -1,48 +1,48 @@ -{-| -Module : Verismith.Tool.Identity -Description : The identity simulator and synthesiser. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -The identity simulator and synthesiser. --} - +-- | +-- Module : Verismith.Tool.Identity +-- Description : The identity simulator and synthesiser. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- The identity simulator and synthesiser. module Verismith.Tool.Identity - ( Identity(..) - , defaultIdentity - ) + ( Identity (..), + defaultIdentity, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly (FilePath) -import Shelly.Lifted (writefile) -import Verismith.Tool.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -data Identity = Identity { identityDesc :: !Text - , identityOutput :: !FilePath - } - deriving (Eq) +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Shelly (FilePath) +import Shelly.Lifted (writefile) +import Verismith.Tool.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) + +data Identity + = Identity + { identityDesc :: !Text, + identityOutput :: !FilePath + } + deriving (Eq) instance Tool Identity where - toText (Identity d _) = d + toText (Identity d _) = d instance Show Identity where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser Identity where - runSynth = runSynthIdentity - synthOutput = identityOutput - setSynthOutput (Identity a _) = Identity a + runSynth = runSynthIdentity + synthOutput = identityOutput + setSynthOutput (Identity a _) = Identity a instance NFData Identity where - rnf = rwhnf + rnf = rwhnf runSynthIdentity :: Show ann => Identity -> (SourceInfo ann) -> ResultSh () runSynthIdentity (Identity _ out) = writefile out . genSource diff --git a/src/Verismith/Tool/Internal.hs b/src/Verismith/Tool/Internal.hs index f462c74..ab2892e 100644 --- a/src/Verismith/Tool/Internal.hs +++ b/src/Verismith/Tool/Internal.hs @@ -1,63 +1,61 @@ -{-| -Module : Verismith.Tool.Internal -Description : Class of the simulator. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Class of the simulator and the synthesize tool. --} - {-# LANGUAGE DeriveFunctor #-} +-- | +-- Module : Verismith.Tool.Internal +-- Description : Class of the simulator. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Class of the simulator and the synthesize tool. module Verismith.Tool.Internal - ( ResultSh - , resultSh - , Tool(..) - , Simulator(..) - , Synthesiser(..) - , Failed(..) - , renameSource - , checkPresent - , checkPresentModules - , replace - , replaceMods - , rootPath - , timeout - , timeout_ - , bsToI - , noPrint - , logger - , logCommand - , logCommand_ - , execute - , execute_ - , (<?>) - , annotate - ) + ( ResultSh, + resultSh, + Tool (..), + Simulator (..), + Synthesiser (..), + Failed (..), + renameSource, + checkPresent, + checkPresentModules, + replace, + replaceMods, + rootPath, + timeout, + timeout_, + bsToI, + noPrint, + logger, + logCommand, + logCommand_, + execute, + execute_, + (<?>), + annotate, + ) where -import Control.Lens -import Control.Monad (forM, void) -import Control.Monad.Catch (throwM) -import Data.Bits (shiftL) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Maybe (catMaybes) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Format (defaultTimeLocale, formatTime) -import Data.Time.LocalTime (getZonedTime) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (MonadSh, liftSh) -import System.FilePath.Posix (takeBaseName) -import Verismith.CounterEg (CounterEg) -import Verismith.Internal -import Verismith.Result -import Verismith.Verilog.AST +import Control.Lens +import Control.Monad (forM, void) +import Control.Monad.Catch (throwM) +import Data.Bits (shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (getZonedTime) +import Shelly +import Shelly.Lifted (MonadSh, liftSh) +import System.FilePath.Posix (takeBaseName) +import Verismith.CounterEg (CounterEg) +import Verismith.Internal +import Verismith.Result +import Verismith.Verilog.AST +import Prelude hiding (FilePath) -- | Tool class. class Tool a where @@ -65,51 +63,62 @@ class Tool a where -- | Simulation type class. class Tool a => Simulator a where - runSim :: Show ann - => a -- ^ Simulator instance - -> SourceInfo ann -- ^ Run information - -> [ByteString] -- ^ Inputs to simulate - -> ResultSh ByteString -- ^ Returns the value of the hash at the output of the testbench. - runSimWithFile :: a - -> FilePath - -> [ByteString] - -> ResultSh ByteString - -data Failed = EmptyFail - | EquivFail (Maybe CounterEg) - | EquivError - | SimFail ByteString - | SynthFail - | TimeoutError - deriving (Eq) + runSim :: + Show ann => + -- | Simulator instance + a -> + -- | Run information + SourceInfo ann -> + -- | Inputs to simulate + [ByteString] -> + -- | Returns the value of the hash at the output of the testbench. + ResultSh ByteString + runSimWithFile :: + a -> + FilePath -> + [ByteString] -> + ResultSh ByteString + +data Failed + = EmptyFail + | EquivFail (Maybe CounterEg) + | EquivError + | SimFail ByteString + | SynthFail + | TimeoutError + deriving (Eq) instance Show Failed where - show EmptyFail = "EmptyFail" - show (EquivFail _) = "EquivFail" - show EquivError = "EquivError" - show (SimFail bs) = "SimFail " <> T.unpack (T.take 10 $ showBS bs) - show SynthFail = "SynthFail" - show TimeoutError = "TimeoutError" + show EmptyFail = "EmptyFail" + show (EquivFail _) = "EquivFail" + show EquivError = "EquivError" + show (SimFail bs) = "SimFail " <> T.unpack (T.take 10 $ showBS bs) + show SynthFail = "SynthFail" + show TimeoutError = "TimeoutError" instance Semigroup Failed where - EmptyFail <> a = a - b <> _ = b + EmptyFail <> a = a + b <> _ = b instance Monoid Failed where - mempty = EmptyFail + mempty = EmptyFail -- | Synthesiser type class. class Tool a => Synthesiser a where - runSynth :: Show ann - => a -- ^ Synthesiser tool instance - -> SourceInfo ann -- ^ Run information - -> ResultSh () -- ^ does not return any values - synthOutput :: a -> FilePath - setSynthOutput :: a -> FilePath -> a + runSynth :: + Show ann => + -- | Synthesiser tool instance + a -> + -- | Run information + SourceInfo ann -> + -- | does not return any values + ResultSh () + synthOutput :: a -> FilePath + setSynthOutput :: a -> FilePath -> a renameSource :: (Synthesiser a) => a -> SourceInfo ann -> SourceInfo ann renameSource a src = - src & infoSrc . _Wrapped . traverse . modId . _Wrapped %~ (<> toText a) + src & infoSrc . _Wrapped . traverse . modId . _Wrapped %~ (<> toText a) -- | Type synonym for a 'ResultT' that will be used throughout 'Verismith'. This -- has instances for 'MonadSh' and 'MonadIO' if the 'Monad' it is parametrised @@ -118,31 +127,33 @@ type ResultSh = ResultT Failed Sh resultSh :: ResultSh a -> Sh a resultSh s = do - result <- runResultT s - case result of - Fail e -> throwM . RunFailed "" [] 1 $ showT e - Pass s' -> return s' + result <- runResultT s + case result of + Fail e -> throwM . RunFailed "" [] 1 $ showT e + Pass s' -> return s' checkPresent :: FilePath -> Text -> Sh (Maybe Text) checkPresent fp t = do - errExit False $ run_ "grep" [t, toTextIgnore fp] - i <- lastExitCode - if i == 0 then return $ Just t else return Nothing + errExit False $ run_ "grep" [t, toTextIgnore fp] + i <- lastExitCode + if i == 0 then return $ Just t else return Nothing -- | Checks what modules are present in the synthesised output, as some modules -- may have been inlined. This could be improved if the parser worked properly. checkPresentModules :: FilePath -> SourceInfo ann -> Sh [Text] checkPresentModules fp (SourceInfo _ src) = do - vals <- forM (src ^.. _Wrapped . traverse . modId . _Wrapped) - $ checkPresent fp - return $ catMaybes vals + vals <- + forM (src ^.. _Wrapped . traverse . modId . _Wrapped) $ + checkPresent fp + return $ catMaybes vals -- | Uses sed to replace a string in a text file. replace :: FilePath -> Text -> Text -> Sh () replace fp t1 t2 = do - errExit False . noPrint $ run_ - "sed" - ["-i", "s/" <> t1 <> "/" <> t2 <> "/g", toTextIgnore fp] + errExit False . noPrint $ + run_ + "sed" + ["-i", "s/" <> t1 <> "/" <> t2 <> "/g", toTextIgnore fp] -- | This is used because rename only renames the definitions of modules of -- course, so instead this just searches and replaces all the module names. This @@ -150,14 +161,14 @@ replace fp t1 t2 = do -- much simpler if the parser works. replaceMods :: FilePath -> Text -> SourceInfo ann -> Sh () replaceMods fp t (SourceInfo _ src) = - void - . forM (src ^.. _Wrapped . traverse . modId . _Wrapped) - $ (\a -> replace fp a (a <> t)) + void + . forM (src ^.. _Wrapped . traverse . modId . _Wrapped) + $ (\a -> replace fp a (a <> t)) rootPath :: Sh FilePath rootPath = do - current <- pwd - maybe current fromText <$> get_env "VERISMITH_ROOT" + current <- pwd + maybe current fromText <$> get_env "VERISMITH_ROOT" timeout :: FilePath -> [Text] -> Sh Text timeout = command1 "timeout" ["300"] . toTextIgnore @@ -178,18 +189,20 @@ noPrint = print_stdout False . print_stderr False logger :: Text -> Sh () logger t = do - fn <- pwd - currentTime <- liftIO getZonedTime - echo - $ "Verismith " - <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime) - <> bname fn - <> " - " - <> t - where bname = T.pack . takeBaseName . T.unpack . toTextIgnore + fn <- pwd + currentTime <- liftIO getZonedTime + echo $ + "Verismith " + <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime) + <> bname fn + <> " - " + <> t + where + bname = T.pack . takeBaseName . T.unpack . toTextIgnore logCommand :: FilePath -> Text -> Sh a -> Sh a -logCommand fp name = log_stderr_with (l "_stderr.log") +logCommand fp name = + log_stderr_with (l "_stderr.log") . log_stdout_with (l ".log") where l s t = appendFile (file s) (T.unpack t) >> appendFile (file s) "\n" @@ -198,29 +211,29 @@ logCommand fp name = log_stderr_with (l "_stderr.log") logCommand_ :: FilePath -> Text -> Sh a -> Sh () logCommand_ fp name = void . logCommand fp name -execute - :: (MonadSh m, Monad m) - => Failed - -> FilePath - -> Text - -> FilePath - -> [Text] - -> ResultT Failed m Text +execute :: + (MonadSh m, Monad m) => + Failed -> + FilePath -> + Text -> + FilePath -> + [Text] -> + ResultT Failed m Text execute f dir name e cs = do - (res, exitCode) <- liftSh $ do - res <- errExit False . logCommand dir name $ timeout e cs - (,) res <$> lastExitCode - case exitCode of - 0 -> ResultT . return $ Pass res - 124 -> ResultT . return $ Fail TimeoutError - _ -> ResultT . return $ Fail f - -execute_ - :: (MonadSh m, Monad m) - => Failed - -> FilePath - -> Text - -> FilePath - -> [Text] - -> ResultT Failed m () + (res, exitCode) <- liftSh $ do + res <- errExit False . logCommand dir name $ timeout e cs + (,) res <$> lastExitCode + case exitCode of + 0 -> ResultT . return $ Pass res + 124 -> ResultT . return $ Fail TimeoutError + _ -> ResultT . return $ Fail f + +execute_ :: + (MonadSh m, Monad m) => + Failed -> + FilePath -> + Text -> + FilePath -> + [Text] -> + ResultT Failed m () execute_ a b c d = void . execute a b c d diff --git a/src/Verismith/Tool/Quartus.hs b/src/Verismith/Tool/Quartus.hs index ff8a62b..70908eb 100644 --- a/src/Verismith/Tool/Quartus.hs +++ b/src/Verismith/Tool/Quartus.hs @@ -1,76 +1,79 @@ -{-| -Module : Verismith.Tool.Quartus -Description : Quartus synthesiser implementation. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Quartus synthesiser implementation. --} - +-- | +-- Module : Verismith.Tool.Quartus +-- Description : Quartus synthesiser implementation. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Quartus synthesiser implementation. module Verismith.Tool.Quartus - ( Quartus(..) - , defaultQuartus - ) + ( Quartus (..), + defaultQuartus, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Shelly +import Shelly.Lifted (liftSh) +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) -data Quartus = Quartus { quartusBin :: !(Maybe FilePath) - , quartusDesc :: !Text - , quartusOutput :: !FilePath - } - deriving (Eq) +data Quartus + = Quartus + { quartusBin :: !(Maybe FilePath), + quartusDesc :: !Text, + quartusOutput :: !FilePath + } + deriving (Eq) instance Tool Quartus where - toText (Quartus _ t _) = t + toText (Quartus _ t _) = t instance Show Quartus where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser Quartus where - runSynth = runSynthQuartus - synthOutput = quartusOutput - setSynthOutput (Quartus a b _) = Quartus a b + runSynth = runSynthQuartus + synthOutput = quartusOutput + setSynthOutput (Quartus a b _) = Quartus a b instance NFData Quartus where - rnf = rwhnf + rnf = rwhnf defaultQuartus :: Quartus defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" runSynthQuartus :: Show ann => Quartus -> (SourceInfo ann) -> ResultSh () runSynthQuartus sim (SourceInfo top src) = do - dir <- liftSh pwd - let ex = execute_ SynthFail dir "quartus" - liftSh $ do - writefile inpf $ genSource src - noPrint $ run_ "sed" [ "-i" - , "s/^module/(* multstyle = \"logic\" *) module/;" - , toTextIgnore inpf - ] - writefile quartusSdc $ "create_clock -period 5 -name clk [get_ports clock]" - writefile quartusTcl $ quartusSynthConfig sim quartusSdc top inpf - ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl] - liftSh $ do - cp (fromText "simulation/vcs" </> fromText top <.> "vo") - $ synthOutput sim - run_ - "sed" - [ "-ri" - , "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;" - , toTextIgnore $ synthOutput sim - ] + dir <- liftSh pwd + let ex = execute_ SynthFail dir "quartus" + liftSh $ do + writefile inpf $ genSource src + noPrint $ + run_ + "sed" + [ "-i", + "s/^module/(* multstyle = \"logic\" *) module/;", + toTextIgnore inpf + ] + writefile quartusSdc $ "create_clock -period 5 -name clk [get_ports clock]" + writefile quartusTcl $ quartusSynthConfig sim quartusSdc top inpf + ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl] + liftSh $ do + cp (fromText "simulation/vcs" </> fromText top <.> "vo") $ + synthOutput sim + run_ + "sed" + [ "-ri", + "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;", + toTextIgnore $ synthOutput sim + ] where inpf = "rtl.v" exec s = maybe (fromText s) (</> fromText s) $ quartusBin sim diff --git a/src/Verismith/Tool/QuartusLight.hs b/src/Verismith/Tool/QuartusLight.hs index cdf2636..cab1087 100644 --- a/src/Verismith/Tool/QuartusLight.hs +++ b/src/Verismith/Tool/QuartusLight.hs @@ -1,76 +1,79 @@ -{-| -Module : Verismith.Tool.QuartusLight -Description : QuartusLight synthesiser implementation. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -QuartusLight synthesiser implementation. --} - +-- | +-- Module : Verismith.Tool.QuartusLight +-- Description : QuartusLight synthesiser implementation. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- QuartusLight synthesiser implementation. module Verismith.Tool.QuartusLight - ( QuartusLight(..) - , defaultQuartusLight - ) + ( QuartusLight (..), + defaultQuartusLight, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Shelly +import Shelly.Lifted (liftSh) +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) -data QuartusLight = QuartusLight { quartusLightBin :: !(Maybe FilePath) - , quartusLightDesc :: !Text - , quartusLightOutput :: !FilePath - } - deriving (Eq) +data QuartusLight + = QuartusLight + { quartusLightBin :: !(Maybe FilePath), + quartusLightDesc :: !Text, + quartusLightOutput :: !FilePath + } + deriving (Eq) instance Tool QuartusLight where - toText (QuartusLight _ t _) = t + toText (QuartusLight _ t _) = t instance Show QuartusLight where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser QuartusLight where - runSynth = runSynthQuartusLight - synthOutput = quartusLightOutput - setSynthOutput (QuartusLight a b _) = QuartusLight a b + runSynth = runSynthQuartusLight + synthOutput = quartusLightOutput + setSynthOutput (QuartusLight a b _) = QuartusLight a b instance NFData QuartusLight where - rnf = rwhnf + rnf = rwhnf defaultQuartusLight :: QuartusLight defaultQuartusLight = QuartusLight Nothing "quartus" "syn_quartus.v" runSynthQuartusLight :: Show ann => QuartusLight -> (SourceInfo ann) -> ResultSh () runSynthQuartusLight sim (SourceInfo top src) = do - dir <- liftSh pwd - let ex = execute_ SynthFail dir "quartus" - liftSh $ do - writefile inpf $ genSource src - noPrint $ run_ "sed" [ "-i" - , "s/^module/(* multstyle = \"logic\" *) module/;" - , toTextIgnore inpf - ] - writefile quartusSdc "create_clock -period 5 -name clk [get_ports clock]" - writefile quartusTcl $ quartusLightSynthConfig sim quartusSdc top inpf - ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl] - liftSh $ do - cp (fromText "simulation/vcs" </> fromText top <.> "vo") - $ synthOutput sim - run_ - "sed" - [ "-ri" - , "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;" - , toTextIgnore $ synthOutput sim - ] + dir <- liftSh pwd + let ex = execute_ SynthFail dir "quartus" + liftSh $ do + writefile inpf $ genSource src + noPrint $ + run_ + "sed" + [ "-i", + "s/^module/(* multstyle = \"logic\" *) module/;", + toTextIgnore inpf + ] + writefile quartusSdc "create_clock -period 5 -name clk [get_ports clock]" + writefile quartusTcl $ quartusLightSynthConfig sim quartusSdc top inpf + ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl] + liftSh $ do + cp (fromText "simulation/vcs" </> fromText top <.> "vo") $ + synthOutput sim + run_ + "sed" + [ "-ri", + "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;", + toTextIgnore $ synthOutput sim + ] where inpf = "rtl.v" exec s = maybe (fromText s) (</> fromText s) $ quartusLightBin sim diff --git a/src/Verismith/Tool/Template.hs b/src/Verismith/Tool/Template.hs index 5a20ff5..d141d46 100644 --- a/src/Verismith/Tool/Template.hs +++ b/src/Verismith/Tool/Template.hs @@ -1,47 +1,45 @@ -{-| -Module : Verismith.Tool.Template -Description : Template file for different configuration files -Copyright : (c) 2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Template file for different configuration files. --} - {-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Verismith.Tool.Template +-- Description : Template file for different configuration files +-- Copyright : (c) 2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Template file for different configuration files. module Verismith.Tool.Template - ( yosysSynthConfigStd - , yosysSatConfig - , yosysSimConfig - , quartusLightSynthConfig - , quartusSynthConfig - , xstSynthConfig - , vivadoSynthConfig - , sbyConfig - , icarusTestbench - ) + ( yosysSynthConfigStd, + yosysSatConfig, + yosysSimConfig, + quartusLightSynthConfig, + quartusSynthConfig, + xstSynthConfig, + vivadoSynthConfig, + sbyConfig, + icarusTestbench, + ) where -import Control.Lens ((^..)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (FilePath) -import Shelly -import Verismith.Tool.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.Lens ((^..)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Shelly +import Verismith.Tool.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) rename :: Text -> [Text] -> Text rename end entries = - T.intercalate "\n" - $ flip mappend end - . mappend "rename " - . doubleName - <$> entries + T.intercalate "\n" $ + flip mappend end + . mappend "rename " + . doubleName + <$> entries {-# INLINE rename #-} doubleName :: Text -> Text @@ -52,26 +50,28 @@ outputText :: Synthesiser a => a -> Text outputText = toTextIgnore . synthOutput yosysSynthConfig :: Synthesiser a => Text -> a -> FilePath -> Text -yosysSynthConfig t a fp = T.unlines - [ "read_verilog " <> toTextIgnore fp - , t - , "write_verilog " <> outputText a - ] +yosysSynthConfig t a fp = + T.unlines + [ "read_verilog " <> toTextIgnore fp, + t, + "write_verilog " <> outputText a + ] yosysSynthConfigStd :: Synthesiser a => a -> FilePath -> Text yosysSynthConfigStd = yosysSynthConfig "synth" yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> (SourceInfo ann) -> Text -yosysSatConfig sim1 sim2 (SourceInfo top src) = T.unlines - [ "read_verilog " <> outputText sim1 - , rename "_1" mis - , "read_verilog syn_" <> outputText sim2 <> ".v" - , rename "_2" mis - , "read_verilog " <> top <> ".v" - , "proc; opt_clean" - , "flatten " <> top - , "sat -timeout 20 -show-all -verify-no-timeout -ignore_div_by_zero -prove y_1 y_2 " <> top - ] +yosysSatConfig sim1 sim2 (SourceInfo top src) = + T.unlines + [ "read_verilog " <> outputText sim1, + rename "_1" mis, + "read_verilog syn_" <> outputText sim2 <> ".v", + rename "_2" mis, + "read_verilog " <> top <> ".v", + "proc; opt_clean", + "flatten " <> top, + "sat -timeout 20 -show-all -verify-no-timeout -ignore_div_by_zero -prove y_1 y_2 " <> top + ] where mis = src ^.. getSourceId @@ -79,109 +79,115 @@ yosysSimConfig :: Text yosysSimConfig = "read_verilog rtl.v; proc;;\nrename mod mod_rtl" quartusLightSynthConfig :: Synthesiser a => a -> FilePath -> Text -> FilePath -> Text -quartusLightSynthConfig q sdc top fp = T.unlines - [ "load_package flow" - , "" - , "project_new -overwrite " <> top - , "" - , "set_global_assignment -name FAMILY \"Cyclone V\"" - , "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp - , "set_global_assignment -name TOP_LEVEL_ENTITY " <> top - , "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc - , "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"" - , "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2" - , "set_instance_assignment -name VIRTUAL_PIN ON -to *" - , "" - , "execute_module -tool map" - , "execute_module -tool fit" - , "execute_module -tool sta -args \"--mode=implement\"" - , "execute_module -tool eda -args \"--simulation --tool=vcs\"" - , "" - , "project_close" - ] +quartusLightSynthConfig q sdc top fp = + T.unlines + [ "load_package flow", + "", + "project_new -overwrite " <> top, + "", + "set_global_assignment -name FAMILY \"Cyclone V\"", + "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp, + "set_global_assignment -name TOP_LEVEL_ENTITY " <> top, + "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc, + "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"", + "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2", + "set_instance_assignment -name VIRTUAL_PIN ON -to *", + "", + "execute_module -tool map", + "execute_module -tool fit", + "execute_module -tool sta -args \"--mode=implement\"", + "execute_module -tool eda -args \"--simulation --tool=vcs\"", + "", + "project_close" + ] quartusSynthConfig :: Synthesiser a => a -> FilePath -> Text -> FilePath -> Text -quartusSynthConfig q sdc top fp = T.unlines - [ "load_package flow" - , "" - , "project_new -overwrite " <> top - , "" - , "set_global_assignment -name FAMILY \"Cyclone 10 GX\"" - , "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp - , "set_global_assignment -name TOP_LEVEL_ENTITY " <> top - , "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc - , "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"" - , "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2" - , "set_instance_assignment -name VIRTUAL_PIN ON -to *" - , "" - , "execute_module -tool syn" - , "execute_module -tool eda -args \"--simulation --tool=vcs\"" - , "" - , "project_close" - ] +quartusSynthConfig q sdc top fp = + T.unlines + [ "load_package flow", + "", + "project_new -overwrite " <> top, + "", + "set_global_assignment -name FAMILY \"Cyclone 10 GX\"", + "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp, + "set_global_assignment -name TOP_LEVEL_ENTITY " <> top, + "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc, + "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"", + "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2", + "set_instance_assignment -name VIRTUAL_PIN ON -to *", + "", + "execute_module -tool syn", + "execute_module -tool eda -args \"--simulation --tool=vcs\"", + "", + "project_close" + ] xstSynthConfig :: Text -> Text -xstSynthConfig top = T.unlines - [ "run" - , "-ifn " <> top <> ".prj -ofn " <> top <> " -p artix7 -top " <> top - , "-iobuf NO -ram_extract NO -rom_extract NO -use_dsp48 NO" - , "-fsm_extract YES -fsm_encoding Auto" - , "-change_error_to_warning \"HDLCompiler:226 HDLCompiler:1832\"" - ] +xstSynthConfig top = + T.unlines + [ "run", + "-ifn " <> top <> ".prj -ofn " <> top <> " -p artix7 -top " <> top, + "-iobuf NO -ram_extract NO -rom_extract NO -use_dsp48 NO", + "-fsm_extract YES -fsm_encoding Auto", + "-change_error_to_warning \"HDLCompiler:226 HDLCompiler:1832\"" + ] vivadoSynthConfig :: Text -> Text -> Text -vivadoSynthConfig top outf = T.unlines - [ "# CRITICAL WARNING: [Synth 8-5821] Potential divide by zero" - , "set_msg_config -id {Synth 8-5821} -new_severity {WARNING}" - , "" - , "read_verilog rtl.v" - , "synth_design -part xc7k70t -top " <> top - , "write_verilog -force " <> outf - ] +vivadoSynthConfig top outf = + T.unlines + [ "# CRITICAL WARNING: [Synth 8-5821] Potential divide by zero", + "set_msg_config -id {Synth 8-5821} -new_severity {WARNING}", + "", + "read_verilog rtl.v", + "synth_design -part xc7k70t -top " <> top, + "write_verilog -force " <> outf + ] sbyConfig :: (Synthesiser a, Synthesiser b) => Maybe Text -> FilePath -> a -> b -> (SourceInfo ann) -> Text -sbyConfig mt datadir sim1 sim2 (SourceInfo top _) = T.unlines - [ "[options]" - , "multiclock on" - , "mode prove" - , "aigsmt " <> fromMaybe "none" mt - , "" - , "[engines]" - , "abc pdr" - , "" - , "[script]" - , readL - , "read -formal " <> outputText sim1 - , "read -formal " <> outputText sim2 - , "read -formal top.v" - , "prep -top " <> top - , "" - , "[files]" - , depList - , outputText sim2 - , outputText sim1 - , "top.v" - ] +sbyConfig mt datadir sim1 sim2 (SourceInfo top _) = + T.unlines + [ "[options]", + "multiclock on", + "mode prove", + "aigsmt " <> fromMaybe "none" mt, + "", + "[engines]", + "abc pdr", + "", + "[script]", + readL, + "read -formal " <> outputText sim1, + "read -formal " <> outputText sim2, + "read -formal top.v", + "prep -top " <> top, + "", + "[files]", + depList, + outputText sim2, + outputText sim1, + "top.v" + ] where deps = ["cells_cmos.v", "cells_cyclone_v.v", "cells_verific.v", "cells_xilinx_7.v", "cells_yosys.v"] depList = - T.intercalate "\n" - $ toTextIgnore - . (datadir </> fromText "data" </>) - . fromText - <$> deps + T.intercalate "\n" $ + toTextIgnore + . (datadir </> fromText "data" </>) + . fromText + <$> deps readL = T.intercalate "\n" $ mappend "read -formal " <$> deps icarusTestbench :: (Synthesiser a, Show ann) => FilePath -> (Verilog ann) -> a -> Text -icarusTestbench datadir t synth1 = T.unlines - [ "`include \"" <> ddir <> "/data/cells_cmos.v\"" - , "`include \"" <> ddir <> "/data/cells_cyclone_v.v\"" - , "`include \"" <> ddir <> "/data/cells_verific.v\"" - , "`include \"" <> ddir <> "/data/cells_xilinx_7.v\"" - , "`include \"" <> ddir <> "/data/cells_yosys.v\"" - , "`include \"" <> toTextIgnore (synthOutput synth1) <> "\"" - , "" - , genSource t - ] +icarusTestbench datadir t synth1 = + T.unlines + [ "`include \"" <> ddir <> "/data/cells_cmos.v\"", + "`include \"" <> ddir <> "/data/cells_cyclone_v.v\"", + "`include \"" <> ddir <> "/data/cells_verific.v\"", + "`include \"" <> ddir <> "/data/cells_xilinx_7.v\"", + "`include \"" <> ddir <> "/data/cells_yosys.v\"", + "`include \"" <> toTextIgnore (synthOutput synth1) <> "\"", + "", + genSource t + ] where ddir = toTextIgnore datadir diff --git a/src/Verismith/Tool/Vivado.hs b/src/Verismith/Tool/Vivado.hs index ef8b1b7..f0f8a23 100644 --- a/src/Verismith/Tool/Vivado.hs +++ b/src/Verismith/Tool/Vivado.hs @@ -1,71 +1,74 @@ -{-| -Module : Verismith.Tool.Vivado -Description : Vivado Synthesiser implementation. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Vivado Synthesiser implementation. --} - +-- | +-- Module : Verismith.Tool.Vivado +-- Description : Vivado Synthesiser implementation. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Vivado Synthesiser implementation. module Verismith.Tool.Vivado - ( Vivado(..) - , defaultVivado - ) + ( Vivado (..), + defaultVivado, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Shelly +import Shelly.Lifted (liftSh) +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) -data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) - , vivadoDesc :: !Text - , vivadoOutput :: !FilePath - } - deriving (Eq) +data Vivado + = Vivado + { vivadoBin :: !(Maybe FilePath), + vivadoDesc :: !Text, + vivadoOutput :: !FilePath + } + deriving (Eq) instance Tool Vivado where - toText (Vivado _ t _) = t + toText (Vivado _ t _) = t instance Show Vivado where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser Vivado where - runSynth = runSynthVivado - synthOutput = vivadoOutput - setSynthOutput (Vivado a b _) = Vivado a b + runSynth = runSynthVivado + synthOutput = vivadoOutput + setSynthOutput (Vivado a b _) = Vivado a b instance NFData Vivado where - rnf = rwhnf + rnf = rwhnf defaultVivado :: Vivado defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" runSynthVivado :: Show ann => Vivado -> (SourceInfo ann) -> ResultSh () runSynthVivado sim (SourceInfo top src) = do - dir <- liftSh pwd - liftSh $ do - writefile vivadoTcl . vivadoSynthConfig top . toTextIgnore $ synthOutput - sim - writefile "rtl.v" $ genSource src - run_ - "sed" - [ "s/^module/(* use_dsp48=\"no\" *) (* use_dsp=\"no\" *) module/;" - , "-i" - , "rtl.v" - ] - let exec_ n = execute_ - SynthFail - dir - "vivado" - (maybe (fromText n) (</> fromText n) $ vivadoBin sim) - exec_ "vivado" ["-mode", "batch", "-source", toTextIgnore vivadoTcl] - where vivadoTcl = fromText ("vivado_" <> top) <.> "tcl" + dir <- liftSh pwd + liftSh $ do + writefile vivadoTcl . vivadoSynthConfig top . toTextIgnore $ + synthOutput + sim + writefile "rtl.v" $ genSource src + run_ + "sed" + [ "s/^module/(* use_dsp48=\"no\" *) (* use_dsp=\"no\" *) module/;", + "-i", + "rtl.v" + ] + let exec_ n = + execute_ + SynthFail + dir + "vivado" + (maybe (fromText n) (</> fromText n) $ vivadoBin sim) + exec_ "vivado" ["-mode", "batch", "-source", toTextIgnore vivadoTcl] + where + vivadoTcl = fromText ("vivado_" <> top) <.> "tcl" diff --git a/src/Verismith/Tool/XST.hs b/src/Verismith/Tool/XST.hs index 213fae8..9447675 100644 --- a/src/Verismith/Tool/XST.hs +++ b/src/Verismith/Tool/XST.hs @@ -1,83 +1,85 @@ -{-| -Module : Verismith.Tool.XST -Description : XST (ise) simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -XST (ise) simulator implementation. --} - {-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Verismith.Tool.XST +-- Description : XST (ise) simulator implementation. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- XST (ise) simulator implementation. module Verismith.Tool.XST - ( XST(..) - , defaultXST - ) + ( XST (..), + defaultXST, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Shelly +import Shelly.Lifted (liftSh) +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Prelude hiding (FilePath) -data XST = XST { xstBin :: !(Maybe FilePath) - , xstDesc :: !Text - , xstOutput :: !FilePath - } - deriving (Eq) +data XST + = XST + { xstBin :: !(Maybe FilePath), + xstDesc :: !Text, + xstOutput :: !FilePath + } + deriving (Eq) instance Tool XST where - toText (XST _ t _) = t + toText (XST _ t _) = t instance Show XST where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser XST where - runSynth = runSynthXST - synthOutput = xstOutput - setSynthOutput (XST a b _) = XST a b + runSynth = runSynthXST + synthOutput = xstOutput + setSynthOutput (XST a b _) = XST a b instance NFData XST where - rnf = rwhnf + rnf = rwhnf defaultXST :: XST defaultXST = XST Nothing "xst" "syn_xst.v" runSynthXST :: Show ann => XST -> (SourceInfo ann) -> ResultSh () runSynthXST sim (SourceInfo top src) = do - dir <- liftSh pwd - let exec n = execute_ - SynthFail - dir - "xst" - (maybe (fromText n) (</> fromText n) $ xstBin sim) - liftSh $ do - writefile xstFile $ xstSynthConfig top - writefile prjFile "verilog work \"rtl.v\"" - writefile "rtl.v" $ genSource src - exec "xst" ["-ifn", toTextIgnore xstFile] - exec - "netgen" - [ "-w" - , "-ofmt" - , "verilog" - , toTextIgnore $ modFile <.> "ngc" - , toTextIgnore $ synthOutput sim - ] - liftSh . noPrint $ run_ - "sed" - [ "-i" - , "/^`ifndef/,/^`endif/ d; s/ *Timestamp: .*//;" - , toTextIgnore $ synthOutput sim - ] + dir <- liftSh pwd + let exec n = + execute_ + SynthFail + dir + "xst" + (maybe (fromText n) (</> fromText n) $ xstBin sim) + liftSh $ do + writefile xstFile $ xstSynthConfig top + writefile prjFile "verilog work \"rtl.v\"" + writefile "rtl.v" $ genSource src + exec "xst" ["-ifn", toTextIgnore xstFile] + exec + "netgen" + [ "-w", + "-ofmt", + "verilog", + toTextIgnore $ modFile <.> "ngc", + toTextIgnore $ synthOutput sim + ] + liftSh . noPrint $ + run_ + "sed" + [ "-i", + "/^`ifndef/,/^`endif/ d; s/ *Timestamp: .*//;", + toTextIgnore $ synthOutput sim + ] where modFile = fromText top xstFile = modFile <.> "xst" diff --git a/src/Verismith/Tool/Yosys.hs b/src/Verismith/Tool/Yosys.hs index f68f39f..32c3fee 100644 --- a/src/Verismith/Tool/Yosys.hs +++ b/src/Verismith/Tool/Yosys.hs @@ -1,53 +1,53 @@ -{-| -Module : Verismith.Tool.Yosys -Description : Yosys simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Yosys simulator implementation. --} - {-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Verismith.Tool.Yosys +-- Description : Yosys simulator implementation. +-- Copyright : (c) 2018-2019, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Yosys simulator implementation. module Verismith.Tool.Yosys - ( Yosys(..) - , defaultYosys - , runEquiv - , runEquivYosys - ) + ( Yosys (..), + defaultYosys, + runEquiv, + runEquivYosys, + ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Control.Lens -import Control.Monad (void) -import Data.Either (fromRight) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly (FilePath, (</>)) -import qualified Shelly as S -import Shelly.Lifted (liftSh, readfile) -import Verismith.CounterEg (parseCounterEg) -import Verismith.Result -import Verismith.Tool.Internal -import Verismith.Tool.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen -import Verismith.Verilog.Mutate +import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.Lens +import Control.Monad (void) +import Data.Either (fromRight) +import Data.Text (Text, unpack) +import Shelly ((</>), FilePath) +import qualified Shelly as S +import Shelly.Lifted (liftSh, readfile) +import Verismith.CounterEg (parseCounterEg) +import Verismith.Result +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Mutate +import Prelude hiding (FilePath) -data Yosys = Yosys { yosysBin :: !(Maybe FilePath) - , yosysDesc :: !Text - , yosysOutput :: !FilePath - } - deriving (Eq) +data Yosys + = Yosys + { yosysBin :: !(Maybe FilePath), + yosysDesc :: !Text, + yosysOutput :: !FilePath + } + deriving (Eq) instance Tool Yosys where - toText (Yosys _ t _) = t + toText (Yosys _ t _) = t instance Show Yosys where - show t = unpack $ toText t + show t = unpack $ toText t instance Synthesiser Yosys where runSynth = runSynthYosys @@ -55,7 +55,7 @@ instance Synthesiser Yosys where setSynthOutput (Yosys a b _) = Yosys a b instance NFData Yosys where - rnf = rwhnf + rnf = rwhnf defaultYosys :: Yosys defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" @@ -65,68 +65,78 @@ yosysPath sim = maybe (S.fromText "yosys") (</> S.fromText "yosys") $ yosysBin s runSynthYosys :: Show ann => Yosys -> (SourceInfo ann) -> ResultSh () runSynthYosys sim (SourceInfo _ src) = do - dir <- liftSh $ do - dir' <- S.pwd - S.writefile inpf $ genSource src - return dir' - execute_ - SynthFail - dir - "yosys" - (yosysPath sim) - [ "-p" - , "read_verilog " <> inp <> "; synth; write_verilog -noattr " <> out - ] + dir <- liftSh $ do + dir' <- S.pwd + S.writefile inpf $ genSource src + return dir' + execute_ + SynthFail + dir + "yosys" + (yosysPath sim) + [ "-p", + "read_verilog " <> inp <> "; synth; write_verilog -noattr " <> out + ] where inpf = "rtl.v" - inp = S.toTextIgnore inpf - out = S.toTextIgnore $ synthOutput sim + inp = S.toTextIgnore inpf + out = S.toTextIgnore $ synthOutput sim -runEquivYosys - :: (Synthesiser a, Synthesiser b, Show ann) - => Yosys - -> a - -> b - -> (SourceInfo ann) - -> ResultSh () +runEquivYosys :: + (Synthesiser a, Synthesiser b, Show ann) => + Yosys -> + a -> + b -> + (SourceInfo ann) -> + ResultSh () runEquivYosys yosys sim1 sim2 srcInfo = do - liftSh $ do - S.writefile "top.v" - . genSource - . initMod - . makeTop 2 - $ srcInfo - ^. mainModule - S.writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo - runSynth sim1 srcInfo - runSynth sim2 srcInfo - liftSh $ S.run_ (yosysPath yosys) [S.toTextIgnore checkFile] - where checkFile = S.fromText $ "test." <> toText sim1 <> "." <> toText sim2 <> ".ys" + liftSh $ do + S.writefile "top.v" + . genSource + . initMod + . makeTop 2 + $ srcInfo + ^. mainModule + S.writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo + runSynth sim1 srcInfo + runSynth sim2 srcInfo + liftSh $ S.run_ (yosysPath yosys) [S.toTextIgnore checkFile] + where + checkFile = S.fromText $ "test." <> toText sim1 <> "." <> toText sim2 <> ".ys" -runEquiv :: (Synthesiser a, Synthesiser b, Show ann) - => Maybe Text -> FilePath -> a -> b -> (SourceInfo ann) -> ResultSh () +runEquiv :: + (Synthesiser a, Synthesiser b, Show ann) => + Maybe Text -> + FilePath -> + a -> + b -> + (SourceInfo ann) -> + ResultSh () runEquiv mt datadir sim1 sim2 srcInfo = do - dir <- liftSh S.pwd - liftSh $ do - S.writefile "top.v" - . genSource - . initMod - . makeTopAssert - $ srcInfo - ^. mainModule - replaceMods (synthOutput sim1) "_1" srcInfo - replaceMods (synthOutput sim2) "_2" srcInfo - S.writefile "proof.sby" $ sbyConfig mt datadir sim1 sim2 srcInfo - e <- liftSh $ do - exe dir "symbiyosys" "sby" ["-f", "proof.sby"] - S.lastExitCode - case e of - 0 -> ResultT . return $ Pass () - 2 -> case mt of - Nothing -> ResultT . return . Fail $ EquivFail Nothing - Just _ -> ResultT $ Fail . EquivFail . Just . fromRight mempty - . parseCounterEg <$> readfile "proof/engine_0/trace.smtc" - 124 -> ResultT . return $ Fail TimeoutError - _ -> ResultT . return $ Fail EquivError + dir <- liftSh S.pwd + liftSh $ do + S.writefile "top.v" + . genSource + . initMod + . makeTopAssert + $ srcInfo + ^. mainModule + replaceMods (synthOutput sim1) "_1" srcInfo + replaceMods (synthOutput sim2) "_2" srcInfo + S.writefile "proof.sby" $ sbyConfig mt datadir sim1 sim2 srcInfo + e <- liftSh $ do + exe dir "symbiyosys" "sby" ["-f", "proof.sby"] + S.lastExitCode + case e of + 0 -> ResultT . return $ Pass () + 2 -> case mt of + Nothing -> ResultT . return . Fail $ EquivFail Nothing + Just _ -> + ResultT $ + Fail . EquivFail . Just . fromRight mempty + . parseCounterEg + <$> readfile "proof/engine_0/trace.smtc" + 124 -> ResultT . return $ Fail TimeoutError + _ -> ResultT . return $ Fail EquivError where exe dir name e = void . S.errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Utils.hs b/src/Verismith/Utils.hs index 1f5dd01..0faf585 100644 --- a/src/Verismith/Utils.hs +++ b/src/Verismith/Utils.hs @@ -1,29 +1,29 @@ -{-| -Module : Verismith -Description : Verismith -Copyright : (c) 2020, Yann Herklotz -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX --} - +-- | +-- Module : Verismith +-- Description : Verismith +-- Copyright : (c) 2020, Yann Herklotz +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX module Verismith.Utils - (generateByteString) + ( generateByteString, + ) where -import System.Random (mkStdGen, newStdGen, randoms) import Data.ByteString (ByteString, pack) +import System.Random (mkStdGen, newStdGen, randoms) generateByteString :: (Maybe Int) -> Int -> Int -> IO [ByteString] generateByteString mseed size n = do - fmap pack . chunksOf size . take (size * n) . randoms <$> - case mseed of - Just seed' -> return $ mkStdGen seed' - Nothing -> newStdGen + fmap pack . chunksOf size . take (size * n) . randoms + <$> case mseed of + Just seed' -> return $ mkStdGen seed' + Nothing -> newStdGen where chunksOf i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i chunksOf i xs = repeatedly (splitAt i) xs repeatedly _ [] = [] repeatedly f as = b : repeatedly f as' - where (b, as') = f as + where + (b, as') = f as diff --git a/src/Verismith/Verilog.hs b/src/Verismith/Verilog.hs index f3d9e85..4de6fda 100644 --- a/src/Verismith/Verilog.hs +++ b/src/Verismith/Verilog.hs @@ -1,106 +1,117 @@ -{-| -Module : Verismith.Verilog -Description : Verilog implementation with random generation and mutations. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Verilog implementation with random generation and mutations. --} - {-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Verismith.Verilog +-- Description : Verilog implementation with random generation and mutations. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Verilog implementation with random generation and mutations. module Verismith.Verilog - ( SourceInfo(..) - , Verilog(..) - , parseVerilog - , GenVerilog(..) - , genSource + ( SourceInfo (..), + Verilog (..), + parseVerilog, + GenVerilog (..), + genSource, + -- * 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(..) - , constToExpr - , exprToConst - , constNum + Expr (..), + ConstExpr (..), + constToExpr, + exprToConst, + constNum, + -- * Assignment - , Assign(..) - , assignReg - , assignDelay - , assignExpr - , ContAssign(..) - , contAssignNetLVal - , contAssignExpr + Assign (..), + assignReg, + assignDelay, + assignExpr, + ContAssign (..), + contAssignNetLVal, + contAssignExpr, + -- * Statment - , Statement(..) - , statDelay - , statDStat - , statEvent - , statEStat - , statements - , stmntBA - , stmntNBA - , stmntTask - , stmntSysTask - , stmntCondExpr - , stmntCondTrue - , stmntCondFalse + Statement (..), + statDelay, + statDStat, + statEvent, + statEStat, + statements, + stmntBA, + stmntNBA, + stmntTask, + stmntSysTask, + stmntCondExpr, + stmntCondTrue, + stmntCondFalse, + -- * Module - , ModDecl(..) - , modId - , modOutPorts - , modInPorts - , modItems - , ModItem(..) - , modContAssign - , modInstId - , modInstName - , modInstConns - , traverseModItem - , declDir - , declPort - , ModConn(..) - , modConnName - , modExpr + ModDecl (..), + modId, + modOutPorts, + modInPorts, + modItems, + ModItem (..), + modContAssign, + modInstId, + modInstName, + modInstConns, + traverseModItem, + declDir, + declPort, + ModConn (..), + modConnName, + modExpr, + -- * Useful Lenses and Traversals - , getModule - , getSourceId + getModule, + getSourceId, + -- * Quote - , verilog - ) + verilog, + ) where -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen -import Verismith.Verilog.Parser -import Verismith.Verilog.Quote +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Parser +import Verismith.Verilog.Quote 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 diff --git a/test/Benchmark.hs b/test/Benchmark.hs index 9c81049..3454ca2 100644 --- a/test/Benchmark.hs +++ b/test/Benchmark.hs @@ -1,15 +1,22 @@ module Main where -import Control.Lens ((&), (.~)) -import Criterion.Main (bench, bgroup, defaultMain, nfAppIO) -import Verismith (configProperty, defaultConfig, proceduralIO, - propSize, propStmntDepth) +import Control.Lens ((&), (.~)) +import Criterion.Main (bench, bgroup, defaultMain, nfAppIO) +import Verismith + ( configProperty, + defaultConfig, + proceduralIO, + propSize, + propStmntDepth, + ) main :: IO () -main = defaultMain - [ bgroup "generation" - [ bench "default" $ nfAppIO (proceduralIO "top") defaultConfig - , bench "depth" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propStmntDepth .~ 10 - , bench "size" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propSize .~ 40 +main = + defaultMain + [ bgroup + "generation" + [ bench "default" $ nfAppIO (proceduralIO "top") defaultConfig, + bench "depth" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propStmntDepth .~ 10, + bench "size" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propSize .~ 40 ] ] diff --git a/test/Doctest.hs b/test/Doctest.hs index 9dc22a4..e18c359 100644 --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -1,10 +1,11 @@ module Main where -import Build_doctests ( flags - , module_sources - , pkgs - ) -import Test.DocTest ( doctest ) +import Build_doctests + ( flags, + module_sources, + pkgs, + ) +import Test.DocTest (doctest) main :: IO () main = doctest args where args = flags ++ pkgs ++ module_sources diff --git a/test/Parser.hs b/test/Parser.hs index 0ce5817..c19f210 100644 --- a/test/Parser.hs +++ b/test/Parser.hs @@ -1,35 +1,33 @@ -{-| -Module : Parser -Description : Test the parser. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Test the parser. --} - +-- | +-- Module : Parser +-- Description : Test the parser. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Test the parser. module Parser - ( parserTests - , parseUnitTests - ) + ( parserTests, + parseUnitTests, + ) where -import Control.Lens -import Data.Either (either, isRight) -import Hedgehog (Gen, Property, (===)) -import qualified Hedgehog as Hog -import qualified Hedgehog.Gen as Hog -import Test.Tasty -import Test.Tasty.Hedgehog -import Test.Tasty.HUnit -import Text.Parsec -import Verismith -import Verismith.Internal -import Verismith.Verilog.Lex -import Verismith.Verilog.Parser -import Verismith.Verilog.Preprocess (uncomment) +import Control.Lens +import Data.Either (either, isRight) +import Hedgehog ((===), Gen, Property) +import qualified Hedgehog as Hog +import qualified Hedgehog.Gen as Hog +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog +import Text.Parsec +import Verismith +import Verismith.Internal +import Verismith.Verilog.Lex +import Verismith.Verilog.Parser +import Verismith.Verilog.Preprocess (uncomment) smallConfig :: Config smallConfig = defaultConfig & configProperty . propSize .~ 5 @@ -39,93 +37,101 @@ randomMod' = Hog.resize 20 (randomMod 3 10) parserInputMod :: Property parserInputMod = Hog.property $ do - v <- GenVerilog <$> Hog.forAll randomMod' :: Hog.PropertyT IO (GenVerilog (ModDecl ())) - Hog.assert . isRight $ parse parseModDecl - "input_test_mod" - (alexScanTokens . uncomment "test" $ show v) + v <- GenVerilog <$> Hog.forAll randomMod' :: Hog.PropertyT IO (GenVerilog (ModDecl ())) + Hog.assert . isRight $ + parse + parseModDecl + "input_test_mod" + (alexScanTokens . uncomment "test" $ show v) parserIdempotentMod :: Property parserIdempotentMod = Hog.property $ do - v <- Hog.forAll randomMod' :: Hog.PropertyT IO (ModDecl ()) - let sv = vshow v - p sv === (p . p) sv + v <- Hog.forAll randomMod' :: Hog.PropertyT IO (ModDecl ()) + let sv = vshow v + p sv === (p . p) sv where vshow = show . GenVerilog p sv = - either (\x -> show x <> "\n" <> sv) vshow - . parse parseModDecl "idempotent_test_mod" - $ alexScanTokens sv + either (\x -> show x <> "\n" <> sv) vshow + . parse parseModDecl "idempotent_test_mod" + $ alexScanTokens sv parserInput :: Property parserInput = Hog.property $ do - v <- Hog.forAll (GenVerilog <$> (procedural "top" smallConfig :: Gen (Verilog ()))) - Hog.assert . isRight $ parse parseModDecl - "input_test" - (alexScanTokens . uncomment "test" $ show v) + v <- Hog.forAll (GenVerilog <$> (procedural "top" smallConfig :: Gen (Verilog ()))) + Hog.assert . isRight $ + parse + parseModDecl + "input_test" + (alexScanTokens . uncomment "test" $ show v) parserIdempotent :: Property parserIdempotent = Hog.property $ do - v <- Hog.forAll (procedural "top" smallConfig) :: Hog.PropertyT IO (Verilog ()) - let sv = vshow v - p sv === (p . p) sv + v <- Hog.forAll (procedural "top" smallConfig) :: Hog.PropertyT IO (Verilog ()) + let sv = vshow v + p sv === (p . p) sv where vshow = showT . GenVerilog - p sv = either (\x -> showT x <> "\n" <> sv) vshow - $ parseVerilog "idempotent_test" sv + p sv = + either (\x -> showT x <> "\n" <> sv) vshow $ + parseVerilog "idempotent_test" sv parserTests :: TestTree -parserTests = testGroup +parserTests = + testGroup "Parser properties" - [ testProperty "Input Mod" parserInputMod - , testProperty "Input" parserInput - , testProperty "Idempotence Mod" parserIdempotentMod - , testProperty "Idempotence" parserIdempotent + [ testProperty "Input Mod" parserInputMod, + testProperty "Input" parserInput, + testProperty "Idempotence Mod" parserIdempotentMod, + testProperty "Idempotence" parserIdempotent ] testParse :: (Eq a, Show a) => Parser a -> String -> String -> a -> TestTree testParse p name input golden = - testCase name $ case parse p "testcase" (alexScanTokens input) of - Left e -> assertFailure $ show e - Right result -> golden @=? result + testCase name $ case parse p "testcase" (alexScanTokens input) of + Left e -> assertFailure $ show e + Right result -> golden @=? result testParseFail :: (Eq a, Show a) => Parser a -> String -> String -> TestTree testParseFail p name input = - testCase name $ case parse p "testcase" (alexScanTokens input) of - Left _ -> return () - Right _ -> assertFailure "Parse incorrectly succeeded" + testCase name $ case parse p "testcase" (alexScanTokens input) of + Left _ -> return () + Right _ -> assertFailure "Parse incorrectly succeeded" parseEventUnit :: TestTree -parseEventUnit = testGroup +parseEventUnit = + testGroup "Event" - [ testFailure "No empty event" "@()" - , test "@*" EAll - , test "@(*)" EAll - , test "@(posedge clk)" $ EPosEdge "clk" - , test "@(negedge clk)" $ ENegEdge "clk" - , test "@(wire1)" $ EId "wire1" - , test "@(a or b or c or d)" - $ EOr (EId "a") (EOr (EId "b") (EOr (EId "c") (EId "d"))) - , test "@(a, b, c, d)" - $ EComb (EId "a") (EComb (EId "b") (EComb (EId "c") (EId "d"))) - , test "@(posedge a or negedge b or c or d)" - $ EOr (EPosEdge "a") (EOr (ENegEdge "b") (EOr (EId "c") (EId "d"))) + [ testFailure "No empty event" "@()", + test "@*" EAll, + test "@(*)" EAll, + test "@(posedge clk)" $ EPosEdge "clk", + test "@(negedge clk)" $ ENegEdge "clk", + test "@(wire1)" $ EId "wire1", + test "@(a or b or c or d)" $ + EOr (EId "a") (EOr (EId "b") (EOr (EId "c") (EId "d"))), + test "@(a, b, c, d)" $ + EComb (EId "a") (EComb (EId "b") (EComb (EId "c") (EId "d"))), + test "@(posedge a or negedge b or c or d)" $ + EOr (EPosEdge "a") (EOr (ENegEdge "b") (EOr (EId "c") (EId "d"))) ] where test a = testParse parseEvent ("Test " <> a) a testFailure = testParseFail parseEvent parseAlwaysUnit :: TestTree -parseAlwaysUnit = testGroup +parseAlwaysUnit = + testGroup "Always" - [ test "Empty" "always begin end" $ Always (SeqBlock []) - , test "Empty with event @*" "always @* begin end" - $ Always (EventCtrl EAll (Just (SeqBlock []))) - , test "Empty with event @(posedge clk)" "always @(posedge clk) begin end" - $ Always (EventCtrl (EPosEdge "clk") (Just (SeqBlock []))) + [ test "Empty" "always begin end" $ Always (SeqBlock []), + test "Empty with event @*" "always @* begin end" $ + Always (EventCtrl EAll (Just (SeqBlock []))), + test "Empty with event @(posedge clk)" "always @(posedge clk) begin end" $ + Always (EventCtrl (EPosEdge "clk") (Just (SeqBlock []))) ] - where - test :: String -> String -> ModItem () -> TestTree - test = testParse parseModItem + where + test :: String -> String -> ModItem () -> TestTree + test = testParse parseModItem parseUnitTests :: TestTree parseUnitTests = testGroup "Parser unit" [parseEventUnit, parseAlwaysUnit] diff --git a/test/Property.hs b/test/Property.hs index 7e1911e..ddbef0d 100644 --- a/test/Property.hs +++ b/test/Property.hs @@ -1,51 +1,51 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-unused-top-binds #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Property - ( propertyTests - ) + ( propertyTests, + ) where -import Data.Either (either, isRight) -import qualified Data.Graph.Inductive as G -import Data.Text (Text) -import Hedgehog (Gen, Property, (===)) -import qualified Hedgehog as Hog -import qualified Hedgehog.Gen as Hog -import qualified Hedgehog.Range as Hog -import Parser (parserTests) -import Test.Tasty -import Test.Tasty.Hedgehog -import Text.Parsec -import Verismith -import Verismith.Result -import Verismith.Verilog.Lex -import Verismith.Verilog.Parser +import Data.Either (either, isRight) +import qualified Data.Graph.Inductive as G +import Data.Text (Text) +import Hedgehog ((===), Gen, Property) +import qualified Hedgehog as Hog +import qualified Hedgehog.Gen as Hog +import qualified Hedgehog.Range as Hog +import Parser (parserTests) +import Test.Tasty +import Test.Tasty.Hedgehog +import Text.Parsec +import Verismith +import Verismith.Result +import Verismith.Verilog.Lex +import Verismith.Verilog.Parser randomDAG' :: Gen Circuit randomDAG' = Hog.resize 30 randomDAG acyclicGraph :: Property acyclicGraph = Hog.property $ do - xs <- Hog.forAllWith (const "") randomDAG' - Hog.assert $ simp xs + xs <- Hog.forAllWith (const "") randomDAG' + Hog.assert $ simp xs where simp g = - (== G.noNodes (getCircuit g)) - . sum - . fmap length - . G.scc - . getCircuit - $ g + (== G.noNodes (getCircuit g)) + . sum + . fmap length + . G.scc + . getCircuit + $ g propertyTests :: TestTree -propertyTests = testGroup +propertyTests = + testGroup "Property Tests" - [ testProperty "acyclic graph generation check" acyclicGraph - , parserTests + [ testProperty "acyclic graph generation check" acyclicGraph, + parserTests ] diff --git a/test/Reduce.hs b/test/Reduce.hs index 47554bf..e6cc8ff 100644 --- a/test/Reduce.hs +++ b/test/Reduce.hs @@ -1,50 +1,52 @@ -{-| -Module : Reduce -Description : Test reduction. -Copyright : (c) 2019, Yann Herklotz Grave -License : GPL-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Test reduction. --} - {-# LANGUAGE QuasiQuotes #-} +-- | +-- Module : Reduce +-- Description : Test reduction. +-- Copyright : (c) 2019, Yann Herklotz Grave +-- License : GPL-3 +-- Maintainer : yann [at] yannherklotz [dot] com +-- Stability : experimental +-- Portability : POSIX +-- +-- Test reduction. module Reduce - ( reduceUnitTests - ) + ( reduceUnitTests, + ) where -import Data.List ((\\)) -import Test.Tasty -import Test.Tasty.HUnit -import Verismith -import Verismith.Reduce +import Data.List ((\\)) import Data.Text (Text) +import Test.Tasty +import Test.Tasty.HUnit +import Verismith +import Verismith.Reduce sourceInfo :: Text -> Verilog ReduceAnn -> SourceInfo ReduceAnn sourceInfo = SourceInfo reduceUnitTests :: TestTree -reduceUnitTests = testGroup +reduceUnitTests = + testGroup "Reducer tests" - [ moduleReducerTest - , modItemReduceTest - , halveStatementsTest - , statementReducerTest - , activeWireTest - , cleanTest - , cleanAllTest - , removeDeclTest + [ moduleReducerTest, + modItemReduceTest, + halveStatementsTest, + statementReducerTest, + activeWireTest, + cleanTest, + cleanAllTest, + removeDeclTest ] removeConstInConcatTest :: TestTree removeConstInConcatTest = testCase "Remove const in concat" $ do - GenVerilog (removeDecl srcInfo1) @?= golden1 + GenVerilog (removeDecl srcInfo1) @?= golden1 where - srcInfo1 = sourceInfo "top" [verilog| + srcInfo1 = + sourceInfo + "top" + [verilog| module top; wire a; reg b; @@ -57,7 +59,11 @@ module top; end endmodule |] - golden1 = GenVerilog $ sourceInfo "top" [verilog| + golden1 = + GenVerilog $ + sourceInfo + "top" + [verilog| module top; wire a; reg b; @@ -73,9 +79,12 @@ endmodule removeDeclTest :: TestTree removeDeclTest = testCase "Remove declarations" $ do - GenVerilog (removeDecl srcInfo1) @?= golden1 - where - srcInfo1 = sourceInfo "top" [verilog| + GenVerilog (removeDecl srcInfo1) @?= golden1 + where + srcInfo1 = + sourceInfo + "top" + [verilog| module top; wire a; wire b; @@ -103,7 +112,11 @@ module top; assign b = g; endmodule |] - golden1 = GenVerilog $ sourceInfo "top" [verilog| + golden1 = + GenVerilog $ + sourceInfo + "top" + [verilog| module top; wire a; wire b; @@ -130,9 +143,12 @@ endmodule |] cleanAllTest = testCase "Clean all" $ do - GenVerilog (cleanSourceInfoAll srcInfo1) @?= golden1 - where - srcInfo1 = sourceInfo "top" [verilog| + GenVerilog (cleanSourceInfoAll srcInfo1) @?= golden1 + where + srcInfo1 = + sourceInfo + "top" + [verilog| module top; wire a; wire b; @@ -160,7 +176,11 @@ module mod2; assign b = c + d; endmodule |] - golden1 = GenVerilog $ sourceInfo "top" [verilog| + golden1 = + GenVerilog $ + sourceInfo + "top" + [verilog| module top; wire a; wire b; @@ -191,10 +211,12 @@ endmodule cleanTest :: TestTree cleanTest = testCase "Clean expression" $ do - clean ["wire1", "wire2"] srcInfo1 @?= golden1 - clean ["wire1", "wire3"] srcInfo2 @?= golden2 - where - srcInfo1 = GenVerilog . sourceInfo "top" $ [verilog| + clean ["wire1", "wire2"] srcInfo1 @?= golden1 + clean ["wire1", "wire3"] srcInfo2 @?= golden2 + where + srcInfo1 = + GenVerilog . sourceInfo "top" $ + [verilog| module top; wire wire1; wire wire2; @@ -202,7 +224,9 @@ module top; assign wire1 = wire2[wire3]; endmodule |] - golden1 = GenVerilog . sourceInfo "top" $ [verilog| + golden1 = + GenVerilog . sourceInfo "top" $ + [verilog| module top; wire wire1; wire wire2; @@ -210,7 +234,9 @@ module top; assign wire1 = wire2[1'b0]; endmodule |] - srcInfo2 = GenVerilog . sourceInfo "top" $ [verilog| + srcInfo2 = + GenVerilog . sourceInfo "top" $ + [verilog| module top; wire wire1; wire wire2; @@ -218,7 +244,9 @@ module top; assign wire1 = wire2[wire3:wire1]; endmodule |] - golden2 = GenVerilog . sourceInfo "top" $ [verilog| + golden2 = + GenVerilog . sourceInfo "top" $ + [verilog| module top; wire wire1; wire wire2; @@ -227,15 +255,17 @@ module top; endmodule |] - activeWireTest :: TestTree activeWireTest = testCase "Active wires" $ do - findActiveWires "top" verilog1 \\ ["x", "y", "z", "w"] @?= [] - findActiveWires "top" verilog2 \\ ["x", "y", "z"] @?= [] - findActiveWires "top" verilog3 \\ ["x", "y", "clk", "r1", "r2"] @?= [] - findActiveWires "top" verilog4 \\ ["x", "y", "w", "a", "b"] @?= [] - where - verilog1 = sourceInfo "top" [verilog| + findActiveWires "top" verilog1 \\ ["x", "y", "z", "w"] @?= [] + findActiveWires "top" verilog2 \\ ["x", "y", "z"] @?= [] + findActiveWires "top" verilog3 \\ ["x", "y", "clk", "r1", "r2"] @?= [] + findActiveWires "top" verilog4 \\ ["x", "y", "w", "a", "b"] @?= [] + where + verilog1 = + sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -246,7 +276,10 @@ module top(y, x); assign y = w + z; endmodule |] - verilog2 = sourceInfo "top" [verilog| + verilog2 = + sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -255,7 +288,10 @@ module top(y, x); assign z = 0; endmodule |] - verilog3 = sourceInfo "top" [verilog| + verilog3 = + sourceInfo + "top" + [verilog| module top(clk, y, x); input clk; input x; @@ -276,7 +312,10 @@ module top(clk, y, x); assign y = {r1, r2, r3}; endmodule |] - verilog4 = sourceInfo "top" [verilog| + verilog4 = + sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -303,9 +342,12 @@ endmodule halveStatementsTest :: TestTree halveStatementsTest = testCase "Statements" $ do - GenVerilog <$> halveStatements "top" (tagAlways "top" srcInfo1) @?= golden1 - where - srcInfo1 = sourceInfo "top" [verilog| + GenVerilog <$> halveStatements "top" (tagAlways "top" srcInfo1) @?= golden1 + where + srcInfo1 = + sourceInfo + "top" + [verilog| module top(clk, y, x); input clk; input x; @@ -327,7 +369,13 @@ module top(clk, y, x); assign y = {r1, r2, r3}; endmodule |] - golden1 = GenVerilog <$> Dual (tagAlways "top" $ sourceInfo "top" [verilog| + golden1 = + GenVerilog + <$> Dual + ( tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(clk, y, x); input clk; input x; @@ -346,7 +394,12 @@ module top(clk, y, x); end assign y = {r1, r2, r3}; endmodule -|]) (tagAlways "top" $ sourceInfo "top" [verilog| +|] + ) + ( tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(clk, y, x); input clk; input x; @@ -366,13 +419,17 @@ module top(clk, y, x); end assign y = {r1, r2, r3}; endmodule -|]) +|] + ) modItemReduceTest :: TestTree modItemReduceTest = testCase "Module items" $ do - GenVerilog <$> halveModItems "top" srcInfo1 @?= golden1 - where - srcInfo1 = sourceInfo "top" [verilog| + GenVerilog <$> halveModItems "top" srcInfo1 @?= golden1 + where + srcInfo1 = + sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -383,7 +440,12 @@ module top(y, x); assign y = w; endmodule |] - golden1 = GenVerilog <$> Dual (sourceInfo "top" [verilog| + golden1 = + GenVerilog + <$> Dual + ( sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -392,7 +454,11 @@ module top(y, x); assign y = 1'b0; assign z = x; endmodule -|]) (sourceInfo "top" [verilog| +|] + ) + ( sourceInfo + "top" + [verilog| module top(y, x); input x; output y; @@ -401,14 +467,19 @@ module top(y, x); assign y = w; assign w = 1'b0; endmodule -|]) +|] + ) statementReducerTest :: TestTree statementReducerTest = testCase "Statement reducer" $ do - GenVerilog <$> halveStatements "top" srcInfo1 @?= fmap GenVerilog golden1 - GenVerilog <$> halveStatements "top" srcInfo2 @?= fmap GenVerilog golden2 - where - srcInfo1 = tagAlways "top" $ sourceInfo "top" [verilog| + GenVerilog <$> halveStatements "top" srcInfo1 @?= fmap GenVerilog golden1 + GenVerilog <$> halveStatements "top" srcInfo2 @?= fmap GenVerilog golden2 + where + srcInfo1 = + tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -428,7 +499,12 @@ module top(y, x); end endmodule |] - golden1 = Dual (tagAlways "top" $ sourceInfo "top" [verilog| + golden1 = + Dual + ( tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -445,7 +521,12 @@ module top(y, x); d <= 4; end endmodule -|]) . tagAlways "top" $ sourceInfo "top" [verilog| +|] + ) + . tagAlways "top" + $ sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -463,7 +544,11 @@ module top(y, x); end endmodule |] - srcInfo2 = tagAlways "top" $ sourceInfo "top" [verilog| + srcInfo2 = + tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -476,7 +561,12 @@ module top(y, x); end endmodule |] - golden2 = Dual (tagAlways "top" $ sourceInfo "top" [verilog| + golden2 = + Dual + ( tagAlways "top" $ + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -484,7 +574,12 @@ module top(y, x); always @(posedge clk) y <= 2; endmodule -|]) . tagAlways "top" $ sourceInfo "top" [verilog| +|] + ) + . tagAlways "top" + $ sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -496,10 +591,13 @@ endmodule moduleReducerTest :: TestTree moduleReducerTest = testCase "Module reducer" $ do - halveModules srcInfo1 @?= golden1 - halveModules srcInfo2 @?= golden2 - where - srcInfo1 = sourceInfo "top" [verilog| + halveModules srcInfo1 @?= golden1 + halveModules srcInfo2 @?= golden2 + where + srcInfo1 = + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -511,13 +609,20 @@ module m(y, x); input wire [4:0] x; endmodule |] - golden1 = Single $ sourceInfo "top" [verilog| + golden1 = + Single $ + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; endmodule |] - srcInfo2 = sourceInfo "top" [verilog| + srcInfo2 = + sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -535,7 +640,11 @@ module m2(y, x); input wire [4:0] x; endmodule |] - golden2 = Dual (sourceInfo "top" [verilog| + golden2 = + Dual + ( sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; @@ -546,7 +655,11 @@ module m(y, x); output wire [4:0] y; input wire [4:0] x; endmodule -|]) $ sourceInfo "top" [verilog| +|] + ) + $ sourceInfo + "top" + [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; diff --git a/test/Test.hs b/test/Test.hs index f2609ba..22cdb29 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,8 +1,8 @@ module Main where -import Property -import Test.Tasty -import Unit +import Property +import Test.Tasty +import Unit tests :: TestTree tests = testGroup "Tests" [unitTests, propertyTests] diff --git a/test/Unit.hs b/test/Unit.hs index f761c68..9cc75fb 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -1,101 +1,109 @@ module Unit - ( unitTests - ) + ( unitTests, + ) where -import Control.Lens -import Data.List.NonEmpty (NonEmpty (..)) -import Parser (parseUnitTests) -import Reduce (reduceUnitTests) -import Test.Tasty -import Test.Tasty.HUnit -import Verismith +import Control.Lens +import Data.List.NonEmpty (NonEmpty (..)) +import Parser (parseUnitTests) +import Reduce (reduceUnitTests) +import Test.Tasty +import Test.Tasty.HUnit +import Verismith unitTests :: TestTree -unitTests = testGroup +unitTests = + testGroup "Unit tests" - [ testCase "Transformation of AST" $ assertEqual - "Successful transformation" - transformExpectedResult - (transform trans transformTestData) - , parseUnitTests - , reduceUnitTests + [ testCase "Transformation of AST" $ + assertEqual + "Successful transformation" + transformExpectedResult + (transform trans transformTestData), + parseUnitTests, + reduceUnitTests ] transformTestData :: Expr -transformTestData = BinOp - (BinOp (BinOp (Id "id1") BinAnd (Id "id2")) - BinAnd - (BinOp (Id "id1") BinAnd (Id "id2")) +transformTestData = + BinOp + ( BinOp + (BinOp (Id "id1") BinAnd (Id "id2")) + BinAnd + (BinOp (Id "id1") BinAnd (Id "id2")) ) BinAnd - (BinOp - (BinOp + ( BinOp + ( BinOp (BinOp (Id "id1") BinAnd (Id "id2")) BinAnd - (BinOp + ( BinOp (Id "id1") BinAnd - (BinOp (BinOp (Id "id1") BinAnd (Id "id2")) - BinAnd - (BinOp (Id "id1") BinAnd (Id "id2")) + ( BinOp + (BinOp (Id "id1") BinAnd (Id "id2")) + BinAnd + (BinOp (Id "id1") BinAnd (Id "id2")) ) ) ) BinOr - ( Concat - $ ( Concat - $ (Concat $ (Id "id1") :| [Id "id2", Id "id2"]) - :| [ Id "id2" - , Id "id2" - , ( Concat - $ (Id "id2") - :| [Id "id2", (Concat $ Id "id1" :| [Id "id2"])] - ) - , Id "id2" - ] - ) - :| [Id "id1", Id "id2"] + ( Concat $ + ( Concat $ + (Concat $ (Id "id1") :| [Id "id2", Id "id2"]) + :| [ Id "id2", + Id "id2", + ( Concat $ + (Id "id2") + :| [Id "id2", (Concat $ Id "id1" :| [Id "id2"])] + ), + Id "id2" + ] + ) + :| [Id "id1", Id "id2"] ) ) transformExpectedResult :: Expr -transformExpectedResult = BinOp - (BinOp (BinOp (Id "id1") BinAnd (Id "Replaced")) - BinAnd - (BinOp (Id "id1") BinAnd (Id "Replaced")) +transformExpectedResult = + BinOp + ( BinOp + (BinOp (Id "id1") BinAnd (Id "Replaced")) + BinAnd + (BinOp (Id "id1") BinAnd (Id "Replaced")) ) BinAnd - (BinOp - (BinOp + ( BinOp + ( BinOp (BinOp (Id "id1") BinAnd (Id "Replaced")) BinAnd - (BinOp + ( BinOp (Id "id1") BinAnd - (BinOp (BinOp (Id "id1") BinAnd (Id "Replaced")) - BinAnd - (BinOp (Id "id1") BinAnd (Id "Replaced")) + ( BinOp + (BinOp (Id "id1") BinAnd (Id "Replaced")) + BinAnd + (BinOp (Id "id1") BinAnd (Id "Replaced")) ) ) ) BinOr - ( Concat - $ ( Concat - $ (Concat $ (Id "id1") :| [Id "Replaced", Id "Replaced"]) - :| [ Id "Replaced" - , Id "Replaced" - , Concat - $ Id "Replaced" - :| [Id "Replaced", Concat $ Id "id1" :| [Id "Replaced"]] - , Id "Replaced" - ] - ) - :| [Id "id1", Id "Replaced"] + ( Concat $ + ( Concat $ + (Concat $ (Id "id1") :| [Id "Replaced", Id "Replaced"]) + :| [ Id "Replaced", + Id "Replaced", + Concat $ + Id "Replaced" + :| [Id "Replaced", Concat $ Id "id1" :| [Id "Replaced"]], + Id "Replaced" + ] + ) + :| [Id "id1", Id "Replaced"] ) ) trans :: Expr -> Expr trans e = case e of - Id i -> if i == Identifier "id2" then Id $ Identifier "Replaced" else Id i - _ -> e + Id i -> if i == Identifier "id2" then Id $ Identifier "Replaced" else Id i + _ -> e |