From 74a14ef30359e653259bf7139fe806548edefd14 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 15 Aug 2019 17:37:17 +1000 Subject: Add new bug that was found --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index ceac479..c1e9208 100644 --- a/README.md +++ b/README.md @@ -42,6 +42,7 @@ reported and 3 were fixed. | Type | Issue | Confirmed | Fixed | |---------------|------------------------------------------------------------|-----------|-------| +| Mis-synthesis | [Issue 1243](https://github.com/YosysHQ/yosys/issues/1243) | ✓ | ✓ | | Mis-synthesis | [Issue 1047](https://github.com/YosysHQ/yosys/issues/1047) | ✓ | ✓ | | Mis-synthesis | [Issue 997](https://github.com/YosysHQ/yosys/issues/997) | ✓ | ✓ | | Crash | [Issue 993](https://github.com/YosysHQ/yosys/issues/993) | ✓ | ✓ | -- cgit From cccb665ebac6e916c4f961eacbe11a9af7d7ceb3 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Thu, 29 Aug 2019 15:44:33 +1000 Subject: Change name from VeriFuzz to VeriSmith --- README.md | 6 +-- app/Main.hs | 2 +- default.nix | 4 +- scripts/run.py | 2 +- scripts/size.py | 2 +- scripts/swarm.py | 4 +- src/VeriFuzz.hs | 46 ++++++++++---------- src/VeriFuzz/Circuit.hs | 18 ++++---- src/VeriFuzz/Circuit/Base.hs | 4 +- src/VeriFuzz/Circuit/Gen.hs | 16 +++---- src/VeriFuzz/Circuit/Internal.hs | 4 +- src/VeriFuzz/Circuit/Random.hs | 6 +-- src/VeriFuzz/Config.hs | 20 ++++----- src/VeriFuzz/Fuzz.hs | 24 +++++------ src/VeriFuzz/Generate.hs | 18 ++++---- src/VeriFuzz/Internal.hs | 4 +- src/VeriFuzz/Reduce.hs | 42 +++++++++---------- src/VeriFuzz/Report.hs | 14 +++---- src/VeriFuzz/Result.hs | 6 +-- src/VeriFuzz/Sim.hs | 18 ++++---- src/VeriFuzz/Sim/Icarus.hs | 56 ++++++++++++------------- src/VeriFuzz/Sim/Identity.hs | 20 ++++----- src/VeriFuzz/Sim/Internal.hs | 16 +++---- src/VeriFuzz/Sim/Quartus.hs | 18 ++++---- src/VeriFuzz/Sim/Template.hs | 20 ++++----- src/VeriFuzz/Sim/Vivado.hs | 20 ++++----- src/VeriFuzz/Sim/XST.hs | 22 +++++----- src/VeriFuzz/Sim/Yosys.hs | 28 ++++++------- src/VeriFuzz/Verilog.hs | 12 +++--- src/VeriFuzz/Verilog/AST.hs | 6 +-- src/VeriFuzz/Verilog/BitVec.hs | 4 +- src/VeriFuzz/Verilog/CodeGen.hs | 12 +++--- src/VeriFuzz/Verilog/Eval.hs | 14 +++---- src/VeriFuzz/Verilog/Internal.hs | 8 ++-- src/VeriFuzz/Verilog/Lex.x | 4 +- src/VeriFuzz/Verilog/Mutate.hs | 28 ++++++------- src/VeriFuzz/Verilog/Parser.hs | 38 ++++++++--------- src/VeriFuzz/Verilog/Preprocess.hs | 4 +- src/VeriFuzz/Verilog/Quote.hs | 6 +-- src/VeriFuzz/Verilog/Token.hs | 4 +- test/Benchmark.hs | 2 +- test/Parser.hs | 16 +++---- test/Property.hs | 35 +++++++--------- test/Reduce.hs | 4 +- test/Unit.hs | 8 ++-- verifuzz.cabal | 86 +++++++++++++++++++------------------- 46 files changed, 372 insertions(+), 379 deletions(-) diff --git a/README.md b/README.md index c1e9208..fcb5402 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -# VeriFuzz [![Build Status](https://travis-ci.com/ymherklotz/verifuzz.svg?token=qfBKKGwxeWkjDsy7e16x&branch=master)](https://travis-ci.com/ymherklotz/verifuzz) +# VeriSmith [![Build Status](https://travis-ci.com/ymherklotz/verismith.svg?token=qfBKKGwxeWkjDsy7e16x&branch=master)](https://travis-ci.com/ymherklotz/verismith) Verilog Fuzzer to test the major verilog compilers by generating random, valid and deterministic Verilog. There is a -[presentation](https://yannherklotz.com/docs/presentation.pdf) about VeriFuzz +[presentation](https://yannherklotz.com/docs/presentation.pdf) about VeriSmith and a [thesis](https://yannherklotz.com/docs/thesis.pdf) which goes over all the details of the implementation and results that were found. @@ -110,7 +110,7 @@ the actual project itself. ## Configuration -VeriFuzz can be configured using a [TOML](https://github.com/toml-lang/toml) +VeriSmith can be configured using a [TOML](https://github.com/toml-lang/toml) file. There are four main sections in the configuration file, an example can be seen [here](/examples/config.toml). diff --git a/app/Main.hs b/app/Main.hs index 7160b5d..39f74aa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main where -import VeriFuzz +import VeriSmith main :: IO () main = defaultMain diff --git a/default.nix b/default.nix index 2d64523..922037b 100644 --- a/default.nix +++ b/default.nix @@ -9,6 +9,6 @@ let }; }; variant = if doBenchmark then nixpkgs.pkgs.haskell.lib.doBenchmark else nixpkgs.pkgs.lib.id; - verifuzz = haskellPackages.callCabal2nix "verifuzz" (./.) {}; + verismith = haskellPackages.callCabal2nix "verismith" (./.) {}; in - variant verifuzz + variant verismith diff --git a/scripts/run.py b/scripts/run.py index 63295af..636e1c3 100755 --- a/scripts/run.py +++ b/scripts/run.py @@ -12,7 +12,7 @@ def main(): if not os.path.exists(directory): os.makedirs(directory) while True: - subprocess.call(["verifuzz", "fuzz" + subprocess.call(["verismith", "fuzz" , "-o", directory + "/" + name + str(i) , "-c", config , "-n", str(iterations)]) diff --git a/scripts/size.py b/scripts/size.py index d6d7466..bd83862 100755 --- a/scripts/size.py +++ b/scripts/size.py @@ -14,7 +14,7 @@ def file_len(fname): def main(c, n): l = [] for x in range(0, n): - subprocess.call(["verifuzz", "generate", "-o", "main.v", "-c", c]) + subprocess.call(["verismith", "generate", "-o", "main.v", "-c", c]) l.append(file_len("main.v")) os.remove("main.v") print("mean: ", statistics.mean(l)) diff --git a/scripts/swarm.py b/scripts/swarm.py index 99b0c54..1441121 100755 --- a/scripts/swarm.py +++ b/scripts/swarm.py @@ -12,11 +12,11 @@ def main(): if not os.path.exists(directory): os.makedirs(directory) while True: - subprocess.call(["verifuzz", "config" + subprocess.call(["verismith", "config" , "-c", config , "-o", directory + "/config_medium_random.toml" , "--randomise"]) - subprocess.call([ "verifuzz", "fuzz" + subprocess.call([ "verismith", "fuzz" , "-o", directory + "/" + name + str(i) , "-c", directory + "/config_medium_random.toml" , "-n", str(iterations)]) diff --git a/src/VeriFuzz.hs b/src/VeriFuzz.hs index 4f52108..6c1a1b5 100644 --- a/src/VeriFuzz.hs +++ b/src/VeriFuzz.hs @@ -1,6 +1,6 @@ {-| -Module : VeriFuzz -Description : VeriFuzz +Module : VeriSmith +Description : VeriSmith Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 Maintainer : yann [at] yannherklotz [dot] com @@ -10,7 +10,7 @@ Portability : POSIX {-# OPTIONS_GHC -Wno-unused-top-binds #-} -module VeriFuzz +module VeriSmith ( defaultMain -- * Types , Opts(..) @@ -27,12 +27,12 @@ module VeriFuzz , proceduralSrcIO , randomMod -- * Extra modules - , module VeriFuzz.Verilog - , module VeriFuzz.Config - , module VeriFuzz.Circuit - , module VeriFuzz.Sim - , module VeriFuzz.Fuzz - , module VeriFuzz.Report + , module VeriSmith.Verilog + , module VeriSmith.Config + , module VeriSmith.Circuit + , module VeriSmith.Sim + , module VeriSmith.Fuzz + , module VeriSmith.Report ) where @@ -58,17 +58,17 @@ import Prelude hiding (FilePath) import Shelly hiding (command) import Shelly.Lifted (liftSh) import System.Random (randomIO) -import VeriFuzz.Circuit -import VeriFuzz.Config -import VeriFuzz.Fuzz -import VeriFuzz.Generate -import VeriFuzz.Reduce -import VeriFuzz.Report -import VeriFuzz.Result -import VeriFuzz.Sim -import VeriFuzz.Sim.Internal -import VeriFuzz.Verilog -import VeriFuzz.Verilog.Parser (parseSourceInfoFile) +import VeriSmith.Circuit +import VeriSmith.Config +import VeriSmith.Fuzz +import VeriSmith.Generate +import VeriSmith.Reduce +import VeriSmith.Report +import VeriSmith.Result +import VeriSmith.Sim +import VeriSmith.Sim.Internal +import VeriSmith.Verilog +import VeriSmith.Verilog.Parser (parseSourceInfoFile) data OptTool = TYosys | TXST @@ -315,7 +315,7 @@ opts = info ( fullDesc <> progDesc "Fuzz different simulators and synthesisers." <> header - "VeriFuzz - A hardware simulator and synthesiser Verilog fuzzer." + "VeriSmith - A hardware simulator and synthesiser Verilog fuzzer." ) getConfig :: Maybe FilePath -> IO Config @@ -504,7 +504,7 @@ checkEquivalence :: SourceInfo -> Text -> IO Bool checkEquivalence src dir = shellyFailDir $ do mkdir_p (fromText dir) curr <- toTextIgnore <$> pwd - setenv "VERIFUZZ_ROOT" curr + setenv "VERISMITH_ROOT" curr cd (fromText dir) catch_sh ((runResultT $ runEquiv defaultYosys defaultVivado src) >> return True) @@ -527,7 +527,7 @@ runEquivalence seed gm t d k i = do shellyFailDir $ do mkdir_p (fromText d fromText n) curr <- toTextIgnore <$> pwd - setenv "VERIFUZZ_ROOT" curr + setenv "VERISMITH_ROOT" curr cd (fromText "output" fromText n) _ <- catch_sh diff --git a/src/VeriFuzz/Circuit.hs b/src/VeriFuzz/Circuit.hs index 6083c8e..aee0d57 100644 --- a/src/VeriFuzz/Circuit.hs +++ b/src/VeriFuzz/Circuit.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Circuit +Module : VeriSmith.Circuit Description : Definition of the circuit graph. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,7 +10,7 @@ Portability : POSIX Definition of the circuit graph. -} -module VeriFuzz.Circuit +module VeriSmith.Circuit ( -- * Circuit Gate(..) , Circuit(..) @@ -26,13 +26,13 @@ module VeriFuzz.Circuit where import Control.Lens -import Hedgehog (Gen) -import qualified Hedgehog.Gen as Hog -import VeriFuzz.Circuit.Base -import VeriFuzz.Circuit.Gen -import VeriFuzz.Circuit.Random -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.Mutate +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 fromGraph = do diff --git a/src/VeriFuzz/Circuit/Base.hs b/src/VeriFuzz/Circuit/Base.hs index 0bcdf39..ddcaf65 100644 --- a/src/VeriFuzz/Circuit/Base.hs +++ b/src/VeriFuzz/Circuit/Base.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Circuit.Base +Module : VeriSmith.Circuit.Base Description : Base types for the circuit module. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,7 +10,7 @@ Portability : POSIX Base types for the circuit module. -} -module VeriFuzz.Circuit.Base +module VeriSmith.Circuit.Base ( Gate(..) , Circuit(..) , CNode(..) diff --git a/src/VeriFuzz/Circuit/Gen.hs b/src/VeriFuzz/Circuit/Gen.hs index eb7cb97..1c4dd37 100644 --- a/src/VeriFuzz/Circuit/Gen.hs +++ b/src/VeriFuzz/Circuit/Gen.hs @@ -10,18 +10,18 @@ Portability : POSIX Generate verilog from circuit. -} -module VeriFuzz.Circuit.Gen +module VeriSmith.Circuit.Gen ( generateAST ) where -import Data.Graph.Inductive (LNode, Node) -import qualified Data.Graph.Inductive as G -import Data.Maybe (catMaybes) -import VeriFuzz.Circuit.Base -import VeriFuzz.Circuit.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.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 diff --git a/src/VeriFuzz/Circuit/Internal.hs b/src/VeriFuzz/Circuit/Internal.hs index 17e1586..b746738 100644 --- a/src/VeriFuzz/Circuit/Internal.hs +++ b/src/VeriFuzz/Circuit/Internal.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Circuit.Internal +Module : VeriSmith.Circuit.Internal Description : Internal helpers for generation. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,7 +10,7 @@ Portability : POSIX Internal helpers for generation. -} -module VeriFuzz.Circuit.Internal +module VeriSmith.Circuit.Internal ( fromNode , filterGr , only diff --git a/src/VeriFuzz/Circuit/Random.hs b/src/VeriFuzz/Circuit/Random.hs index fdb5253..ca8cc26 100644 --- a/src/VeriFuzz/Circuit/Random.hs +++ b/src/VeriFuzz/Circuit/Random.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Circuit.Random +Module : VeriSmith.Circuit.Random Description : Random generation for DAG Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,7 +10,7 @@ Portability : POSIX Define the random generation for the directed acyclic graph. -} -module VeriFuzz.Circuit.Random +module VeriSmith.Circuit.Random ( rDups , rDupsCirc , randomDAG @@ -25,7 +25,7 @@ import Data.List (nub) import Hedgehog (Gen) import qualified Hedgehog.Gen as Hog import qualified Hedgehog.Range as Hog -import VeriFuzz.Circuit.Base +import VeriSmith.Circuit.Base dupFolder :: (Eq a, Eq b) => Context a b -> [Context a b] -> [Context a b] dupFolder cont ns = unique cont : ns diff --git a/src/VeriFuzz/Config.hs b/src/VeriFuzz/Config.hs index 8705f7c..adc3d19 100644 --- a/src/VeriFuzz/Config.hs +++ b/src/VeriFuzz/Config.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Config +Module : VeriSmith.Config Description : Configuration file format and parser. Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -12,7 +12,7 @@ TOML Configuration file format and parser. {-# LANGUAGE TemplateHaskell #-} -module VeriFuzz.Config +module VeriSmith.Config ( -- * TOML Configuration -- $conf Config(..) @@ -88,18 +88,18 @@ import qualified Data.Text.IO as T import Data.Version (showVersion) import Development.GitRev import Hedgehog.Internal.Seed (Seed) -import Paths_verifuzz (version) +import Paths_verismith (version) import Shelly (toTextIgnore) import Toml (TomlCodec, (.=)) import qualified Toml -import VeriFuzz.Sim.Quartus -import VeriFuzz.Sim.Vivado -import VeriFuzz.Sim.XST -import VeriFuzz.Sim.Yosys +import VeriSmith.Sim.Quartus +import VeriSmith.Sim.Vivado +import VeriSmith.Sim.XST +import VeriSmith.Sim.Yosys -- $conf -- --- VeriFuzz supports a TOML configuration file that can be passed using the @-c@ +-- VeriSmith supports a TOML configuration file that can be passed using the @-c@ -- flag or using the 'parseConfig' and 'encodeConfig' functions. The -- configuration can then be manipulated using the lenses that are also provided -- in this module. @@ -111,7 +111,7 @@ import VeriFuzz.Sim.Yosys -- exact generation. A default value is associated with each key in the -- configuration file, which means that only the options that need overriding -- can be added to the configuration. The defaults can be observed in --- 'defaultConfig' or when running @verifuzz config@. +-- 'defaultConfig' or when running @verismith config@. -- -- == Configuration Sections -- @@ -487,7 +487,7 @@ encodeConfigFile f = T.writeFile f . encodeConfig versionInfo :: String versionInfo = - "VeriFuzz " + "VeriSmith " <> showVersion version <> " (" <> $(gitCommitDate) diff --git a/src/VeriFuzz/Fuzz.hs b/src/VeriFuzz/Fuzz.hs index df0ee2d..9331a5e 100644 --- a/src/VeriFuzz/Fuzz.hs +++ b/src/VeriFuzz/Fuzz.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Fuzz +Module : VeriSmith.Fuzz Description : Environment to run the simulator and synthesisers in a matrix. Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -14,7 +14,7 @@ Environment to run the simulator and synthesisers in a matrix. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} -module VeriFuzz.Fuzz +module VeriSmith.Fuzz ( Fuzz , fuzz , fuzzInDir @@ -54,16 +54,16 @@ import Prelude hiding (FilePath) import Shelly hiding (get) import Shelly.Lifted (MonadSh, liftSh) import System.FilePath.Posix (takeBaseName) -import VeriFuzz.Config -import VeriFuzz.Internal -import VeriFuzz.Reduce -import VeriFuzz.Report -import VeriFuzz.Result -import VeriFuzz.Sim.Icarus -import VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Yosys -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import VeriSmith.Config +import VeriSmith.Internal +import VeriSmith.Reduce +import VeriSmith.Report +import VeriSmith.Result +import VeriSmith.Sim.Icarus +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Yosys +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] , getSimulators :: ![SimTool] diff --git a/src/VeriFuzz/Generate.hs b/src/VeriFuzz/Generate.hs index a82f56b..095baee 100644 --- a/src/VeriFuzz/Generate.hs +++ b/src/VeriFuzz/Generate.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Generate +Module : VeriSmith.Generate Description : Various useful generators. Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -13,7 +13,7 @@ Various useful generators. {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-imports #-} -module VeriFuzz.Generate +module VeriSmith.Generate ( -- * Generation methods procedural , proceduralIO @@ -73,13 +73,13 @@ import qualified Data.Text as T import Hedgehog (Gen) import qualified Hedgehog.Gen as Hog import qualified Hedgehog.Range as Hog -import VeriFuzz.Config -import VeriFuzz.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec -import VeriFuzz.Verilog.Eval -import VeriFuzz.Verilog.Internal -import VeriFuzz.Verilog.Mutate +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 = Context { _variables :: [Port] , _parameters :: [Parameter] diff --git a/src/VeriFuzz/Internal.hs b/src/VeriFuzz/Internal.hs index c7105fc..86cb1f7 100644 --- a/src/VeriFuzz/Internal.hs +++ b/src/VeriFuzz/Internal.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Internal +Module : VeriSmith.Internal Description : Shared high level code used in the other modules internally. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,7 +10,7 @@ Portability : POSIX Shared high level code used in the other modules internally. -} -module VeriFuzz.Internal +module VeriSmith.Internal ( -- * Useful functions safe , showT diff --git a/src/VeriFuzz/Reduce.hs b/src/VeriFuzz/Reduce.hs index 61b7bba..c57b457 100644 --- a/src/VeriFuzz/Reduce.hs +++ b/src/VeriFuzz/Reduce.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Reduce +Module : VeriSmith.Reduce Description : Test case reducer implementation. Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -13,7 +13,7 @@ Test case reducer implementation. {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module VeriFuzz.Reduce +module VeriSmith.Reduce ( -- $strategy reduceWithScript , reduceSynth @@ -35,26 +35,26 @@ module VeriFuzz.Reduce ) where -import Control.Lens hiding ((<.>)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -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 ((<.>)) +import Control.Lens hiding ((<.>)) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +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 ((<.>)) import qualified Shelly -import Shelly.Lifted (MonadSh, liftSh) -import VeriFuzz.Internal -import VeriFuzz.Result -import VeriFuzz.Sim -import VeriFuzz.Sim.Internal -import VeriFuzz.Verilog -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.Mutate -import VeriFuzz.Verilog.Parser +import Shelly.Lifted (MonadSh, liftSh) +import VeriSmith.Internal +import VeriSmith.Result +import VeriSmith.Sim +import VeriSmith.Sim.Internal +import VeriSmith.Verilog +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.Mutate +import VeriSmith.Verilog.Parser -- $strategy diff --git a/src/VeriFuzz/Report.hs b/src/VeriFuzz/Report.hs index 56fd062..fe680c3 100644 --- a/src/VeriFuzz/Report.hs +++ b/src/VeriFuzz/Report.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-| -Module : VeriFuzz.Report +Module : VeriSmith.Report Description : Generate a report from a fuzz run. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -13,7 +13,7 @@ Generate a report from a fuzz run. {-# LANGUAGE TemplateHaskell #-} -module VeriFuzz.Report +module VeriSmith.Report ( SynthTool(..) , SynthStatus(..) , SynthResult(..) @@ -60,11 +60,11 @@ 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 VeriFuzz.Config -import VeriFuzz.Internal -import VeriFuzz.Result -import VeriFuzz.Sim -import VeriFuzz.Sim.Internal +import VeriSmith.Config +import VeriSmith.Internal +import VeriSmith.Result +import VeriSmith.Sim +import VeriSmith.Sim.Internal -- | Common type alias for synthesis results type UResult = Result Failed () diff --git a/src/VeriFuzz/Result.hs b/src/VeriFuzz/Result.hs index 61b1452..7bfbf9b 100644 --- a/src/VeriFuzz/Result.hs +++ b/src/VeriFuzz/Result.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Result +Module : VeriSmith.Result Description : Result monadic type. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -9,7 +9,7 @@ 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 "VeriFuzz". +needed in "VeriSmith". -} {-# LANGUAGE FlexibleContexts #-} @@ -19,7 +19,7 @@ needed in "VeriFuzz". {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module VeriFuzz.Result +module VeriSmith.Result ( Result(..) , ResultT(..) , () diff --git a/src/VeriFuzz/Sim.hs b/src/VeriFuzz/Sim.hs index 92d1bc4..f0489d3 100644 --- a/src/VeriFuzz/Sim.hs +++ b/src/VeriFuzz/Sim.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim +Module : VeriSmith.Sim Description : Simulator implementations. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,7 +10,7 @@ Portability : POSIX Simulator implementations. -} -module VeriFuzz.Sim +module VeriSmith.Sim ( -- * Simulators -- ** Icarus @@ -42,10 +42,10 @@ module VeriFuzz.Sim ) where -import VeriFuzz.Sim.Icarus -import VeriFuzz.Sim.Identity -import VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Quartus -import VeriFuzz.Sim.Vivado -import VeriFuzz.Sim.XST -import VeriFuzz.Sim.Yosys +import VeriSmith.Sim.Icarus +import VeriSmith.Sim.Identity +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Quartus +import VeriSmith.Sim.Vivado +import VeriSmith.Sim.XST +import VeriSmith.Sim.Yosys diff --git a/src/VeriFuzz/Sim/Icarus.hs b/src/VeriFuzz/Sim/Icarus.hs index e7c92dc..f104630 100644 --- a/src/VeriFuzz/Sim/Icarus.hs +++ b/src/VeriFuzz/Sim/Icarus.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Icarus +Module : VeriSmith.Sim.Icarus Description : Icarus verilog module. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,42 +10,42 @@ Portability : POSIX Icarus verilog module. -} -module VeriFuzz.Sim.Icarus +module VeriSmith.Sim.Icarus ( Icarus(..) , defaultIcarus , runSimIc ) where -import Control.DeepSeq (NFData, rnf, rwhnf) +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 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 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 VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Template -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec -import VeriFuzz.Verilog.CodeGen -import VeriFuzz.Verilog.Internal -import VeriFuzz.Verilog.Mutate +import Shelly.Lifted (liftSh) +import VeriSmith.Sim.Internal +import VeriSmith.Sim.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 diff --git a/src/VeriFuzz/Sim/Identity.hs b/src/VeriFuzz/Sim/Identity.hs index bfa99f5..cac230f 100644 --- a/src/VeriFuzz/Sim/Identity.hs +++ b/src/VeriFuzz/Sim/Identity.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Identity +Module : VeriSmith.Sim.Identity Description : The identity simulator and synthesiser. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,20 +10,20 @@ Portability : POSIX The identity simulator and synthesiser. -} -module VeriFuzz.Sim.Identity +module VeriSmith.Sim.Identity ( 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 VeriFuzz.Sim.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) +import Shelly (FilePath) +import Shelly.Lifted (writefile) +import VeriSmith.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text , identityOutput :: {-# UNPACK #-} !FilePath diff --git a/src/VeriFuzz/Sim/Internal.hs b/src/VeriFuzz/Sim/Internal.hs index f5351c7..017faad 100644 --- a/src/VeriFuzz/Sim/Internal.hs +++ b/src/VeriFuzz/Sim/Internal.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Internal +Module : VeriSmith.Sim.Internal Description : Class of the simulator. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -12,7 +12,7 @@ Class of the simulator and the synthesize tool. {-# LANGUAGE DeriveFunctor #-} -module VeriFuzz.Sim.Internal +module VeriSmith.Sim.Internal ( ResultSh , resultSh , Tool(..) @@ -54,9 +54,9 @@ import Prelude hiding (FilePath) import Shelly import Shelly.Lifted (MonadSh, liftSh) import System.FilePath.Posix (takeBaseName) -import VeriFuzz.Internal -import VeriFuzz.Result -import VeriFuzz.Verilog.AST +import VeriSmith.Internal +import VeriSmith.Result +import VeriSmith.Verilog.AST -- | Tool class. class Tool a where @@ -100,7 +100,7 @@ renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo renameSource a src = src & infoSrc . _Wrapped . traverse . modId . _Wrapped %~ (<> toText a) --- | Type synonym for a 'ResultT' that will be used throughout 'VeriFuzz'. This +-- | Type synonym for a 'ResultT' that will be used throughout 'VeriSmith'. This -- has instances for 'MonadSh' and 'MonadIO' if the 'Monad' it is parametrised -- with also has those instances. type ResultSh = ResultT Failed Sh @@ -146,7 +146,7 @@ replaceMods fp t (SourceInfo _ src) = rootPath :: Sh FilePath rootPath = do current <- pwd - maybe current fromText <$> get_env "VERIFUZZ_ROOT" + maybe current fromText <$> get_env "VERISMITH_ROOT" timeout :: FilePath -> [Text] -> Sh Text timeout = command1 "timeout" ["300"] . toTextIgnore @@ -170,7 +170,7 @@ logger t = do fn <- pwd currentTime <- liftIO getZonedTime echo - $ "VeriFuzz " + $ "VeriSmith " <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime) <> bname fn <> " - " diff --git a/src/VeriFuzz/Sim/Quartus.hs b/src/VeriFuzz/Sim/Quartus.hs index 254bfa5..6837133 100644 --- a/src/VeriFuzz/Sim/Quartus.hs +++ b/src/VeriFuzz/Sim/Quartus.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Quartus +Module : VeriSmith.Sim.Quartus Description : Quartus synthesiser implementation. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,20 +10,20 @@ Portability : POSIX Quartus synthesiser implementation. -} -module VeriFuzz.Sim.Quartus +module VeriSmith.Sim.Quartus ( Quartus(..) , defaultQuartus ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) import Shelly -import Shelly.Lifted (liftSh) -import VeriFuzz.Sim.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import Shelly.Lifted (liftSh) +import VeriSmith.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen data Quartus = Quartus { quartusBin :: !(Maybe FilePath) , quartusDesc :: {-# UNPACK #-} !Text diff --git a/src/VeriFuzz/Sim/Template.hs b/src/VeriFuzz/Sim/Template.hs index 9b8ee9f..d232420 100644 --- a/src/VeriFuzz/Sim/Template.hs +++ b/src/VeriFuzz/Sim/Template.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Template +Module : VeriSmith.Sim.Template Description : Template file for different configuration files Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -12,7 +12,7 @@ Template file for different configuration files. {-# LANGUAGE QuasiQuotes #-} -module VeriFuzz.Sim.Template +module VeriSmith.Sim.Template ( yosysSatConfig , yosysSimConfig , xstSynthConfig @@ -22,15 +22,15 @@ module VeriFuzz.Sim.Template ) where -import Control.Lens ((^..)) -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (FilePath) +import Control.Lens ((^..)) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (FilePath) import Shelly -import Text.Shakespeare.Text (st) -import VeriFuzz.Sim.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import Text.Shakespeare.Text (st) +import VeriSmith.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen rename :: Text -> [Text] -> Text rename end entries = diff --git a/src/VeriFuzz/Sim/Vivado.hs b/src/VeriFuzz/Sim/Vivado.hs index 4ddb048..e8d8f0d 100644 --- a/src/VeriFuzz/Sim/Vivado.hs +++ b/src/VeriFuzz/Sim/Vivado.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Vivado +Module : VeriSmith.Sim.Vivado Description : Vivado Synthesiser implementation. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,21 +10,21 @@ Portability : POSIX Vivado Synthesiser implementation. -} -module VeriFuzz.Sim.Vivado +module VeriSmith.Sim.Vivado ( Vivado(..) , defaultVivado ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) import Shelly -import Shelly.Lifted (liftSh) -import VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Template -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import Shelly.Lifted (liftSh) +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) , vivadoDesc :: {-# UNPACK #-} !Text diff --git a/src/VeriFuzz/Sim/XST.hs b/src/VeriFuzz/Sim/XST.hs index 86db667..30a4b0b 100644 --- a/src/VeriFuzz/Sim/XST.hs +++ b/src/VeriFuzz/Sim/XST.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.XST +Module : VeriSmith.Sim.XST Description : XST (ise) simulator implementation. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -12,22 +12,22 @@ XST (ise) simulator implementation. {-# LANGUAGE QuasiQuotes #-} -module VeriFuzz.Sim.XST +module VeriSmith.Sim.XST ( XST(..) , defaultXST ) where -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) import Shelly -import Shelly.Lifted (liftSh) -import Text.Shakespeare.Text (st) -import VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Template -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen +import Shelly.Lifted (liftSh) +import Text.Shakespeare.Text (st) +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen data XST = XST { xstBin :: !(Maybe FilePath) , xstDesc :: {-# UNPACK #-} !Text diff --git a/src/VeriFuzz/Sim/Yosys.hs b/src/VeriFuzz/Sim/Yosys.hs index 8c73b86..1f583a8 100644 --- a/src/VeriFuzz/Sim/Yosys.hs +++ b/src/VeriFuzz/Sim/Yosys.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Sim.Yosys +Module : VeriSmith.Sim.Yosys Description : Yosys simulator implementation. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -12,7 +12,7 @@ Yosys simulator implementation. {-# LANGUAGE QuasiQuotes #-} -module VeriFuzz.Sim.Yosys +module VeriSmith.Sim.Yosys ( Yosys(..) , defaultYosys , runEquiv @@ -20,20 +20,20 @@ module VeriFuzz.Sim.Yosys ) where -import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.DeepSeq (NFData, rnf, rwhnf) import Control.Lens -import Control.Monad (void) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) +import Control.Monad (void) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) import Shelly -import Shelly.Lifted (liftSh) -import Text.Shakespeare.Text (st) -import VeriFuzz.Result -import VeriFuzz.Sim.Internal -import VeriFuzz.Sim.Template -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen -import VeriFuzz.Verilog.Mutate +import Shelly.Lifted (liftSh) +import Text.Shakespeare.Text (st) +import VeriSmith.Result +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen +import VeriSmith.Verilog.Mutate data Yosys = Yosys { yosysBin :: !(Maybe FilePath) , yosysDesc :: {-# UNPACK #-} !Text diff --git a/src/VeriFuzz/Verilog.hs b/src/VeriFuzz/Verilog.hs index 4b5029c..6e7851c 100644 --- a/src/VeriFuzz/Verilog.hs +++ b/src/VeriFuzz/Verilog.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog +Module : VeriSmith.Verilog Description : Verilog implementation with random generation and mutations. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -12,7 +12,7 @@ Verilog implementation with random generation and mutations. {-# LANGUAGE QuasiQuotes #-} -module VeriFuzz.Verilog +module VeriSmith.Verilog ( SourceInfo(..) , Verilog(..) , parseVerilog @@ -100,7 +100,7 @@ module VeriFuzz.Verilog ) where -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.CodeGen -import VeriFuzz.Verilog.Parser -import VeriFuzz.Verilog.Quote +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen +import VeriSmith.Verilog.Parser +import VeriSmith.Verilog.Quote diff --git a/src/VeriFuzz/Verilog/AST.hs b/src/VeriFuzz/Verilog/AST.hs index a85c365..78bad45 100644 --- a/src/VeriFuzz/Verilog/AST.hs +++ b/src/VeriFuzz/Verilog/AST.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.AST +Module : VeriSmith.Verilog.AST Description : Definition of the Verilog AST types. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -22,7 +22,7 @@ Defines the types to build a Verilog AST. {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module VeriFuzz.Verilog.AST +module VeriSmith.Verilog.AST ( -- * Top level types SourceInfo(..) , infoTop @@ -150,7 +150,7 @@ import Data.String (IsString, fromString) import Data.Text (Text, pack) import Data.Traversable (sequenceA) import GHC.Generics (Generic) -import VeriFuzz.Verilog.BitVec +import VeriSmith.Verilog.BitVec -- | 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, diff --git a/src/VeriFuzz/Verilog/BitVec.hs b/src/VeriFuzz/Verilog/BitVec.hs index 0cc9eb3..dab9e2c 100644 --- a/src/VeriFuzz/Verilog/BitVec.hs +++ b/src/VeriFuzz/Verilog/BitVec.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.BitVec +Module : VeriSmith.Verilog.BitVec Description : Unsigned BitVec implementation. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -17,7 +17,7 @@ Unsigned BitVec implementation. {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} -module VeriFuzz.Verilog.BitVec +module VeriSmith.Verilog.BitVec ( BitVecF(..) , BitVec , bitVec diff --git a/src/VeriFuzz/Verilog/CodeGen.hs b/src/VeriFuzz/Verilog/CodeGen.hs index 56e2819..1e94472 100644 --- a/src/VeriFuzz/Verilog/CodeGen.hs +++ b/src/VeriFuzz/Verilog/CodeGen.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.CodeGen +Module : VeriSmith.Verilog.CodeGen Description : Code generation for Verilog AST. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -8,13 +8,13 @@ Stability : experimental Portability : POSIX This module generates the code from the Verilog AST defined in -"VeriFuzz.Verilog.AST". +"VeriSmith.Verilog.AST". -} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} -module VeriFuzz.Verilog.CodeGen +module VeriSmith.Verilog.CodeGen ( -- * Code Generation GenVerilog(..) , Source(..) @@ -28,9 +28,9 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Prettyprint.Doc import Numeric (showHex) -import VeriFuzz.Internal hiding (comma) -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec +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 diff --git a/src/VeriFuzz/Verilog/Eval.hs b/src/VeriFuzz/Verilog/Eval.hs index c802267..1ebaa80 100644 --- a/src/VeriFuzz/Verilog/Eval.hs +++ b/src/VeriFuzz/Verilog/Eval.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Eval +Module : VeriSmith.Verilog.Eval Description : Evaluation of Verilog expressions and statements. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,18 +10,18 @@ Portability : POSIX Evaluation of Verilog expressions and statements. -} -module VeriFuzz.Verilog.Eval +module VeriSmith.Verilog.Eval ( evaluateConst , resize ) where import Data.Bits -import Data.Foldable (fold) -import Data.Functor.Foldable hiding (fold) -import Data.Maybe (listToMaybe) -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec +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] diff --git a/src/VeriFuzz/Verilog/Internal.hs b/src/VeriFuzz/Verilog/Internal.hs index 42eb4e2..ed91b12 100644 --- a/src/VeriFuzz/Verilog/Internal.hs +++ b/src/VeriFuzz/Verilog/Internal.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Internal +Module : VeriSmith.Verilog.Internal Description : Defaults and common functions. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -10,7 +10,7 @@ Portability : POSIX Defaults and common functions. -} -module VeriFuzz.Verilog.Internal +module VeriSmith.Verilog.Internal ( regDecl , wireDecl , emptyMod @@ -29,8 +29,8 @@ module VeriFuzz.Verilog.Internal where import Control.Lens -import Data.Text (Text) -import VeriFuzz.Verilog.AST +import Data.Text (Text) +import VeriSmith.Verilog.AST regDecl :: Identifier -> ModItem regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing diff --git a/src/VeriFuzz/Verilog/Lex.x b/src/VeriFuzz/Verilog/Lex.x index cc67ecc..3d1dd8d 100644 --- a/src/VeriFuzz/Verilog/Lex.x +++ b/src/VeriFuzz/Verilog/Lex.x @@ -1,11 +1,11 @@ -- -*- haskell -*- { {-# OPTIONS_GHC -w #-} -module VeriFuzz.Verilog.Lex +module VeriSmith.Verilog.Lex ( alexScanTokens ) where -import VeriFuzz.Verilog.Token +import VeriSmith.Verilog.Token } diff --git a/src/VeriFuzz/Verilog/Mutate.hs b/src/VeriFuzz/Verilog/Mutate.hs index 37d3a7d..58675e3 100644 --- a/src/VeriFuzz/Verilog/Mutate.hs +++ b/src/VeriFuzz/Verilog/Mutate.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Mutate +Module : VeriSmith.Verilog.Mutate Description : Functions to mutate the Verilog AST. Copyright : (c) 2018-2019, Yann Herklotz License : BSD-3 @@ -7,13 +7,13 @@ Maintainer : yann [at] yannherklotz [dot] com Stability : experimental Portability : POSIX -Functions to mutate the Verilog AST from "VeriFuzz.Verilog.AST" to generate more +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 VeriFuzz.Verilog.Mutate +module VeriSmith.Verilog.Mutate ( Mutate(..) , inPort , findAssign @@ -41,16 +41,16 @@ module VeriFuzz.Verilog.Mutate where import Control.Lens -import Data.Foldable (fold) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import VeriFuzz.Circuit.Internal -import VeriFuzz.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec -import VeriFuzz.Verilog.CodeGen -import VeriFuzz.Verilog.Internal +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 @@ -210,7 +210,7 @@ allVars m = <> (m ^.. modInPorts . traverse . portName) -- $setup --- >>> import VeriFuzz.Verilog.CodeGen +-- >>> import VeriSmith.Verilog.CodeGen -- >>> let m = (ModDecl (Identifier "m") [Port Wire False 5 (Identifier "y")] [Port Wire False 5 "x"] [] []) -- >>> let main = (ModDecl "main" [] [] [] []) diff --git a/src/VeriFuzz/Verilog/Parser.hs b/src/VeriFuzz/Verilog/Parser.hs index c08ebcd..8d2b729 100644 --- a/src/VeriFuzz/Verilog/Parser.hs +++ b/src/VeriFuzz/Verilog/Parser.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Parser +Module : VeriSmith.Verilog.Parser Description : Minimal Verilog parser to reconstruct the AST. Copyright : (c) 2019, Yann Herklotz License : GPL-3 @@ -11,7 +11,7 @@ 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 VeriFuzz.Verilog.Parser +module VeriSmith.Verilog.Parser ( -- * Parser parseVerilog , parseVerilogFile @@ -26,25 +26,25 @@ module VeriFuzz.Verilog.Parser where import Control.Lens -import Control.Monad (void) -import Data.Bifunctor (bimap) +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 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 VeriFuzz.Internal -import VeriFuzz.Verilog.AST -import VeriFuzz.Verilog.BitVec -import VeriFuzz.Verilog.Internal -import VeriFuzz.Verilog.Lex -import VeriFuzz.Verilog.Preprocess -import VeriFuzz.Verilog.Token +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] () diff --git a/src/VeriFuzz/Verilog/Preprocess.hs b/src/VeriFuzz/Verilog/Preprocess.hs index c783ac5..c30252b 100644 --- a/src/VeriFuzz/Verilog/Preprocess.hs +++ b/src/VeriFuzz/Verilog/Preprocess.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Preprocess +Module : VeriSmith.Verilog.Preprocess Description : Simple preprocessor for `define and comments. Copyright : (c) 2011-2015 Tom Hawkins, 2019 Yann Herklotz License : GPL-3 @@ -14,7 +14,7 @@ The code is from https://github.com/tomahawkins/verilog. Edits to the original code are warning fixes and formatting changes. -} -module VeriFuzz.Verilog.Preprocess +module VeriSmith.Verilog.Preprocess ( uncomment , preprocess ) diff --git a/src/VeriFuzz/Verilog/Quote.hs b/src/VeriFuzz/Verilog/Quote.hs index c6d3e3c..3815fe6 100644 --- a/src/VeriFuzz/Verilog/Quote.hs +++ b/src/VeriFuzz/Verilog/Quote.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Quote +Module : VeriSmith.Verilog.Quote Description : QuasiQuotation for verilog code in Haskell. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -12,7 +12,7 @@ QuasiQuotation for verilog code in Haskell. {-# LANGUAGE TemplateHaskell #-} -module VeriFuzz.Verilog.Quote +module VeriSmith.Verilog.Quote ( verilog ) where @@ -22,7 +22,7 @@ import qualified Data.Text as T import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax -import VeriFuzz.Verilog.Parser +import VeriSmith.Verilog.Parser liftDataWithText :: Data a => a -> Q Exp liftDataWithText = dataToExpQ $ fmap liftText . cast diff --git a/src/VeriFuzz/Verilog/Token.hs b/src/VeriFuzz/Verilog/Token.hs index d69f0b3..590672e 100644 --- a/src/VeriFuzz/Verilog/Token.hs +++ b/src/VeriFuzz/Verilog/Token.hs @@ -1,5 +1,5 @@ {-| -Module : VeriFuzz.Verilog.Token +Module : VeriSmith.Verilog.Token Description : Tokens for Verilog parsing. Copyright : (c) 2019, Yann Herklotz Grave License : GPL-3 @@ -10,7 +10,7 @@ Portability : POSIX Tokens for Verilog parsing. -} -module VeriFuzz.Verilog.Token +module VeriSmith.Verilog.Token ( Token(..) , TokenName(..) , Position(..) diff --git a/test/Benchmark.hs b/test/Benchmark.hs index d0ea9cd..7d59e2d 100644 --- a/test/Benchmark.hs +++ b/test/Benchmark.hs @@ -2,7 +2,7 @@ module Main where import Control.Lens ((&), (.~)) import Criterion.Main (bench, bgroup, defaultMain, nfAppIO) -import VeriFuzz (configProperty, defaultConfig, proceduralIO, +import VeriSmith (configProperty, defaultConfig, proceduralIO, propSize, propStmntDepth) main :: IO () diff --git a/test/Parser.hs b/test/Parser.hs index d300d8a..b372bbe 100644 --- a/test/Parser.hs +++ b/test/Parser.hs @@ -17,18 +17,18 @@ module Parser 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 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 VeriFuzz -import VeriFuzz.Internal -import VeriFuzz.Verilog.Lex -import VeriFuzz.Verilog.Parser +import VeriSmith +import VeriSmith.Internal +import VeriSmith.Verilog.Lex +import VeriSmith.Verilog.Parser smallConfig :: Config smallConfig = defaultConfig & configProperty . propSize .~ 5 diff --git a/test/Property.hs b/test/Property.hs index 4e17695..afb1d11 100644 --- a/test/Property.hs +++ b/test/Property.hs @@ -11,30 +11,23 @@ module Property ) 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 Hedgehog.Function ( Arg - , Vary - ) -import qualified Hedgehog.Function as Hog -import qualified Hedgehog.Gen as Hog -import qualified Hedgehog.Range as Hog -import Parser ( parserTests ) +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 Hedgehog.Function (Arg, Vary) +import qualified Hedgehog.Function 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 VeriFuzz -import VeriFuzz.Result -import VeriFuzz.Verilog.Lex -import VeriFuzz.Verilog.Parser +import VeriSmith +import VeriSmith.Result +import VeriSmith.Verilog.Lex +import VeriSmith.Verilog.Parser randomDAG' :: Gen Circuit randomDAG' = Hog.resize 30 randomDAG diff --git a/test/Reduce.hs b/test/Reduce.hs index 722ddea..f3ddf5c 100644 --- a/test/Reduce.hs +++ b/test/Reduce.hs @@ -20,8 +20,8 @@ where import Data.List ((\\)) import Test.Tasty import Test.Tasty.HUnit -import VeriFuzz -import VeriFuzz.Reduce +import VeriSmith +import VeriSmith.Reduce reduceUnitTests :: TestTree reduceUnitTests = testGroup diff --git a/test/Unit.hs b/test/Unit.hs index aaffe09..f9283be 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -4,12 +4,12 @@ module Unit where import Control.Lens -import Data.List.NonEmpty ( NonEmpty(..) ) -import Parser ( parseUnitTests ) -import Reduce ( reduceUnitTests ) +import Data.List.NonEmpty (NonEmpty (..)) +import Parser (parseUnitTests) +import Reduce (reduceUnitTests) import Test.Tasty import Test.Tasty.HUnit -import VeriFuzz +import VeriSmith unitTests :: TestTree unitTests = testGroup diff --git a/verifuzz.cabal b/verifuzz.cabal index 6d15d45..ef27082 100644 --- a/verifuzz.cabal +++ b/verifuzz.cabal @@ -1,10 +1,10 @@ -name: verifuzz +name: verismith version: 0.3.1.0 synopsis: Random verilog generation and simulator testing. description: - VeriFuzz provides random verilog generation modules + VeriSmith provides random verilog generation modules implementing functions to test supported simulators. -homepage: https://github.com/ymherklotz/VeriFuzz#readme +homepage: https://github.com/ymherklotz/VeriSmith#readme license: BSD3 license-file: LICENSE author: Yann Herklotz @@ -26,41 +26,41 @@ library hs-source-dirs: src default-language: Haskell2010 build-tools: alex >=3 && <4 - other-modules: Paths_verifuzz - exposed-modules: VeriFuzz - , VeriFuzz.Circuit - , VeriFuzz.Circuit.Base - , VeriFuzz.Circuit.Gen - , VeriFuzz.Circuit.Internal - , VeriFuzz.Circuit.Random - , VeriFuzz.Config - , VeriFuzz.Fuzz - , VeriFuzz.Generate - , VeriFuzz.Internal - , VeriFuzz.Reduce - , VeriFuzz.Report - , VeriFuzz.Result - , VeriFuzz.Sim - , VeriFuzz.Sim.Icarus - , VeriFuzz.Sim.Identity - , VeriFuzz.Sim.Internal - , VeriFuzz.Sim.Quartus - , VeriFuzz.Sim.Template - , VeriFuzz.Sim.Vivado - , VeriFuzz.Sim.XST - , VeriFuzz.Sim.Yosys - , VeriFuzz.Verilog - , VeriFuzz.Verilog.AST - , VeriFuzz.Verilog.BitVec - , VeriFuzz.Verilog.CodeGen - , VeriFuzz.Verilog.Eval - , VeriFuzz.Verilog.Internal - , VeriFuzz.Verilog.Lex - , VeriFuzz.Verilog.Mutate - , VeriFuzz.Verilog.Parser - , VeriFuzz.Verilog.Preprocess - , VeriFuzz.Verilog.Quote - , VeriFuzz.Verilog.Token + other-modules: Paths_verismith + exposed-modules: VeriSmith + , VeriSmith.Circuit + , VeriSmith.Circuit.Base + , VeriSmith.Circuit.Gen + , VeriSmith.Circuit.Internal + , VeriSmith.Circuit.Random + , VeriSmith.Config + , VeriSmith.Fuzz + , VeriSmith.Generate + , VeriSmith.Internal + , VeriSmith.Reduce + , VeriSmith.Report + , VeriSmith.Result + , VeriSmith.Sim + , VeriSmith.Sim.Icarus + , VeriSmith.Sim.Identity + , VeriSmith.Sim.Internal + , VeriSmith.Sim.Quartus + , VeriSmith.Sim.Template + , VeriSmith.Sim.Vivado + , VeriSmith.Sim.XST + , VeriSmith.Sim.Yosys + , VeriSmith.Verilog + , VeriSmith.Verilog.AST + , VeriSmith.Verilog.BitVec + , VeriSmith.Verilog.CodeGen + , VeriSmith.Verilog.Eval + , VeriSmith.Verilog.Internal + , VeriSmith.Verilog.Lex + , VeriSmith.Verilog.Mutate + , VeriSmith.Verilog.Parser + , VeriSmith.Verilog.Preprocess + , VeriSmith.Verilog.Quote + , VeriSmith.Verilog.Token build-depends: base >=4.7 && <5 -- Cannot upgrade to 1.0 because of missing MonadGen instance for -- StateT. @@ -99,13 +99,13 @@ library , unordered-containers >=0.2.10 && <0.3 default-extensions: OverloadedStrings -executable verifuzz +executable verismith hs-source-dirs: app main-is: Main.hs default-language: Haskell2010 ghc-options: -threaded build-depends: base >= 4.7 && < 5 - , verifuzz + , verismith default-extensions: OverloadedStrings benchmark benchmark @@ -114,7 +114,7 @@ benchmark benchmark hs-source-dirs: test main-is: Benchmark.hs build-depends: base >=4 && <5 - , verifuzz + , verismith , criterion >=1.5.5 && <1.6 , lens >=4.16.1 && <4.18 default-extensions: OverloadedStrings @@ -129,7 +129,7 @@ test-suite test , Reduce , Parser build-depends: base >=4 && <5 - , verifuzz + , verismith , fgl >=5.6 && <5.8 , tasty >=1.0.1.1 && <1.3 , tasty-hunit >=0.10 && <0.11 @@ -151,5 +151,5 @@ test-suite test -- build-depends: base >=4.7 && <5 -- , doctest >=0.16 && <0.17 -- , Glob >=0.9.3 && <0.11 --- , verifuzz +-- , verismith -- default-extensions: OverloadedStrings -- cgit From a2b01b92612a098673ff03890e6e8aef4ceb28ea Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Wed, 4 Sep 2019 20:15:51 +1000 Subject: Renaming to VeriSmith --- src/VeriFuzz.hs | 553 -------------------------------- src/VeriFuzz/Circuit.hs | 45 --- src/VeriFuzz/Circuit/Base.hs | 44 --- src/VeriFuzz/Circuit/Gen.hs | 79 ----- src/VeriFuzz/Circuit/Internal.hs | 55 ---- src/VeriFuzz/Circuit/Random.hs | 67 ---- src/VeriFuzz/Config.hs | 496 ---------------------------- src/VeriFuzz/Fuzz.hs | 466 --------------------------- src/VeriFuzz/Generate.hs | 623 ------------------------------------ src/VeriFuzz/Internal.hs | 49 --- src/VeriFuzz/Reduce.hs | 609 ----------------------------------- src/VeriFuzz/Report.hs | 398 ----------------------- src/VeriFuzz/Result.hs | 137 -------- src/VeriFuzz/Sim.hs | 51 --- src/VeriFuzz/Sim/Icarus.hs | 188 ----------- src/VeriFuzz/Sim/Identity.hs | 51 --- src/VeriFuzz/Sim/Internal.hs | 215 ------------- src/VeriFuzz/Sim/Quartus.hs | 77 ----- src/VeriFuzz/Sim/Template.hs | 133 -------- src/VeriFuzz/Sim/Vivado.hs | 71 ---- src/VeriFuzz/Sim/XST.hs | 85 ----- src/VeriFuzz/Sim/Yosys.hs | 127 -------- src/VeriFuzz/Verilog.hs | 106 ------ src/VeriFuzz/Verilog/AST.hs | 583 --------------------------------- src/VeriFuzz/Verilog/BitVec.hs | 119 ------- src/VeriFuzz/Verilog/CodeGen.hs | 341 -------------------- src/VeriFuzz/Verilog/Eval.hs | 119 ------- src/VeriFuzz/Verilog/Internal.hs | 93 ------ src/VeriFuzz/Verilog/Lex.x | 188 ----------- src/VeriFuzz/Verilog/Mutate.hs | 401 ----------------------- src/VeriFuzz/Verilog/Parser.hs | 511 ----------------------------- src/VeriFuzz/Verilog/Preprocess.hs | 111 ------- src/VeriFuzz/Verilog/Quote.hs | 50 --- src/VeriFuzz/Verilog/Token.hs | 350 -------------------- src/VeriSmith.hs | 553 ++++++++++++++++++++++++++++++++ src/VeriSmith/Circuit.hs | 45 +++ src/VeriSmith/Circuit/Base.hs | 44 +++ src/VeriSmith/Circuit/Gen.hs | 79 +++++ src/VeriSmith/Circuit/Internal.hs | 55 ++++ src/VeriSmith/Circuit/Random.hs | 67 ++++ src/VeriSmith/Config.hs | 496 ++++++++++++++++++++++++++++ src/VeriSmith/Fuzz.hs | 466 +++++++++++++++++++++++++++ src/VeriSmith/Generate.hs | 623 ++++++++++++++++++++++++++++++++++++ src/VeriSmith/Internal.hs | 49 +++ src/VeriSmith/Reduce.hs | 609 +++++++++++++++++++++++++++++++++++ src/VeriSmith/Report.hs | 398 +++++++++++++++++++++++ src/VeriSmith/Result.hs | 137 ++++++++ src/VeriSmith/Sim.hs | 51 +++ src/VeriSmith/Sim/Icarus.hs | 188 +++++++++++ src/VeriSmith/Sim/Identity.hs | 51 +++ src/VeriSmith/Sim/Internal.hs | 215 +++++++++++++ src/VeriSmith/Sim/Quartus.hs | 77 +++++ src/VeriSmith/Sim/Template.hs | 133 ++++++++ src/VeriSmith/Sim/Vivado.hs | 71 ++++ src/VeriSmith/Sim/XST.hs | 85 +++++ src/VeriSmith/Sim/Yosys.hs | 127 ++++++++ src/VeriSmith/Verilog.hs | 106 ++++++ src/VeriSmith/Verilog/AST.hs | 583 +++++++++++++++++++++++++++++++++ src/VeriSmith/Verilog/BitVec.hs | 119 +++++++ src/VeriSmith/Verilog/CodeGen.hs | 341 ++++++++++++++++++++ src/VeriSmith/Verilog/Eval.hs | 119 +++++++ src/VeriSmith/Verilog/Internal.hs | 93 ++++++ src/VeriSmith/Verilog/Lex.x | 188 +++++++++++ src/VeriSmith/Verilog/Mutate.hs | 401 +++++++++++++++++++++++ src/VeriSmith/Verilog/Parser.hs | 511 +++++++++++++++++++++++++++++ src/VeriSmith/Verilog/Preprocess.hs | 111 +++++++ src/VeriSmith/Verilog/Quote.hs | 50 +++ src/VeriSmith/Verilog/Token.hs | 350 ++++++++++++++++++++ 68 files changed, 7591 insertions(+), 7591 deletions(-) delete mode 100644 src/VeriFuzz.hs delete mode 100644 src/VeriFuzz/Circuit.hs delete mode 100644 src/VeriFuzz/Circuit/Base.hs delete mode 100644 src/VeriFuzz/Circuit/Gen.hs delete mode 100644 src/VeriFuzz/Circuit/Internal.hs delete mode 100644 src/VeriFuzz/Circuit/Random.hs delete mode 100644 src/VeriFuzz/Config.hs delete mode 100644 src/VeriFuzz/Fuzz.hs delete mode 100644 src/VeriFuzz/Generate.hs delete mode 100644 src/VeriFuzz/Internal.hs delete mode 100644 src/VeriFuzz/Reduce.hs delete mode 100644 src/VeriFuzz/Report.hs delete mode 100644 src/VeriFuzz/Result.hs delete mode 100644 src/VeriFuzz/Sim.hs delete mode 100644 src/VeriFuzz/Sim/Icarus.hs delete mode 100644 src/VeriFuzz/Sim/Identity.hs delete mode 100644 src/VeriFuzz/Sim/Internal.hs delete mode 100644 src/VeriFuzz/Sim/Quartus.hs delete mode 100644 src/VeriFuzz/Sim/Template.hs delete mode 100644 src/VeriFuzz/Sim/Vivado.hs delete mode 100644 src/VeriFuzz/Sim/XST.hs delete mode 100644 src/VeriFuzz/Sim/Yosys.hs delete mode 100644 src/VeriFuzz/Verilog.hs delete mode 100644 src/VeriFuzz/Verilog/AST.hs delete mode 100644 src/VeriFuzz/Verilog/BitVec.hs delete mode 100644 src/VeriFuzz/Verilog/CodeGen.hs delete mode 100644 src/VeriFuzz/Verilog/Eval.hs delete mode 100644 src/VeriFuzz/Verilog/Internal.hs delete mode 100644 src/VeriFuzz/Verilog/Lex.x delete mode 100644 src/VeriFuzz/Verilog/Mutate.hs delete mode 100644 src/VeriFuzz/Verilog/Parser.hs delete mode 100644 src/VeriFuzz/Verilog/Preprocess.hs delete mode 100644 src/VeriFuzz/Verilog/Quote.hs delete mode 100644 src/VeriFuzz/Verilog/Token.hs create mode 100644 src/VeriSmith.hs create mode 100644 src/VeriSmith/Circuit.hs create mode 100644 src/VeriSmith/Circuit/Base.hs create mode 100644 src/VeriSmith/Circuit/Gen.hs create mode 100644 src/VeriSmith/Circuit/Internal.hs create mode 100644 src/VeriSmith/Circuit/Random.hs create mode 100644 src/VeriSmith/Config.hs create mode 100644 src/VeriSmith/Fuzz.hs create mode 100644 src/VeriSmith/Generate.hs create mode 100644 src/VeriSmith/Internal.hs create mode 100644 src/VeriSmith/Reduce.hs create mode 100644 src/VeriSmith/Report.hs create mode 100644 src/VeriSmith/Result.hs create mode 100644 src/VeriSmith/Sim.hs create mode 100644 src/VeriSmith/Sim/Icarus.hs create mode 100644 src/VeriSmith/Sim/Identity.hs create mode 100644 src/VeriSmith/Sim/Internal.hs create mode 100644 src/VeriSmith/Sim/Quartus.hs create mode 100644 src/VeriSmith/Sim/Template.hs create mode 100644 src/VeriSmith/Sim/Vivado.hs create mode 100644 src/VeriSmith/Sim/XST.hs create mode 100644 src/VeriSmith/Sim/Yosys.hs create mode 100644 src/VeriSmith/Verilog.hs create mode 100644 src/VeriSmith/Verilog/AST.hs create mode 100644 src/VeriSmith/Verilog/BitVec.hs create mode 100644 src/VeriSmith/Verilog/CodeGen.hs create mode 100644 src/VeriSmith/Verilog/Eval.hs create mode 100644 src/VeriSmith/Verilog/Internal.hs create mode 100644 src/VeriSmith/Verilog/Lex.x create mode 100644 src/VeriSmith/Verilog/Mutate.hs create mode 100644 src/VeriSmith/Verilog/Parser.hs create mode 100644 src/VeriSmith/Verilog/Preprocess.hs create mode 100644 src/VeriSmith/Verilog/Quote.hs create mode 100644 src/VeriSmith/Verilog/Token.hs diff --git a/src/VeriFuzz.hs b/src/VeriFuzz.hs deleted file mode 100644 index 6c1a1b5..0000000 --- a/src/VeriFuzz.hs +++ /dev/null @@ -1,553 +0,0 @@ -{-| -Module : VeriSmith -Description : VeriSmith -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX --} - -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module VeriSmith - ( defaultMain - -- * Types - , Opts(..) - , SourceInfo(..) - -- * Run functions - , runEquivalence - , runSimulation - , runReduce - , draw - -- * Verilog generation functions - , procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod - -- * Extra modules - , module VeriSmith.Verilog - , module VeriSmith.Config - , module VeriSmith.Circuit - , module VeriSmith.Sim - , module VeriSmith.Fuzz - , module VeriSmith.Report - ) -where - -import Control.Concurrent -import Control.Lens hiding ((<.>)) -import Control.Monad.IO.Class (liftIO) -import qualified Crypto.Random.DRBG as C -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 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.Reduce -import VeriSmith.Report -import VeriSmith.Result -import VeriSmith.Sim -import VeriSmith.Sim.Internal -import VeriSmith.Verilog -import VeriSmith.Verilog.Parser (parseSourceInfoFile) - -data OptTool = TYosys - | TXST - | TIcarus - -instance Show OptTool where - show TYosys = "yosys" - show TXST = "xst" - show TIcarus = "icarus" - -data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text - , configFile :: !(Maybe FilePath) - , forced :: !Bool - , keepAll :: !Bool - , num :: {-# UNPACK #-} !Int - } - | Generate { mFileName :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - } - | Parse { fileName :: {-# UNPACK #-} !FilePath - } - | Reduce { fileName :: {-# UNPACK #-} !FilePath - , top :: {-# UNPACK #-} !Text - , reduceScript :: !(Maybe FilePath) - , synthesiserDesc :: ![SynthDescription] - , rerun :: Bool - } - | ConfigOpt { writeConfig :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - , doRandomise :: !Bool - } - -myForkIO :: IO () -> IO (MVar ()) -myForkIO io = do - mvar <- newEmptyMVar - _ <- forkFinally io (\_ -> putMVar mvar ()) - return mvar - -textOption :: Mod OptionFields String -> Parser Text -textOption = fmap T.pack . strOption - -optReader :: (String -> Maybe a) -> ReadM a -optReader f = eitherReader $ \arg -> case f arg of - 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 - -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 - -parseSim :: String -> Maybe OptTool -parseSim val | val == "icarus" = Just TIcarus - | otherwise = Nothing - -fuzzOpts :: Parser Opts -fuzzOpts = - Fuzz - <$> textOption - ( long "output" - <> short 'o' - <> metavar "DIR" - <> help "Output directory that the fuzz run takes place in." - <> showDefault - <> value "output" - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> (switch $ long "force" <> short 'f' <> help - "Overwrite the specified directory." - ) - <*> (switch $ long "keep" <> short 'k' <> help - "Keep all the directories." - ) - <*> ( option auto - $ long "num" - <> short 'n' - <> help "The number of fuzz runs that should be performed." - <> showDefault - <> value 1 - <> metavar "INT" - ) - -genOpts :: Parser Opts -genOpts = - Generate - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a verilog file instead." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the generation run." - ) - -parseOpts :: Parser Opts -parseOpts = Parse . fromText . T.pack <$> strArgument - (metavar "FILE" <> help "Verilog input file.") - -reduceOpts :: Parser Opts -reduceOpts = - Reduce - . fromText - . T.pack - <$> strArgument (metavar "FILE" <> help "Verilog input file.") - <*> textOption - ( short 't' - <> long "top" - <> metavar "TOP" - <> help "Name of top level module." - <> showDefault - <> value "top" - ) - <*> ( optional - . strOption - $ long "script" - <> metavar "SCRIPT" - <> help - "Script that determines if the current file is interesting, which is determined by the script returning 0." - ) - <*> ( many - . option (optReader parseSynthDesc) - $ short 's' - <> long "synth" - <> metavar "SYNTH" - <> help "Specify synthesiser to use." - ) - <*> ( switch - $ short 'r' - <> long "rerun" - <> help - "Only rerun the current synthesis file with all the synthesisers." - ) - -configOpts :: Parser Opts -configOpts = - ConfigOpt - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a TOML Config file." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> ( switch - $ long "randomise" - <> short 'r' - <> help - "Randomise the given default config, or the default config by randomly switchin on and off options." - ) - -argparse :: Parser Opts -argparse = - hsubparser - ( command - "fuzz" - (info - fuzzOpts - (progDesc - "Run fuzzing on the specified simulators and synthesisers." - ) - ) - <> metavar "fuzz" - ) - <|> hsubparser - ( command - "generate" - (info - genOpts - (progDesc "Generate a random Verilog program.") - ) - <> metavar "generate" - ) - <|> hsubparser - ( command - "parse" - (info - parseOpts - (progDesc - "Parse a verilog file and output a pretty printed version." - ) - ) - <> metavar "parse" - ) - <|> hsubparser - ( command - "reduce" - (info - reduceOpts - (progDesc - "Reduce a Verilog file by rerunning the fuzzer on the file." - ) - ) - <> metavar "reduce" - ) - <|> hsubparser - ( command - "config" - (info - configOpts - (progDesc - "Print the current configuration of the fuzzer." - ) - ) - <> metavar "config" - ) - -version :: Parser (a -> a) -version = infoOption versionInfo $ mconcat - [long "version", short 'v', help "Show version information.", hidden] - -opts :: ParserInfo Opts -opts = info - (argparse <**> helper <**> version) - ( fullDesc - <> progDesc "Fuzz different simulators and synthesisers." - <> header - "VeriSmith - A hardware simulator and synthesiser Verilog fuzzer." - ) - -getConfig :: Maybe FilePath -> IO Config -getConfig s = - maybe (return defaultConfig) parseConfigFile $ T.unpack . 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 - -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 - 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) - ) - c - d - e - where - cm = config ^. configProbability . probModItem - cs = config ^. configProbability . probStmnt - ce = config ^. configProbability . probExpr - -handleOpts :: Opts -> IO () -handleOpts (Fuzz o configF _ _ n) = do - config <- getConfig configF - _ <- runFuzz - config - defaultYosys - (fuzzMultiple n (Just $ fromText o) (proceduralSrc "top" config)) - return () -handleOpts (Generate f c) = do - config <- getConfig c - source <- proceduralIO "top" config - maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) - $ T.unpack - . toTextIgnore - <$> f -handleOpts (Parse f) = do - verilogSrc <- T.readFile file - case parseVerilog (T.pack file) verilogSrc of - Left l -> print l - Right v -> print $ GenVerilog v - where file = T.unpack . toTextIgnore $ f -handleOpts (Reduce f t _ ls' False) = do - src <- parseSourceInfoFile t (toTextIgnore f) - case descriptionToSynth <$> ls' of - a : b : _ -> do - putStrLn "Reduce with equivalence check" - shelly $ do - make dir - pop dir $ do - src' <- reduceSynth a b src - 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) - 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 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 - -defaultMain :: IO () -defaultMain = do - optsparsed <- execParser opts - handleOpts optsparsed - --- | Generate a specific number of random bytestrings of size 256. -randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] -randomByteString gen n bytes - | n == 0 = ranBytes : bytes - | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes - where Right (ranBytes, newGen) = C.genBytes 32 gen - --- | generates the specific number of bytestring with a random seed. -generateByteString :: Int -> IO [ByteString] -generateByteString n = do - gen <- C.newGenIO :: IO C.CtrDRBG - return $ randomByteString gen n [] - -makeSrcInfo :: ModDecl -> SourceInfo -makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) - --- | Draw a randomly generated DAG to a dot file and compile it to a png so it --- 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"] - --- | Function to show a bytestring in a hex format. -showBS :: ByteString -> Text -showBS = decodeUtf8 . L.toStrict . toLazyByteString . byteStringHex - --- | Run a simulation on a random DAG or a random module. -runSimulation :: IO () -runSimulation = do - -- gr <- Hog.generate $ rDups <$> Hog.resize 100 (randomDAG :: Gen (G.Gr Gate ())) - -- let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr - -- writeFile "file.dot" dot - -- shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] - -- let circ = - -- head $ (nestUpTo 30 . generateAST $ Circuit gr) ^.. getVerilog . traverse . getDescription - rand <- generateByteString 20 - rand2 <- Hog.sample (randomMod 10 100) - 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 - -checkEquivalence :: SourceInfo -> Text -> IO Bool -checkEquivalence src dir = shellyFailDir $ do - mkdir_p (fromText dir) - curr <- toTextIgnore <$> pwd - setenv "VERISMITH_ROOT" curr - cd (fromText dir) - catch_sh - ((runResultT $ runEquiv 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 seed gm t d k i = do - (_, m) <- shelly $ sampleSeed seed gm - let srcInfo = SourceInfo "top" m - rand <- generateByteString 20 - shellyFailDir $ do - mkdir_p (fromText d fromText n) - curr <- toTextIgnore <$> pwd - setenv "VERISMITH_ROOT" curr - cd (fromText "output" fromText n) - _ <- - catch_sh - ( runResultT - $ runEquiv 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 (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s diff --git a/src/VeriFuzz/Circuit.hs b/src/VeriFuzz/Circuit.hs deleted file mode 100644 index aee0d57..0000000 --- a/src/VeriFuzz/Circuit.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-| -Module : VeriSmith.Circuit -Description : Definition of the circuit graph. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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 - -fromGraph :: Gen ModDecl -fromGraph = do - gr <- rDupsCirc <$> Hog.resize 100 randomDAG - return - $ initMod - . head - $ nestUpTo 5 (generateAST gr) - ^.. _Wrapped - . traverse diff --git a/src/VeriFuzz/Circuit/Base.hs b/src/VeriFuzz/Circuit/Base.hs deleted file mode 100644 index ddcaf65..0000000 --- a/src/VeriFuzz/Circuit/Base.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-| -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(..) - ) -where - -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) - --- | Newtype for the Circuit which implements a Graph from fgl. -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 for a named edge which is empty, as it does not need a label. -newtype CEdge = CEdge { getCEdge :: LEdge () } - -instance Random Gate where - randomR (a, b) g = - case randomR (fromEnum a, fromEnum b) g of - (x, g') -> (toEnum x, g') - - random = randomR (minBound, maxBound) diff --git a/src/VeriFuzz/Circuit/Gen.hs b/src/VeriFuzz/Circuit/Gen.hs deleted file mode 100644 index 1c4dd37..0000000 --- a/src/VeriFuzz/Circuit/Gen.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-| -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 - ) -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 - --- | Converts a 'CNode' to an 'Identifier'. -frNode :: Node -> Identifier -frNode = Identifier . fromNode - --- | Converts a 'Gate' to a 'BinaryOperator', which should be a bijective --- mapping. -fromGate :: Gate -> BinaryOperator -fromGate And = BinAnd -fromGate Or = BinOr -fromGate Xor = BinXor - -inputsC :: Circuit -> [Node] -inputsC c = inputs (getCircuit c) - -genPortsAST :: (Circuit -> [Node]) -> Circuit -> [Port] -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 g (n : ns) = BinOp wire oper <$> genAssignExpr g ns - where - wire = Id $ frNode n - oper = fromGate g - --- | Generate the continuous assignment AST for a particular node. If it does --- not have any nodes that link to it then return 'Nothing', as that means that --- the assignment will just be empty. -genContAssignAST :: Circuit -> LNode Gate -> Maybe ModItem -genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes - where - gr = getCircuit c - nodes = G.pre gr n - name = frNode n - -genAssignAST :: Circuit -> [ModItem] -genAssignAST c = catMaybes $ genContAssignAST c <$> nodes - where - gr = getCircuit c - nodes = G.labNodes gr - -genModuleDeclAST :: Circuit -> ModDecl -genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] - where - i = Identifier "gen_module" - ports = genPortsAST inputsC c - output = [] - a = genAssignAST c - yPort = Port Wire False 90 "y" - -generateAST :: Circuit -> Verilog -generateAST c = Verilog [genModuleDeclAST c] diff --git a/src/VeriFuzz/Circuit/Internal.hs b/src/VeriFuzz/Circuit/Internal.hs deleted file mode 100644 index b746738..0000000 --- a/src/VeriFuzz/Circuit/Internal.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-| -Module : VeriSmith.Circuit.Internal -Description : Internal helpers for generation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Internal helpers for generation. --} - -module VeriSmith.Circuit.Internal - ( fromNode - , filterGr - , only - , inputs - , outputs - ) -where - -import Data.Graph.Inductive (Graph, Node) -import qualified Data.Graph.Inductive as G -import qualified Data.Text as T - --- | Convert an integer into a label. --- --- >>> fromNode 5 --- "w5" -fromNode :: Int -> T.Text -fromNode node = T.pack $ "w" <> show node - --- | General function which runs 'filter' over a graph. -filterGr :: (Graph gr) => gr n e -> (Node -> Bool) -> [Node] -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 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 --- an input themselves. -inputs :: (Graph gr) => gr n e -> [Node] -inputs graph = filterGr graph $ only graph G.indeg G.outdeg - --- | Returns all the output nodes to a graph, similar to the 'inputs' function. -outputs :: (Graph gr) => gr n e -> [Node] -outputs graph = filterGr graph $ only graph G.outdeg G.indeg diff --git a/src/VeriFuzz/Circuit/Random.hs b/src/VeriFuzz/Circuit/Random.hs deleted file mode 100644 index ca8cc26..0000000 --- a/src/VeriFuzz/Circuit/Random.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-| -Module : VeriSmith.Circuit.Random -Description : Random generation for DAG -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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 - -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) - --- | Remove duplicates. -rDups :: (Eq a, Eq b) => Gr a b -> Gr a b -rDups g = G.buildGr $ G.ufold dupFolder [] g - --- | Remove duplicates. -rDupsCirc :: Circuit -> Circuit -rDupsCirc = Circuit . rDups . getCircuit - --- | Gen instance to create an arbitrary edge, where the edges are limited by --- `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, ()) - where - 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 = 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 - where - nodes l = zip [0 .. length l - 1] l - aE = getCEdge <$> Hog.sized arbitraryEdge - --- | Generate a random acyclic DAG with an IO instance. -genRandomDAG :: IO Circuit -genRandomDAG = Hog.sample randomDAG diff --git a/src/VeriFuzz/Config.hs b/src/VeriFuzz/Config.hs deleted file mode 100644 index adc3d19..0000000 --- a/src/VeriFuzz/Config.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-| -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 - ( -- * TOML Configuration - -- $conf - Config(..) - , defaultConfig - -- ** Probabilities - , Probability(..) - -- *** Expression - , ProbExpr(..) - -- *** Module Item - , ProbModItem(..) - -- *** Statement - , ProbStatement(..) - -- ** ConfProperty - , ConfProperty(..) - -- ** Simulator Description - , SimDescription(..) - -- ** Synthesiser Description - , SynthDescription(..) - -- * Useful Lenses - , fromXST - , fromYosys - , fromVivado - , fromQuartus - , configProbability - , configProperty - , configSimulators - , configSynthesisers - , probModItem - , 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 - , 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 qualified Toml -import VeriSmith.Sim.Quartus -import VeriSmith.Sim.Vivado -import VeriSmith.Sim.XST -import VeriSmith.Sim.Yosys - --- $conf --- --- VeriSmith supports a TOML configuration file that can be passed using the @-c@ --- flag or using the 'parseConfig' and 'encodeConfig' functions. The --- configuration can then be manipulated using the lenses that are also provided --- in this module. --- --- The configuration file can be used to tweak the random Verilog generation by --- passing different probabilities to each of the syntax nodes in the AST. It --- can also be used to specify which simulators to fuzz with which options. A --- seed for the run can also be set, to replay a previous run using the same --- exact generation. A default value is associated with each key in the --- configuration file, which means that only the options that need overriding --- can be added to the configuration. The defaults can be observed in --- 'defaultConfig' or when running @verismith config@. --- --- == Configuration Sections --- --- There are four main configuration sections in the TOML file: --- --- [@probability@] The @probability@ section defines the probabilities at --- every node in the AST. --- --- [@property@] Controls different properties of the generation, such as --- adding a seed or the depth of the statements. --- --- [@simulator@] This is an array of tables containing descriptions of the --- different simulators that should be used. It currently only supports --- . --- --- [@synthesiser@] This is also an array of tables containing descriptions of --- the different synthesisers that should be used. The synthesisers that are --- currently supported are: --- --- - --- - --- - --- - - --- | Probability of different expressions nodes. -data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int - -- ^ 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 - -- ^ Probability of generating an identifier that is in - -- scope and of the right type. - , _probExprRangeSelect :: {-# UNPACK #-} !Int - -- ^ Probability of generating a range selection from a port. - , _probExprUnOp :: {-# UNPACK #-} !Int - -- ^ Probability of generating a unary operator. - , _probExprBinOp :: {-# UNPACK #-} !Int - -- ^ Probability of generation a binary operator. - , _probExprCond :: {-# UNPACK #-} !Int - -- ^ probability of generating a conditional ternary - -- operator. - , _probExprConcat :: {-# UNPACK #-} !Int - -- ^ Probability of generating a concatenation. - , _probExprStr :: {-# UNPACK #-} !Int - -- ^ Probability of generating a string. This is not - -- fully supported therefore currently cannot be set. - , _probExprSigned :: {-# UNPACK #-} !Int - -- ^ Probability of generating a signed function - -- @$signed(...)@. - , _probExprUnsigned :: {-# UNPACK #-} !Int - -- ^ Probability of generating an unsigned function - -- @$unsigned(...)@. - } - deriving (Eq, Show) - --- | Probability of generating different nodes inside a module declaration. -data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int - -- ^ Probability of generating an @assign@. - , _probModItemSeqAlways :: {-# UNPACK #-} !Int - -- ^ Probability of generating a sequential @always@ block. - , _probModItemCombAlways :: {-# UNPACK #-} !Int - -- ^ Probability of generating an combinational @always@ block. - , _probModItemInst :: {-# UNPACK #-} !Int - -- ^ Probability of generating a module - -- instantiation. - } - deriving (Eq, Show) - -data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int - , _probStmntNonBlock :: {-# UNPACK #-} !Int - , _probStmntCond :: {-# UNPACK #-} !Int - , _probStmntFor :: {-# UNPACK #-} !Int - } - deriving (Eq, Show) - -data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem - , _probStmnt :: {-# UNPACK #-} !ProbStatement - , _probExpr :: {-# UNPACK #-} !ProbExpr - } - deriving (Eq, Show) - -data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int - -- ^ The size of the generated Verilog. - , _propSeed :: !(Maybe Seed) - -- ^ A possible seed that could be used to - -- generate the same Verilog. - , _propStmntDepth :: {-# UNPACK #-} !Int - -- ^ The maximum statement depth that should be - -- reached. - , _propModDepth :: {-# UNPACK #-} !Int - -- ^ The maximium module depth that should be - -- reached. - , _propMaxModules :: {-# UNPACK #-} !Int - -- ^ The maximum number of modules that are - -- allowed to be created at each level. - , _propSampleMethod :: !Text - -- ^ The sampling method that should be used to - -- generate specific distributions of random - -- programs. - , _propSampleSize :: {-# UNPACK #-} !Int - -- ^ The number of samples to take for the - -- sampling method. - , _propCombine :: !Bool - -- ^ If the output should be combined into one - -- bit or not. - , _propNonDeterminism :: {-# UNPACK #-} !Int - -- ^ The frequency at which nondeterminism - -- should be generated. - , _propDeterminism :: {-# UNPACK #-} !Int - -- ^ The frequency at which determinism should - -- be generated. - } - deriving (Eq, Show) - -data Info = Info { _infoCommit :: !Text - , _infoVersion :: !Text - } - deriving (Eq, Show) - -data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text } - deriving (Eq, Show) - -data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text - , synthBin :: Maybe Text - , synthDesc :: Maybe Text - , 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 ''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 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) - -fromYosys :: Yosys -> SynthDescription -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) - -fromQuartus :: Quartus -> SynthDescription -fromQuartus (Quartus a b c) = SynthDescription "quartus" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) - -defaultConfig :: Config -defaultConfig = Config - (Info (pack $(gitHash)) (pack $ showVersion version)) - (Probability defModItem defStmnt defExpr) - (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1) - [] - [fromYosys defaultYosys, fromVivado defaultVivado] - where - defModItem = - 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 - 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 - -twoKey :: Toml.Piece -> Toml.Piece -> Toml.Key -twoKey a b = Toml.Key (a :| [b]) - -int :: Toml.Piece -> Toml.Piece -> TomlCodec Int -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 - 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 - 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 - where - defProb i = defaultConfig ^. configProbability . probModItem . i - intM = int "moditem" - -probCodec :: TomlCodec Probability -probCodec = - Probability - <$> defaultValue (defProb probModItem) modItemCodec - .= _probModItem - <*> defaultValue (defProb probStmnt) stmntCodec - .= _probStmnt - <*> defaultValue (defProb probExpr) exprCodec - .= _probExpr - 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 - where defProp i = defaultConfig ^. configProperty . i - -simulator :: TomlCodec SimDescription -simulator = Toml.textBy pprint parseIcarus "name" - where - parseIcarus i@"icarus" = Right $ SimDescription i - parseIcarus s = Left $ "Could not match '" <> s <> "' with a simulator." - pprint (SimDescription a) = a - -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 - -infoCodec :: TomlCodec Info -infoCodec = - 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 - -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" - -encodeConfig :: Config -> Text -encodeConfig = Toml.encode configCodec - -encodeConfigFile :: FilePath -> Config -> IO () -encodeConfigFile f = T.writeFile f . encodeConfig - -versionInfo :: String -versionInfo = - "VeriSmith " - <> showVersion version - <> " (" - <> $(gitCommitDate) - <> " " - <> $(gitHash) - <> ")" diff --git a/src/VeriFuzz/Fuzz.hs b/src/VeriFuzz/Fuzz.hs deleted file mode 100644 index 9331a5e..0000000 --- a/src/VeriFuzz/Fuzz.hs +++ /dev/null @@ -1,466 +0,0 @@ -{-| -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 FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - -module VeriSmith.Fuzz - ( Fuzz - , fuzz - , fuzzInDir - , fuzzMultiple - , runFuzz - , sampleSeed - -- * Helpers - , 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.Trans.Class (lift) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Maybe (runMaybeT) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import qualified Crypto.Random.DRBG as C -import Data.ByteString (ByteString) -import Data.List (nubBy, sort) -import Data.Maybe (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) -import Shelly.Lifted (MonadSh, liftSh) -import System.FilePath.Posix (takeBaseName) -import VeriSmith.Config -import VeriSmith.Internal -import VeriSmith.Reduce -import VeriSmith.Report -import VeriSmith.Result -import VeriSmith.Sim.Icarus -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Yosys -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] - , getSimulators :: ![SimTool] - , yosysInstance :: {-# UNPACK #-} !Yosys - } - deriving (Eq, Show) - -data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult] - , _fuzzSimResults :: ![SimResult] - , _fuzzSynthStatus :: ![SynthStatus] - } - deriving (Eq, Show) - -$(makeLenses ''FuzzState) - -type Frequency a = [(Seed, a)] -> [(Int, Gen (Seed, a))] - --- | The main type for the fuzzing, which contains an environment that can be --- read from and the current state of all the results. -type Fuzz m = StateT FuzzState (ReaderT FuzzEnv m) - -type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) - -runFuzz :: MonadIO m => Config -> Yosys -> (Config -> Fuzz Sh a) -> m a -runFuzz conf yos m = shelly $ runFuzz' conf yos m - -runFuzz' :: Monad m => Config -> Yosys -> (Config -> Fuzz m b) -> m b -runFuzz' conf yos m = runReaderT - (evalStateT (m conf) (FuzzState [] [] [])) - (FuzzEnv - ( force - $ defaultIdentitySynth - : (descriptionToSynth <$> conf ^. configSynthesisers) - ) - (force $ descriptionToSim <$> conf ^. configSimulators) - yos - ) - -synthesisers :: Monad m => Fuzz m [SynthTool] -synthesisers = lift $ asks getSynthesisers - ---simulators :: (Monad m) => Fuzz () m [SimTool] ---simulators = lift $ asks getSimulators - ---combinations :: [a] -> [b] -> [(a, b)] ---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) - -synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () -synthesis src = do - 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 - -passedSynthesis :: MonadSh m => Fuzz m [SynthTool] -passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get - where - passed (SynthStatus _ (Pass _) _) = True - 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 - toSynth (SynthStatus s _ _) = s - -make :: MonadSh m => FilePath -> m () -make f = liftSh $ do - mkdir_p f - cp_r "data" $ f fromText "data" - -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 - -applyList :: [a -> b] -> [a] -> [b] -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 a b = applyLots SynthResult a $ fmap swap b - -toolRun :: (MonadIO m, MonadSh m) => Text -> m a -> m (NominalDiffTime, a) -toolRun t m = do - logT $ "Running " <> t - (diff, res) <- timeit m - logT $ "Finished " <> t <> " (" <> showT diff <> ")" - return (diff, res) - -equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () -equivalence src = do - synth <- passedSynthesis --- let synthComb = --- nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth - let synthComb = - nubBy tupEq - . filter (uncurry (/=)) - $ (,) defaultIdentitySynth - <$> synth - resTimes <- liftSh $ mapM (uncurry equiv) synthComb - fuzzSynthResults .= toSynthResult synthComb resTimes - liftSh $ inspect resTimes - where - tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') - equiv 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 - runEquiv a b src - where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b - -simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () -simulation src = do - synth <- passEquiv - vals <- liftIO $ generateByteString 20 - ident <- liftSh $ equiv vals defaultIdentitySynth - resTimes <- liftSh $ mapM (equiv vals) $ conv <$> synth - liftSh - . inspect - $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) - <$> (ident : resTimes) - where - conv (SynthResult _ a _ _) = a - equiv b 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 defaultIcarus a src b - where dir = fromText $ "simulation_" <> toText a - --- | Generate a specific number of random bytestrings of size 256. -randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] -randomByteString gen n bytes - | n == 0 = ranBytes : bytes - | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes - where Right (ranBytes, newGen) = C.genBytes 32 gen - --- | generates the specific number of bytestring with a random seed. -generateByteString :: Int -> IO [ByteString] -generateByteString n = do - gen <- C.newGenIO :: IO C.CtrDRBG - return $ randomByteString gen n [] - -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 - -passEquiv :: (MonadSh m) => Fuzz m [SynthResult] -passEquiv = filter withIdentity . _fuzzSynthResults <$> get - where - withIdentity (SynthResult _ _ (Pass _) _) = True - withIdentity _ = False - --- | Always reduces with respect to 'Identity'. -reduction :: (MonadSh m) => SourceInfo -> Fuzz m () -reduction src = do - fails <- failEquivWithIdentity - synthFails <- failedSynthesis - _ <- liftSh $ mapM red fails - _ <- liftSh $ mapM redSynth synthFails - return () - where - red (SynthResult a b _ _) = do - make dir - pop dir $ do - s <- reduceSynth a b src - writefile (fromText ".." dir <.> "v") $ genSource s - return s - where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b - redSynth a = do - make dir - pop dir $ do - s <- reduceSynthesis a src - writefile (fromText ".." dir <.> "v") $ genSource s - return s - where dir = fromText $ "reduce_" <> toText 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) - -whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) -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) - => Fuzz m (Seed, SourceInfo) - -> Fuzz m (Seed, SourceInfo) -generateSample f = do - 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 - -hatFreqs :: Frequency a -hatFreqs l = zip hat (return <$> l) - where - h = length l `div` 2 - hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] - -meanFreqs :: Source a => Frequency a -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 - sizes = verilogSize . snd <$> l - -medianFreqs :: Frequency a -medianFreqs l = zip hat (return <$> l) - where - h = length l `div` 2 - hat = set_ <$> [1 .. length l] - set_ n = if n == h then 1 else 0 - -fuzz :: MonadFuzz m => Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzz gen conf = do - (seed', src) <- generateSample genMethod - let size = length . lines . T.unpack $ genSource src - liftSh - . writefile "config.toml" - . encodeConfig - $ conf - & configProperty - . propSeed - ?~ seed' - (tsynth, _) <- titleRun "Synthesis" $ synthesis src - (tequiv, _) <- titleRun "Equivalence Check" $ equivalence src - (_ , _) <- titleRun "Simulation" $ simulation src - fails <- failEquivWithIdentity - synthFails <- failedSynthesis - redResult <- - whenMaybe (not $ null fails && null synthFails) - . 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) - liftSh . writefile "index.html" $ printResultReport (bname currdir) report - return report - where - seed = conf ^. configProperty . propSeed - bname = T.pack . takeBaseName . T.unpack . toTextIgnore - genMethod = 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 - 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 - -fuzzInDir - :: MonadFuzz m => FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzzInDir fp src conf = do - make fp - res <- pop fp $ fuzz src conf - relativeFuzzReport res - -fuzzMultiple - :: MonadFuzz m - => Int - -> Maybe FilePath - -> Gen SourceInfo - -> Config - -> Fuzz m [FuzzReport] -fuzzMultiple n fp src conf = do - x <- case fp 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 .. n] fuzzDir' - else (: []) <$> fuzzDir' (1 :: Int) - liftSh . writefile (fromText "index" <.> "html") $ printSummary - "Fuzz Summary" - results - return results - where - fuzzDir' n' = fuzzInDir (fromText $ "fuzz_" <> showT n') src conf - seed = conf ^. configProperty . propSeed - -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 - runIdentity - . runMaybeT - . Hog.runTree - $ Hog.runGenT 30 seed gen - of - Nothing -> loop (n - 1) - Just x -> return (seed, Hog.nodeValue x) - in loop (100 :: Int) - diff --git a/src/VeriFuzz/Generate.hs b/src/VeriFuzz/Generate.hs deleted file mode 100644 index 095baee..0000000 --- a/src/VeriFuzz/Generate.hs +++ /dev/null @@ -1,623 +0,0 @@ -{-| -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 TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} - -module VeriSmith.Generate - ( -- * Generation methods - procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod - -- ** Generate Functions - , gen - , 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 - ) -where - -import Control.Lens hiding (Context) -import Control.Monad (replicateM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import Data.Foldable (fold) -import Data.Functor.Foldable (cata) -import Data.List (foldl', partition) -import qualified Data.Text as T -import Hedgehog (Gen) -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 = Context { _variables :: [Port] - , _parameters :: [Parameter] - , _modules :: [ModDecl] - , _nameCounter :: {-# UNPACK #-} !Int - , _stmntDepth :: {-# UNPACK #-} !Int - , _modDepth :: {-# UNPACK #-} !Int - , _determinism :: !Bool - } - -makeLenses ''Context - -type StateGen = StateT Context (ReaderT Config Gen) - -toId :: Int -> Identifier -toId = Identifier . ("w" <>) . T.pack . show - -toPort :: Identifier -> Gen Port -toPort ident = do - i <- range - return $ wire i ident - -sumSize :: [Port] -> Range -sumSize ps = sum $ ps ^.. traverse . portSize - -random :: [Port] -> (Expr -> ContAssign) -> Gen ModItem -random ctx fun = do - 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 - -randomOrdAssigns :: [Port] -> [Port] -> [Gen ModItem] -randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids - where - generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) - -randomMod :: Int -> Int -> Gen ModDecl -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]) - [] - where - ids = toId <$> [1 .. total] - end = drop inps - start = take inps - --- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the --- 'Port'. -lvalFromPort :: Port -> LVal -lvalFromPort (Port _ _ _ i) = RegId i - --- | Returns the probability from the configuration. -probability :: Config -> Probability -probability c = c ^. configProbability - --- | Gets the current probabilities from the 'State'. -askProbability :: StateGen Probability -askProbability = lift $ asks probability - --- | Lifts a 'Gen' into the 'StateGen' monad. -gen :: Gen a -> StateGen a -gen = lift . lift - --- | Generates a random large number, which can also be negative. -largeNum :: Gen Int -largeNum = Hog.int $ Hog.linear (-100) 100 - --- | Generates a random size for a wire so that it is not too small and not too --- large. -wireSize :: Gen Int -wireSize = Hog.int $ Hog.linear 2 100 - --- | Generates a random range by using the 'wireSize' and 0 as the lower bound. -range :: Gen Range -range = Range <$> fmap fromIntegral wireSize <*> pure 0 - --- | Generate a random bit vector using 'largeNum'. -genBitVec :: Gen BitVec -genBitVec = fmap fromIntegral largeNum - --- | Return a random 'BinaryOperator'. This currently excludes 'BinDiv', --- 'BinMod' because they can take a long time to synthesis, and 'BinCEq', --- 'BinCNEq', because these are not synthesisable. 'BinPower' is also excluded --- because it can only be used in conjunction with base powers of 2 which is --- currently not enforced. -binOp :: Gen 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 - ] - --- | Generate a random 'UnaryOperator'. -unOp :: Gen UnaryOperator -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 :: [Parameter] -> ProbExpr -> Hog.Size -> Gen 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 - --- | The list of safe 'Expr', meaning that these will not recurse and will end --- the 'Expr' generation. -exprSafeList :: ProbExpr -> [(Int, Gen Expr)] -exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] - --- | List of 'Expr' that have the chance to recurse and will therefore not be --- used when the expression grows too large. -exprRecList :: ProbExpr -> (Hog.Size -> Gen Expr) -> [(Int, Gen 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) - ] - --- | Select a random port from a list of ports and generate a safe bit selection --- for that port. -rangeSelect :: [Parameter] -> [Port] -> Gen 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) - --- | Generate a random expression from the 'Context' with a guarantee that it --- will terminate using the list of safe 'Expr'. -exprWithContext :: ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> Gen 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 l n - | n == 0 - = Hog.frequency - $ (prob ^. probExprId, Id . fromPort <$> Hog.element l) - : exprSafeList prob - | 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 - --- | Runs a 'StateGen' for a random number of times, limited by an 'Int' that is --- passed to it. -someI :: Int -> StateGen a -> StateGen [a] -someI m f = do - amount <- gen $ 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 :: T.Text -> StateGen Identifier -makeIdentifier prefix = do - context <- get - let ident = Identifier $ prefix <> showT (context ^. nameCounter) - nameCounter += 1 - return ident - -getPort' :: PortType -> Identifier -> [Port] -> StateGen 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' - --- | 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 --- 'newPort'. This is used subsequently in all the functions to create a port, --- in case a port with the same name was already created. This could be because --- the generation is currently in the other branch of an if-statement. -nextPort :: PortType -> StateGen Port -nextPort pt = do - context <- get - ident <- makeIdentifier . T.toLower $ showT pt - 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 Port -newPort ident pt = do - p <- gen $ Port pt <$> Hog.bool <*> range <*> pure ident - variables %= (p :) - return p - --- | Generates an expression from variables that are currently in scope. -scopedExpr :: StateGen Expr -scopedExpr = do - context <- get - prob <- askProbability - gen - . 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 ContAssign -contAssign = do - expr <- scopedExpr - p <- nextPort Wire - return $ ContAssign (p ^. portName) expr - --- | Generate a random assignment and assign it to a random 'Reg'. -assignment :: StateGen Assign -assignment = do - expr <- scopedExpr - lval <- lvalFromPort <$> nextPort Reg - return $ Assign lval Nothing expr - --- | Generate a random 'Statement' safely, by also increasing the depth counter. -seqBlock :: StateGen Statement -seqBlock = do - 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' --- is not reused, it is left at 0, as all the 'Reg' are initialised to 0 at the --- start. -conditional :: StateGen Statement -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) - --- | Generate a random for loop by creating a new variable name for the counter --- and then generating random statements in the body. -forLoop :: StateGen Statement -forLoop = do - num <- Hog.int (Hog.linear 0 20) - var <- lvalFromPort <$> nextPort 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 Statement -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 - --- | Generate a sequential always block which is dependent on the clock. -alwaysSeq :: StateGen ModItem -alwaysSeq = Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock - --- | Should resize a port that connects to a module port if the latter is --- larger. This should not cause any problems if the same net is used as input --- 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 - --- | Instantiate a module, where the outputs are new nets that are created, and --- the inputs are taken from existing ports in the context. --- --- 1 is subtracted from the inputs for the length because the clock is not --- counted and is assumed to be there, this should be made nicer by filtering --- out the clock instead. I think that in general there should be a special --- representation for the clock. -instantiate :: ModDecl -> StateGen ModItem -instantiate (ModDecl i outP inP _ _) = do - context <- get - outs <- replicateM (length outP) (nextPort Wire) - ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) - 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) - , ModInst i ident <$> Hog.shuffle - (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) (toE $ outs <> clkPort <> ins)) - ] - 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 --- for every instance and for every level until either the deepest level is --- achieved, or the maximum number of modules are reached. --- --- If the maximum number of levels are reached, it will always pick an instance --- from the current context. The problem with this approach is that at the end --- there may be many more than the max amount of modules, as the modules are --- always set to empty when entering a new level. This is to fix recursive --- definitions of modules, which are not defined. --- --- One way to fix that is to also decrement the max modules for every level, --- depending on how many modules have already been generated. This would mean --- there would be moments when the module cannot generate a new instance but --- also not take a module from the current context. A fix for that may be to --- have a default definition of a simple module that is used instead. --- --- Another different way to handle this would be to have a probability of taking --- a module from a context or generating a new one. -modInst :: StateGen ModItem -modInst = do - prob <- lift 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 ModItem -modItem = do - conf <- lift 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 - 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 Identifier -moduleName (Just t) = return t -moduleName Nothing = makeIdentifier "module" - --- | Generate a random 'ConstExpr' by using the current context of 'Parameters'. -constExpr :: StateGen ConstExpr -constExpr = do - prob <- askProbability - context <- get - gen . 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 Parameter -parameter = do - 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 - --- | Calculate a range to an int by maybe resizing the ranges to a value. -calcRange :: [Parameter] -> Maybe Int -> Range -> Int -calcRange ps i (Range l r) = eval l - eval r + 1 - where - eval a = fromIntegral . cata (evaluateConst ps) $ maybe a (`resize` a) i - --- | Filter out a port based on it's name instead of equality of the ports. This --- is because the ports might not be equal if the sizes are being updated. -identElem :: Port -> [Port] -> Bool -identElem p = elem (p ^. portName) . toListOf (traverse . portName) - --- | Generates a module definition randomly. It always has one output port which --- is set to @y@. The size of @y@ is the total combination of all the locally --- defined wires, so that it correctly reflects the internal state of the --- module. -moduleDef :: Maybe Identifier -> StateGen ModDecl -moduleDef top = do - name <- moduleName top - portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire - mi <- Hog.list (Hog.linear 4 100) modItem - ps <- Hog.list (Hog.linear 0 10) parameter - context <- get - config <- lift ask - let (newPorts, local) = partition (`identElem` portList) $ _variables context - let - size = - evalRange (_parameters context) 32 - . sum - $ local - ^.. traverse - . portSize - let combine = config ^. configProperty . propCombine - let clock = Port Wire False 1 "clk" - let yport = - if combine then Port Wire False 1 "y" else Port Wire False size "y" - let comb = combineAssigns_ combine yport local - 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 :: T.Text -> Config -> Gen Verilog -procedural top config = do - (mainMod, st) <- Hog.resize num $ runReaderT - (runStateT (moduleDef (Just $ Identifier top)) context) - config - return . Verilog $ mainMod : st ^. modules - where - context = - Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True - num = fromIntegral $ confProp propSize - confProp i = config ^. configProperty . i - --- | Samples the 'Gen' directly to generate random 'Verilog' using the 'T.Text' as --- the name of the main module and the configuration 'Config' to influence the --- generation. -proceduralIO :: T.Text -> Config -> IO Verilog -proceduralIO t = Hog.sample . procedural t - --- | Given a 'T.Text' and a 'Config' will generate a 'SourceInfo' which has the --- top module set to the right name. -proceduralSrc :: T.Text -> Config -> Gen SourceInfo -proceduralSrc t c = SourceInfo t <$> procedural t c - --- | Sampled and wrapped into a 'SourceInfo' with the given top module name. -proceduralSrcIO :: T.Text -> Config -> IO SourceInfo -proceduralSrcIO t c = SourceInfo t <$> proceduralIO t c diff --git a/src/VeriFuzz/Internal.hs b/src/VeriFuzz/Internal.hs deleted file mode 100644 index 86cb1f7..0000000 --- a/src/VeriFuzz/Internal.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-| -Module : VeriSmith.Internal -Description : Shared high level code used in the other modules internally. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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) - --- | Function to show a bytestring in a hex format. -showBS :: ByteString -> Text -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 - --- | Show function for 'Text' -showT :: (Show a) => a -> Text -showT = T.pack . show - --- | Inserts commas between '[Text]' and except the last one. -comma :: [Text] -> Text -comma = T.intercalate ", " - --- | Inserts commas and newlines between '[Text]' and except the last one. -commaNL :: [Text] -> Text -commaNL = T.intercalate ",\n" diff --git a/src/VeriFuzz/Reduce.hs b/src/VeriFuzz/Reduce.hs deleted file mode 100644 index c57b457..0000000 --- a/src/VeriFuzz/Reduce.hs +++ /dev/null @@ -1,609 +0,0 @@ -{-| -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 ScopedTypeVariables #-} - -module VeriSmith.Reduce - ( -- $strategy - reduceWithScript - , reduceSynth - , reduceSynthesis - , reduce - , reduce_ - , Replacement(..) - , halveModules - , halveModItems - , halveStatements - , halveExpr - , halveAssigns - , findActiveWires - , clean - , cleanSourceInfo - , cleanSourceInfoAll - , removeDecl - , filterExpr - ) -where - -import Control.Lens hiding ((<.>)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -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 ((<.>)) -import qualified Shelly -import Shelly.Lifted (MonadSh, liftSh) -import VeriSmith.Internal -import VeriSmith.Result -import VeriSmith.Sim -import VeriSmith.Sim.Internal -import VeriSmith.Verilog -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.Mutate -import VeriSmith.Verilog.Parser - - --- $strategy --- The reduction strategy has multiple different steps. 'reduce' will run these --- strategies one after another, starting at the most coarse grained one. The --- supported reduction strategies are the following: --- --- [Modules] First of all, the reducer will try and remove all the modules --- except the top module. --- --- [Module Items] Then, the module items will be reduced by using standard --- delta debugging. Half of the module items will be removed, and both --- versions will be tested. If both succeed, they will be divided further and --- tested further. Finally, the shortest version will be returned. --- --- [Statements] Once the module items have been reduced, the statements will --- be reduced as well. This is done using delta debugging, just like the --- module items. --- --- [Expressions] Finally, the expressions themselves will be reduced. This is --- done by splitting the top most binary expressions in half and testing each --- half. - --- | 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) - -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 - -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 - -instance Foldable Replacement where - 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 - --- | Split a list in two halves. -halve :: Replace [a] -halve [] = Single [] -halve [_] = Single [] -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 - --- | 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 --- module. -combine :: Lens' a b -> Replace b -> Replace a -combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res - --- | Deletes Id 'Expr' if they are not part of the current scope, and replaces --- these by 0. -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 -filterExpr ids (RangeSelect i r) = - 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 -> 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 -> Bool -filterAssigns out (ModCA (ContAssign i _)) = - elem i $ out ^.. traverse . portName -filterAssigns _ _ = True - -clean :: (Mutate a) => [Identifier] -> a -> a -clean ids = mutExpr (transform $ filterExpr ids) - -cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem] -cleanUndefined ids mis = clean usedWires mis - where - usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids - -halveModAssign :: Replace ModDecl -halveModAssign m = cleanMod m $ modify <$> assigns (m ^. modItems) - where - assigns = halve . filter (filterAssigns $ m ^. modOutPorts) - modify l = m & modItems .~ l - -cleanMod :: ModDecl -> Replacement ModDecl -> Replacement ModDecl -cleanMod m newm = modify . change <$> newm - where - 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 - -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 - -halveModExpr :: Replace ModItem -halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca -halveModExpr a = Single a - --- | Remove all the undefined mod instances. -cleanModInst :: SourceInfo -> SourceInfo -cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned - where - validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId - cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped - --- | Clean all the undefined module instances in a specific module using a --- context. -cleanModInst' :: [Identifier] -> ModDecl -> ModDecl -cleanModInst' ids m = m & modItems .~ newModItem - where newModItem = filter (validModInst ids) $ m ^.. modItems . traverse - --- | Check if a mod instance is in the current context. -validModInst :: [Identifier] -> ModItem -> Bool -validModInst ids (ModInst i _ _) = i `elem` ids -validModInst _ _ = True - --- | Adds a 'ModDecl' to a 'SourceInfo'. -addMod :: ModDecl -> SourceInfo -> SourceInfo -addMod m srcInfo = srcInfo & infoSrc . _Wrapped %~ (m :) - --- | Split a module declaration in half by trying to remove assign --- statements. This is only done in the main module of the source. -halveAssigns :: Replace SourceInfo -halveAssigns = combine mainModule halveModAssign - --- | Checks if a module item is needed in the module declaration. -relevantModItem :: ModDecl -> ModItem -> Bool -relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) = - i `elem` fmap _portName out -relevantModItem _ Decl{} = True -relevantModItem _ _ = False - -isAssign :: Statement -> Bool -isAssign (BlockAssign _) = True -isAssign (NonBlockAssign _) = True -isAssign _ = False - -lValName :: LVal -> [Identifier] -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 - --- | 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 (RangeSelect i _) = [i] -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 (RangeSelect i _) = Just i -exprId _ = Nothing - -eventId :: Event -> Maybe Identifier -eventId (EId i) = Just i -eventId (EPosEdge i) = Just i -eventId (ENegEdge i) = Just i -eventId _ = Nothing - -portToId :: Port -> Identifier -portToId (Port _ _ _ i) = i - -paramToId :: Parameter -> Identifier -paramToId (Parameter i _) = i - -isModule :: Identifier -> ModDecl -> Bool -isModule i (ModDecl n _ _ _ _) = i == n - -modInstActive :: [ModDecl] -> ModItem -> [Identifier] -modInstActive decl (ModInst n _ i) = case m of - 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 _ _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName o = exprName e - | otherwise = [] -modInstActive _ _ = [] - -fixModInst :: SourceInfo -> ModItem -> ModItem -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 ..] - 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 - fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e - | otherwise = Nothing -fixModInst _ a = a - -findActiveWires :: Identifier -> SourceInfo -> [Identifier] -findActiveWires t src = - 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) - allStat = filter isAssign . concat $ fmap universe stat - stat = - (m ^.. modItems . traverse . _Initial) - <> (m ^.. modItems . traverse . _Always) - modinstwires = - 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 --- 'SourceInfo', otherwise it will crash. -cleanSourceInfo :: Identifier -> SourceInfo -> SourceInfo -cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) - -cleanSourceInfoAll :: SourceInfo -> SourceInfo -cleanSourceInfoAll src = foldr cleanSourceInfo src allMods - where allMods = src ^.. infoSrc . _Wrapped . traverse . modId - --- | Returns true if the text matches the name of a module. -matchesModName :: Identifier -> ModDecl -> Bool -matchesModName top (ModDecl i _ _ _ _) = top == i - -halveStatement :: Replace Statement -halveStatement (SeqBlock [s]) = halveStatement s -halveStatement (SeqBlock s) = SeqBlock <$> halve s -halveStatement (CondStmnt _ (Just s1) (Just s2)) = Dual s1 s2 -halveStatement (CondStmnt _ (Just s1) Nothing) = Single s1 -halveStatement (CondStmnt _ Nothing (Just s1)) = Single s1 -halveStatement (EventCtrl e (Just s)) = EventCtrl e . Just <$> halveStatement s -halveStatement (TimeCtrl e (Just s)) = TimeCtrl e . Just <$> halveStatement s -halveStatement a = Single a - -halveAlways :: Replace ModItem -halveAlways (Always s) = Always <$> halveStatement s -halveAlways a = Single a - --- | Removes half the modules randomly, until it reaches a minimal amount of --- modules. This is done by doing a binary search on the list of modules and --- removing the instantiations from the main module body. -halveModules :: Replace SourceInfo -halveModules srcInfo@(SourceInfo top _) = - cleanSourceInfoAll - . cleanModInst - . addMod main - <$> combine (infoSrc . _Wrapped) repl srcInfo - where - repl = halve . filter (not . matchesModName (Identifier top)) - main = srcInfo ^. mainModule - -moduleBot :: SourceInfo -> Bool -moduleBot (SourceInfo _ (Verilog [] )) = True -moduleBot (SourceInfo _ (Verilog [_])) = True -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 -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 - addRelevant = aModule t . modItems %~ (relevant ++) - -modItemBot :: Identifier -> SourceInfo -> Bool -modItemBot t srcInfo | length modItemsNoDecl > 2 = False - | otherwise = True - where - modItemsNoDecl = - filter noDecl $ srcInfo ^.. aModule t . modItems . traverse - noDecl Decl{} = False - noDecl _ = True - -halveStatements :: Identifier -> Replace SourceInfo -halveStatements t m = - cleanSourceInfo t <$> combine (aModule t . modItems) halves m - where halves = traverse halveAlways - --- | Reduce expressions by splitting them in half and keeping the half that --- succeeds. -halveExpr :: Identifier -> Replace SourceInfo -halveExpr t = combine contexpr $ traverse halveModExpr - where - contexpr :: Lens' SourceInfo [ModItem] - contexpr = aModule t . modItems - -toIds :: [Expr] -> [Identifier] -toIds = nub . mapMaybe exprId . concatMap universe - -toIdsConst :: [ConstExpr] -> [Identifier] -toIdsConst = toIds . fmap constToExpr - -toIdsEvent :: [Event] -> [Identifier] -toIdsEvent = nub . mapMaybe eventId . concatMap universe - -allStatIds' :: Statement -> [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) - eventProcessedIds = toIdsEvent $ s ^.. statEvent - -allStatIds :: Statement -> [Identifier] -allStatIds s = nub . concat $ allStatIds' <$> universe s - -fromRange :: Range -> [ConstExpr] -fromRange r = [rangeMSB r, rangeLSB r] - -allExprIds :: ModDecl -> [Identifier] -allExprIds m = - nub - $ contAssignIds - <> modInstIds - <> modInitialIds - <> modAlwaysIds - <> modPortIds - <> modDeclIds - <> paramIds - where - contAssignIds = - toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr - modInstIds = - toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr - modInitialIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial - modAlwaysIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always - modPortIds = - 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 - ) - -isUsedDecl :: [Identifier] -> ModItem -> Bool -isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids -isUsedDecl _ _ = True - -isUsedParam :: [Identifier] -> Parameter -> Bool -isUsedParam ids (Parameter i _) = i `elem` ids - -isUsedPort :: [Identifier] -> Port -> Bool -isUsedPort ids (Port _ _ _ i) = i `elem` ids - -removeDecl :: SourceInfo -> SourceInfo -removeDecl src = foldr fix removed allMods - where - removeDecl' t src' = - 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) - allMods = src ^.. infoSrc . _Wrapped . traverse . modId - fix t a = a & aModule t . modItems %~ fmap (fixModInst a) - removed = foldr removeDecl' src allMods - -defaultBot :: SourceInfo -> Bool -defaultBot = const False - --- | Reduction using custom reduction strategies. -reduce_ - :: MonadSh m - => Text - -> Replace SourceInfo - -> (SourceInfo -> Bool) - -> (SourceInfo -> m Bool) - -> SourceInfo - -> m SourceInfo -reduce_ title repl bot eval src = do - 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 src - else case repl src of - Single s -> do - red <- eval s - if red - then if cond s then recReduction s else return s - else return src - Dual l r -> do - red <- eval l - if red - then if cond l then recReduction l else return l - else do - red' <- eval r - if red' - then if cond r then recReduction r else return r - else return src - None -> return src - where - cond s = s /= src - recReduction = reduce_ title repl bot eval - --- | Reduce an input to a minimal representation. It follows the reduction --- strategy mentioned above. -reduce - :: MonadSh m - => (SourceInfo -> m Bool) -- ^ Failed or not. - -> SourceInfo -- ^ Input verilog source to be reduced. - -> m SourceInfo -- ^ Reduced output. -reduce eval src = - fmap removeDecl - $ red "Modules" moduleBot halveModules src - >>= redAll "Module Items" modItemBot halveModItems - >>= redAll "Statements" (const defaultBot) halveStatements - -- >>= redAll "Expressions" (const defaultBot) halveExpr - where - red s bot a = reduce_ s a bot eval - red' s bot a t = reduce_ s (a t) (bot t) eval - redAll s bot halve' src' = foldrM - (\t -> red' (s <> " (" <> getIdentifier t <> ")") bot halve' t) - src' - (src' ^.. infoSrc . _Wrapped . traverse . modId) - -runScript - :: MonadSh m => Shelly.FilePath -> Shelly.FilePath -> SourceInfo -> 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 - --- | Reduce using a script that is passed to it -reduceWithScript - :: (MonadSh m, MonadIO m) - => Text - -> Shelly.FilePath - -> Shelly.FilePath - -> m () -reduceWithScript top script file = do - liftSh . Shelly.cp file $ file <.> "original" - srcInfo <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file - void $ reduce (runScript script file) srcInfo - --- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it. -reduceSynth - :: (Synthesiser a, Synthesiser b, MonadSh m) - => a - -> b - -> SourceInfo - -> m SourceInfo -reduceSynth a b = reduce synth - where - synth src' = liftSh $ do - r <- runResultT $ do - runSynth a src' - runSynth b src' - runEquiv a b src' - return $ case r of - Fail EquivFail -> True - Fail _ -> False - Pass _ -> False - -reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo -> m SourceInfo -reduceSynthesis a = reduce synth - where - synth src = liftSh $ do - r <- runResultT $ runSynth a src - return $ case r of - Fail SynthFail -> True - Fail _ -> False - Pass _ -> False diff --git a/src/VeriFuzz/Report.hs b/src/VeriFuzz/Report.hs deleted file mode 100644 index fe680c3..0000000 --- a/src/VeriFuzz/Report.hs +++ /dev/null @@ -1,398 +0,0 @@ -{-# 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 TemplateHaskell #-} - -module VeriSmith.Report - ( SynthTool(..) - , SynthStatus(..) - , SynthResult(..) - , SimResult(..) - , SimTool(..) - , FuzzReport(..) - , printResultReport - , printSummary - , synthResults - , simResults - , synthStatus - , equivTime - , fuzzDir - , fileLines - , reducTime - , synthTime - , defaultIcarusSim - , defaultVivadoSynth - , defaultYosysSynth - , defaultXSTSynth - , defaultQuartusSynth - , 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 Data.Vector (fromList) -import Prelude hiding (FilePath) -import Shelly (FilePath, fromText, - toTextIgnore, (<.>), ()) -import Statistics.Sample (meanVariance) -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.Sim -import VeriSmith.Sim.Internal - --- | Common type alias for synthesis results -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 - | 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 (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 (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 (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 (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 (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 (IdentitySynth identity) = IdentitySynth . setSynthOutput identity - -defaultYosysSynth :: SynthTool -defaultYosysSynth = YosysSynth defaultYosys - -defaultQuartusSynth :: SynthTool -defaultQuartusSynth = QuartusSynth defaultQuartus - -defaultVivadoSynth :: SynthTool -defaultVivadoSynth = VivadoSynth defaultVivado - -defaultXSTSynth :: SynthTool -defaultXSTSynth = XSTSynth defaultXST - -defaultIdentitySynth :: SynthTool -defaultIdentitySynth = IdentitySynth defaultIdentity - -newtype SimTool = IcarusSim Icarus - deriving (Eq) - -instance NFData SimTool where - rnf (IcarusSim a) = rnf a - -instance Tool SimTool where - toText (IcarusSim icarus) = toText icarus - -instance Simulator SimTool where - runSim (IcarusSim icarus) = runSim icarus - runSimWithFile (IcarusSim icarus) = runSimWithFile icarus - -instance Show SimTool where - show (IcarusSim icarus) = show icarus - -defaultIcarusSim :: SimTool -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 !BResult !NominalDiffTime - 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 <> ")" - -getSimResult :: SimResult -> UResult -getSimResult (SimResult _ _ (Pass _) _) = Pass () -getSimResult (SimResult _ _ (Fail b) _) = Fail b - --- | The results of comparing the synthesised outputs of two files using a --- 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) - -instance Show SynthResult where - show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" - -getSynthResult :: SynthResult -> UResult -getSynthResult (SynthResult _ _ a _) = a - --- | The status of the synthesis using a simulator. This will be checked before --- attempting to run the equivalence checks on the simulator, as that would be --- unnecessary otherwise. -data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime - 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 <> ")" - --- | The complete state that will be used during fuzzing, which contains the --- results from all the operations. -data FuzzReport = FuzzReport { _fuzzDir :: !FilePath - , _synthResults :: ![SynthResult] - , _simResults :: ![SimResult] - , _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 <> "'" - --- | 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 -descriptionToSynth (SynthDescription "vivado" bin desc 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 -descriptionToSynth (SynthDescription "quartus" bin desc out) = - QuartusSynth - . Quartus (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 -descriptionToSynth 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 (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" - -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 - -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 - -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" - -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 - -resultStatus :: Result a b -> Html -resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" -resultStatus (Fail _) = H.td ! A.class_ "is-danger" $ "Failed" - -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 = fromList . 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 - ! A.href - ( H.textValue - $ toTextIgnore (dir fromText "index" <.> "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 - ] - 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 - -printResultReport :: Text -> FuzzReport -> Text -printResultReport t f = toStrict . renderHtml $ resultReport t f - -printSummary :: Text -> [FuzzReport] -> Text -printSummary t f = toStrict . renderHtml $ summary t f diff --git a/src/VeriFuzz/Result.hs b/src/VeriFuzz/Result.hs deleted file mode 100644 index 7bfbf9b..0000000 --- a/src/VeriFuzz/Result.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-| -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 MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module VeriSmith.Result - ( Result(..) - , ResultT(..) - , () - , annotate - ) -where - -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, liftSh) - --- | 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) - -instance Semigroup (Result a b) where - Pass _ <> a = a - a <> _ = a - -instance (Monoid b) => Monoid (Result a b) where - mempty = Pass mempty - -instance Functor (Result a) where - 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 - -instance Monad (Result a) where - Pass a >>= f = f a - Fail b >>= _ = Fail b - -instance MonadBase (Result a) (Result a) where - liftBase = id - -instance Bifunctor Result where - 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) } - -instance Functor f => Functor (ResultT a f) where - 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) - -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) - -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)) - -instance MonadIO m => MonadIO (ResultT a m) where - liftIO s = ResultT $ Pass <$> liftIO s - -instance MonadBase b m => MonadBase b (ResultT a m) where - liftBase = liftBaseDefault - -instance MonadTrans (ResultT e) where - 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 #-} - -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 #-} - -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 - -annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b -annotate = flip () diff --git a/src/VeriFuzz/Sim.hs b/src/VeriFuzz/Sim.hs deleted file mode 100644 index f0489d3..0000000 --- a/src/VeriFuzz/Sim.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : VeriSmith.Sim -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.Sim - ( - -- * Simulators - -- ** Icarus - Icarus(..) - , defaultIcarus - -- * Synthesisers - -- ** Yosys - , Yosys(..) - , defaultYosys - -- ** Vivado - , Vivado(..) - , defaultVivado - -- ** XST - , XST(..) - , defaultXST - -- ** Quartus - , Quartus(..) - , defaultQuartus - -- ** Identity - , Identity(..) - , defaultIdentity - -- * Equivalence - , runEquiv - -- * Simulation - , runSim - -- * Synthesis - , runSynth - , logger - ) -where - -import VeriSmith.Sim.Icarus -import VeriSmith.Sim.Identity -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Quartus -import VeriSmith.Sim.Vivado -import VeriSmith.Sim.XST -import VeriSmith.Sim.Yosys diff --git a/src/VeriFuzz/Sim/Icarus.hs b/src/VeriFuzz/Sim/Icarus.hs deleted file mode 100644 index f104630..0000000 --- a/src/VeriFuzz/Sim/Icarus.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-| -Module : VeriSmith.Sim.Icarus -Description : Icarus verilog module. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Icarus verilog module. --} - -module VeriSmith.Sim.Icarus - ( Icarus(..) - , defaultIcarus - , runSimIc - ) -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.Sim.Internal -import VeriSmith.Sim.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) - -instance Show Icarus where - show _ = "iverilog" - -instance Tool Icarus where - toText _ = "iverilog" - -instance Simulator Icarus where - runSim = runSimIcarus - runSimWithFile = runSimIcarusWithFile - -instance NFData Icarus where - rnf = rwhnf - -defaultIcarus :: Icarus -defaultIcarus = Icarus "iverilog" "vvp" - -addDisplay :: [Statement] -> [Statement] -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 -assignFunc inp bs = - 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 - -mask :: Text -> Text -mask = T.replace "x" "0" - -callback :: ByteString -> Text -> ByteString -callback b t = b <> convert (mask t) - -runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss - where m = rinfo ^. mainModule - -runSimIcarusWithFile - :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString -runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) - -fromBytes :: ByteString -> Integer -fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b - -runSimIc - :: (Synthesiser b) - => Icarus - -> b - -> SourceInfo - -> [ByteString] - -> ResultSh ByteString -runSimIc sim1 synth1 srcInfo bss = do - dir <- liftSh pwd - let top = srcInfo ^. mainModule - let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) - let - tb = 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 - ) - <> (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"] - ] - [] - - liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 - liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] - liftSh - $ B.take 8 - . BA.convert - . (hash :: ByteString -> Digest SHA256) - <$> logCommand - dir - "vvp" - (runFoldLines (mempty :: ByteString) - callback - (vvpPath sim1) - ["main"] - ) - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriFuzz/Sim/Identity.hs b/src/VeriFuzz/Sim/Identity.hs deleted file mode 100644 index cac230f..0000000 --- a/src/VeriFuzz/Sim/Identity.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Identity - ( 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.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text - , identityOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Identity where - toText (Identity d _) = d - -instance Show Identity where - show t = unpack $ toText t - -instance Synthesiser Identity where - runSynth = runSynthIdentity - synthOutput = identityOutput - setSynthOutput (Identity a _) = Identity a - -instance NFData Identity where - rnf = rwhnf - -runSynthIdentity :: Identity -> SourceInfo -> ResultSh () -runSynthIdentity (Identity _ out) = writefile out . genSource - -defaultIdentity :: Identity -defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/VeriFuzz/Sim/Internal.hs b/src/VeriFuzz/Sim/Internal.hs deleted file mode 100644 index 017faad..0000000 --- a/src/VeriFuzz/Sim/Internal.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| -Module : VeriSmith.Sim.Internal -Description : Class of the simulator. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Class of the simulator and the synthesize tool. --} - -{-# LANGUAGE DeriveFunctor #-} - -module VeriSmith.Sim.Internal - ( 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.Internal -import VeriSmith.Result -import VeriSmith.Verilog.AST - --- | Tool class. -class Tool a where - toText :: a -> Text - --- | Simulation type class. -class Tool a => Simulator a where - runSim :: a -- ^ Simulator instance - -> SourceInfo -- ^ 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 - | EquivError - | SimFail - | SynthFail - | TimeoutError - deriving (Eq, Show) - -instance Semigroup Failed where - EmptyFail <> a = a - b <> _ = b - -instance Monoid Failed where - mempty = EmptyFail - --- | Synthesiser type class. -class Tool a => Synthesiser a where - runSynth :: a -- ^ Synthesiser tool instance - -> SourceInfo -- ^ Run information - -> ResultSh () -- ^ does not return any values - synthOutput :: a -> FilePath - setSynthOutput :: a -> FilePath -> a - -renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo -renameSource a src = - 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 --- with also has those instances. -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' - -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 - --- | 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 -> Sh [Text] -checkPresentModules fp (SourceInfo _ src) = do - 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] - --- | 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 --- should find all the instantiations and definitions. This could again be made --- much simpler if the parser works. -replaceMods :: FilePath -> Text -> SourceInfo -> Sh () -replaceMods fp t (SourceInfo _ src) = - 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" - -timeout :: FilePath -> [Text] -> Sh Text -timeout = command1 "timeout" ["300"] . toTextIgnore -{-# INLINE timeout #-} - -timeout_ :: FilePath -> [Text] -> Sh () -timeout_ = command1_ "timeout" ["300"] . toTextIgnore -{-# INLINE timeout_ #-} - --- | Helper function to convert bytestrings to integers -bsToI :: ByteString -> Integer -bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 -{-# INLINE bsToI #-} - -noPrint :: Sh a -> Sh a -noPrint = print_stdout False . print_stderr False -{-# INLINE noPrint #-} - -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 - -logCommand :: FilePath -> Text -> Sh a -> Sh a -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" - file s = T.unpack (toTextIgnore $ fp fromText name) <> s - -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 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 () -execute_ a b c d = void . execute a b c d diff --git a/src/VeriFuzz/Sim/Quartus.hs b/src/VeriFuzz/Sim/Quartus.hs deleted file mode 100644 index 6837133..0000000 --- a/src/VeriFuzz/Sim/Quartus.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Quartus - ( 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.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Quartus = Quartus { quartusBin :: !(Maybe FilePath) - , quartusDesc :: {-# UNPACK #-} !Text - , quartusOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Quartus where - toText (Quartus _ t _) = t - -instance Show Quartus where - show t = unpack $ toText t - -instance Synthesiser Quartus where - runSynth = runSynthQuartus - synthOutput = quartusOutput - setSynthOutput (Quartus a b _) = Quartus a b - -instance NFData Quartus where - rnf = rwhnf - -defaultQuartus :: Quartus -defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" - -runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () -runSynthQuartus sim (SourceInfo top src) = do - dir <- liftSh pwd - let ex = execute_ SynthFail dir "quartus" - liftSh . writefile inpf $ genSource src - liftSh . noPrint $ run_ - "sed" - [ "-i" - , "s/^module/(* multstyle = \"logic\" *) module/;" - , toTextIgnore inpf - ] - ex (exec "quartus_map") - [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] - ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] - ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] - 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/VeriFuzz/Sim/Template.hs b/src/VeriFuzz/Sim/Template.hs deleted file mode 100644 index d232420..0000000 --- a/src/VeriFuzz/Sim/Template.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Template - ( yosysSatConfig - , yosysSimConfig - , xstSynthConfig - , vivadoSynthConfig - , sbyConfig - , icarusTestbench - ) -where - -import Control.Lens ((^..)) -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (FilePath) -import Shelly -import Text.Shakespeare.Text (st) -import VeriSmith.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -rename :: Text -> [Text] -> Text -rename end entries = - T.intercalate "\n" - $ flip mappend end - . mappend "rename " - . doubleName - <$> entries -{-# INLINE rename #-} - -doubleName :: Text -> Text -doubleName n = n <> " " <> n -{-# INLINE doubleName #-} - -outputText :: Synthesiser a => a -> Text -outputText = toTextIgnore . synthOutput - --- brittany-disable-next-binding -yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 - --- brittany-disable-next-binding -yosysSimConfig :: Text -yosysSimConfig = [st|read_verilog rtl.v; proc;; -rename mod mod_rtl -|] - --- brittany-disable-next-binding -xstSynthConfig :: Text -> Text -xstSynthConfig top = [st|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" -|] - --- brittany-disable-next-binding -vivadoSynthConfig :: Text -> Text -> Text -vivadoSynthConfig top outf = [st| -# 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} -|] - --- brittany-disable-next-binding -sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] -multiclock on -mode prove - -[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 - . (fromText "data" ) - . fromText - <$> deps - readL = T.intercalate "\n" $ mappend "read -formal " <$> deps - -icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text -icarusTestbench t synth1 = [st| -`include "data/cells_cmos.v" -`include "data/cells_cyclone_v.v" -`include "data/cells_verific.v" -`include "data/cells_xilinx_7.v" -`include "data/cells_yosys.v" -`include "#{toTextIgnore $ synthOutput synth1}" - -#{genSource t} -|] diff --git a/src/VeriFuzz/Sim/Vivado.hs b/src/VeriFuzz/Sim/Vivado.hs deleted file mode 100644 index e8d8f0d..0000000 --- a/src/VeriFuzz/Sim/Vivado.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Vivado - ( 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.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) - , vivadoDesc :: {-# UNPACK #-} !Text - , vivadoOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Vivado where - toText (Vivado _ t _) = t - -instance Show Vivado where - show t = unpack $ toText t - -instance Synthesiser Vivado where - runSynth = runSynthVivado - synthOutput = vivadoOutput - setSynthOutput (Vivado a b _) = Vivado a b - -instance NFData Vivado where - rnf = rwhnf - -defaultVivado :: Vivado -defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" - -runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/VeriFuzz/Sim/XST.hs b/src/VeriFuzz/Sim/XST.hs deleted file mode 100644 index 30a4b0b..0000000 --- a/src/VeriFuzz/Sim/XST.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| -Module : VeriSmith.Sim.XST -Description : XST (ise) simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -XST (ise) simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module VeriSmith.Sim.XST - ( 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 Text.Shakespeare.Text (st) -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data XST = XST { xstBin :: !(Maybe FilePath) - , xstDesc :: {-# UNPACK #-} !Text - , xstOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool XST where - toText (XST _ t _) = t - -instance Show XST where - show t = unpack $ toText t - -instance Synthesiser XST where - runSynth = runSynthXST - synthOutput = xstOutput - setSynthOutput (XST a b _) = XST a b - -instance NFData XST where - rnf = rwhnf - -defaultXST :: XST -defaultXST = XST Nothing "xst" "syn_xst.v" - -runSynthXST :: XST -> SourceInfo -> 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 [st|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" - prjFile = modFile <.> "prj" diff --git a/src/VeriFuzz/Sim/Yosys.hs b/src/VeriFuzz/Sim/Yosys.hs deleted file mode 100644 index 1f583a8..0000000 --- a/src/VeriFuzz/Sim/Yosys.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-| -Module : VeriSmith.Sim.Yosys -Description : Yosys simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Yosys simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module VeriSmith.Sim.Yosys - ( Yosys(..) - , defaultYosys - , runEquiv - , runEquivYosys - ) -where - -import Control.DeepSeq (NFData, rnf, rwhnf) -import Control.Lens -import Control.Monad (void) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Text.Shakespeare.Text (st) -import VeriSmith.Result -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen -import VeriSmith.Verilog.Mutate - -data Yosys = Yosys { yosysBin :: !(Maybe FilePath) - , yosysDesc :: {-# UNPACK #-} !Text - , yosysOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Yosys where - toText (Yosys _ t _) = t - -instance Show Yosys where - show t = unpack $ toText t - -instance Synthesiser Yosys where - runSynth = runSynthYosys - synthOutput = yosysOutput - setSynthOutput (Yosys a b _) = Yosys a b - -instance NFData Yosys where - rnf = rwhnf - -defaultYosys :: Yosys -defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" - -yosysPath :: Yosys -> FilePath -yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim - -runSynthYosys :: Yosys -> SourceInfo -> ResultSh () -runSynthYosys sim (SourceInfo _ src) = do - dir <- liftSh $ do - dir' <- pwd - 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 = toTextIgnore inpf - out = toTextIgnore $ synthOutput sim - -runEquivYosys - :: (Synthesiser a, Synthesiser b) - => Yosys - -> a - -> b - -> SourceInfo - -> ResultSh () -runEquivYosys yosys sim1 sim2 srcInfo = do - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTop 2 - $ srcInfo - ^. mainModule - writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo - runSynth sim1 srcInfo - runSynth sim2 srcInfo - liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] - where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] - -runEquiv - :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () -runEquiv sim1 sim2 srcInfo = do - dir <- liftSh pwd - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTopAssert - $ srcInfo - ^. mainModule - replaceMods (synthOutput sim1) "_1" srcInfo - replaceMods (synthOutput sim2) "_2" srcInfo - writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo - e <- liftSh $ do - exe dir "symbiyosys" "sby" ["-f", "proof.sby"] - lastExitCode - case e of - 0 -> ResultT . return $ Pass () - 2 -> ResultT . return $ Fail EquivFail - 124 -> ResultT . return $ Fail TimeoutError - _ -> ResultT . return $ Fail EquivError - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriFuzz/Verilog.hs b/src/VeriFuzz/Verilog.hs deleted file mode 100644 index 6e7851c..0000000 --- a/src/VeriFuzz/Verilog.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-| -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 - ( SourceInfo(..) - , Verilog(..) - , parseVerilog - , GenVerilog(..) - , genSource - -- * Primitives - -- ** Identifier - , Identifier(..) - -- ** Control - , Delay(..) - , Event(..) - -- ** Operators - , BinaryOperator(..) - , UnaryOperator(..) - -- ** Task - , Task(..) - , taskName - , taskExpr - -- ** Left hand side value - , LVal(..) - , regId - , regExprId - , regExpr - , regSizeId - , regSizeRange - , regConc - -- ** Ports - , PortDir(..) - , PortType(..) - , Port(..) - , portType - , portSigned - , portSize - , portName - -- * Expression - , Expr(..) - , ConstExpr(..) - , constToExpr - , exprToConst - , constNum - -- * Assignment - , Assign(..) - , assignReg - , assignDelay - , assignExpr - , ContAssign(..) - , contAssignNetLVal - , contAssignExpr - -- * Statment - , 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 - -- * Useful Lenses and Traversals - , getModule - , getSourceId - -- * Quote - , verilog - ) -where - -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen -import VeriSmith.Verilog.Parser -import VeriSmith.Verilog.Quote diff --git a/src/VeriFuzz/Verilog/AST.hs b/src/VeriFuzz/Verilog/AST.hs deleted file mode 100644 index 78bad45..0000000 --- a/src/VeriFuzz/Verilog/AST.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-| -Module : VeriSmith.Verilog.AST -Description : Definition of the Verilog AST types. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module VeriSmith.Verilog.AST - ( -- * Top level types - SourceInfo(..) - , infoTop - , infoSrc - , Verilog(..) - -- * Primitives - -- ** Identifier - , Identifier(..) - -- ** Control - , Delay(..) - , Event(..) - -- ** Operators - , BinaryOperator(..) - , UnaryOperator(..) - -- ** Task - , Task(..) - , taskName - , taskExpr - -- ** Left hand side value - , LVal(..) - , regId - , regExprId - , regExpr - , regSizeId - , regSizeRange - , regConc - -- ** Ports - , 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 - -- * Assignment - , Assign(..) - , assignReg - , assignDelay - , assignExpr - , ContAssign(..) - , contAssignNetLVal - , contAssignExpr - -- ** Parameters - , Parameter(..) - , paramIdent - , paramValue - , LocalParam(..) - , localParamIdent - , localParamValue - -- * Statment - , Statement(..) - , statDelay - , statDStat - , statEvent - , statEStat - , statements - , stmntBA - , stmntNBA - , stmntTask - , stmntSysTask - , stmntCondExpr - , stmntCondTrue - , stmntCondFalse - , 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 - -- * Useful Lenses and Traversals - , aModule - , getModule - , getSourceId - , mainModule - ) -where - -import Control.DeepSeq (NFData) -import Control.Lens hiding ((<|)) -import Data.Data -import Data.Data.Lens -import Data.Functor.Foldable.TH (makeBaseFunctor) -import Data.List.NonEmpty (NonEmpty (..), (<|)) -import Data.String (IsString, fromString) -import Data.Text (Text, pack) -import Data.Traversable (sequenceA) -import GHC.Generics (Generic) -import VeriSmith.Verilog.BitVec - --- | 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) - -instance IsString Identifier where - fromString = Identifier . pack - -instance Semigroup Identifier where - Identifier a <> Identifier b = Identifier $ a <> b - -instance Monoid Identifier where - mempty = Identifier mempty - --- | Verilog syntax for adding a delay, which is represented as @#num@. -newtype Delay = Delay { _getDelay :: Int } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Num Delay where - Delay a + Delay b = Delay $ a + b - Delay a - Delay b = Delay $ a - b - Delay a * Delay b = Delay $ a * b - negate (Delay a) = Delay $ negate a - abs (Delay a) = Delay $ abs a - signum (Delay a) = Delay $ signum a - fromInteger = Delay . fromInteger - --- | 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) - -instance Plated Event where - 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) - --- | 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) - --- | Verilog expression, which can either be a primary expression, unary --- expression, binary operator expression or a conditional expression. -data Expr = Number {-# UNPACK #-} !BitVec - -- ^ Number implementation containing the size and the value itself - | Id {-# UNPACK #-} !Identifier - | VecSelect {-# UNPACK #-} !Identifier !Expr - | RangeSelect {-# UNPACK #-} !Identifier !Range - -- ^ Symbols - | Concat !(NonEmpty Expr) - -- ^ Bit-wise concatenation of expressions represented by braces. - | UnOp !UnaryOperator !Expr - | BinOp !Expr !BinaryOperator !Expr - | Cond !Expr !Expr !Expr - | Appl !Identifier !Expr - | Str {-# UNPACK #-} !Text - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Num Expr where - a + b = BinOp a BinPlus b - a - b = BinOp a BinMinus b - a * b = BinOp a BinTimes b - negate = UnOp UnMinus - abs = undefined - signum = undefined - fromInteger = Number . fromInteger - -instance Semigroup Expr where - (Concat a) <> (Concat b) = Concat $ a <> b - (Concat a) <> b = Concat $ a <> (b :| []) - a <> (Concat b) = Concat $ a <| b - a <> b = Concat $ a <| b :| [] - -instance Monoid Expr where - mempty = Number 0 - -instance IsString Expr where - fromString = Str . fromString - -instance Plated Expr where - plate = uniplate - --- | 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) - -constToExpr :: ConstExpr -> Expr -constToExpr (ConstNum a ) = Number a -constToExpr (ParamId a ) = Id a -constToExpr (ConstConcat a ) = Concat $ fmap constToExpr a -constToExpr (ConstUnOp a b ) = UnOp a $ constToExpr b -constToExpr (ConstBinOp a b c) = BinOp (constToExpr a) b $ constToExpr c -constToExpr (ConstCond a b c) = - Cond (constToExpr a) (constToExpr b) $ constToExpr c -constToExpr (ConstStr a) = Str a - -exprToConst :: Expr -> ConstExpr -exprToConst (Number a ) = ConstNum a -exprToConst (Id a ) = ParamId a -exprToConst (Concat a ) = ConstConcat $ fmap exprToConst a -exprToConst (UnOp a b ) = ConstUnOp a $ exprToConst b -exprToConst (BinOp a b c) = ConstBinOp (exprToConst a) b $ exprToConst c -exprToConst (Cond a b c) = - ConstCond (exprToConst a) (exprToConst b) $ exprToConst c -exprToConst (Str a) = ConstStr a -exprToConst _ = error "Not a constant expression" - -instance Num ConstExpr where - a + b = ConstBinOp a BinPlus b - a - b = ConstBinOp a BinMinus b - a * b = ConstBinOp a BinTimes b - negate = ConstUnOp UnMinus - abs = undefined - signum = undefined - fromInteger = ConstNum . fromInteger - -instance Semigroup ConstExpr where - (ConstConcat a) <> (ConstConcat b) = ConstConcat $ a <> b - (ConstConcat a) <> b = ConstConcat $ a <> (b :| []) - a <> (ConstConcat b) = ConstConcat $ a <| b - a <> b = ConstConcat $ a <| b :| [] - -instance Monoid ConstExpr where - mempty = ConstNum 0 - -instance IsString ConstExpr where - fromString = ConstStr . fromString - -instance Plated ConstExpr where - plate = uniplate - -data Task = Task { _taskName :: {-# UNPACK #-} !Identifier - , _taskExpr :: [Expr] - } deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | Type that represents the left hand side of an assignment, which can be a --- concatenation such as in: --- --- @ --- {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) - -instance IsString LVal where - fromString = RegId . fromString - --- | Different port direction that are supported in Verilog. -data PortDir = PortIn -- ^ Input direction for port (@input@). - | PortOut -- ^ Output direction for port (@output@). - | PortInOut -- ^ Inout direction for port (@inout@). - 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) - --- | 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) - -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 - --- | 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 --- an input or output port. However, this is not always necessary and was more --- cumbersome than useful, as a lot of ports can be declared without input and --- output port. --- --- This is now implemented inside 'ModDecl' 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) - --- | This is currently a type because direct module declaration should also be --- added: --- --- @ --- 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 ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier - , _contAssignExpr :: !Expr - } deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | Statements in Verilog. -data Statement = TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay - , _statDStat :: Maybe Statement - } -- ^ Time control (@#NUM@) - | EventCtrl { _statEvent :: !Event - , _statEStat :: Maybe Statement - } - | SeqBlock { _statements :: [Statement] } -- ^ Sequential block (@begin ... end@) - | BlockAssign { _stmntBA :: !Assign } -- ^ blocking assignment (@=@) - | NonBlockAssign { _stmntNBA :: !Assign } -- ^ Non blocking assignment (@<=@) - | TaskEnable { _stmntTask :: !Task } - | SysTaskEnable { _stmntSysTask :: !Task } - | CondStmnt { _stmntCondExpr :: Expr - , _stmntCondTrue :: Maybe Statement - , _stmntCondFalse :: Maybe Statement - } - | ForLoop { _forAssign :: !Assign - , _forExpr :: Expr - , _forIncr :: !Assign - , _forStmnt :: Statement - } -- ^ Loop bounds shall be statically computable for a for loop. - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Plated Statement where - plate = uniplate - -instance Semigroup Statement where - (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b - (SeqBlock a) <> b = SeqBlock $ a <> [b] - a <> (SeqBlock b) = SeqBlock $ a : b - a <> b = SeqBlock [a, b] - -instance Monoid Statement where - mempty = SeqBlock [] - --- | 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) - --- | 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) - --- | Module item which is the body of the module expression. -data ModItem = ModCA { _modContAssign :: !ContAssign } - | ModInst { _modInstId :: {-# UNPACK #-} !Identifier - , _modInstName :: {-# UNPACK #-} !Identifier - , _modInstConns :: [ModConn] - } - | Initial !Statement - | Always !Statement - | Decl { _declDir :: !(Maybe PortDir) - , _declPort :: !Port - , _declVal :: Maybe ConstExpr - } - | ParamDecl { _paramDecl :: NonEmpty Parameter } - | LocalParamDecl { _localParamDecl :: NonEmpty LocalParam } - deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module' -data ModDecl = ModDecl { _modId :: {-# UNPACK #-} !Identifier - , _modOutPorts :: ![Port] - , _modInPorts :: ![Port] - , _modItems :: ![ModItem] - , _modParams :: ![Parameter] - } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn -traverseModConn f (ModConn e ) = ModConn <$> f e -traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e - -traverseModItem :: (Applicative f) => (Expr -> f Expr) -> ModItem -> f ModItem -traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e -traverseModItem f (ModInst a b e) = - ModInst a b <$> sequenceA (traverseModConn f <$> e) -traverseModItem _ e = pure e - --- | The complete sourcetext for the Verilog module. -newtype Verilog = Verilog { getVerilog :: [ModDecl] } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Semigroup Verilog where - Verilog a <> Verilog b = Verilog $ a <> b - -instance Monoid Verilog where - mempty = Verilog mempty - -data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text - , _infoSrc :: !Verilog - } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -$(makeLenses ''Expr) -$(makeLenses ''ConstExpr) -$(makeLenses ''Task) -$(makeLenses ''LVal) -$(makeLenses ''PortType) -$(makeLenses ''Port) -$(makeLenses ''ModConn) -$(makeLenses ''Assign) -$(makeLenses ''ContAssign) -$(makeLenses ''Statement) -$(makeLenses ''ModItem) -$(makeLenses ''Parameter) -$(makeLenses ''LocalParam) -$(makeLenses ''ModDecl) -$(makeLenses ''SourceInfo) -$(makeWrapped ''Verilog) -$(makeWrapped ''Identifier) -$(makeWrapped ''Delay) -$(makePrisms ''ModItem) - -$(makeBaseFunctor ''Event) -$(makeBaseFunctor ''Expr) -$(makeBaseFunctor ''ConstExpr) - -getModule :: Traversal' Verilog ModDecl -getModule = _Wrapped . traverse -{-# INLINE getModule #-} - -getSourceId :: Traversal' Verilog Text -getSourceId = getModule . modId . _Wrapped -{-# INLINE getSourceId #-} - --- | May need to change this to Traversal to be safe. For now it will fail when --- the main has not been properly set with. -aModule :: Identifier -> Lens' SourceInfo ModDecl -aModule t = lens get_ set_ - where - set_ (SourceInfo top main) v = - SourceInfo top (main & getModule %~ update (getIdentifier t) v) - update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v - | otherwise = m - get_ (SourceInfo _ main) = - head . filter (f $ getIdentifier t) $ main ^.. getModule - f top (ModDecl (Identifier i) _ _ _ _) = i == top - - --- | 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 ModDecl -mainModule = lens get_ set_ - where - set_ (SourceInfo top main) v = - SourceInfo top (main & getModule %~ update top v) - update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v - | otherwise = m - get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule - f top (ModDecl (Identifier i) _ _ _ _) = i == top diff --git a/src/VeriFuzz/Verilog/BitVec.hs b/src/VeriFuzz/Verilog/BitVec.hs deleted file mode 100644 index dab9e2c..0000000 --- a/src/VeriFuzz/Verilog/BitVec.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-| -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 DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} - -module VeriSmith.Verilog.BitVec - ( BitVecF(..) - , BitVec - , bitVec - , select - ) -where - -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) - --- | 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 - -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 - -instance (Integral a, Bits a) => Real (BitVecF a) where - 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 - -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 - -instance (Num a, Bits a) => FiniteBits (BitVecF a) where - finiteBitSize (BitVec w _) = w - -instance Bits a => Semigroup (BitVecF a) where - (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) - -instance Bits a => Monoid (BitVecF a) where - 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 (BitVec _ v) (msb, lsb) = - 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 - 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 - where - 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/VeriFuzz/Verilog/CodeGen.hs b/src/VeriFuzz/Verilog/CodeGen.hs deleted file mode 100644 index 1e94472..0000000 --- a/src/VeriFuzz/Verilog/CodeGen.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-| -Module : VeriSmith.Verilog.CodeGen -Description : Code generation for Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 #-} - -module VeriSmith.Verilog.CodeGen - ( -- * 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 - --- | '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 --- can then be processed further. -class Source a where - genSource :: a -> Text - --- | Map a 'Maybe Statement' to 'Text'. If it is 'Just statement', the generated --- statements are returned. If it is 'Nothing', then @;\n@ is returned. -defMap :: Maybe Statement -> Doc a -defMap = maybe semi statement - --- | Convert the 'Verilog' type to 'Text' so that it can be rendered. -verilogSrc :: Verilog -> Doc a -verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules - --- | Generate the 'ModDecl' for a module and convert it to 'Text'. -moduleDecl :: ModDecl -> Doc a -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 - outIn = outP ++ inP - params [] = "" - params (p : pps) = hcat ["#", paramList (p :| pps)] - --- | Generates a parameter list. Can only be called with a 'NonEmpty' list. -paramList :: NonEmpty Parameter -> Doc a -paramList ps = tupled . toList $ parameter <$> ps - --- | Generates a localparam list. Can only be called with a 'NonEmpty' list. -localParamList :: NonEmpty LocalParam -> Doc a -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] - --- | Generates the assignment for a 'LocalParam'. -localParam :: LocalParam -> Doc a -localParam (LocalParam name val) = - hsep ["localparameter", identifier name, "=", constExpr val] - -identifier :: Identifier -> Doc a -identifier (Identifier i) = pretty i - --- | Conversts 'Port' to 'Text' for the module list, which means it only --- generates a list of identifiers. -modPort :: Port -> Doc a -modPort (Port _ _ _ i) = identifier i - --- | Generate the 'Port' description. -port :: Port -> Doc a -port (Port tp sgn r name) = hsep [t, sign, range r, identifier name] - where - t = pType tp - sign = signed sgn - -range :: Range -> Doc a -range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] - -signed :: Bool -> Doc a -signed True = "signed" -signed _ = mempty - --- | Convert the 'PortDir' type to 'Text'. -portDir :: PortDir -> Doc a -portDir PortIn = "input" -portDir PortOut = "output" -portDir PortInOut = "inout" - --- | Generate a 'ModItem'. -moduleItem :: ModItem -> Doc a -moduleItem (ModCA ca ) = contAssign ca -moduleItem (ModInst i name conn) = hsep - [ identifier i - , identifier name - , parens . hsep $ punctuate comma (mConn <$> conn) - , semi - ] -moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat] -moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat] -moduleItem (Decl dir p ini) = hsep - [maybe mempty makePort dir, port p, maybe mempty makeIni ini, semi] - where - makePort = portDir - makeIni = ("=" <+>) . constExpr -moduleItem (ParamDecl p) = hcat [paramList p, semi] -moduleItem (LocalParamDecl p) = hcat [localParamList p, semi] - -mConn :: ModConn -> Doc a -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) = - hsep ["assign", identifier val, "=", align $ expr e, semi] - --- | 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 (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c) -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]] -expr (Appl f e) = hcat [identifier f, parens $ expr e] -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) "")] - where - minus | signum n >= 0 = mempty - | otherwise = "-" - -constExpr :: ConstExpr -> Doc a -constExpr (ConstNum b) = showNum b -constExpr (ParamId i) = identifier i -constExpr (ConstConcat 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] -constExpr (ConstCond l t 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 BinXNorInv = "~^" -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 UnNxorInv = "^~" - -event :: Event -> Doc a -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 (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] - --- | Generates verilog code for a 'Delay'. -delay :: Delay -> Doc a -delay (Delay i) = "#" <> pretty i - --- | Generate the verilog code for an 'LVal'. -lVal :: LVal -> Doc a -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" - -genAssign :: Text -> Assign -> Doc a -genAssign op (Assign r d e) = - hsep [lVal r, pretty op, maybe mempty delay d, expr e] - -statement :: Statement -> Doc a -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] -statement (NonBlockAssign a) = hcat [genAssign "<=" a, 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] -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 - [ hsep - [ "for" - , parens . hsep $ punctuate - semi - [genAssign "=" a, expr e, genAssign "=" incr] - ] - , indent 2 $ statement stmnt - ] - -task :: Task -> Doc a -task (Task i 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 () -render = print . genSource - --- Instances - -instance Source Identifier where - genSource = showT . identifier - -instance Source Task where - genSource = showT . task - -instance Source Statement where - genSource = showT . statement - -instance Source PortType where - genSource = showT . pType - -instance Source ConstExpr where - genSource = showT . constExpr - -instance Source LVal where - genSource = showT . lVal - -instance Source Delay where - genSource = showT . delay - -instance Source Event where - genSource = showT . event - -instance Source UnaryOperator where - genSource = showT . unaryOp - -instance Source Expr where - genSource = showT . expr - -instance Source ContAssign where - genSource = showT . contAssign - -instance Source ModItem where - genSource = showT . moduleItem - -instance Source PortDir where - genSource = showT . portDir - -instance Source Port where - genSource = showT . port - -instance Source ModDecl where - genSource = showT . moduleDecl - -instance Source Verilog where - genSource = showT . verilogSrc - -instance Source SourceInfo where - genSource (SourceInfo _ src) = genSource src - -newtype GenVerilog a = GenVerilog { unGenVerilog :: a } - deriving (Eq, Ord, Data) - -instance (Source a) => Show (GenVerilog a) where - show = T.unpack . genSource . unGenVerilog diff --git a/src/VeriFuzz/Verilog/Eval.hs b/src/VeriFuzz/Verilog/Eval.hs deleted file mode 100644 index 1ebaa80..0000000 --- a/src/VeriFuzz/Verilog/Eval.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-| -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 - ) -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 - -type Bindings = [Parameter] - -paramIdent_ :: Parameter -> Identifier -paramIdent_ (Parameter i _) = i - -paramValue_ :: Parameter -> ConstExpr -paramValue_ (Parameter _ v) = v - -applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a -applyUnary UnPlus a = a -applyUnary UnMinus a = negate a -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 - -compXor :: Bits c => c -> c -> c -compXor a = complement . xor a - -toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p -toIntegral a b c = if a b c then 1 else 0 - -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 BinXNorInv = compXor -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 -evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b -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 (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c -applyBitVec f (ConstBinOp a binop 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 -applyBitVec _ a = a - --- | This probably could be implemented using some recursion scheme in the --- future. It would also be fixed by having a polymorphic expression type. -resize :: Int -> ConstExpr -> ConstExpr -resize n = applyBitVec (resize' n) where resize' n' (BitVec _ a) = BitVec n' a diff --git a/src/VeriFuzz/Verilog/Internal.hs b/src/VeriFuzz/Verilog/Internal.hs deleted file mode 100644 index ed91b12..0000000 --- a/src/VeriFuzz/Verilog/Internal.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-| -Module : VeriSmith.Verilog.Internal -Description : Defaults and common functions. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -where - -import Control.Lens -import Data.Text (Text) -import VeriSmith.Verilog.AST - -regDecl :: Identifier -> ModItem -regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing - -wireDecl :: Identifier -> ModItem -wireDecl i = Decl Nothing (Port Wire False (Range 1 0) i) Nothing - --- | Create an empty module. -emptyMod :: ModDecl -emptyMod = ModDecl "" [] [] [] [] - --- | Set a module name for a module declaration. -setModName :: Text -> ModDecl -> ModDecl -setModName str = modId .~ Identifier str - --- | Add a input port to the module declaration. -addModPort :: Port -> ModDecl -> ModDecl -addModPort port = modInPorts %~ (:) port - -addModDecl :: ModDecl -> Verilog -> Verilog -addModDecl desc = _Wrapped %~ (:) desc - -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 - ] - ] - [] - -addTestBench :: Verilog -> Verilog -addTestBench = addModDecl testBench - -defaultPort :: Identifier -> Port -defaultPort = Port Wire False (Range 1 0) - -portToExpr :: Port -> Expr -portToExpr (Port _ _ _ i) = Id i - -modName :: ModDecl -> Text -modName = getIdentifier . view modId - -yPort :: Identifier -> Port -yPort = Port Wire False (Range 90 0) - -wire :: Range -> Identifier -> Port -wire = Port Wire False - -reg :: Range -> Identifier -> Port -reg = Port Reg False diff --git a/src/VeriFuzz/Verilog/Lex.x b/src/VeriFuzz/Verilog/Lex.x deleted file mode 100644 index 3d1dd8d..0000000 --- a/src/VeriFuzz/Verilog/Lex.x +++ /dev/null @@ -1,188 +0,0 @@ --- -*- haskell -*- -{ -{-# OPTIONS_GHC -w #-} -module VeriSmith.Verilog.Lex - ( alexScanTokens - ) where - -import VeriSmith.Verilog.Token - -} - -%wrapper "posn" - --- Numbers - -$nonZeroDecimalDigit = [1-9] -$decimalDigit = [0-9] -@binaryDigit = [0-1] -@octalDigit = [0-7] -@hexDigit = [0-9a-fA-F] - -@decimalBase = "'" [dD] -@binaryBase = "'" [bB] -@octalBase = "'" [oO] -@hexBase = "'" [hH] - -@binaryValue = @binaryDigit ("_" | @binaryDigit)* -@octalValue = @octalDigit ("_" | @octalDigit)* -@hexValue = @hexDigit ("_" | @hexDigit)* - -@unsignedNumber = $decimalDigit ("_" | $decimalDigit)* - -@size = @unsignedNumber - -@decimalNumber - = @unsignedNumber - | @size? @decimalBase @unsignedNumber - -@binaryNumber = @size? @binaryBase @binaryValue -@octalNumber = @size? @octalBase @octalValue -@hexNumber = @size? @hexBase @hexValue - --- $exp = [eE] --- $sign = [\+\-] --- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber -@number = @decimalNumber | @octalNumber | @binaryNumber | @hexNumber - --- Strings - -@string = \" [^\r\n]* \" - --- Identifiers - -@escapedIdentifier = "\" ($printable # $white)+ $white -@simpleIdentifier = [a-zA-Z_] [a-zA-Z0-9_\$]* -@systemIdentifier = "$" [a-zA-Z0-9_\$]+ - - -tokens :- - - "always" { tok KWAlways } - "assign" { tok KWAssign } - "begin" { tok KWBegin } - "case" { tok KWCase } - "default" { tok KWDefault } - "else" { tok KWElse } - "end" { tok KWEnd } - "endcase" { tok KWEndcase } - "endmodule" { tok KWEndmodule } - "for" { tok KWFor } - "if" { tok KWIf } - "initial" { tok KWInitial } - "inout" { tok KWInout } - "input" { tok KWInput } - "integer" { tok KWInteger } - "localparam" { tok KWLocalparam } - "module" { tok KWModule } - "negedge" { tok KWNegedge } - "or" { tok KWOr } - "output" { tok KWOutput } - "parameter" { tok KWParameter } - "posedge" { tok KWPosedge } - "reg" { tok KWReg } - "wire" { tok KWWire } - "signed" { tok KWSigned } - - @simpleIdentifier { tok IdSimple } - @escapedIdentifier { tok IdEscaped } - @systemIdentifier { tok IdSystem } - - @number { tok LitNumber } - @string { tok LitString } - - "(" { tok SymParenL } - ")" { tok SymParenR } - "[" { tok SymBrackL } - "]" { tok SymBrackR } - "{" { tok SymBraceL } - "}" { tok SymBraceR } - "~" { tok SymTildy } - "!" { tok SymBang } - "@" { tok SymAt } - "#" { tok SymPound } - "%" { tok SymPercent } - "^" { tok SymHat } - "&" { tok SymAmp } - "|" { tok SymBar } - "*" { tok SymAster } - "." { tok SymDot } - "," { tok SymComma } - ":" { tok SymColon } - ";" { tok SymSemi } - "=" { tok SymEq } - "<" { tok SymLt } - ">" { tok SymGt } - "+" { tok SymPlus } - "-" { tok SymDash } - "?" { tok SymQuestion } - "/" { tok SymSlash } - "$" { tok SymDollar } - "'" { tok SymSQuote } - - "~&" { tok SymTildyAmp } - "~|" { tok SymTildyBar } - "~^" { tok SymTildyHat } - "^~" { tok SymHatTildy } - "==" { tok SymEqEq } - "!=" { tok SymBangEq } - "&&" { tok SymAmpAmp } - "||" { tok SymBarBar } - "**" { tok SymAsterAster } - "<=" { tok SymLtEq } - ">=" { tok SymGtEq } - ">>" { tok SymGtGt } - "<<" { tok SymLtLt } - "++" { tok SymPlusPlus } - "--" { tok SymDashDash } - "+=" { tok SymPlusEq } - "-=" { tok SymDashEq } - "*=" { tok SymAsterEq } - "/=" { tok SymSlashEq } - "%=" { tok SymPercentEq } - "&=" { tok SymAmpEq } - "|=" { tok SymBarEq } - "^=" { tok SymHatEq } - "+:" { tok SymPlusColon } - "-:" { tok SymDashColon } - "::" { tok SymColonColon } - ".*" { tok SymDotAster } - "->" { tok SymDashGt } - ":=" { tok SymColonEq } - ":/" { tok SymColonSlash } - "##" { tok SymPoundPound } - "[*" { tok SymBrackLAster } - "[=" { tok SymBrackLEq } - "=>" { tok SymEqGt } - "@*" { tok SymAtAster } - "(*" { tok SymParenLAster } - "*)" { tok SymAsterParenR } - "*>" { tok SymAsterGt } - - "===" { tok SymEqEqEq } - "!==" { tok SymBangEqEq } - "=?=" { tok SymEqQuestionEq } - "!?=" { tok SymBangQuestionEq } - ">>>" { tok SymGtGtGt } - "<<<" { tok SymLtLtLt } - "<<=" { tok SymLtLtEq } - ">>=" { tok SymGtGtEq } - "|->" { tok SymBarDashGt } - "|=>" { tok SymBarEqGt } - "[->" { tok SymBrackLDashGt } - "@@(" { tok SymAtAtParenL } - "(*)" { tok SymParenLAsterParenR } - "->>" { tok SymDashGtGt } - "&&&" { tok SymAmpAmpAmp } - - "<<<=" { tok SymLtLtLtEq } - ">>>=" { tok SymGtGtGtEq } - - $white ; - - . { tok Unknown } - -{ -tok :: TokenName -> AlexPosn -> String -> Token -tok t (AlexPn _ l c) s = Token t s $ Position "" l c -} diff --git a/src/VeriFuzz/Verilog/Mutate.hs b/src/VeriFuzz/Verilog/Mutate.hs deleted file mode 100644 index 58675e3..0000000 --- a/src/VeriFuzz/Verilog/Mutate.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-| -Module : VeriSmith.Verilog.Mutate -Description : Functions to mutate the Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ( 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 - -class Mutate a where - mutExpr :: (Expr -> Expr) -> a -> a - -instance Mutate Identifier where - mutExpr _ = id - -instance Mutate Delay where - mutExpr _ = id - -instance Mutate Event where - mutExpr f (EExpr e) = EExpr $ f e - mutExpr _ a = a - -instance Mutate BinaryOperator where - mutExpr _ = id - -instance Mutate UnaryOperator where - mutExpr _ = id - -instance Mutate Expr where - mutExpr f = f - -instance Mutate ConstExpr where - mutExpr _ = id - -instance Mutate Task where - 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 - -instance Mutate PortDir where - mutExpr _ = id - -instance Mutate PortType where - mutExpr _ = id - -instance Mutate Range where - mutExpr _ = id - -instance Mutate Port where - mutExpr _ = id - -instance Mutate ModConn where - 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 - -instance Mutate ContAssign where - mutExpr f (ContAssign a e) = ContAssign a $ f e - -instance Mutate Statement 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 (mutExpr f a1) (f e) (mutExpr f a2) $ mutExpr f s - -instance Mutate Parameter where - mutExpr _ = id - -instance Mutate LocalParam where - mutExpr _ = id - -instance Mutate ModItem 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 _ d@Decl{} = d - mutExpr _ p@ParamDecl{} = p - mutExpr _ l@LocalParamDecl{} = l - -instance Mutate ModDecl 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) - -instance Mutate Verilog where - mutExpr f (Verilog a) = Verilog $ mutExpr f a - -instance Mutate SourceInfo where - mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b - -instance Mutate a => Mutate [a] where - mutExpr f a = mutExpr f <$> a - -instance Mutate a => Mutate (Maybe a) where - mutExpr f a = mutExpr f <$> a - -instance Mutate a => Mutate (GenVerilog a) where - mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a - --- | Return if the 'Identifier' is in a 'ModDecl'. -inPort :: Identifier -> ModDecl -> Bool -inPort i m = inInput - where - inInput = - 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] -> Maybe Expr -findAssign i items = safe last . catMaybes $ isAssign <$> items - where - 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 _ _ e = e - --- | Replaces the identifier recursively in an expression. -replace :: Identifier -> Expr -> Expr -> Expr -replace = (transform .) . idTrans - --- | Nest expressions for a specific 'Identifier'. If the 'Identifier' is not --- found, the AST is not changed. --- --- This could be improved by instead of only using the last assignment to the --- wire that one finds, to use the assignment to the wire before the current --- expression. This would require a different approach though. -nestId :: Identifier -> ModDecl -> ModDecl -nestId i 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 - --- | Replaces an identifier by a expression in all the module declaration. -nestSource :: Identifier -> Verilog -> Verilog -nestSource i src = src & getModule %~ nestId i - --- | Nest variables in the format @w[0-9]*@ up to a certain number. -nestUpTo :: Int -> Verilog -> Verilog -nestUpTo i src = - foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] - -allVars :: ModDecl -> [Identifier] -allVars m = - (m ^.. modOutPorts . traverse . portName) - <> (m ^.. modInPorts . traverse . portName) - --- $setup --- >>> import VeriSmith.Verilog.CodeGen --- >>> let m = (ModDecl (Identifier "m") [Port Wire False 5 (Identifier "y")] [Port Wire False 5 "x"] [] []) --- >>> let main = (ModDecl "main" [] [] [] []) - --- | Add a Module Instantiation using 'ModInst' from the first module passed to --- it to the body of the second module. It first has to make all the inputs into --- @reg@. --- --- >>> render $ instantiateMod m main --- module main; --- wire [(3'h4):(1'h0)] y; --- reg [(3'h4):(1'h0)] x; --- m m1(y, x); --- endmodule --- --- -instantiateMod :: ModDecl -> ModDecl -> ModDecl -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 - count = - length - . filter (== m ^. modId) - $ main - ^.. modItems - . traverse - . modInstId - conns = ModConn . Id <$> allVars m - --- | Instantiate without adding wire declarations. It also does not count the --- current instantiations of the same module. --- --- >>> GenVerilog $ instantiateMod_ m --- m m(y, x); --- -instantiateMod_ :: ModDecl -> ModItem -instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns - where - conns = - 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. --- --- >>> GenVerilog $ instantiateModSpec_ "_" m --- m m(.y(y), .x(x)); --- -instantiateModSpec_ :: Text -> ModDecl -> ModItem -instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns - where - 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) - --- | Initialise all the inputs and outputs to a module. --- --- >>> GenVerilog $ initMod m --- module m(y, x); --- output wire [(3'h4):(1'h0)] y; --- input wire [(3'h4):(1'h0)] x; --- endmodule --- --- -initMod :: ModDecl -> ModDecl -initMod m = m & modItems %~ ((out ++ inp) ++) - where - out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing - inp = Decl (Just PortIn) <$> (m ^. modInPorts) <*> pure Nothing - --- | Make an 'Identifier' from and existing Identifier and an object with a --- 'Show' instance to make it unique. -makeIdFrom :: (Show a) => a -> Identifier -> Identifier -makeIdFrom a i = (i <>) . Identifier . ("_" <>) $ showT a - --- | Make top level module for equivalence verification. Also takes in how many --- modules to instantiate. -makeTop :: Int -> ModDecl -> ModDecl -makeTop i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] - where - ys = yPort . flip makeIdFrom "y" <$> [1 .. i] - modIt = instantiateModSpec_ "_" . modN <$> [1 .. i] - modN n = - 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 -> ModDecl -makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2 - where - 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 --- registers, it should assign them to 0. -declareMod :: [Port] -> ModDecl -> ModDecl -declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) - where - decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0) - 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 --- no more changes were made to the expression. --- --- >>> GenVerilog . simplify $ (Id "x") + 0 --- x --- --- >>> 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 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 - --- | 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 --- simplified further. --- --- >>> GenVerilog . removeId ["x"] $ Id "x" + Id "y" --- (x + (1'h0)) -removeId :: [Identifier] -> Expr -> Expr -removeId i = transform trans - where - trans (Id ident) | ident `notElem` i = Number 0 - | otherwise = Id ident - trans e = e - -combineAssigns :: Port -> [ModItem] -> [ModItem] -combineAssigns p a = - a - <> [ ModCA - . ContAssign (p ^. portName) - . UnOp UnXor - . fold - $ Id - <$> assigns - ] - where assigns = a ^.. traverse . modContAssign . contAssignNetLVal - -combineAssigns_ :: Bool -> Port -> [Port] -> ModItem -combineAssigns_ comb p ps = - 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/VeriFuzz/Verilog/Parser.hs b/src/VeriFuzz/Verilog/Parser.hs deleted file mode 100644 index 8d2b729..0000000 --- a/src/VeriFuzz/Verilog/Parser.hs +++ /dev/null @@ -1,511 +0,0 @@ -{-| -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 - -- ** Internal parsers - , 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 - -type Parser = Parsec [Token] () - -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 - --- | This parser succeeds whenever the given predicate returns true when called --- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'. -satisfy :: (Token -> Bool) -> Parser TokenName -satisfy f = tokenPrim show nextPos tokeq - where - tokeq :: Token -> Maybe TokenName - tokeq t@(Token t' _ _) = if f t then Just t' else Nothing - -satisfy' :: (Token -> Maybe a) -> Parser a -satisfy' = tokenPrim show nextPos - -nextPos :: SourcePos -> Token -> [Token] -> SourcePos -nextPos pos _ (Token _ _ (Position _ l c) : _) = - setSourceColumn (setSourceLine pos l) c -nextPos pos _ [] = pos - --- | Parses given `TokenName`. -tok :: TokenName -> Parser TokenName -tok t = satisfy (\(Token t' _ _) -> t' == t) show t - --- | Parse without returning the `TokenName`. -tok' :: TokenName -> Parser () -tok' p = void $ tok p - -parens :: Parser a -> Parser a -parens = between (tok SymParenL) (tok SymParenR) - -brackets :: Parser a -> Parser a -brackets = between (tok SymBrackL) (tok SymBrackR) - -braces :: Parser a -> Parser a -braces = between (tok SymBraceL) (tok SymBraceR) - -sBinOp :: BinaryOperator -> Expr -> Expr -> Expr -sBinOp = sOp BinOp where sOp f b a = f a b - -parseExpr' :: Parser Expr -parseExpr' = buildExpressionParser parseTable parseTerm "expr" - -decToExpr :: Decimal -> Expr -decToExpr (Decimal s n) = Number $ bitVec s n - --- | Parse a Number depending on if it is in a hex or decimal form. Octal and --- binary are not supported yet. -parseNum :: Parser Expr -parseNum = decToExpr <$> number - -parseVar :: Parser Expr -parseVar = Id <$> identifier - -parseVecSelect :: Parser Expr -parseVecSelect = do - i <- identifier - expr <- brackets parseExpr - return $ VecSelect i expr - -parseRangeSelect :: Parser Expr -parseRangeSelect = do - i <- identifier - range <- parseRange - return $ RangeSelect i range - -systemFunc :: Parser String -systemFunc = satisfy' matchId - where - matchId (Token IdSystem s _) = Just s - matchId _ = Nothing - -parseFun :: Parser Expr -parseFun = do - 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." - -parseTerm :: Parser Expr -parseTerm = - 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 - -parseExpr :: Parser Expr -parseExpr = do - e <- parseExpr' - option e . try $ parseCond e - -parseConstExpr :: Parser ConstExpr -parseConstExpr = fmap exprToConst parseExpr - --- | Table of binary and unary operators that encode the right precedence for --- 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] - ] - -binary :: TokenName -> (a -> a -> a) -> Assoc -> ParseOperator a -binary name fun = Infix ((tok name "binary") >> return fun) - -prefix :: TokenName -> (a -> a) -> ParseOperator a -prefix name fun = Prefix ((tok name "prefix") >> return fun) - -commaSep :: Parser a -> Parser [a] -commaSep = flip sepBy $ tok SymComma - -parseContAssign :: Parser ContAssign -parseContAssign = do - 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 - -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 - 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' - --- toInteger' :: Decimal -> Integer --- toInteger' (Decimal _ n) = n - -toInt' :: Decimal -> Int -toInt' (Decimal _ n) = fromInteger n - --- | Parse a range and return the total size. As it is inclusive, 1 has to be --- added to the difference. -parseRange :: Parser Range -parseRange = do - 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 IdEscaped s _) = Just s - matchId _ = Nothing - -identifier :: Parser Identifier -identifier = Identifier . T.pack <$> strId - -parseNetDecl :: Maybe PortDir -> Parser ModItem -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 - -parsePortDir :: Parser PortDir -parsePortDir = - tok KWOutput - $> PortOut - <|> tok KWInput - $> PortIn - <|> tok KWInout - $> PortInOut - -parseDecl :: Parser ModItem -parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing - -parseConditional :: Parser Statement -parseConditional = do - 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)) - ex i = do - e <- tok' SymBrackL *> parseExpr - tok' SymBrackR - return $ RegExpr i e - sz i = RegSize i <$> parseRange - -parseDelay :: Parser Delay -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 - -parseLoop :: Parser Statement -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 - -eventList :: TokenName -> Parser [Event] -eventList t = do - 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)) - -parseEvent' :: Parser Event -parseEvent' = - try (tok' KWPosedge *> fmap EPosEdge identifier) - <|> try (tok' KWNegedge *> fmap ENegEdge identifier) - <|> try (fmap EId identifier) - <|> try (fmap EExpr parseExpr) - -parseEventCtrl :: Parser Statement -parseEventCtrl = do - event <- parseEvent - statement <- option Nothing maybeEmptyStatement - return $ EventCtrl event statement - -parseDelayCtrl :: Parser Statement -parseDelayCtrl = do - delay <- parseDelay - statement <- option Nothing maybeEmptyStatement - return $ TimeCtrl delay statement - -parseBlocking :: Parser Statement -parseBlocking = do - a <- parseAssign SymEq - tok' SymSemi - return $ BlockAssign a - -parseNonBlocking :: Parser Statement -parseNonBlocking = do - a <- parseAssign SymLtEq - tok' SymSemi - return $ NonBlockAssign a - -parseSeq :: Parser Statement -parseSeq = do - seq' <- tok' KWBegin *> many parseStatement - tok' KWEnd - return $ SeqBlock seq' - -parseStatement :: Parser Statement -parseStatement = - parseSeq - <|> parseConditional - <|> parseLoop - <|> parseEventCtrl - <|> parseDelayCtrl - <|> try parseBlocking - <|> parseNonBlocking - -maybeEmptyStatement :: Parser (Maybe Statement) -maybeEmptyStatement = - (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) - -parseAlways :: Parser ModItem -parseAlways = tok' KWAlways *> (Always <$> parseStatement) - -parseInitial :: Parser ModItem -parseInitial = tok' KWInitial *> (Initial <$> parseStatement) - -namedModConn :: Parser ModConn -namedModConn = do - target <- tok' SymDot *> identifier - expr <- parens parseExpr - return $ ModConnNamed target expr - -parseModConn :: Parser ModConn -parseModConn = try (fmap ModConn parseExpr) <|> namedModConn - -parseModInst :: Parser ModItem -parseModInst = do - m <- identifier - name <- identifier - modconns <- parens (commaSep parseModConn) - tok' SymSemi - return $ ModInst m name modconns - -parseModItem :: Parser ModItem -parseModItem = - try (ModCA <$> parseContAssign) - <|> try parseDecl - <|> parseAlways - <|> parseInitial - <|> parseModInst - -parseModList :: Parser [Identifier] -parseModList = list <|> return [] where list = parens $ commaSep identifier - -filterDecl :: PortDir -> ModItem -> Bool -filterDecl p (Decl (Just p') _ _) = p == p' -filterDecl _ _ = False - -modPorts :: PortDir -> [ModItem] -> [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 - -parseParams :: Parser [Parameter] -parseParams = tok' SymPound *> parens (commaSep parseParam) - -parseModDecl :: Parser ModDecl -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 - --- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace --- and then parsing multiple Verilog source. -parseVerilogSrc :: Parser Verilog -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 -- ^ Returns 'String' with error - -- message if parse fails. -parseVerilog s = - bimap showT id - . parse parseVerilogSrc (T.unpack s) - . alexScanTokens - . preprocess [] (T.unpack s) - . T.unpack - -parseVerilogFile :: Text -> IO Verilog -parseVerilogFile file = do - 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 -parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile diff --git a/src/VeriFuzz/Verilog/Preprocess.hs b/src/VeriFuzz/Verilog/Preprocess.hs deleted file mode 100644 index c30252b..0000000 --- a/src/VeriFuzz/Verilog/Preprocess.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-| -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 - ) -where - --- | Remove comments from code. There is no difference between @(* *)@ and --- @/* */@, therefore in this implementation, @*/@ could close @(*@ and vice-versa, --- This will be fixed in an upcoming version. -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 - - removeEOL a = case a of - "" -> "" - '\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 - - 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 - - ignoreString a = case a of - "" -> 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 - where - pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String] - 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 - -ppLine :: [(String, String)] -> String -> String -ppLine _ "" = "" -ppLine env ('`' : a) = case lookup name env of - Just value -> value ++ ppLine env rest - Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env - where - name = takeWhile - (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) - a - rest = drop (length name) a -ppLine env (a : b) = a : ppLine env b diff --git a/src/VeriFuzz/Verilog/Quote.hs b/src/VeriFuzz/Verilog/Quote.hs deleted file mode 100644 index 3815fe6..0000000 --- a/src/VeriFuzz/Verilog/Quote.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-| -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 - ( 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 - -liftDataWithText :: Data a => a -> Q Exp -liftDataWithText = dataToExpQ $ fmap liftText . cast - -liftText :: T.Text -> Q Exp -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 - } - -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 diff --git a/src/VeriFuzz/Verilog/Token.hs b/src/VeriFuzz/Verilog/Token.hs deleted file mode 100644 index 590672e..0000000 --- a/src/VeriFuzz/Verilog/Token.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-| -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 - ) -where - -import Text.Printf - -tokenString :: Token -> String -tokenString (Token _ s _) = s - -data Position = Position String Int Int deriving Eq - -instance Show Position where - show (Position f l c) = printf "%s:%d:%d" f l c - -data Token = Token TokenName String Position deriving (Show, Eq) - -data TokenName - = KWAlias - | KWAlways - | KWAlwaysComb - | KWAlwaysFf - | KWAlwaysLatch - | KWAnd - | KWAssert - | KWAssign - | KWAssume - | KWAutomatic - | KWBefore - | KWBegin - | KWBind - | KWBins - | KWBinsof - | KWBit - | KWBreak - | KWBuf - | KWBufif0 - | KWBufif1 - | KWByte - | KWCase - | KWCasex - | KWCasez - | KWCell - | KWChandle - | KWClass - | KWClocking - | KWCmos - | KWConfig - | KWConst - | KWConstraint - | KWContext - | KWContinue - | KWCover - | KWCovergroup - | KWCoverpoint - | KWCross - | KWDeassign - | KWDefault - | KWDefparam - | KWDesign - | KWDisable - | KWDist - | KWDo - | KWEdge - | KWElse - | KWEnd - | KWEndcase - | KWEndclass - | KWEndclocking - | KWEndconfig - | KWEndfunction - | KWEndgenerate - | KWEndgroup - | KWEndinterface - | KWEndmodule - | KWEndpackage - | KWEndprimitive - | KWEndprogram - | KWEndproperty - | KWEndspecify - | KWEndsequence - | KWEndtable - | KWEndtask - | KWEnum - | KWEvent - | KWExpect - | KWExport - | KWExtends - | KWExtern - | KWFinal - | KWFirstMatch - | KWFor - | KWForce - | KWForeach - | KWForever - | KWFork - | KWForkjoin - | KWFunction - | KWFunctionPrototype - | KWGenerate - | KWGenvar - | KWHighz0 - | KWHighz1 - | KWIf - | KWIff - | KWIfnone - | KWIgnoreBins - | KWIllegalBins - | KWImport - | KWIncdir - | KWInclude - | KWInitial - | KWInout - | KWInput - | KWInside - | KWInstance - | KWInt - | KWInteger - | KWInterface - | KWIntersect - | KWJoin - | KWJoinAny - | KWJoinNone - | KWLarge - | KWLiblist - | KWLibrary - | KWLocal - | KWLocalparam - | KWLogic - | KWLongint - | KWMacromodule - | KWMatches - | KWMedium - | KWModport - | KWModule - | KWNand - | KWNegedge - | KWNew - | KWNmos - | KWNor - | KWNoshowcancelled - | KWNot - | KWNotif0 - | KWNotif1 - | KWNull - | KWOption - | KWOr - | KWOutput - | KWPackage - | KWPacked - | KWParameter - | KWPathpulseDollar - | KWPmos - | KWPosedge - | KWPrimitive - | KWPriority - | KWProgram - | KWProperty - | KWProtected - | KWPull0 - | KWPull1 - | KWPulldown - | KWPullup - | KWPulsestyleOnevent - | KWPulsestyleOndetect - | KWPure - | KWRand - | KWRandc - | KWRandcase - | KWRandsequence - | KWRcmos - | KWReal - | KWRealtime - | KWRef - | KWReg - | KWRelease - | KWRepeat - | KWReturn - | KWRnmos - | KWRpmos - | KWRtran - | KWRtranif0 - | KWRtranif1 - | KWScalared - | KWSequence - | KWShortint - | KWShortreal - | KWShowcancelled - | KWSigned - | KWSmall - | KWSolve - | KWSpecify - | KWSpecparam - | KWStatic - | KWStrength0 - | KWStrength1 - | KWString - | KWStrong0 - | KWStrong1 - | KWStruct - | KWSuper - | KWSupply0 - | KWSupply1 - | KWTable - | KWTagged - | KWTask - | KWThis - | KWThroughout - | KWTime - | KWTimeprecision - | KWTimeunit - | KWTran - | KWTranif0 - | KWTranif1 - | KWTri - | KWTri0 - | KWTri1 - | KWTriand - | KWTrior - | KWTrireg - | KWType - | KWTypedef - | KWTypeOption - | KWUnion - | KWUnique - | KWUnsigned - | KWUse - | KWVar - | KWVectored - | KWVirtual - | KWVoid - | KWWait - | KWWaitOrder - | KWWand - | KWWeak0 - | KWWeak1 - | KWWhile - | KWWildcard - | KWWire - | KWWith - | KWWithin - | KWWor - | KWXnor - | KWXor - | IdSimple - | IdEscaped - | IdSystem - | LitNumberUnsigned - | LitNumber - | LitString - | SymParenL - | SymParenR - | SymBrackL - | SymBrackR - | SymBraceL - | SymBraceR - | SymTildy - | SymBang - | SymAt - | SymPound - | SymPercent - | SymHat - | SymAmp - | SymBar - | SymAster - | SymDot - | SymComma - | SymColon - | SymSemi - | SymEq - | SymLt - | SymGt - | SymPlus - | SymDash - | SymQuestion - | SymSlash - | SymDollar - | SymSQuote - | SymTildyAmp - | SymTildyBar - | SymTildyHat - | SymHatTildy - | SymEqEq - | SymBangEq - | SymAmpAmp - | SymBarBar - | SymAsterAster - | SymLtEq - | SymGtEq - | SymGtGt - | SymLtLt - | SymPlusPlus - | SymDashDash - | SymPlusEq - | SymDashEq - | SymAsterEq - | SymSlashEq - | SymPercentEq - | SymAmpEq - | SymBarEq - | SymHatEq - | SymPlusColon - | SymDashColon - | SymColonColon - | SymDotAster - | SymDashGt - | SymColonEq - | SymColonSlash - | SymPoundPound - | SymBrackLAster - | SymBrackLEq - | SymEqGt - | SymAtAster - | SymParenLAster - | SymAsterParenR - | SymAsterGt - | SymEqEqEq - | SymBangEqEq - | SymEqQuestionEq - | SymBangQuestionEq - | SymGtGtGt - | SymLtLtLt - | SymLtLtEq - | SymGtGtEq - | SymBarDashGt - | SymBarEqGt - | SymBrackLDashGt - | SymAtAtParenL - | SymParenLAsterParenR - | SymDashGtGt - | SymAmpAmpAmp - | SymLtLtLtEq - | SymGtGtGtEq - | Unknown - deriving (Show, Eq) diff --git a/src/VeriSmith.hs b/src/VeriSmith.hs new file mode 100644 index 0000000..6c1a1b5 --- /dev/null +++ b/src/VeriSmith.hs @@ -0,0 +1,553 @@ +{-| +Module : VeriSmith +Description : VeriSmith +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX +-} + +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module VeriSmith + ( defaultMain + -- * Types + , Opts(..) + , SourceInfo(..) + -- * Run functions + , runEquivalence + , runSimulation + , runReduce + , draw + -- * Verilog generation functions + , procedural + , proceduralIO + , proceduralSrc + , proceduralSrcIO + , randomMod + -- * Extra modules + , module VeriSmith.Verilog + , module VeriSmith.Config + , module VeriSmith.Circuit + , module VeriSmith.Sim + , module VeriSmith.Fuzz + , module VeriSmith.Report + ) +where + +import Control.Concurrent +import Control.Lens hiding ((<.>)) +import Control.Monad.IO.Class (liftIO) +import qualified Crypto.Random.DRBG as C +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 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.Reduce +import VeriSmith.Report +import VeriSmith.Result +import VeriSmith.Sim +import VeriSmith.Sim.Internal +import VeriSmith.Verilog +import VeriSmith.Verilog.Parser (parseSourceInfoFile) + +data OptTool = TYosys + | TXST + | TIcarus + +instance Show OptTool where + show TYosys = "yosys" + show TXST = "xst" + show TIcarus = "icarus" + +data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text + , configFile :: !(Maybe FilePath) + , forced :: !Bool + , keepAll :: !Bool + , num :: {-# UNPACK #-} !Int + } + | Generate { mFileName :: !(Maybe FilePath) + , configFile :: !(Maybe FilePath) + } + | Parse { fileName :: {-# UNPACK #-} !FilePath + } + | Reduce { fileName :: {-# UNPACK #-} !FilePath + , top :: {-# UNPACK #-} !Text + , reduceScript :: !(Maybe FilePath) + , synthesiserDesc :: ![SynthDescription] + , rerun :: Bool + } + | ConfigOpt { writeConfig :: !(Maybe FilePath) + , configFile :: !(Maybe FilePath) + , doRandomise :: !Bool + } + +myForkIO :: IO () -> IO (MVar ()) +myForkIO io = do + mvar <- newEmptyMVar + _ <- forkFinally io (\_ -> putMVar mvar ()) + return mvar + +textOption :: Mod OptionFields String -> Parser Text +textOption = fmap T.pack . strOption + +optReader :: (String -> Maybe a) -> ReadM a +optReader f = eitherReader $ \arg -> case f arg of + 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 + +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 + +parseSim :: String -> Maybe OptTool +parseSim val | val == "icarus" = Just TIcarus + | otherwise = Nothing + +fuzzOpts :: Parser Opts +fuzzOpts = + Fuzz + <$> textOption + ( long "output" + <> short 'o' + <> metavar "DIR" + <> help "Output directory that the fuzz run takes place in." + <> showDefault + <> value "output" + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the current fuzz run." + ) + <*> (switch $ long "force" <> short 'f' <> help + "Overwrite the specified directory." + ) + <*> (switch $ long "keep" <> short 'k' <> help + "Keep all the directories." + ) + <*> ( option auto + $ long "num" + <> short 'n' + <> help "The number of fuzz runs that should be performed." + <> showDefault + <> value 1 + <> metavar "INT" + ) + +genOpts :: Parser Opts +genOpts = + Generate + <$> ( optional + . strOption + $ long "output" + <> short 'o' + <> metavar "FILE" + <> help "Output to a verilog file instead." + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the generation run." + ) + +parseOpts :: Parser Opts +parseOpts = Parse . fromText . T.pack <$> strArgument + (metavar "FILE" <> help "Verilog input file.") + +reduceOpts :: Parser Opts +reduceOpts = + Reduce + . fromText + . T.pack + <$> strArgument (metavar "FILE" <> help "Verilog input file.") + <*> textOption + ( short 't' + <> long "top" + <> metavar "TOP" + <> help "Name of top level module." + <> showDefault + <> value "top" + ) + <*> ( optional + . strOption + $ long "script" + <> metavar "SCRIPT" + <> help + "Script that determines if the current file is interesting, which is determined by the script returning 0." + ) + <*> ( many + . option (optReader parseSynthDesc) + $ short 's' + <> long "synth" + <> metavar "SYNTH" + <> help "Specify synthesiser to use." + ) + <*> ( switch + $ short 'r' + <> long "rerun" + <> help + "Only rerun the current synthesis file with all the synthesisers." + ) + +configOpts :: Parser Opts +configOpts = + ConfigOpt + <$> ( optional + . strOption + $ long "output" + <> short 'o' + <> metavar "FILE" + <> help "Output to a TOML Config file." + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the current fuzz run." + ) + <*> ( switch + $ long "randomise" + <> short 'r' + <> help + "Randomise the given default config, or the default config by randomly switchin on and off options." + ) + +argparse :: Parser Opts +argparse = + hsubparser + ( command + "fuzz" + (info + fuzzOpts + (progDesc + "Run fuzzing on the specified simulators and synthesisers." + ) + ) + <> metavar "fuzz" + ) + <|> hsubparser + ( command + "generate" + (info + genOpts + (progDesc "Generate a random Verilog program.") + ) + <> metavar "generate" + ) + <|> hsubparser + ( command + "parse" + (info + parseOpts + (progDesc + "Parse a verilog file and output a pretty printed version." + ) + ) + <> metavar "parse" + ) + <|> hsubparser + ( command + "reduce" + (info + reduceOpts + (progDesc + "Reduce a Verilog file by rerunning the fuzzer on the file." + ) + ) + <> metavar "reduce" + ) + <|> hsubparser + ( command + "config" + (info + configOpts + (progDesc + "Print the current configuration of the fuzzer." + ) + ) + <> metavar "config" + ) + +version :: Parser (a -> a) +version = infoOption versionInfo $ mconcat + [long "version", short 'v', help "Show version information.", hidden] + +opts :: ParserInfo Opts +opts = info + (argparse <**> helper <**> version) + ( fullDesc + <> progDesc "Fuzz different simulators and synthesisers." + <> header + "VeriSmith - A hardware simulator and synthesiser Verilog fuzzer." + ) + +getConfig :: Maybe FilePath -> IO Config +getConfig s = + maybe (return defaultConfig) parseConfigFile $ T.unpack . 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 + +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 + 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) + ) + c + d + e + where + cm = config ^. configProbability . probModItem + cs = config ^. configProbability . probStmnt + ce = config ^. configProbability . probExpr + +handleOpts :: Opts -> IO () +handleOpts (Fuzz o configF _ _ n) = do + config <- getConfig configF + _ <- runFuzz + config + defaultYosys + (fuzzMultiple n (Just $ fromText o) (proceduralSrc "top" config)) + return () +handleOpts (Generate f c) = do + config <- getConfig c + source <- proceduralIO "top" config + maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) + $ T.unpack + . toTextIgnore + <$> f +handleOpts (Parse f) = do + verilogSrc <- T.readFile file + case parseVerilog (T.pack file) verilogSrc of + Left l -> print l + Right v -> print $ GenVerilog v + where file = T.unpack . toTextIgnore $ f +handleOpts (Reduce f t _ ls' False) = do + src <- parseSourceInfoFile t (toTextIgnore f) + case descriptionToSynth <$> ls' of + a : b : _ -> do + putStrLn "Reduce with equivalence check" + shelly $ do + make dir + pop dir $ do + src' <- reduceSynth a b src + 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) + 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 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 + +defaultMain :: IO () +defaultMain = do + optsparsed <- execParser opts + handleOpts optsparsed + +-- | Generate a specific number of random bytestrings of size 256. +randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] +randomByteString gen n bytes + | n == 0 = ranBytes : bytes + | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes + where Right (ranBytes, newGen) = C.genBytes 32 gen + +-- | generates the specific number of bytestring with a random seed. +generateByteString :: Int -> IO [ByteString] +generateByteString n = do + gen <- C.newGenIO :: IO C.CtrDRBG + return $ randomByteString gen n [] + +makeSrcInfo :: ModDecl -> SourceInfo +makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) + +-- | Draw a randomly generated DAG to a dot file and compile it to a png so it +-- 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"] + +-- | Function to show a bytestring in a hex format. +showBS :: ByteString -> Text +showBS = decodeUtf8 . L.toStrict . toLazyByteString . byteStringHex + +-- | Run a simulation on a random DAG or a random module. +runSimulation :: IO () +runSimulation = do + -- gr <- Hog.generate $ rDups <$> Hog.resize 100 (randomDAG :: Gen (G.Gr Gate ())) + -- let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr + -- writeFile "file.dot" dot + -- shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] + -- let circ = + -- head $ (nestUpTo 30 . generateAST $ Circuit gr) ^.. getVerilog . traverse . getDescription + rand <- generateByteString 20 + rand2 <- Hog.sample (randomMod 10 100) + 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 + +checkEquivalence :: SourceInfo -> Text -> IO Bool +checkEquivalence src dir = shellyFailDir $ do + mkdir_p (fromText dir) + curr <- toTextIgnore <$> pwd + setenv "VERISMITH_ROOT" curr + cd (fromText dir) + catch_sh + ((runResultT $ runEquiv 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 seed gm t d k i = do + (_, m) <- shelly $ sampleSeed seed gm + let srcInfo = SourceInfo "top" m + rand <- generateByteString 20 + shellyFailDir $ do + mkdir_p (fromText d fromText n) + curr <- toTextIgnore <$> pwd + setenv "VERISMITH_ROOT" curr + cd (fromText "output" fromText n) + _ <- + catch_sh + ( runResultT + $ runEquiv 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 (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s diff --git a/src/VeriSmith/Circuit.hs b/src/VeriSmith/Circuit.hs new file mode 100644 index 0000000..aee0d57 --- /dev/null +++ b/src/VeriSmith/Circuit.hs @@ -0,0 +1,45 @@ +{-| +Module : VeriSmith.Circuit +Description : Definition of the circuit graph. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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 + +fromGraph :: Gen ModDecl +fromGraph = do + 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 new file mode 100644 index 0000000..ddcaf65 --- /dev/null +++ b/src/VeriSmith/Circuit/Base.hs @@ -0,0 +1,44 @@ +{-| +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(..) + ) +where + +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) + +-- | Newtype for the Circuit which implements a Graph from fgl. +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 for a named edge which is empty, as it does not need a label. +newtype CEdge = CEdge { getCEdge :: LEdge () } + +instance Random Gate where + randomR (a, b) g = + case randomR (fromEnum a, fromEnum b) g of + (x, g') -> (toEnum x, g') + + random = randomR (minBound, maxBound) diff --git a/src/VeriSmith/Circuit/Gen.hs b/src/VeriSmith/Circuit/Gen.hs new file mode 100644 index 0000000..1c4dd37 --- /dev/null +++ b/src/VeriSmith/Circuit/Gen.hs @@ -0,0 +1,79 @@ +{-| +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 + ) +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 + +-- | Converts a 'CNode' to an 'Identifier'. +frNode :: Node -> Identifier +frNode = Identifier . fromNode + +-- | Converts a 'Gate' to a 'BinaryOperator', which should be a bijective +-- mapping. +fromGate :: Gate -> BinaryOperator +fromGate And = BinAnd +fromGate Or = BinOr +fromGate Xor = BinXor + +inputsC :: Circuit -> [Node] +inputsC c = inputs (getCircuit c) + +genPortsAST :: (Circuit -> [Node]) -> Circuit -> [Port] +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 g (n : ns) = BinOp wire oper <$> genAssignExpr g ns + where + wire = Id $ frNode n + oper = fromGate g + +-- | Generate the continuous assignment AST for a particular node. If it does +-- not have any nodes that link to it then return 'Nothing', as that means that +-- the assignment will just be empty. +genContAssignAST :: Circuit -> LNode Gate -> Maybe ModItem +genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes + where + gr = getCircuit c + nodes = G.pre gr n + name = frNode n + +genAssignAST :: Circuit -> [ModItem] +genAssignAST c = catMaybes $ genContAssignAST c <$> nodes + where + gr = getCircuit c + nodes = G.labNodes gr + +genModuleDeclAST :: Circuit -> ModDecl +genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] + where + i = Identifier "gen_module" + ports = genPortsAST inputsC c + output = [] + a = genAssignAST c + yPort = Port Wire False 90 "y" + +generateAST :: Circuit -> Verilog +generateAST c = Verilog [genModuleDeclAST c] diff --git a/src/VeriSmith/Circuit/Internal.hs b/src/VeriSmith/Circuit/Internal.hs new file mode 100644 index 0000000..b746738 --- /dev/null +++ b/src/VeriSmith/Circuit/Internal.hs @@ -0,0 +1,55 @@ +{-| +Module : VeriSmith.Circuit.Internal +Description : Internal helpers for generation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Internal helpers for generation. +-} + +module VeriSmith.Circuit.Internal + ( fromNode + , filterGr + , only + , inputs + , outputs + ) +where + +import Data.Graph.Inductive (Graph, Node) +import qualified Data.Graph.Inductive as G +import qualified Data.Text as T + +-- | Convert an integer into a label. +-- +-- >>> fromNode 5 +-- "w5" +fromNode :: Int -> T.Text +fromNode node = T.pack $ "w" <> show node + +-- | General function which runs 'filter' over a graph. +filterGr :: (Graph gr) => gr n e -> (Node -> Bool) -> [Node] +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 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 +-- an input themselves. +inputs :: (Graph gr) => gr n e -> [Node] +inputs graph = filterGr graph $ only graph G.indeg G.outdeg + +-- | Returns all the output nodes to a graph, similar to the 'inputs' function. +outputs :: (Graph gr) => gr n e -> [Node] +outputs graph = filterGr graph $ only graph G.outdeg G.indeg diff --git a/src/VeriSmith/Circuit/Random.hs b/src/VeriSmith/Circuit/Random.hs new file mode 100644 index 0000000..ca8cc26 --- /dev/null +++ b/src/VeriSmith/Circuit/Random.hs @@ -0,0 +1,67 @@ +{-| +Module : VeriSmith.Circuit.Random +Description : Random generation for DAG +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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 + +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) + +-- | Remove duplicates. +rDups :: (Eq a, Eq b) => Gr a b -> Gr a b +rDups g = G.buildGr $ G.ufold dupFolder [] g + +-- | Remove duplicates. +rDupsCirc :: Circuit -> Circuit +rDupsCirc = Circuit . rDups . getCircuit + +-- | Gen instance to create an arbitrary edge, where the edges are limited by +-- `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, ()) + where + 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 = 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 + where + nodes l = zip [0 .. length l - 1] l + aE = getCEdge <$> Hog.sized arbitraryEdge + +-- | Generate a random acyclic DAG with an IO instance. +genRandomDAG :: IO Circuit +genRandomDAG = Hog.sample randomDAG diff --git a/src/VeriSmith/Config.hs b/src/VeriSmith/Config.hs new file mode 100644 index 0000000..adc3d19 --- /dev/null +++ b/src/VeriSmith/Config.hs @@ -0,0 +1,496 @@ +{-| +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 + ( -- * TOML Configuration + -- $conf + Config(..) + , defaultConfig + -- ** Probabilities + , Probability(..) + -- *** Expression + , ProbExpr(..) + -- *** Module Item + , ProbModItem(..) + -- *** Statement + , ProbStatement(..) + -- ** ConfProperty + , ConfProperty(..) + -- ** Simulator Description + , SimDescription(..) + -- ** Synthesiser Description + , SynthDescription(..) + -- * Useful Lenses + , fromXST + , fromYosys + , fromVivado + , fromQuartus + , configProbability + , configProperty + , configSimulators + , configSynthesisers + , probModItem + , 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 + , 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 qualified Toml +import VeriSmith.Sim.Quartus +import VeriSmith.Sim.Vivado +import VeriSmith.Sim.XST +import VeriSmith.Sim.Yosys + +-- $conf +-- +-- VeriSmith supports a TOML configuration file that can be passed using the @-c@ +-- flag or using the 'parseConfig' and 'encodeConfig' functions. The +-- configuration can then be manipulated using the lenses that are also provided +-- in this module. +-- +-- The configuration file can be used to tweak the random Verilog generation by +-- passing different probabilities to each of the syntax nodes in the AST. It +-- can also be used to specify which simulators to fuzz with which options. A +-- seed for the run can also be set, to replay a previous run using the same +-- exact generation. A default value is associated with each key in the +-- configuration file, which means that only the options that need overriding +-- can be added to the configuration. The defaults can be observed in +-- 'defaultConfig' or when running @verismith config@. +-- +-- == Configuration Sections +-- +-- There are four main configuration sections in the TOML file: +-- +-- [@probability@] The @probability@ section defines the probabilities at +-- every node in the AST. +-- +-- [@property@] Controls different properties of the generation, such as +-- adding a seed or the depth of the statements. +-- +-- [@simulator@] This is an array of tables containing descriptions of the +-- different simulators that should be used. It currently only supports +-- . +-- +-- [@synthesiser@] This is also an array of tables containing descriptions of +-- the different synthesisers that should be used. The synthesisers that are +-- currently supported are: +-- +-- - +-- - +-- - +-- - + +-- | Probability of different expressions nodes. +data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int + -- ^ 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 + -- ^ Probability of generating an identifier that is in + -- scope and of the right type. + , _probExprRangeSelect :: {-# UNPACK #-} !Int + -- ^ Probability of generating a range selection from a port. + , _probExprUnOp :: {-# UNPACK #-} !Int + -- ^ Probability of generating a unary operator. + , _probExprBinOp :: {-# UNPACK #-} !Int + -- ^ Probability of generation a binary operator. + , _probExprCond :: {-# UNPACK #-} !Int + -- ^ probability of generating a conditional ternary + -- operator. + , _probExprConcat :: {-# UNPACK #-} !Int + -- ^ Probability of generating a concatenation. + , _probExprStr :: {-# UNPACK #-} !Int + -- ^ Probability of generating a string. This is not + -- fully supported therefore currently cannot be set. + , _probExprSigned :: {-# UNPACK #-} !Int + -- ^ Probability of generating a signed function + -- @$signed(...)@. + , _probExprUnsigned :: {-# UNPACK #-} !Int + -- ^ Probability of generating an unsigned function + -- @$unsigned(...)@. + } + deriving (Eq, Show) + +-- | Probability of generating different nodes inside a module declaration. +data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int + -- ^ Probability of generating an @assign@. + , _probModItemSeqAlways :: {-# UNPACK #-} !Int + -- ^ Probability of generating a sequential @always@ block. + , _probModItemCombAlways :: {-# UNPACK #-} !Int + -- ^ Probability of generating an combinational @always@ block. + , _probModItemInst :: {-# UNPACK #-} !Int + -- ^ Probability of generating a module + -- instantiation. + } + deriving (Eq, Show) + +data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int + , _probStmntNonBlock :: {-# UNPACK #-} !Int + , _probStmntCond :: {-# UNPACK #-} !Int + , _probStmntFor :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) + +data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem + , _probStmnt :: {-# UNPACK #-} !ProbStatement + , _probExpr :: {-# UNPACK #-} !ProbExpr + } + deriving (Eq, Show) + +data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int + -- ^ The size of the generated Verilog. + , _propSeed :: !(Maybe Seed) + -- ^ A possible seed that could be used to + -- generate the same Verilog. + , _propStmntDepth :: {-# UNPACK #-} !Int + -- ^ The maximum statement depth that should be + -- reached. + , _propModDepth :: {-# UNPACK #-} !Int + -- ^ The maximium module depth that should be + -- reached. + , _propMaxModules :: {-# UNPACK #-} !Int + -- ^ The maximum number of modules that are + -- allowed to be created at each level. + , _propSampleMethod :: !Text + -- ^ The sampling method that should be used to + -- generate specific distributions of random + -- programs. + , _propSampleSize :: {-# UNPACK #-} !Int + -- ^ The number of samples to take for the + -- sampling method. + , _propCombine :: !Bool + -- ^ If the output should be combined into one + -- bit or not. + , _propNonDeterminism :: {-# UNPACK #-} !Int + -- ^ The frequency at which nondeterminism + -- should be generated. + , _propDeterminism :: {-# UNPACK #-} !Int + -- ^ The frequency at which determinism should + -- be generated. + } + deriving (Eq, Show) + +data Info = Info { _infoCommit :: !Text + , _infoVersion :: !Text + } + deriving (Eq, Show) + +data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text } + deriving (Eq, Show) + +data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text + , synthBin :: Maybe Text + , synthDesc :: Maybe Text + , 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 ''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 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) + +fromYosys :: Yosys -> SynthDescription +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) + +fromQuartus :: Quartus -> SynthDescription +fromQuartus (Quartus a b c) = SynthDescription "quartus" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) + +defaultConfig :: Config +defaultConfig = Config + (Info (pack $(gitHash)) (pack $ showVersion version)) + (Probability defModItem defStmnt defExpr) + (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1) + [] + [fromYosys defaultYosys, fromVivado defaultVivado] + where + defModItem = + 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 + 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 + +twoKey :: Toml.Piece -> Toml.Piece -> Toml.Key +twoKey a b = Toml.Key (a :| [b]) + +int :: Toml.Piece -> Toml.Piece -> TomlCodec Int +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 + 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 + 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 + where + defProb i = defaultConfig ^. configProbability . probModItem . i + intM = int "moditem" + +probCodec :: TomlCodec Probability +probCodec = + Probability + <$> defaultValue (defProb probModItem) modItemCodec + .= _probModItem + <*> defaultValue (defProb probStmnt) stmntCodec + .= _probStmnt + <*> defaultValue (defProb probExpr) exprCodec + .= _probExpr + 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 + where defProp i = defaultConfig ^. configProperty . i + +simulator :: TomlCodec SimDescription +simulator = Toml.textBy pprint parseIcarus "name" + where + parseIcarus i@"icarus" = Right $ SimDescription i + parseIcarus s = Left $ "Could not match '" <> s <> "' with a simulator." + pprint (SimDescription a) = a + +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 + +infoCodec :: TomlCodec Info +infoCodec = + 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 + +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" + +encodeConfig :: Config -> Text +encodeConfig = Toml.encode configCodec + +encodeConfigFile :: FilePath -> Config -> IO () +encodeConfigFile f = T.writeFile f . encodeConfig + +versionInfo :: String +versionInfo = + "VeriSmith " + <> showVersion version + <> " (" + <> $(gitCommitDate) + <> " " + <> $(gitHash) + <> ")" diff --git a/src/VeriSmith/Fuzz.hs b/src/VeriSmith/Fuzz.hs new file mode 100644 index 0000000..9331a5e --- /dev/null +++ b/src/VeriSmith/Fuzz.hs @@ -0,0 +1,466 @@ +{-| +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 FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +module VeriSmith.Fuzz + ( Fuzz + , fuzz + , fuzzInDir + , fuzzMultiple + , runFuzz + , sampleSeed + -- * Helpers + , 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.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Maybe (runMaybeT) +import Control.Monad.Trans.Reader hiding (local) +import Control.Monad.Trans.State.Strict +import qualified Crypto.Random.DRBG as C +import Data.ByteString (ByteString) +import Data.List (nubBy, sort) +import Data.Maybe (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) +import Shelly.Lifted (MonadSh, liftSh) +import System.FilePath.Posix (takeBaseName) +import VeriSmith.Config +import VeriSmith.Internal +import VeriSmith.Reduce +import VeriSmith.Report +import VeriSmith.Result +import VeriSmith.Sim.Icarus +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Yosys +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] + , getSimulators :: ![SimTool] + , yosysInstance :: {-# UNPACK #-} !Yosys + } + deriving (Eq, Show) + +data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult] + , _fuzzSimResults :: ![SimResult] + , _fuzzSynthStatus :: ![SynthStatus] + } + deriving (Eq, Show) + +$(makeLenses ''FuzzState) + +type Frequency a = [(Seed, a)] -> [(Int, Gen (Seed, a))] + +-- | The main type for the fuzzing, which contains an environment that can be +-- read from and the current state of all the results. +type Fuzz m = StateT FuzzState (ReaderT FuzzEnv m) + +type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) + +runFuzz :: MonadIO m => Config -> Yosys -> (Config -> Fuzz Sh a) -> m a +runFuzz conf yos m = shelly $ runFuzz' conf yos m + +runFuzz' :: Monad m => Config -> Yosys -> (Config -> Fuzz m b) -> m b +runFuzz' conf yos m = runReaderT + (evalStateT (m conf) (FuzzState [] [] [])) + (FuzzEnv + ( force + $ defaultIdentitySynth + : (descriptionToSynth <$> conf ^. configSynthesisers) + ) + (force $ descriptionToSim <$> conf ^. configSimulators) + yos + ) + +synthesisers :: Monad m => Fuzz m [SynthTool] +synthesisers = lift $ asks getSynthesisers + +--simulators :: (Monad m) => Fuzz () m [SimTool] +--simulators = lift $ asks getSimulators + +--combinations :: [a] -> [b] -> [(a, b)] +--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) + +synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () +synthesis src = do + 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 + +passedSynthesis :: MonadSh m => Fuzz m [SynthTool] +passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get + where + passed (SynthStatus _ (Pass _) _) = True + 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 + toSynth (SynthStatus s _ _) = s + +make :: MonadSh m => FilePath -> m () +make f = liftSh $ do + mkdir_p f + cp_r "data" $ f fromText "data" + +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 + +applyList :: [a -> b] -> [a] -> [b] +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 a b = applyLots SynthResult a $ fmap swap b + +toolRun :: (MonadIO m, MonadSh m) => Text -> m a -> m (NominalDiffTime, a) +toolRun t m = do + logT $ "Running " <> t + (diff, res) <- timeit m + logT $ "Finished " <> t <> " (" <> showT diff <> ")" + return (diff, res) + +equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () +equivalence src = do + synth <- passedSynthesis +-- let synthComb = +-- nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth + let synthComb = + nubBy tupEq + . filter (uncurry (/=)) + $ (,) defaultIdentitySynth + <$> synth + resTimes <- liftSh $ mapM (uncurry equiv) synthComb + fuzzSynthResults .= toSynthResult synthComb resTimes + liftSh $ inspect resTimes + where + tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') + equiv 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 + runEquiv a b src + where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b + +simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () +simulation src = do + synth <- passEquiv + vals <- liftIO $ generateByteString 20 + ident <- liftSh $ equiv vals defaultIdentitySynth + resTimes <- liftSh $ mapM (equiv vals) $ conv <$> synth + liftSh + . inspect + $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) + <$> (ident : resTimes) + where + conv (SynthResult _ a _ _) = a + equiv b 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 defaultIcarus a src b + where dir = fromText $ "simulation_" <> toText a + +-- | Generate a specific number of random bytestrings of size 256. +randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] +randomByteString gen n bytes + | n == 0 = ranBytes : bytes + | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes + where Right (ranBytes, newGen) = C.genBytes 32 gen + +-- | generates the specific number of bytestring with a random seed. +generateByteString :: Int -> IO [ByteString] +generateByteString n = do + gen <- C.newGenIO :: IO C.CtrDRBG + return $ randomByteString gen n [] + +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 + +passEquiv :: (MonadSh m) => Fuzz m [SynthResult] +passEquiv = filter withIdentity . _fuzzSynthResults <$> get + where + withIdentity (SynthResult _ _ (Pass _) _) = True + withIdentity _ = False + +-- | Always reduces with respect to 'Identity'. +reduction :: (MonadSh m) => SourceInfo -> Fuzz m () +reduction src = do + fails <- failEquivWithIdentity + synthFails <- failedSynthesis + _ <- liftSh $ mapM red fails + _ <- liftSh $ mapM redSynth synthFails + return () + where + red (SynthResult a b _ _) = do + make dir + pop dir $ do + s <- reduceSynth a b src + writefile (fromText ".." dir <.> "v") $ genSource s + return s + where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b + redSynth a = do + make dir + pop dir $ do + s <- reduceSynthesis a src + writefile (fromText ".." dir <.> "v") $ genSource s + return s + where dir = fromText $ "reduce_" <> toText 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) + +whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) +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) + => Fuzz m (Seed, SourceInfo) + -> Fuzz m (Seed, SourceInfo) +generateSample f = do + 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 + +hatFreqs :: Frequency a +hatFreqs l = zip hat (return <$> l) + where + h = length l `div` 2 + hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] + +meanFreqs :: Source a => Frequency a +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 + sizes = verilogSize . snd <$> l + +medianFreqs :: Frequency a +medianFreqs l = zip hat (return <$> l) + where + h = length l `div` 2 + hat = set_ <$> [1 .. length l] + set_ n = if n == h then 1 else 0 + +fuzz :: MonadFuzz m => Gen SourceInfo -> Config -> Fuzz m FuzzReport +fuzz gen conf = do + (seed', src) <- generateSample genMethod + let size = length . lines . T.unpack $ genSource src + liftSh + . writefile "config.toml" + . encodeConfig + $ conf + & configProperty + . propSeed + ?~ seed' + (tsynth, _) <- titleRun "Synthesis" $ synthesis src + (tequiv, _) <- titleRun "Equivalence Check" $ equivalence src + (_ , _) <- titleRun "Simulation" $ simulation src + fails <- failEquivWithIdentity + synthFails <- failedSynthesis + redResult <- + whenMaybe (not $ null fails && null synthFails) + . 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) + liftSh . writefile "index.html" $ printResultReport (bname currdir) report + return report + where + seed = conf ^. configProperty . propSeed + bname = T.pack . takeBaseName . T.unpack . toTextIgnore + genMethod = 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 + 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 + +fuzzInDir + :: MonadFuzz m => FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport +fuzzInDir fp src conf = do + make fp + res <- pop fp $ fuzz src conf + relativeFuzzReport res + +fuzzMultiple + :: MonadFuzz m + => Int + -> Maybe FilePath + -> Gen SourceInfo + -> Config + -> Fuzz m [FuzzReport] +fuzzMultiple n fp src conf = do + x <- case fp 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 .. n] fuzzDir' + else (: []) <$> fuzzDir' (1 :: Int) + liftSh . writefile (fromText "index" <.> "html") $ printSummary + "Fuzz Summary" + results + return results + where + fuzzDir' n' = fuzzInDir (fromText $ "fuzz_" <> showT n') src conf + seed = conf ^. configProperty . propSeed + +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 + runIdentity + . runMaybeT + . Hog.runTree + $ Hog.runGenT 30 seed gen + of + Nothing -> loop (n - 1) + Just x -> return (seed, Hog.nodeValue x) + in loop (100 :: Int) + diff --git a/src/VeriSmith/Generate.hs b/src/VeriSmith/Generate.hs new file mode 100644 index 0000000..095baee --- /dev/null +++ b/src/VeriSmith/Generate.hs @@ -0,0 +1,623 @@ +{-| +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 TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module VeriSmith.Generate + ( -- * Generation methods + procedural + , proceduralIO + , proceduralSrc + , proceduralSrcIO + , randomMod + -- ** Generate Functions + , gen + , 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 + ) +where + +import Control.Lens hiding (Context) +import Control.Monad (replicateM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader hiding (local) +import Control.Monad.Trans.State.Strict +import Data.Foldable (fold) +import Data.Functor.Foldable (cata) +import Data.List (foldl', partition) +import qualified Data.Text as T +import Hedgehog (Gen) +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 = Context { _variables :: [Port] + , _parameters :: [Parameter] + , _modules :: [ModDecl] + , _nameCounter :: {-# UNPACK #-} !Int + , _stmntDepth :: {-# UNPACK #-} !Int + , _modDepth :: {-# UNPACK #-} !Int + , _determinism :: !Bool + } + +makeLenses ''Context + +type StateGen = StateT Context (ReaderT Config Gen) + +toId :: Int -> Identifier +toId = Identifier . ("w" <>) . T.pack . show + +toPort :: Identifier -> Gen Port +toPort ident = do + i <- range + return $ wire i ident + +sumSize :: [Port] -> Range +sumSize ps = sum $ ps ^.. traverse . portSize + +random :: [Port] -> (Expr -> ContAssign) -> Gen ModItem +random ctx fun = do + 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 + +randomOrdAssigns :: [Port] -> [Port] -> [Gen ModItem] +randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids + where + generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) + +randomMod :: Int -> Int -> Gen ModDecl +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]) + [] + where + ids = toId <$> [1 .. total] + end = drop inps + start = take inps + +-- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the +-- 'Port'. +lvalFromPort :: Port -> LVal +lvalFromPort (Port _ _ _ i) = RegId i + +-- | Returns the probability from the configuration. +probability :: Config -> Probability +probability c = c ^. configProbability + +-- | Gets the current probabilities from the 'State'. +askProbability :: StateGen Probability +askProbability = lift $ asks probability + +-- | Lifts a 'Gen' into the 'StateGen' monad. +gen :: Gen a -> StateGen a +gen = lift . lift + +-- | Generates a random large number, which can also be negative. +largeNum :: Gen Int +largeNum = Hog.int $ Hog.linear (-100) 100 + +-- | Generates a random size for a wire so that it is not too small and not too +-- large. +wireSize :: Gen Int +wireSize = Hog.int $ Hog.linear 2 100 + +-- | Generates a random range by using the 'wireSize' and 0 as the lower bound. +range :: Gen Range +range = Range <$> fmap fromIntegral wireSize <*> pure 0 + +-- | Generate a random bit vector using 'largeNum'. +genBitVec :: Gen BitVec +genBitVec = fmap fromIntegral largeNum + +-- | Return a random 'BinaryOperator'. This currently excludes 'BinDiv', +-- 'BinMod' because they can take a long time to synthesis, and 'BinCEq', +-- 'BinCNEq', because these are not synthesisable. 'BinPower' is also excluded +-- because it can only be used in conjunction with base powers of 2 which is +-- currently not enforced. +binOp :: Gen 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 + ] + +-- | Generate a random 'UnaryOperator'. +unOp :: Gen UnaryOperator +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 :: [Parameter] -> ProbExpr -> Hog.Size -> Gen 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 + +-- | The list of safe 'Expr', meaning that these will not recurse and will end +-- the 'Expr' generation. +exprSafeList :: ProbExpr -> [(Int, Gen Expr)] +exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] + +-- | List of 'Expr' that have the chance to recurse and will therefore not be +-- used when the expression grows too large. +exprRecList :: ProbExpr -> (Hog.Size -> Gen Expr) -> [(Int, Gen 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) + ] + +-- | Select a random port from a list of ports and generate a safe bit selection +-- for that port. +rangeSelect :: [Parameter] -> [Port] -> Gen 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) + +-- | Generate a random expression from the 'Context' with a guarantee that it +-- will terminate using the list of safe 'Expr'. +exprWithContext :: ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> Gen 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 l n + | n == 0 + = Hog.frequency + $ (prob ^. probExprId, Id . fromPort <$> Hog.element l) + : exprSafeList prob + | 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 + +-- | Runs a 'StateGen' for a random number of times, limited by an 'Int' that is +-- passed to it. +someI :: Int -> StateGen a -> StateGen [a] +someI m f = do + amount <- gen $ 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 :: T.Text -> StateGen Identifier +makeIdentifier prefix = do + context <- get + let ident = Identifier $ prefix <> showT (context ^. nameCounter) + nameCounter += 1 + return ident + +getPort' :: PortType -> Identifier -> [Port] -> StateGen 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' + +-- | 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 +-- 'newPort'. This is used subsequently in all the functions to create a port, +-- in case a port with the same name was already created. This could be because +-- the generation is currently in the other branch of an if-statement. +nextPort :: PortType -> StateGen Port +nextPort pt = do + context <- get + ident <- makeIdentifier . T.toLower $ showT pt + 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 Port +newPort ident pt = do + p <- gen $ Port pt <$> Hog.bool <*> range <*> pure ident + variables %= (p :) + return p + +-- | Generates an expression from variables that are currently in scope. +scopedExpr :: StateGen Expr +scopedExpr = do + context <- get + prob <- askProbability + gen + . 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 ContAssign +contAssign = do + expr <- scopedExpr + p <- nextPort Wire + return $ ContAssign (p ^. portName) expr + +-- | Generate a random assignment and assign it to a random 'Reg'. +assignment :: StateGen Assign +assignment = do + expr <- scopedExpr + lval <- lvalFromPort <$> nextPort Reg + return $ Assign lval Nothing expr + +-- | Generate a random 'Statement' safely, by also increasing the depth counter. +seqBlock :: StateGen Statement +seqBlock = do + 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' +-- is not reused, it is left at 0, as all the 'Reg' are initialised to 0 at the +-- start. +conditional :: StateGen Statement +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) + +-- | Generate a random for loop by creating a new variable name for the counter +-- and then generating random statements in the body. +forLoop :: StateGen Statement +forLoop = do + num <- Hog.int (Hog.linear 0 20) + var <- lvalFromPort <$> nextPort 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 Statement +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 + +-- | Generate a sequential always block which is dependent on the clock. +alwaysSeq :: StateGen ModItem +alwaysSeq = Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock + +-- | Should resize a port that connects to a module port if the latter is +-- larger. This should not cause any problems if the same net is used as input +-- 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 + +-- | Instantiate a module, where the outputs are new nets that are created, and +-- the inputs are taken from existing ports in the context. +-- +-- 1 is subtracted from the inputs for the length because the clock is not +-- counted and is assumed to be there, this should be made nicer by filtering +-- out the clock instead. I think that in general there should be a special +-- representation for the clock. +instantiate :: ModDecl -> StateGen ModItem +instantiate (ModDecl i outP inP _ _) = do + context <- get + outs <- replicateM (length outP) (nextPort Wire) + ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) + 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) + , ModInst i ident <$> Hog.shuffle + (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) (toE $ outs <> clkPort <> ins)) + ] + 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 +-- for every instance and for every level until either the deepest level is +-- achieved, or the maximum number of modules are reached. +-- +-- If the maximum number of levels are reached, it will always pick an instance +-- from the current context. The problem with this approach is that at the end +-- there may be many more than the max amount of modules, as the modules are +-- always set to empty when entering a new level. This is to fix recursive +-- definitions of modules, which are not defined. +-- +-- One way to fix that is to also decrement the max modules for every level, +-- depending on how many modules have already been generated. This would mean +-- there would be moments when the module cannot generate a new instance but +-- also not take a module from the current context. A fix for that may be to +-- have a default definition of a simple module that is used instead. +-- +-- Another different way to handle this would be to have a probability of taking +-- a module from a context or generating a new one. +modInst :: StateGen ModItem +modInst = do + prob <- lift 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 ModItem +modItem = do + conf <- lift 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 + 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 Identifier +moduleName (Just t) = return t +moduleName Nothing = makeIdentifier "module" + +-- | Generate a random 'ConstExpr' by using the current context of 'Parameters'. +constExpr :: StateGen ConstExpr +constExpr = do + prob <- askProbability + context <- get + gen . 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 Parameter +parameter = do + 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 + +-- | Calculate a range to an int by maybe resizing the ranges to a value. +calcRange :: [Parameter] -> Maybe Int -> Range -> Int +calcRange ps i (Range l r) = eval l - eval r + 1 + where + eval a = fromIntegral . cata (evaluateConst ps) $ maybe a (`resize` a) i + +-- | Filter out a port based on it's name instead of equality of the ports. This +-- is because the ports might not be equal if the sizes are being updated. +identElem :: Port -> [Port] -> Bool +identElem p = elem (p ^. portName) . toListOf (traverse . portName) + +-- | Generates a module definition randomly. It always has one output port which +-- is set to @y@. The size of @y@ is the total combination of all the locally +-- defined wires, so that it correctly reflects the internal state of the +-- module. +moduleDef :: Maybe Identifier -> StateGen ModDecl +moduleDef top = do + name <- moduleName top + portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire + mi <- Hog.list (Hog.linear 4 100) modItem + ps <- Hog.list (Hog.linear 0 10) parameter + context <- get + config <- lift ask + let (newPorts, local) = partition (`identElem` portList) $ _variables context + let + size = + evalRange (_parameters context) 32 + . sum + $ local + ^.. traverse + . portSize + let combine = config ^. configProperty . propCombine + let clock = Port Wire False 1 "clk" + let yport = + if combine then Port Wire False 1 "y" else Port Wire False size "y" + let comb = combineAssigns_ combine yport local + 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 :: T.Text -> Config -> Gen Verilog +procedural top config = do + (mainMod, st) <- Hog.resize num $ runReaderT + (runStateT (moduleDef (Just $ Identifier top)) context) + config + return . Verilog $ mainMod : st ^. modules + where + context = + Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True + num = fromIntegral $ confProp propSize + confProp i = config ^. configProperty . i + +-- | Samples the 'Gen' directly to generate random 'Verilog' using the 'T.Text' as +-- the name of the main module and the configuration 'Config' to influence the +-- generation. +proceduralIO :: T.Text -> Config -> IO Verilog +proceduralIO t = Hog.sample . procedural t + +-- | Given a 'T.Text' and a 'Config' will generate a 'SourceInfo' which has the +-- top module set to the right name. +proceduralSrc :: T.Text -> Config -> Gen SourceInfo +proceduralSrc t c = SourceInfo t <$> procedural t c + +-- | Sampled and wrapped into a 'SourceInfo' with the given top module name. +proceduralSrcIO :: T.Text -> Config -> IO SourceInfo +proceduralSrcIO t c = SourceInfo t <$> proceduralIO t c diff --git a/src/VeriSmith/Internal.hs b/src/VeriSmith/Internal.hs new file mode 100644 index 0000000..86cb1f7 --- /dev/null +++ b/src/VeriSmith/Internal.hs @@ -0,0 +1,49 @@ +{-| +Module : VeriSmith.Internal +Description : Shared high level code used in the other modules internally. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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) + +-- | Function to show a bytestring in a hex format. +showBS :: ByteString -> Text +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 + +-- | Show function for 'Text' +showT :: (Show a) => a -> Text +showT = T.pack . show + +-- | Inserts commas between '[Text]' and except the last one. +comma :: [Text] -> Text +comma = T.intercalate ", " + +-- | Inserts commas and newlines between '[Text]' and except the last one. +commaNL :: [Text] -> Text +commaNL = T.intercalate ",\n" diff --git a/src/VeriSmith/Reduce.hs b/src/VeriSmith/Reduce.hs new file mode 100644 index 0000000..c57b457 --- /dev/null +++ b/src/VeriSmith/Reduce.hs @@ -0,0 +1,609 @@ +{-| +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 ScopedTypeVariables #-} + +module VeriSmith.Reduce + ( -- $strategy + reduceWithScript + , reduceSynth + , reduceSynthesis + , reduce + , reduce_ + , Replacement(..) + , halveModules + , halveModItems + , halveStatements + , halveExpr + , halveAssigns + , findActiveWires + , clean + , cleanSourceInfo + , cleanSourceInfoAll + , removeDecl + , filterExpr + ) +where + +import Control.Lens hiding ((<.>)) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +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 ((<.>)) +import qualified Shelly +import Shelly.Lifted (MonadSh, liftSh) +import VeriSmith.Internal +import VeriSmith.Result +import VeriSmith.Sim +import VeriSmith.Sim.Internal +import VeriSmith.Verilog +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.Mutate +import VeriSmith.Verilog.Parser + + +-- $strategy +-- The reduction strategy has multiple different steps. 'reduce' will run these +-- strategies one after another, starting at the most coarse grained one. The +-- supported reduction strategies are the following: +-- +-- [Modules] First of all, the reducer will try and remove all the modules +-- except the top module. +-- +-- [Module Items] Then, the module items will be reduced by using standard +-- delta debugging. Half of the module items will be removed, and both +-- versions will be tested. If both succeed, they will be divided further and +-- tested further. Finally, the shortest version will be returned. +-- +-- [Statements] Once the module items have been reduced, the statements will +-- be reduced as well. This is done using delta debugging, just like the +-- module items. +-- +-- [Expressions] Finally, the expressions themselves will be reduced. This is +-- done by splitting the top most binary expressions in half and testing each +-- half. + +-- | 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) + +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 + +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 + +instance Foldable Replacement where + 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 + +-- | Split a list in two halves. +halve :: Replace [a] +halve [] = Single [] +halve [_] = Single [] +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 + +-- | 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 +-- module. +combine :: Lens' a b -> Replace b -> Replace a +combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res + +-- | Deletes Id 'Expr' if they are not part of the current scope, and replaces +-- these by 0. +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 +filterExpr ids (RangeSelect i r) = + 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 -> 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 -> Bool +filterAssigns out (ModCA (ContAssign i _)) = + elem i $ out ^.. traverse . portName +filterAssigns _ _ = True + +clean :: (Mutate a) => [Identifier] -> a -> a +clean ids = mutExpr (transform $ filterExpr ids) + +cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem] +cleanUndefined ids mis = clean usedWires mis + where + usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids + +halveModAssign :: Replace ModDecl +halveModAssign m = cleanMod m $ modify <$> assigns (m ^. modItems) + where + assigns = halve . filter (filterAssigns $ m ^. modOutPorts) + modify l = m & modItems .~ l + +cleanMod :: ModDecl -> Replacement ModDecl -> Replacement ModDecl +cleanMod m newm = modify . change <$> newm + where + 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 + +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 + +halveModExpr :: Replace ModItem +halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca +halveModExpr a = Single a + +-- | Remove all the undefined mod instances. +cleanModInst :: SourceInfo -> SourceInfo +cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned + where + validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId + cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped + +-- | Clean all the undefined module instances in a specific module using a +-- context. +cleanModInst' :: [Identifier] -> ModDecl -> ModDecl +cleanModInst' ids m = m & modItems .~ newModItem + where newModItem = filter (validModInst ids) $ m ^.. modItems . traverse + +-- | Check if a mod instance is in the current context. +validModInst :: [Identifier] -> ModItem -> Bool +validModInst ids (ModInst i _ _) = i `elem` ids +validModInst _ _ = True + +-- | Adds a 'ModDecl' to a 'SourceInfo'. +addMod :: ModDecl -> SourceInfo -> SourceInfo +addMod m srcInfo = srcInfo & infoSrc . _Wrapped %~ (m :) + +-- | Split a module declaration in half by trying to remove assign +-- statements. This is only done in the main module of the source. +halveAssigns :: Replace SourceInfo +halveAssigns = combine mainModule halveModAssign + +-- | Checks if a module item is needed in the module declaration. +relevantModItem :: ModDecl -> ModItem -> Bool +relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) = + i `elem` fmap _portName out +relevantModItem _ Decl{} = True +relevantModItem _ _ = False + +isAssign :: Statement -> Bool +isAssign (BlockAssign _) = True +isAssign (NonBlockAssign _) = True +isAssign _ = False + +lValName :: LVal -> [Identifier] +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 + +-- | 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 (RangeSelect i _) = [i] +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 (RangeSelect i _) = Just i +exprId _ = Nothing + +eventId :: Event -> Maybe Identifier +eventId (EId i) = Just i +eventId (EPosEdge i) = Just i +eventId (ENegEdge i) = Just i +eventId _ = Nothing + +portToId :: Port -> Identifier +portToId (Port _ _ _ i) = i + +paramToId :: Parameter -> Identifier +paramToId (Parameter i _) = i + +isModule :: Identifier -> ModDecl -> Bool +isModule i (ModDecl n _ _ _ _) = i == n + +modInstActive :: [ModDecl] -> ModItem -> [Identifier] +modInstActive decl (ModInst n _ i) = case m of + 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 _ _ _) (ModConnNamed i' e, _) + | i' `elem` fmap _portName o = exprName e + | otherwise = [] +modInstActive _ _ = [] + +fixModInst :: SourceInfo -> ModItem -> ModItem +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 ..] + 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 + fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _) + | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e + | otherwise = Nothing +fixModInst _ a = a + +findActiveWires :: Identifier -> SourceInfo -> [Identifier] +findActiveWires t src = + 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) + allStat = filter isAssign . concat $ fmap universe stat + stat = + (m ^.. modItems . traverse . _Initial) + <> (m ^.. modItems . traverse . _Always) + modinstwires = + 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 +-- 'SourceInfo', otherwise it will crash. +cleanSourceInfo :: Identifier -> SourceInfo -> SourceInfo +cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) + +cleanSourceInfoAll :: SourceInfo -> SourceInfo +cleanSourceInfoAll src = foldr cleanSourceInfo src allMods + where allMods = src ^.. infoSrc . _Wrapped . traverse . modId + +-- | Returns true if the text matches the name of a module. +matchesModName :: Identifier -> ModDecl -> Bool +matchesModName top (ModDecl i _ _ _ _) = top == i + +halveStatement :: Replace Statement +halveStatement (SeqBlock [s]) = halveStatement s +halveStatement (SeqBlock s) = SeqBlock <$> halve s +halveStatement (CondStmnt _ (Just s1) (Just s2)) = Dual s1 s2 +halveStatement (CondStmnt _ (Just s1) Nothing) = Single s1 +halveStatement (CondStmnt _ Nothing (Just s1)) = Single s1 +halveStatement (EventCtrl e (Just s)) = EventCtrl e . Just <$> halveStatement s +halveStatement (TimeCtrl e (Just s)) = TimeCtrl e . Just <$> halveStatement s +halveStatement a = Single a + +halveAlways :: Replace ModItem +halveAlways (Always s) = Always <$> halveStatement s +halveAlways a = Single a + +-- | Removes half the modules randomly, until it reaches a minimal amount of +-- modules. This is done by doing a binary search on the list of modules and +-- removing the instantiations from the main module body. +halveModules :: Replace SourceInfo +halveModules srcInfo@(SourceInfo top _) = + cleanSourceInfoAll + . cleanModInst + . addMod main + <$> combine (infoSrc . _Wrapped) repl srcInfo + where + repl = halve . filter (not . matchesModName (Identifier top)) + main = srcInfo ^. mainModule + +moduleBot :: SourceInfo -> Bool +moduleBot (SourceInfo _ (Verilog [] )) = True +moduleBot (SourceInfo _ (Verilog [_])) = True +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 +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 + addRelevant = aModule t . modItems %~ (relevant ++) + +modItemBot :: Identifier -> SourceInfo -> Bool +modItemBot t srcInfo | length modItemsNoDecl > 2 = False + | otherwise = True + where + modItemsNoDecl = + filter noDecl $ srcInfo ^.. aModule t . modItems . traverse + noDecl Decl{} = False + noDecl _ = True + +halveStatements :: Identifier -> Replace SourceInfo +halveStatements t m = + cleanSourceInfo t <$> combine (aModule t . modItems) halves m + where halves = traverse halveAlways + +-- | Reduce expressions by splitting them in half and keeping the half that +-- succeeds. +halveExpr :: Identifier -> Replace SourceInfo +halveExpr t = combine contexpr $ traverse halveModExpr + where + contexpr :: Lens' SourceInfo [ModItem] + contexpr = aModule t . modItems + +toIds :: [Expr] -> [Identifier] +toIds = nub . mapMaybe exprId . concatMap universe + +toIdsConst :: [ConstExpr] -> [Identifier] +toIdsConst = toIds . fmap constToExpr + +toIdsEvent :: [Event] -> [Identifier] +toIdsEvent = nub . mapMaybe eventId . concatMap universe + +allStatIds' :: Statement -> [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) + eventProcessedIds = toIdsEvent $ s ^.. statEvent + +allStatIds :: Statement -> [Identifier] +allStatIds s = nub . concat $ allStatIds' <$> universe s + +fromRange :: Range -> [ConstExpr] +fromRange r = [rangeMSB r, rangeLSB r] + +allExprIds :: ModDecl -> [Identifier] +allExprIds m = + nub + $ contAssignIds + <> modInstIds + <> modInitialIds + <> modAlwaysIds + <> modPortIds + <> modDeclIds + <> paramIds + where + contAssignIds = + toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr + modInstIds = + toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr + modInitialIds = + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial + modAlwaysIds = + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always + modPortIds = + 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 + ) + +isUsedDecl :: [Identifier] -> ModItem -> Bool +isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids +isUsedDecl _ _ = True + +isUsedParam :: [Identifier] -> Parameter -> Bool +isUsedParam ids (Parameter i _) = i `elem` ids + +isUsedPort :: [Identifier] -> Port -> Bool +isUsedPort ids (Port _ _ _ i) = i `elem` ids + +removeDecl :: SourceInfo -> SourceInfo +removeDecl src = foldr fix removed allMods + where + removeDecl' t src' = + 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) + allMods = src ^.. infoSrc . _Wrapped . traverse . modId + fix t a = a & aModule t . modItems %~ fmap (fixModInst a) + removed = foldr removeDecl' src allMods + +defaultBot :: SourceInfo -> Bool +defaultBot = const False + +-- | Reduction using custom reduction strategies. +reduce_ + :: MonadSh m + => Text + -> Replace SourceInfo + -> (SourceInfo -> Bool) + -> (SourceInfo -> m Bool) + -> SourceInfo + -> m SourceInfo +reduce_ title repl bot eval src = do + 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 src + else case repl src of + Single s -> do + red <- eval s + if red + then if cond s then recReduction s else return s + else return src + Dual l r -> do + red <- eval l + if red + then if cond l then recReduction l else return l + else do + red' <- eval r + if red' + then if cond r then recReduction r else return r + else return src + None -> return src + where + cond s = s /= src + recReduction = reduce_ title repl bot eval + +-- | Reduce an input to a minimal representation. It follows the reduction +-- strategy mentioned above. +reduce + :: MonadSh m + => (SourceInfo -> m Bool) -- ^ Failed or not. + -> SourceInfo -- ^ Input verilog source to be reduced. + -> m SourceInfo -- ^ Reduced output. +reduce eval src = + fmap removeDecl + $ red "Modules" moduleBot halveModules src + >>= redAll "Module Items" modItemBot halveModItems + >>= redAll "Statements" (const defaultBot) halveStatements + -- >>= redAll "Expressions" (const defaultBot) halveExpr + where + red s bot a = reduce_ s a bot eval + red' s bot a t = reduce_ s (a t) (bot t) eval + redAll s bot halve' src' = foldrM + (\t -> red' (s <> " (" <> getIdentifier t <> ")") bot halve' t) + src' + (src' ^.. infoSrc . _Wrapped . traverse . modId) + +runScript + :: MonadSh m => Shelly.FilePath -> Shelly.FilePath -> SourceInfo -> 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 + +-- | Reduce using a script that is passed to it +reduceWithScript + :: (MonadSh m, MonadIO m) + => Text + -> Shelly.FilePath + -> Shelly.FilePath + -> m () +reduceWithScript top script file = do + liftSh . Shelly.cp file $ file <.> "original" + srcInfo <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file + void $ reduce (runScript script file) srcInfo + +-- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it. +reduceSynth + :: (Synthesiser a, Synthesiser b, MonadSh m) + => a + -> b + -> SourceInfo + -> m SourceInfo +reduceSynth a b = reduce synth + where + synth src' = liftSh $ do + r <- runResultT $ do + runSynth a src' + runSynth b src' + runEquiv a b src' + return $ case r of + Fail EquivFail -> True + Fail _ -> False + Pass _ -> False + +reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo -> m SourceInfo +reduceSynthesis a = reduce synth + where + synth src = liftSh $ do + r <- runResultT $ runSynth a src + return $ case r of + Fail SynthFail -> True + Fail _ -> False + Pass _ -> False diff --git a/src/VeriSmith/Report.hs b/src/VeriSmith/Report.hs new file mode 100644 index 0000000..fe680c3 --- /dev/null +++ b/src/VeriSmith/Report.hs @@ -0,0 +1,398 @@ +{-# 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 TemplateHaskell #-} + +module VeriSmith.Report + ( SynthTool(..) + , SynthStatus(..) + , SynthResult(..) + , SimResult(..) + , SimTool(..) + , FuzzReport(..) + , printResultReport + , printSummary + , synthResults + , simResults + , synthStatus + , equivTime + , fuzzDir + , fileLines + , reducTime + , synthTime + , defaultIcarusSim + , defaultVivadoSynth + , defaultYosysSynth + , defaultXSTSynth + , defaultQuartusSynth + , 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 Data.Vector (fromList) +import Prelude hiding (FilePath) +import Shelly (FilePath, fromText, + toTextIgnore, (<.>), ()) +import Statistics.Sample (meanVariance) +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.Sim +import VeriSmith.Sim.Internal + +-- | Common type alias for synthesis results +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 + | 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 (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 (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 (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 (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 (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 (IdentitySynth identity) = IdentitySynth . setSynthOutput identity + +defaultYosysSynth :: SynthTool +defaultYosysSynth = YosysSynth defaultYosys + +defaultQuartusSynth :: SynthTool +defaultQuartusSynth = QuartusSynth defaultQuartus + +defaultVivadoSynth :: SynthTool +defaultVivadoSynth = VivadoSynth defaultVivado + +defaultXSTSynth :: SynthTool +defaultXSTSynth = XSTSynth defaultXST + +defaultIdentitySynth :: SynthTool +defaultIdentitySynth = IdentitySynth defaultIdentity + +newtype SimTool = IcarusSim Icarus + deriving (Eq) + +instance NFData SimTool where + rnf (IcarusSim a) = rnf a + +instance Tool SimTool where + toText (IcarusSim icarus) = toText icarus + +instance Simulator SimTool where + runSim (IcarusSim icarus) = runSim icarus + runSimWithFile (IcarusSim icarus) = runSimWithFile icarus + +instance Show SimTool where + show (IcarusSim icarus) = show icarus + +defaultIcarusSim :: SimTool +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 !BResult !NominalDiffTime + 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 <> ")" + +getSimResult :: SimResult -> UResult +getSimResult (SimResult _ _ (Pass _) _) = Pass () +getSimResult (SimResult _ _ (Fail b) _) = Fail b + +-- | The results of comparing the synthesised outputs of two files using a +-- 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) + +instance Show SynthResult where + show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" + +getSynthResult :: SynthResult -> UResult +getSynthResult (SynthResult _ _ a _) = a + +-- | The status of the synthesis using a simulator. This will be checked before +-- attempting to run the equivalence checks on the simulator, as that would be +-- unnecessary otherwise. +data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime + 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 <> ")" + +-- | The complete state that will be used during fuzzing, which contains the +-- results from all the operations. +data FuzzReport = FuzzReport { _fuzzDir :: !FilePath + , _synthResults :: ![SynthResult] + , _simResults :: ![SimResult] + , _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 <> "'" + +-- | 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 +descriptionToSynth (SynthDescription "vivado" bin desc 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 +descriptionToSynth (SynthDescription "quartus" bin desc out) = + QuartusSynth + . Quartus (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 +descriptionToSynth 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 (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" + +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 + +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 + +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" + +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 + +resultStatus :: Result a b -> Html +resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" +resultStatus (Fail _) = H.td ! A.class_ "is-danger" $ "Failed" + +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 = fromList . 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 + ! A.href + ( H.textValue + $ toTextIgnore (dir fromText "index" <.> "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 + ] + 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 + +printResultReport :: Text -> FuzzReport -> Text +printResultReport t f = toStrict . renderHtml $ resultReport t f + +printSummary :: Text -> [FuzzReport] -> Text +printSummary t f = toStrict . renderHtml $ summary t f diff --git a/src/VeriSmith/Result.hs b/src/VeriSmith/Result.hs new file mode 100644 index 0000000..7bfbf9b --- /dev/null +++ b/src/VeriSmith/Result.hs @@ -0,0 +1,137 @@ +{-| +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 MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module VeriSmith.Result + ( Result(..) + , ResultT(..) + , () + , annotate + ) +where + +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, liftSh) + +-- | 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) + +instance Semigroup (Result a b) where + Pass _ <> a = a + a <> _ = a + +instance (Monoid b) => Monoid (Result a b) where + mempty = Pass mempty + +instance Functor (Result a) where + 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 + +instance Monad (Result a) where + Pass a >>= f = f a + Fail b >>= _ = Fail b + +instance MonadBase (Result a) (Result a) where + liftBase = id + +instance Bifunctor Result where + 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) } + +instance Functor f => Functor (ResultT a f) where + 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) + +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) + +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)) + +instance MonadIO m => MonadIO (ResultT a m) where + liftIO s = ResultT $ Pass <$> liftIO s + +instance MonadBase b m => MonadBase b (ResultT a m) where + liftBase = liftBaseDefault + +instance MonadTrans (ResultT e) where + 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 #-} + +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 #-} + +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 + +annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b +annotate = flip () diff --git a/src/VeriSmith/Sim.hs b/src/VeriSmith/Sim.hs new file mode 100644 index 0000000..f0489d3 --- /dev/null +++ b/src/VeriSmith/Sim.hs @@ -0,0 +1,51 @@ +{-| +Module : VeriSmith.Sim +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.Sim + ( + -- * Simulators + -- ** Icarus + Icarus(..) + , defaultIcarus + -- * Synthesisers + -- ** Yosys + , Yosys(..) + , defaultYosys + -- ** Vivado + , Vivado(..) + , defaultVivado + -- ** XST + , XST(..) + , defaultXST + -- ** Quartus + , Quartus(..) + , defaultQuartus + -- ** Identity + , Identity(..) + , defaultIdentity + -- * Equivalence + , runEquiv + -- * Simulation + , runSim + -- * Synthesis + , runSynth + , logger + ) +where + +import VeriSmith.Sim.Icarus +import VeriSmith.Sim.Identity +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Quartus +import VeriSmith.Sim.Vivado +import VeriSmith.Sim.XST +import VeriSmith.Sim.Yosys diff --git a/src/VeriSmith/Sim/Icarus.hs b/src/VeriSmith/Sim/Icarus.hs new file mode 100644 index 0000000..f104630 --- /dev/null +++ b/src/VeriSmith/Sim/Icarus.hs @@ -0,0 +1,188 @@ +{-| +Module : VeriSmith.Sim.Icarus +Description : Icarus verilog module. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Icarus verilog module. +-} + +module VeriSmith.Sim.Icarus + ( Icarus(..) + , defaultIcarus + , runSimIc + ) +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.Sim.Internal +import VeriSmith.Sim.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) + +instance Show Icarus where + show _ = "iverilog" + +instance Tool Icarus where + toText _ = "iverilog" + +instance Simulator Icarus where + runSim = runSimIcarus + runSimWithFile = runSimIcarusWithFile + +instance NFData Icarus where + rnf = rwhnf + +defaultIcarus :: Icarus +defaultIcarus = Icarus "iverilog" "vvp" + +addDisplay :: [Statement] -> [Statement] +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 +assignFunc inp bs = + 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 + +mask :: Text -> Text +mask = T.replace "x" "0" + +callback :: ByteString -> Text -> ByteString +callback b t = b <> convert (mask t) + +runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss + where m = rinfo ^. mainModule + +runSimIcarusWithFile + :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString +runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) + +fromBytes :: ByteString -> Integer +fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b + +runSimIc + :: (Synthesiser b) + => Icarus + -> b + -> SourceInfo + -> [ByteString] + -> ResultSh ByteString +runSimIc sim1 synth1 srcInfo bss = do + dir <- liftSh pwd + let top = srcInfo ^. mainModule + let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) + let + tb = 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 + ) + <> (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"] + ] + [] + + liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 + liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] + liftSh + $ B.take 8 + . BA.convert + . (hash :: ByteString -> Digest SHA256) + <$> logCommand + dir + "vvp" + (runFoldLines (mempty :: ByteString) + callback + (vvpPath sim1) + ["main"] + ) + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriSmith/Sim/Identity.hs b/src/VeriSmith/Sim/Identity.hs new file mode 100644 index 0000000..cac230f --- /dev/null +++ b/src/VeriSmith/Sim/Identity.hs @@ -0,0 +1,51 @@ +{-| +Module : VeriSmith.Sim.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.Sim.Identity + ( 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.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text + , identityOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Identity where + toText (Identity d _) = d + +instance Show Identity where + show t = unpack $ toText t + +instance Synthesiser Identity where + runSynth = runSynthIdentity + synthOutput = identityOutput + setSynthOutput (Identity a _) = Identity a + +instance NFData Identity where + rnf = rwhnf + +runSynthIdentity :: Identity -> SourceInfo -> ResultSh () +runSynthIdentity (Identity _ out) = writefile out . genSource + +defaultIdentity :: Identity +defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/VeriSmith/Sim/Internal.hs b/src/VeriSmith/Sim/Internal.hs new file mode 100644 index 0000000..017faad --- /dev/null +++ b/src/VeriSmith/Sim/Internal.hs @@ -0,0 +1,215 @@ +{-| +Module : VeriSmith.Sim.Internal +Description : Class of the simulator. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Class of the simulator and the synthesize tool. +-} + +{-# LANGUAGE DeriveFunctor #-} + +module VeriSmith.Sim.Internal + ( 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.Internal +import VeriSmith.Result +import VeriSmith.Verilog.AST + +-- | Tool class. +class Tool a where + toText :: a -> Text + +-- | Simulation type class. +class Tool a => Simulator a where + runSim :: a -- ^ Simulator instance + -> SourceInfo -- ^ 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 + | EquivError + | SimFail + | SynthFail + | TimeoutError + deriving (Eq, Show) + +instance Semigroup Failed where + EmptyFail <> a = a + b <> _ = b + +instance Monoid Failed where + mempty = EmptyFail + +-- | Synthesiser type class. +class Tool a => Synthesiser a where + runSynth :: a -- ^ Synthesiser tool instance + -> SourceInfo -- ^ Run information + -> ResultSh () -- ^ does not return any values + synthOutput :: a -> FilePath + setSynthOutput :: a -> FilePath -> a + +renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo +renameSource a src = + 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 +-- with also has those instances. +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' + +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 + +-- | 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 -> Sh [Text] +checkPresentModules fp (SourceInfo _ src) = do + 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] + +-- | 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 +-- should find all the instantiations and definitions. This could again be made +-- much simpler if the parser works. +replaceMods :: FilePath -> Text -> SourceInfo -> Sh () +replaceMods fp t (SourceInfo _ src) = + 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" + +timeout :: FilePath -> [Text] -> Sh Text +timeout = command1 "timeout" ["300"] . toTextIgnore +{-# INLINE timeout #-} + +timeout_ :: FilePath -> [Text] -> Sh () +timeout_ = command1_ "timeout" ["300"] . toTextIgnore +{-# INLINE timeout_ #-} + +-- | Helper function to convert bytestrings to integers +bsToI :: ByteString -> Integer +bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 +{-# INLINE bsToI #-} + +noPrint :: Sh a -> Sh a +noPrint = print_stdout False . print_stderr False +{-# INLINE noPrint #-} + +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 + +logCommand :: FilePath -> Text -> Sh a -> Sh a +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" + file s = T.unpack (toTextIgnore $ fp fromText name) <> s + +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 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 () +execute_ a b c d = void . execute a b c d diff --git a/src/VeriSmith/Sim/Quartus.hs b/src/VeriSmith/Sim/Quartus.hs new file mode 100644 index 0000000..6837133 --- /dev/null +++ b/src/VeriSmith/Sim/Quartus.hs @@ -0,0 +1,77 @@ +{-| +Module : VeriSmith.Sim.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.Sim.Quartus + ( 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.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +data Quartus = Quartus { quartusBin :: !(Maybe FilePath) + , quartusDesc :: {-# UNPACK #-} !Text + , quartusOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Quartus where + toText (Quartus _ t _) = t + +instance Show Quartus where + show t = unpack $ toText t + +instance Synthesiser Quartus where + runSynth = runSynthQuartus + synthOutput = quartusOutput + setSynthOutput (Quartus a b _) = Quartus a b + +instance NFData Quartus where + rnf = rwhnf + +defaultQuartus :: Quartus +defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" + +runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () +runSynthQuartus sim (SourceInfo top src) = do + dir <- liftSh pwd + let ex = execute_ SynthFail dir "quartus" + liftSh . writefile inpf $ genSource src + liftSh . noPrint $ run_ + "sed" + [ "-i" + , "s/^module/(* multstyle = \"logic\" *) module/;" + , toTextIgnore inpf + ] + ex (exec "quartus_map") + [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] + ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] + ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] + 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/Sim/Template.hs b/src/VeriSmith/Sim/Template.hs new file mode 100644 index 0000000..d232420 --- /dev/null +++ b/src/VeriSmith/Sim/Template.hs @@ -0,0 +1,133 @@ +{-| +Module : VeriSmith.Sim.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.Sim.Template + ( yosysSatConfig + , yosysSimConfig + , xstSynthConfig + , vivadoSynthConfig + , sbyConfig + , icarusTestbench + ) +where + +import Control.Lens ((^..)) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (FilePath) +import Shelly +import Text.Shakespeare.Text (st) +import VeriSmith.Sim.Internal +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +rename :: Text -> [Text] -> Text +rename end entries = + T.intercalate "\n" + $ flip mappend end + . mappend "rename " + . doubleName + <$> entries +{-# INLINE rename #-} + +doubleName :: Text -> Text +doubleName n = n <> " " <> n +{-# INLINE doubleName #-} + +outputText :: Synthesiser a => a -> Text +outputText = toTextIgnore . synthOutput + +-- brittany-disable-next-binding +yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 + +-- brittany-disable-next-binding +yosysSimConfig :: Text +yosysSimConfig = [st|read_verilog rtl.v; proc;; +rename mod mod_rtl +|] + +-- brittany-disable-next-binding +xstSynthConfig :: Text -> Text +xstSynthConfig top = [st|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" +|] + +-- brittany-disable-next-binding +vivadoSynthConfig :: Text -> Text -> Text +vivadoSynthConfig top outf = [st| +# 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} +|] + +-- brittany-disable-next-binding +sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] +multiclock on +mode prove + +[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 + . (fromText "data" ) + . fromText + <$> deps + readL = T.intercalate "\n" $ mappend "read -formal " <$> deps + +icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text +icarusTestbench t synth1 = [st| +`include "data/cells_cmos.v" +`include "data/cells_cyclone_v.v" +`include "data/cells_verific.v" +`include "data/cells_xilinx_7.v" +`include "data/cells_yosys.v" +`include "#{toTextIgnore $ synthOutput synth1}" + +#{genSource t} +|] diff --git a/src/VeriSmith/Sim/Vivado.hs b/src/VeriSmith/Sim/Vivado.hs new file mode 100644 index 0000000..e8d8f0d --- /dev/null +++ b/src/VeriSmith/Sim/Vivado.hs @@ -0,0 +1,71 @@ +{-| +Module : VeriSmith.Sim.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.Sim.Vivado + ( 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.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) + , vivadoDesc :: {-# UNPACK #-} !Text + , vivadoOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Vivado where + toText (Vivado _ t _) = t + +instance Show Vivado where + show t = unpack $ toText t + +instance Synthesiser Vivado where + runSynth = runSynthVivado + synthOutput = vivadoOutput + setSynthOutput (Vivado a b _) = Vivado a b + +instance NFData Vivado where + rnf = rwhnf + +defaultVivado :: Vivado +defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" + +runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/VeriSmith/Sim/XST.hs b/src/VeriSmith/Sim/XST.hs new file mode 100644 index 0000000..30a4b0b --- /dev/null +++ b/src/VeriSmith/Sim/XST.hs @@ -0,0 +1,85 @@ +{-| +Module : VeriSmith.Sim.XST +Description : XST (ise) simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +XST (ise) simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module VeriSmith.Sim.XST + ( 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 Text.Shakespeare.Text (st) +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen + +data XST = XST { xstBin :: !(Maybe FilePath) + , xstDesc :: {-# UNPACK #-} !Text + , xstOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool XST where + toText (XST _ t _) = t + +instance Show XST where + show t = unpack $ toText t + +instance Synthesiser XST where + runSynth = runSynthXST + synthOutput = xstOutput + setSynthOutput (XST a b _) = XST a b + +instance NFData XST where + rnf = rwhnf + +defaultXST :: XST +defaultXST = XST Nothing "xst" "syn_xst.v" + +runSynthXST :: XST -> SourceInfo -> 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 [st|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" + prjFile = modFile <.> "prj" diff --git a/src/VeriSmith/Sim/Yosys.hs b/src/VeriSmith/Sim/Yosys.hs new file mode 100644 index 0000000..1f583a8 --- /dev/null +++ b/src/VeriSmith/Sim/Yosys.hs @@ -0,0 +1,127 @@ +{-| +Module : VeriSmith.Sim.Yosys +Description : Yosys simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Yosys simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module VeriSmith.Sim.Yosys + ( Yosys(..) + , defaultYosys + , runEquiv + , runEquivYosys + ) +where + +import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.Lens +import Control.Monad (void) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) +import Shelly +import Shelly.Lifted (liftSh) +import Text.Shakespeare.Text (st) +import VeriSmith.Result +import VeriSmith.Sim.Internal +import VeriSmith.Sim.Template +import VeriSmith.Verilog.AST +import VeriSmith.Verilog.CodeGen +import VeriSmith.Verilog.Mutate + +data Yosys = Yosys { yosysBin :: !(Maybe FilePath) + , yosysDesc :: {-# UNPACK #-} !Text + , yosysOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Yosys where + toText (Yosys _ t _) = t + +instance Show Yosys where + show t = unpack $ toText t + +instance Synthesiser Yosys where + runSynth = runSynthYosys + synthOutput = yosysOutput + setSynthOutput (Yosys a b _) = Yosys a b + +instance NFData Yosys where + rnf = rwhnf + +defaultYosys :: Yosys +defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" + +yosysPath :: Yosys -> FilePath +yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim + +runSynthYosys :: Yosys -> SourceInfo -> ResultSh () +runSynthYosys sim (SourceInfo _ src) = do + dir <- liftSh $ do + dir' <- pwd + 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 = toTextIgnore inpf + out = toTextIgnore $ synthOutput sim + +runEquivYosys + :: (Synthesiser a, Synthesiser b) + => Yosys + -> a + -> b + -> SourceInfo + -> ResultSh () +runEquivYosys yosys sim1 sim2 srcInfo = do + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTop 2 + $ srcInfo + ^. mainModule + writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo + runSynth sim1 srcInfo + runSynth sim2 srcInfo + liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] + where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] + +runEquiv + :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () +runEquiv sim1 sim2 srcInfo = do + dir <- liftSh pwd + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTopAssert + $ srcInfo + ^. mainModule + replaceMods (synthOutput sim1) "_1" srcInfo + replaceMods (synthOutput sim2) "_2" srcInfo + writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo + e <- liftSh $ do + exe dir "symbiyosys" "sby" ["-f", "proof.sby"] + lastExitCode + case e of + 0 -> ResultT . return $ Pass () + 2 -> ResultT . return $ Fail EquivFail + 124 -> ResultT . return $ Fail TimeoutError + _ -> ResultT . return $ Fail EquivError + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriSmith/Verilog.hs b/src/VeriSmith/Verilog.hs new file mode 100644 index 0000000..6e7851c --- /dev/null +++ b/src/VeriSmith/Verilog.hs @@ -0,0 +1,106 @@ +{-| +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 + ( SourceInfo(..) + , Verilog(..) + , parseVerilog + , GenVerilog(..) + , genSource + -- * Primitives + -- ** Identifier + , Identifier(..) + -- ** Control + , Delay(..) + , Event(..) + -- ** Operators + , BinaryOperator(..) + , UnaryOperator(..) + -- ** Task + , Task(..) + , taskName + , taskExpr + -- ** Left hand side value + , LVal(..) + , regId + , regExprId + , regExpr + , regSizeId + , regSizeRange + , regConc + -- ** Ports + , PortDir(..) + , PortType(..) + , Port(..) + , portType + , portSigned + , portSize + , portName + -- * Expression + , Expr(..) + , ConstExpr(..) + , constToExpr + , exprToConst + , constNum + -- * Assignment + , Assign(..) + , assignReg + , assignDelay + , assignExpr + , ContAssign(..) + , contAssignNetLVal + , contAssignExpr + -- * Statment + , 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 + -- * Useful Lenses and Traversals + , getModule + , getSourceId + -- * Quote + , verilog + ) +where + +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 new file mode 100644 index 0000000..78bad45 --- /dev/null +++ b/src/VeriSmith/Verilog/AST.hs @@ -0,0 +1,583 @@ +{-| +Module : VeriSmith.Verilog.AST +Description : Definition of the Verilog AST types. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module VeriSmith.Verilog.AST + ( -- * Top level types + SourceInfo(..) + , infoTop + , infoSrc + , Verilog(..) + -- * Primitives + -- ** Identifier + , Identifier(..) + -- ** Control + , Delay(..) + , Event(..) + -- ** Operators + , BinaryOperator(..) + , UnaryOperator(..) + -- ** Task + , Task(..) + , taskName + , taskExpr + -- ** Left hand side value + , LVal(..) + , regId + , regExprId + , regExpr + , regSizeId + , regSizeRange + , regConc + -- ** Ports + , 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 + -- * Assignment + , Assign(..) + , assignReg + , assignDelay + , assignExpr + , ContAssign(..) + , contAssignNetLVal + , contAssignExpr + -- ** Parameters + , Parameter(..) + , paramIdent + , paramValue + , LocalParam(..) + , localParamIdent + , localParamValue + -- * Statment + , Statement(..) + , statDelay + , statDStat + , statEvent + , statEStat + , statements + , stmntBA + , stmntNBA + , stmntTask + , stmntSysTask + , stmntCondExpr + , stmntCondTrue + , stmntCondFalse + , 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 + -- * Useful Lenses and Traversals + , aModule + , getModule + , getSourceId + , mainModule + ) +where + +import Control.DeepSeq (NFData) +import Control.Lens hiding ((<|)) +import Data.Data +import Data.Data.Lens +import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.String (IsString, fromString) +import Data.Text (Text, pack) +import Data.Traversable (sequenceA) +import GHC.Generics (Generic) +import VeriSmith.Verilog.BitVec + +-- | 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) + +instance IsString Identifier where + fromString = Identifier . pack + +instance Semigroup Identifier where + Identifier a <> Identifier b = Identifier $ a <> b + +instance Monoid Identifier where + mempty = Identifier mempty + +-- | Verilog syntax for adding a delay, which is represented as @#num@. +newtype Delay = Delay { _getDelay :: Int } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Num Delay where + Delay a + Delay b = Delay $ a + b + Delay a - Delay b = Delay $ a - b + Delay a * Delay b = Delay $ a * b + negate (Delay a) = Delay $ negate a + abs (Delay a) = Delay $ abs a + signum (Delay a) = Delay $ signum a + fromInteger = Delay . fromInteger + +-- | 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) + +instance Plated Event where + 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) + +-- | 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) + +-- | Verilog expression, which can either be a primary expression, unary +-- expression, binary operator expression or a conditional expression. +data Expr = Number {-# UNPACK #-} !BitVec + -- ^ Number implementation containing the size and the value itself + | Id {-# UNPACK #-} !Identifier + | VecSelect {-# UNPACK #-} !Identifier !Expr + | RangeSelect {-# UNPACK #-} !Identifier !Range + -- ^ Symbols + | Concat !(NonEmpty Expr) + -- ^ Bit-wise concatenation of expressions represented by braces. + | UnOp !UnaryOperator !Expr + | BinOp !Expr !BinaryOperator !Expr + | Cond !Expr !Expr !Expr + | Appl !Identifier !Expr + | Str {-# UNPACK #-} !Text + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Num Expr where + a + b = BinOp a BinPlus b + a - b = BinOp a BinMinus b + a * b = BinOp a BinTimes b + negate = UnOp UnMinus + abs = undefined + signum = undefined + fromInteger = Number . fromInteger + +instance Semigroup Expr where + (Concat a) <> (Concat b) = Concat $ a <> b + (Concat a) <> b = Concat $ a <> (b :| []) + a <> (Concat b) = Concat $ a <| b + a <> b = Concat $ a <| b :| [] + +instance Monoid Expr where + mempty = Number 0 + +instance IsString Expr where + fromString = Str . fromString + +instance Plated Expr where + plate = uniplate + +-- | 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) + +constToExpr :: ConstExpr -> Expr +constToExpr (ConstNum a ) = Number a +constToExpr (ParamId a ) = Id a +constToExpr (ConstConcat a ) = Concat $ fmap constToExpr a +constToExpr (ConstUnOp a b ) = UnOp a $ constToExpr b +constToExpr (ConstBinOp a b c) = BinOp (constToExpr a) b $ constToExpr c +constToExpr (ConstCond a b c) = + Cond (constToExpr a) (constToExpr b) $ constToExpr c +constToExpr (ConstStr a) = Str a + +exprToConst :: Expr -> ConstExpr +exprToConst (Number a ) = ConstNum a +exprToConst (Id a ) = ParamId a +exprToConst (Concat a ) = ConstConcat $ fmap exprToConst a +exprToConst (UnOp a b ) = ConstUnOp a $ exprToConst b +exprToConst (BinOp a b c) = ConstBinOp (exprToConst a) b $ exprToConst c +exprToConst (Cond a b c) = + ConstCond (exprToConst a) (exprToConst b) $ exprToConst c +exprToConst (Str a) = ConstStr a +exprToConst _ = error "Not a constant expression" + +instance Num ConstExpr where + a + b = ConstBinOp a BinPlus b + a - b = ConstBinOp a BinMinus b + a * b = ConstBinOp a BinTimes b + negate = ConstUnOp UnMinus + abs = undefined + signum = undefined + fromInteger = ConstNum . fromInteger + +instance Semigroup ConstExpr where + (ConstConcat a) <> (ConstConcat b) = ConstConcat $ a <> b + (ConstConcat a) <> b = ConstConcat $ a <> (b :| []) + a <> (ConstConcat b) = ConstConcat $ a <| b + a <> b = ConstConcat $ a <| b :| [] + +instance Monoid ConstExpr where + mempty = ConstNum 0 + +instance IsString ConstExpr where + fromString = ConstStr . fromString + +instance Plated ConstExpr where + plate = uniplate + +data Task = Task { _taskName :: {-# UNPACK #-} !Identifier + , _taskExpr :: [Expr] + } deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | Type that represents the left hand side of an assignment, which can be a +-- concatenation such as in: +-- +-- @ +-- {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) + +instance IsString LVal where + fromString = RegId . fromString + +-- | Different port direction that are supported in Verilog. +data PortDir = PortIn -- ^ Input direction for port (@input@). + | PortOut -- ^ Output direction for port (@output@). + | PortInOut -- ^ Inout direction for port (@inout@). + 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) + +-- | 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) + +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 + +-- | 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 +-- an input or output port. However, this is not always necessary and was more +-- cumbersome than useful, as a lot of ports can be declared without input and +-- output port. +-- +-- This is now implemented inside 'ModDecl' 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) + +-- | This is currently a type because direct module declaration should also be +-- added: +-- +-- @ +-- 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 ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier + , _contAssignExpr :: !Expr + } deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | Statements in Verilog. +data Statement = TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay + , _statDStat :: Maybe Statement + } -- ^ Time control (@#NUM@) + | EventCtrl { _statEvent :: !Event + , _statEStat :: Maybe Statement + } + | SeqBlock { _statements :: [Statement] } -- ^ Sequential block (@begin ... end@) + | BlockAssign { _stmntBA :: !Assign } -- ^ blocking assignment (@=@) + | NonBlockAssign { _stmntNBA :: !Assign } -- ^ Non blocking assignment (@<=@) + | TaskEnable { _stmntTask :: !Task } + | SysTaskEnable { _stmntSysTask :: !Task } + | CondStmnt { _stmntCondExpr :: Expr + , _stmntCondTrue :: Maybe Statement + , _stmntCondFalse :: Maybe Statement + } + | ForLoop { _forAssign :: !Assign + , _forExpr :: Expr + , _forIncr :: !Assign + , _forStmnt :: Statement + } -- ^ Loop bounds shall be statically computable for a for loop. + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Plated Statement where + plate = uniplate + +instance Semigroup Statement where + (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b + (SeqBlock a) <> b = SeqBlock $ a <> [b] + a <> (SeqBlock b) = SeqBlock $ a : b + a <> b = SeqBlock [a, b] + +instance Monoid Statement where + mempty = SeqBlock [] + +-- | 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) + +-- | 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) + +-- | Module item which is the body of the module expression. +data ModItem = ModCA { _modContAssign :: !ContAssign } + | ModInst { _modInstId :: {-# UNPACK #-} !Identifier + , _modInstName :: {-# UNPACK #-} !Identifier + , _modInstConns :: [ModConn] + } + | Initial !Statement + | Always !Statement + | Decl { _declDir :: !(Maybe PortDir) + , _declPort :: !Port + , _declVal :: Maybe ConstExpr + } + | ParamDecl { _paramDecl :: NonEmpty Parameter } + | LocalParamDecl { _localParamDecl :: NonEmpty LocalParam } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module' +data ModDecl = ModDecl { _modId :: {-# UNPACK #-} !Identifier + , _modOutPorts :: ![Port] + , _modInPorts :: ![Port] + , _modItems :: ![ModItem] + , _modParams :: ![Parameter] + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn +traverseModConn f (ModConn e ) = ModConn <$> f e +traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e + +traverseModItem :: (Applicative f) => (Expr -> f Expr) -> ModItem -> f ModItem +traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e +traverseModItem f (ModInst a b e) = + ModInst a b <$> sequenceA (traverseModConn f <$> e) +traverseModItem _ e = pure e + +-- | The complete sourcetext for the Verilog module. +newtype Verilog = Verilog { getVerilog :: [ModDecl] } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Semigroup Verilog where + Verilog a <> Verilog b = Verilog $ a <> b + +instance Monoid Verilog where + mempty = Verilog mempty + +data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text + , _infoSrc :: !Verilog + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Expr) +$(makeLenses ''ConstExpr) +$(makeLenses ''Task) +$(makeLenses ''LVal) +$(makeLenses ''PortType) +$(makeLenses ''Port) +$(makeLenses ''ModConn) +$(makeLenses ''Assign) +$(makeLenses ''ContAssign) +$(makeLenses ''Statement) +$(makeLenses ''ModItem) +$(makeLenses ''Parameter) +$(makeLenses ''LocalParam) +$(makeLenses ''ModDecl) +$(makeLenses ''SourceInfo) +$(makeWrapped ''Verilog) +$(makeWrapped ''Identifier) +$(makeWrapped ''Delay) +$(makePrisms ''ModItem) + +$(makeBaseFunctor ''Event) +$(makeBaseFunctor ''Expr) +$(makeBaseFunctor ''ConstExpr) + +getModule :: Traversal' Verilog ModDecl +getModule = _Wrapped . traverse +{-# INLINE getModule #-} + +getSourceId :: Traversal' Verilog Text +getSourceId = getModule . modId . _Wrapped +{-# INLINE getSourceId #-} + +-- | May need to change this to Traversal to be safe. For now it will fail when +-- the main has not been properly set with. +aModule :: Identifier -> Lens' SourceInfo ModDecl +aModule t = lens get_ set_ + where + set_ (SourceInfo top main) v = + SourceInfo top (main & getModule %~ update (getIdentifier t) v) + update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v + | otherwise = m + get_ (SourceInfo _ main) = + head . filter (f $ getIdentifier t) $ main ^.. getModule + f top (ModDecl (Identifier i) _ _ _ _) = i == top + + +-- | 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 ModDecl +mainModule = lens get_ set_ + where + set_ (SourceInfo top main) v = + SourceInfo top (main & getModule %~ update top v) + update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v + | otherwise = m + get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule + f top (ModDecl (Identifier i) _ _ _ _) = i == top diff --git a/src/VeriSmith/Verilog/BitVec.hs b/src/VeriSmith/Verilog/BitVec.hs new file mode 100644 index 0000000..dab9e2c --- /dev/null +++ b/src/VeriSmith/Verilog/BitVec.hs @@ -0,0 +1,119 @@ +{-| +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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +module VeriSmith.Verilog.BitVec + ( BitVecF(..) + , BitVec + , bitVec + , select + ) +where + +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) + +-- | 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 + +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 + +instance (Integral a, Bits a) => Real (BitVecF a) where + 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 + +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 + +instance (Num a, Bits a) => FiniteBits (BitVecF a) where + finiteBitSize (BitVec w _) = w + +instance Bits a => Semigroup (BitVecF a) where + (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) + +instance Bits a => Monoid (BitVecF a) where + 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 (BitVec _ v) (msb, lsb) = + 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 + 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 + where + 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 new file mode 100644 index 0000000..1e94472 --- /dev/null +++ b/src/VeriSmith/Verilog/CodeGen.hs @@ -0,0 +1,341 @@ +{-| +Module : VeriSmith.Verilog.CodeGen +Description : Code generation for Verilog AST. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 #-} + +module VeriSmith.Verilog.CodeGen + ( -- * 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 + +-- | '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 +-- can then be processed further. +class Source a where + genSource :: a -> Text + +-- | Map a 'Maybe Statement' to 'Text'. If it is 'Just statement', the generated +-- statements are returned. If it is 'Nothing', then @;\n@ is returned. +defMap :: Maybe Statement -> Doc a +defMap = maybe semi statement + +-- | Convert the 'Verilog' type to 'Text' so that it can be rendered. +verilogSrc :: Verilog -> Doc a +verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules + +-- | Generate the 'ModDecl' for a module and convert it to 'Text'. +moduleDecl :: ModDecl -> Doc a +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 + outIn = outP ++ inP + params [] = "" + params (p : pps) = hcat ["#", paramList (p :| pps)] + +-- | Generates a parameter list. Can only be called with a 'NonEmpty' list. +paramList :: NonEmpty Parameter -> Doc a +paramList ps = tupled . toList $ parameter <$> ps + +-- | Generates a localparam list. Can only be called with a 'NonEmpty' list. +localParamList :: NonEmpty LocalParam -> Doc a +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] + +-- | Generates the assignment for a 'LocalParam'. +localParam :: LocalParam -> Doc a +localParam (LocalParam name val) = + hsep ["localparameter", identifier name, "=", constExpr val] + +identifier :: Identifier -> Doc a +identifier (Identifier i) = pretty i + +-- | Conversts 'Port' to 'Text' for the module list, which means it only +-- generates a list of identifiers. +modPort :: Port -> Doc a +modPort (Port _ _ _ i) = identifier i + +-- | Generate the 'Port' description. +port :: Port -> Doc a +port (Port tp sgn r name) = hsep [t, sign, range r, identifier name] + where + t = pType tp + sign = signed sgn + +range :: Range -> Doc a +range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] + +signed :: Bool -> Doc a +signed True = "signed" +signed _ = mempty + +-- | Convert the 'PortDir' type to 'Text'. +portDir :: PortDir -> Doc a +portDir PortIn = "input" +portDir PortOut = "output" +portDir PortInOut = "inout" + +-- | Generate a 'ModItem'. +moduleItem :: ModItem -> Doc a +moduleItem (ModCA ca ) = contAssign ca +moduleItem (ModInst i name conn) = hsep + [ identifier i + , identifier name + , parens . hsep $ punctuate comma (mConn <$> conn) + , semi + ] +moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat] +moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat] +moduleItem (Decl dir p ini) = hsep + [maybe mempty makePort dir, port p, maybe mempty makeIni ini, semi] + where + makePort = portDir + makeIni = ("=" <+>) . constExpr +moduleItem (ParamDecl p) = hcat [paramList p, semi] +moduleItem (LocalParamDecl p) = hcat [localParamList p, semi] + +mConn :: ModConn -> Doc a +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) = + hsep ["assign", identifier val, "=", align $ expr e, semi] + +-- | 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 (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c) +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]] +expr (Appl f e) = hcat [identifier f, parens $ expr e] +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) "")] + where + minus | signum n >= 0 = mempty + | otherwise = "-" + +constExpr :: ConstExpr -> Doc a +constExpr (ConstNum b) = showNum b +constExpr (ParamId i) = identifier i +constExpr (ConstConcat 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] +constExpr (ConstCond l t 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 BinXNorInv = "~^" +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 UnNxorInv = "^~" + +event :: Event -> Doc a +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 (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] + +-- | Generates verilog code for a 'Delay'. +delay :: Delay -> Doc a +delay (Delay i) = "#" <> pretty i + +-- | Generate the verilog code for an 'LVal'. +lVal :: LVal -> Doc a +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" + +genAssign :: Text -> Assign -> Doc a +genAssign op (Assign r d e) = + hsep [lVal r, pretty op, maybe mempty delay d, expr e] + +statement :: Statement -> Doc a +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] +statement (NonBlockAssign a) = hcat [genAssign "<=" a, 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] +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 + [ hsep + [ "for" + , parens . hsep $ punctuate + semi + [genAssign "=" a, expr e, genAssign "=" incr] + ] + , indent 2 $ statement stmnt + ] + +task :: Task -> Doc a +task (Task i 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 () +render = print . genSource + +-- Instances + +instance Source Identifier where + genSource = showT . identifier + +instance Source Task where + genSource = showT . task + +instance Source Statement where + genSource = showT . statement + +instance Source PortType where + genSource = showT . pType + +instance Source ConstExpr where + genSource = showT . constExpr + +instance Source LVal where + genSource = showT . lVal + +instance Source Delay where + genSource = showT . delay + +instance Source Event where + genSource = showT . event + +instance Source UnaryOperator where + genSource = showT . unaryOp + +instance Source Expr where + genSource = showT . expr + +instance Source ContAssign where + genSource = showT . contAssign + +instance Source ModItem where + genSource = showT . moduleItem + +instance Source PortDir where + genSource = showT . portDir + +instance Source Port where + genSource = showT . port + +instance Source ModDecl where + genSource = showT . moduleDecl + +instance Source Verilog where + genSource = showT . verilogSrc + +instance Source SourceInfo where + genSource (SourceInfo _ src) = genSource src + +newtype GenVerilog a = GenVerilog { unGenVerilog :: a } + deriving (Eq, Ord, Data) + +instance (Source a) => Show (GenVerilog a) where + show = T.unpack . genSource . unGenVerilog diff --git a/src/VeriSmith/Verilog/Eval.hs b/src/VeriSmith/Verilog/Eval.hs new file mode 100644 index 0000000..1ebaa80 --- /dev/null +++ b/src/VeriSmith/Verilog/Eval.hs @@ -0,0 +1,119 @@ +{-| +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 + ) +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 + +type Bindings = [Parameter] + +paramIdent_ :: Parameter -> Identifier +paramIdent_ (Parameter i _) = i + +paramValue_ :: Parameter -> ConstExpr +paramValue_ (Parameter _ v) = v + +applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a +applyUnary UnPlus a = a +applyUnary UnMinus a = negate a +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 + +compXor :: Bits c => c -> c -> c +compXor a = complement . xor a + +toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p +toIntegral a b c = if a b c then 1 else 0 + +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 BinXNorInv = compXor +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 +evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b +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 (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c +applyBitVec f (ConstBinOp a binop 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 +applyBitVec _ a = a + +-- | This probably could be implemented using some recursion scheme in the +-- future. It would also be fixed by having a polymorphic expression type. +resize :: Int -> ConstExpr -> ConstExpr +resize n = applyBitVec (resize' n) where resize' n' (BitVec _ a) = BitVec n' a diff --git a/src/VeriSmith/Verilog/Internal.hs b/src/VeriSmith/Verilog/Internal.hs new file mode 100644 index 0000000..ed91b12 --- /dev/null +++ b/src/VeriSmith/Verilog/Internal.hs @@ -0,0 +1,93 @@ +{-| +Module : VeriSmith.Verilog.Internal +Description : Defaults and common functions. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +where + +import Control.Lens +import Data.Text (Text) +import VeriSmith.Verilog.AST + +regDecl :: Identifier -> ModItem +regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing + +wireDecl :: Identifier -> ModItem +wireDecl i = Decl Nothing (Port Wire False (Range 1 0) i) Nothing + +-- | Create an empty module. +emptyMod :: ModDecl +emptyMod = ModDecl "" [] [] [] [] + +-- | Set a module name for a module declaration. +setModName :: Text -> ModDecl -> ModDecl +setModName str = modId .~ Identifier str + +-- | Add a input port to the module declaration. +addModPort :: Port -> ModDecl -> ModDecl +addModPort port = modInPorts %~ (:) port + +addModDecl :: ModDecl -> Verilog -> Verilog +addModDecl desc = _Wrapped %~ (:) desc + +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 + ] + ] + [] + +addTestBench :: Verilog -> Verilog +addTestBench = addModDecl testBench + +defaultPort :: Identifier -> Port +defaultPort = Port Wire False (Range 1 0) + +portToExpr :: Port -> Expr +portToExpr (Port _ _ _ i) = Id i + +modName :: ModDecl -> Text +modName = getIdentifier . view modId + +yPort :: Identifier -> Port +yPort = Port Wire False (Range 90 0) + +wire :: Range -> Identifier -> Port +wire = Port Wire False + +reg :: Range -> Identifier -> Port +reg = Port Reg False diff --git a/src/VeriSmith/Verilog/Lex.x b/src/VeriSmith/Verilog/Lex.x new file mode 100644 index 0000000..3d1dd8d --- /dev/null +++ b/src/VeriSmith/Verilog/Lex.x @@ -0,0 +1,188 @@ +-- -*- haskell -*- +{ +{-# OPTIONS_GHC -w #-} +module VeriSmith.Verilog.Lex + ( alexScanTokens + ) where + +import VeriSmith.Verilog.Token + +} + +%wrapper "posn" + +-- Numbers + +$nonZeroDecimalDigit = [1-9] +$decimalDigit = [0-9] +@binaryDigit = [0-1] +@octalDigit = [0-7] +@hexDigit = [0-9a-fA-F] + +@decimalBase = "'" [dD] +@binaryBase = "'" [bB] +@octalBase = "'" [oO] +@hexBase = "'" [hH] + +@binaryValue = @binaryDigit ("_" | @binaryDigit)* +@octalValue = @octalDigit ("_" | @octalDigit)* +@hexValue = @hexDigit ("_" | @hexDigit)* + +@unsignedNumber = $decimalDigit ("_" | $decimalDigit)* + +@size = @unsignedNumber + +@decimalNumber + = @unsignedNumber + | @size? @decimalBase @unsignedNumber + +@binaryNumber = @size? @binaryBase @binaryValue +@octalNumber = @size? @octalBase @octalValue +@hexNumber = @size? @hexBase @hexValue + +-- $exp = [eE] +-- $sign = [\+\-] +-- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber +@number = @decimalNumber | @octalNumber | @binaryNumber | @hexNumber + +-- Strings + +@string = \" [^\r\n]* \" + +-- Identifiers + +@escapedIdentifier = "\" ($printable # $white)+ $white +@simpleIdentifier = [a-zA-Z_] [a-zA-Z0-9_\$]* +@systemIdentifier = "$" [a-zA-Z0-9_\$]+ + + +tokens :- + + "always" { tok KWAlways } + "assign" { tok KWAssign } + "begin" { tok KWBegin } + "case" { tok KWCase } + "default" { tok KWDefault } + "else" { tok KWElse } + "end" { tok KWEnd } + "endcase" { tok KWEndcase } + "endmodule" { tok KWEndmodule } + "for" { tok KWFor } + "if" { tok KWIf } + "initial" { tok KWInitial } + "inout" { tok KWInout } + "input" { tok KWInput } + "integer" { tok KWInteger } + "localparam" { tok KWLocalparam } + "module" { tok KWModule } + "negedge" { tok KWNegedge } + "or" { tok KWOr } + "output" { tok KWOutput } + "parameter" { tok KWParameter } + "posedge" { tok KWPosedge } + "reg" { tok KWReg } + "wire" { tok KWWire } + "signed" { tok KWSigned } + + @simpleIdentifier { tok IdSimple } + @escapedIdentifier { tok IdEscaped } + @systemIdentifier { tok IdSystem } + + @number { tok LitNumber } + @string { tok LitString } + + "(" { tok SymParenL } + ")" { tok SymParenR } + "[" { tok SymBrackL } + "]" { tok SymBrackR } + "{" { tok SymBraceL } + "}" { tok SymBraceR } + "~" { tok SymTildy } + "!" { tok SymBang } + "@" { tok SymAt } + "#" { tok SymPound } + "%" { tok SymPercent } + "^" { tok SymHat } + "&" { tok SymAmp } + "|" { tok SymBar } + "*" { tok SymAster } + "." { tok SymDot } + "," { tok SymComma } + ":" { tok SymColon } + ";" { tok SymSemi } + "=" { tok SymEq } + "<" { tok SymLt } + ">" { tok SymGt } + "+" { tok SymPlus } + "-" { tok SymDash } + "?" { tok SymQuestion } + "/" { tok SymSlash } + "$" { tok SymDollar } + "'" { tok SymSQuote } + + "~&" { tok SymTildyAmp } + "~|" { tok SymTildyBar } + "~^" { tok SymTildyHat } + "^~" { tok SymHatTildy } + "==" { tok SymEqEq } + "!=" { tok SymBangEq } + "&&" { tok SymAmpAmp } + "||" { tok SymBarBar } + "**" { tok SymAsterAster } + "<=" { tok SymLtEq } + ">=" { tok SymGtEq } + ">>" { tok SymGtGt } + "<<" { tok SymLtLt } + "++" { tok SymPlusPlus } + "--" { tok SymDashDash } + "+=" { tok SymPlusEq } + "-=" { tok SymDashEq } + "*=" { tok SymAsterEq } + "/=" { tok SymSlashEq } + "%=" { tok SymPercentEq } + "&=" { tok SymAmpEq } + "|=" { tok SymBarEq } + "^=" { tok SymHatEq } + "+:" { tok SymPlusColon } + "-:" { tok SymDashColon } + "::" { tok SymColonColon } + ".*" { tok SymDotAster } + "->" { tok SymDashGt } + ":=" { tok SymColonEq } + ":/" { tok SymColonSlash } + "##" { tok SymPoundPound } + "[*" { tok SymBrackLAster } + "[=" { tok SymBrackLEq } + "=>" { tok SymEqGt } + "@*" { tok SymAtAster } + "(*" { tok SymParenLAster } + "*)" { tok SymAsterParenR } + "*>" { tok SymAsterGt } + + "===" { tok SymEqEqEq } + "!==" { tok SymBangEqEq } + "=?=" { tok SymEqQuestionEq } + "!?=" { tok SymBangQuestionEq } + ">>>" { tok SymGtGtGt } + "<<<" { tok SymLtLtLt } + "<<=" { tok SymLtLtEq } + ">>=" { tok SymGtGtEq } + "|->" { tok SymBarDashGt } + "|=>" { tok SymBarEqGt } + "[->" { tok SymBrackLDashGt } + "@@(" { tok SymAtAtParenL } + "(*)" { tok SymParenLAsterParenR } + "->>" { tok SymDashGtGt } + "&&&" { tok SymAmpAmpAmp } + + "<<<=" { tok SymLtLtLtEq } + ">>>=" { tok SymGtGtGtEq } + + $white ; + + . { tok Unknown } + +{ +tok :: TokenName -> AlexPosn -> String -> Token +tok t (AlexPn _ l c) s = Token t s $ Position "" l c +} diff --git a/src/VeriSmith/Verilog/Mutate.hs b/src/VeriSmith/Verilog/Mutate.hs new file mode 100644 index 0000000..58675e3 --- /dev/null +++ b/src/VeriSmith/Verilog/Mutate.hs @@ -0,0 +1,401 @@ +{-| +Module : VeriSmith.Verilog.Mutate +Description : Functions to mutate the Verilog AST. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ( 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 + +class Mutate a where + mutExpr :: (Expr -> Expr) -> a -> a + +instance Mutate Identifier where + mutExpr _ = id + +instance Mutate Delay where + mutExpr _ = id + +instance Mutate Event where + mutExpr f (EExpr e) = EExpr $ f e + mutExpr _ a = a + +instance Mutate BinaryOperator where + mutExpr _ = id + +instance Mutate UnaryOperator where + mutExpr _ = id + +instance Mutate Expr where + mutExpr f = f + +instance Mutate ConstExpr where + mutExpr _ = id + +instance Mutate Task where + 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 + +instance Mutate PortDir where + mutExpr _ = id + +instance Mutate PortType where + mutExpr _ = id + +instance Mutate Range where + mutExpr _ = id + +instance Mutate Port where + mutExpr _ = id + +instance Mutate ModConn where + 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 + +instance Mutate ContAssign where + mutExpr f (ContAssign a e) = ContAssign a $ f e + +instance Mutate Statement 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 (mutExpr f a1) (f e) (mutExpr f a2) $ mutExpr f s + +instance Mutate Parameter where + mutExpr _ = id + +instance Mutate LocalParam where + mutExpr _ = id + +instance Mutate ModItem 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 _ d@Decl{} = d + mutExpr _ p@ParamDecl{} = p + mutExpr _ l@LocalParamDecl{} = l + +instance Mutate ModDecl 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) + +instance Mutate Verilog where + mutExpr f (Verilog a) = Verilog $ mutExpr f a + +instance Mutate SourceInfo where + mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b + +instance Mutate a => Mutate [a] where + mutExpr f a = mutExpr f <$> a + +instance Mutate a => Mutate (Maybe a) where + mutExpr f a = mutExpr f <$> a + +instance Mutate a => Mutate (GenVerilog a) where + mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a + +-- | Return if the 'Identifier' is in a 'ModDecl'. +inPort :: Identifier -> ModDecl -> Bool +inPort i m = inInput + where + inInput = + 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] -> Maybe Expr +findAssign i items = safe last . catMaybes $ isAssign <$> items + where + 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 _ _ e = e + +-- | Replaces the identifier recursively in an expression. +replace :: Identifier -> Expr -> Expr -> Expr +replace = (transform .) . idTrans + +-- | Nest expressions for a specific 'Identifier'. If the 'Identifier' is not +-- found, the AST is not changed. +-- +-- This could be improved by instead of only using the last assignment to the +-- wire that one finds, to use the assignment to the wire before the current +-- expression. This would require a different approach though. +nestId :: Identifier -> ModDecl -> ModDecl +nestId i 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 + +-- | Replaces an identifier by a expression in all the module declaration. +nestSource :: Identifier -> Verilog -> Verilog +nestSource i src = src & getModule %~ nestId i + +-- | Nest variables in the format @w[0-9]*@ up to a certain number. +nestUpTo :: Int -> Verilog -> Verilog +nestUpTo i src = + foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] + +allVars :: ModDecl -> [Identifier] +allVars m = + (m ^.. modOutPorts . traverse . portName) + <> (m ^.. modInPorts . traverse . portName) + +-- $setup +-- >>> import VeriSmith.Verilog.CodeGen +-- >>> let m = (ModDecl (Identifier "m") [Port Wire False 5 (Identifier "y")] [Port Wire False 5 "x"] [] []) +-- >>> let main = (ModDecl "main" [] [] [] []) + +-- | Add a Module Instantiation using 'ModInst' from the first module passed to +-- it to the body of the second module. It first has to make all the inputs into +-- @reg@. +-- +-- >>> render $ instantiateMod m main +-- module main; +-- wire [(3'h4):(1'h0)] y; +-- reg [(3'h4):(1'h0)] x; +-- m m1(y, x); +-- endmodule +-- +-- +instantiateMod :: ModDecl -> ModDecl -> ModDecl +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 + count = + length + . filter (== m ^. modId) + $ main + ^.. modItems + . traverse + . modInstId + conns = ModConn . Id <$> allVars m + +-- | Instantiate without adding wire declarations. It also does not count the +-- current instantiations of the same module. +-- +-- >>> GenVerilog $ instantiateMod_ m +-- m m(y, x); +-- +instantiateMod_ :: ModDecl -> ModItem +instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns + where + conns = + 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. +-- +-- >>> GenVerilog $ instantiateModSpec_ "_" m +-- m m(.y(y), .x(x)); +-- +instantiateModSpec_ :: Text -> ModDecl -> ModItem +instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns + where + 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) + +-- | Initialise all the inputs and outputs to a module. +-- +-- >>> GenVerilog $ initMod m +-- module m(y, x); +-- output wire [(3'h4):(1'h0)] y; +-- input wire [(3'h4):(1'h0)] x; +-- endmodule +-- +-- +initMod :: ModDecl -> ModDecl +initMod m = m & modItems %~ ((out ++ inp) ++) + where + out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing + inp = Decl (Just PortIn) <$> (m ^. modInPorts) <*> pure Nothing + +-- | Make an 'Identifier' from and existing Identifier and an object with a +-- 'Show' instance to make it unique. +makeIdFrom :: (Show a) => a -> Identifier -> Identifier +makeIdFrom a i = (i <>) . Identifier . ("_" <>) $ showT a + +-- | Make top level module for equivalence verification. Also takes in how many +-- modules to instantiate. +makeTop :: Int -> ModDecl -> ModDecl +makeTop i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] + where + ys = yPort . flip makeIdFrom "y" <$> [1 .. i] + modIt = instantiateModSpec_ "_" . modN <$> [1 .. i] + modN n = + 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 -> ModDecl +makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2 + where + 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 +-- registers, it should assign them to 0. +declareMod :: [Port] -> ModDecl -> ModDecl +declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) + where + decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0) + 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 +-- no more changes were made to the expression. +-- +-- >>> GenVerilog . simplify $ (Id "x") + 0 +-- x +-- +-- >>> 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 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 + +-- | 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 +-- simplified further. +-- +-- >>> GenVerilog . removeId ["x"] $ Id "x" + Id "y" +-- (x + (1'h0)) +removeId :: [Identifier] -> Expr -> Expr +removeId i = transform trans + where + trans (Id ident) | ident `notElem` i = Number 0 + | otherwise = Id ident + trans e = e + +combineAssigns :: Port -> [ModItem] -> [ModItem] +combineAssigns p a = + a + <> [ ModCA + . ContAssign (p ^. portName) + . UnOp UnXor + . fold + $ Id + <$> assigns + ] + where assigns = a ^.. traverse . modContAssign . contAssignNetLVal + +combineAssigns_ :: Bool -> Port -> [Port] -> ModItem +combineAssigns_ comb p ps = + 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 new file mode 100644 index 0000000..8d2b729 --- /dev/null +++ b/src/VeriSmith/Verilog/Parser.hs @@ -0,0 +1,511 @@ +{-| +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 + -- ** Internal parsers + , 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 + +type Parser = Parsec [Token] () + +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 + +-- | This parser succeeds whenever the given predicate returns true when called +-- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'. +satisfy :: (Token -> Bool) -> Parser TokenName +satisfy f = tokenPrim show nextPos tokeq + where + tokeq :: Token -> Maybe TokenName + tokeq t@(Token t' _ _) = if f t then Just t' else Nothing + +satisfy' :: (Token -> Maybe a) -> Parser a +satisfy' = tokenPrim show nextPos + +nextPos :: SourcePos -> Token -> [Token] -> SourcePos +nextPos pos _ (Token _ _ (Position _ l c) : _) = + setSourceColumn (setSourceLine pos l) c +nextPos pos _ [] = pos + +-- | Parses given `TokenName`. +tok :: TokenName -> Parser TokenName +tok t = satisfy (\(Token t' _ _) -> t' == t) show t + +-- | Parse without returning the `TokenName`. +tok' :: TokenName -> Parser () +tok' p = void $ tok p + +parens :: Parser a -> Parser a +parens = between (tok SymParenL) (tok SymParenR) + +brackets :: Parser a -> Parser a +brackets = between (tok SymBrackL) (tok SymBrackR) + +braces :: Parser a -> Parser a +braces = between (tok SymBraceL) (tok SymBraceR) + +sBinOp :: BinaryOperator -> Expr -> Expr -> Expr +sBinOp = sOp BinOp where sOp f b a = f a b + +parseExpr' :: Parser Expr +parseExpr' = buildExpressionParser parseTable parseTerm "expr" + +decToExpr :: Decimal -> Expr +decToExpr (Decimal s n) = Number $ bitVec s n + +-- | Parse a Number depending on if it is in a hex or decimal form. Octal and +-- binary are not supported yet. +parseNum :: Parser Expr +parseNum = decToExpr <$> number + +parseVar :: Parser Expr +parseVar = Id <$> identifier + +parseVecSelect :: Parser Expr +parseVecSelect = do + i <- identifier + expr <- brackets parseExpr + return $ VecSelect i expr + +parseRangeSelect :: Parser Expr +parseRangeSelect = do + i <- identifier + range <- parseRange + return $ RangeSelect i range + +systemFunc :: Parser String +systemFunc = satisfy' matchId + where + matchId (Token IdSystem s _) = Just s + matchId _ = Nothing + +parseFun :: Parser Expr +parseFun = do + 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." + +parseTerm :: Parser Expr +parseTerm = + 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 + +parseExpr :: Parser Expr +parseExpr = do + e <- parseExpr' + option e . try $ parseCond e + +parseConstExpr :: Parser ConstExpr +parseConstExpr = fmap exprToConst parseExpr + +-- | Table of binary and unary operators that encode the right precedence for +-- 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] + ] + +binary :: TokenName -> (a -> a -> a) -> Assoc -> ParseOperator a +binary name fun = Infix ((tok name "binary") >> return fun) + +prefix :: TokenName -> (a -> a) -> ParseOperator a +prefix name fun = Prefix ((tok name "prefix") >> return fun) + +commaSep :: Parser a -> Parser [a] +commaSep = flip sepBy $ tok SymComma + +parseContAssign :: Parser ContAssign +parseContAssign = do + 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 + +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 + 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' + +-- toInteger' :: Decimal -> Integer +-- toInteger' (Decimal _ n) = n + +toInt' :: Decimal -> Int +toInt' (Decimal _ n) = fromInteger n + +-- | Parse a range and return the total size. As it is inclusive, 1 has to be +-- added to the difference. +parseRange :: Parser Range +parseRange = do + 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 IdEscaped s _) = Just s + matchId _ = Nothing + +identifier :: Parser Identifier +identifier = Identifier . T.pack <$> strId + +parseNetDecl :: Maybe PortDir -> Parser ModItem +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 + +parsePortDir :: Parser PortDir +parsePortDir = + tok KWOutput + $> PortOut + <|> tok KWInput + $> PortIn + <|> tok KWInout + $> PortInOut + +parseDecl :: Parser ModItem +parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing + +parseConditional :: Parser Statement +parseConditional = do + 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)) + ex i = do + e <- tok' SymBrackL *> parseExpr + tok' SymBrackR + return $ RegExpr i e + sz i = RegSize i <$> parseRange + +parseDelay :: Parser Delay +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 + +parseLoop :: Parser Statement +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 + +eventList :: TokenName -> Parser [Event] +eventList t = do + 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)) + +parseEvent' :: Parser Event +parseEvent' = + try (tok' KWPosedge *> fmap EPosEdge identifier) + <|> try (tok' KWNegedge *> fmap ENegEdge identifier) + <|> try (fmap EId identifier) + <|> try (fmap EExpr parseExpr) + +parseEventCtrl :: Parser Statement +parseEventCtrl = do + event <- parseEvent + statement <- option Nothing maybeEmptyStatement + return $ EventCtrl event statement + +parseDelayCtrl :: Parser Statement +parseDelayCtrl = do + delay <- parseDelay + statement <- option Nothing maybeEmptyStatement + return $ TimeCtrl delay statement + +parseBlocking :: Parser Statement +parseBlocking = do + a <- parseAssign SymEq + tok' SymSemi + return $ BlockAssign a + +parseNonBlocking :: Parser Statement +parseNonBlocking = do + a <- parseAssign SymLtEq + tok' SymSemi + return $ NonBlockAssign a + +parseSeq :: Parser Statement +parseSeq = do + seq' <- tok' KWBegin *> many parseStatement + tok' KWEnd + return $ SeqBlock seq' + +parseStatement :: Parser Statement +parseStatement = + parseSeq + <|> parseConditional + <|> parseLoop + <|> parseEventCtrl + <|> parseDelayCtrl + <|> try parseBlocking + <|> parseNonBlocking + +maybeEmptyStatement :: Parser (Maybe Statement) +maybeEmptyStatement = + (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) + +parseAlways :: Parser ModItem +parseAlways = tok' KWAlways *> (Always <$> parseStatement) + +parseInitial :: Parser ModItem +parseInitial = tok' KWInitial *> (Initial <$> parseStatement) + +namedModConn :: Parser ModConn +namedModConn = do + target <- tok' SymDot *> identifier + expr <- parens parseExpr + return $ ModConnNamed target expr + +parseModConn :: Parser ModConn +parseModConn = try (fmap ModConn parseExpr) <|> namedModConn + +parseModInst :: Parser ModItem +parseModInst = do + m <- identifier + name <- identifier + modconns <- parens (commaSep parseModConn) + tok' SymSemi + return $ ModInst m name modconns + +parseModItem :: Parser ModItem +parseModItem = + try (ModCA <$> parseContAssign) + <|> try parseDecl + <|> parseAlways + <|> parseInitial + <|> parseModInst + +parseModList :: Parser [Identifier] +parseModList = list <|> return [] where list = parens $ commaSep identifier + +filterDecl :: PortDir -> ModItem -> Bool +filterDecl p (Decl (Just p') _ _) = p == p' +filterDecl _ _ = False + +modPorts :: PortDir -> [ModItem] -> [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 + +parseParams :: Parser [Parameter] +parseParams = tok' SymPound *> parens (commaSep parseParam) + +parseModDecl :: Parser ModDecl +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 + +-- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace +-- and then parsing multiple Verilog source. +parseVerilogSrc :: Parser Verilog +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 -- ^ Returns 'String' with error + -- message if parse fails. +parseVerilog s = + bimap showT id + . parse parseVerilogSrc (T.unpack s) + . alexScanTokens + . preprocess [] (T.unpack s) + . T.unpack + +parseVerilogFile :: Text -> IO Verilog +parseVerilogFile file = do + 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 +parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile diff --git a/src/VeriSmith/Verilog/Preprocess.hs b/src/VeriSmith/Verilog/Preprocess.hs new file mode 100644 index 0000000..c30252b --- /dev/null +++ b/src/VeriSmith/Verilog/Preprocess.hs @@ -0,0 +1,111 @@ +{-| +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 + ) +where + +-- | Remove comments from code. There is no difference between @(* *)@ and +-- @/* */@, therefore in this implementation, @*/@ could close @(*@ and vice-versa, +-- This will be fixed in an upcoming version. +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 + + removeEOL a = case a of + "" -> "" + '\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 + + 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 + + ignoreString a = case a of + "" -> 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 + where + pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String] + 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 + +ppLine :: [(String, String)] -> String -> String +ppLine _ "" = "" +ppLine env ('`' : a) = case lookup name env of + Just value -> value ++ ppLine env rest + Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env + where + name = takeWhile + (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) + a + rest = drop (length name) a +ppLine env (a : b) = a : ppLine env b diff --git a/src/VeriSmith/Verilog/Quote.hs b/src/VeriSmith/Verilog/Quote.hs new file mode 100644 index 0000000..3815fe6 --- /dev/null +++ b/src/VeriSmith/Verilog/Quote.hs @@ -0,0 +1,50 @@ +{-| +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 + ( 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 + +liftDataWithText :: Data a => a -> Q Exp +liftDataWithText = dataToExpQ $ fmap liftText . cast + +liftText :: T.Text -> Q Exp +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 + } + +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 diff --git a/src/VeriSmith/Verilog/Token.hs b/src/VeriSmith/Verilog/Token.hs new file mode 100644 index 0000000..590672e --- /dev/null +++ b/src/VeriSmith/Verilog/Token.hs @@ -0,0 +1,350 @@ +{-| +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 + ) +where + +import Text.Printf + +tokenString :: Token -> String +tokenString (Token _ s _) = s + +data Position = Position String Int Int deriving Eq + +instance Show Position where + show (Position f l c) = printf "%s:%d:%d" f l c + +data Token = Token TokenName String Position deriving (Show, Eq) + +data TokenName + = KWAlias + | KWAlways + | KWAlwaysComb + | KWAlwaysFf + | KWAlwaysLatch + | KWAnd + | KWAssert + | KWAssign + | KWAssume + | KWAutomatic + | KWBefore + | KWBegin + | KWBind + | KWBins + | KWBinsof + | KWBit + | KWBreak + | KWBuf + | KWBufif0 + | KWBufif1 + | KWByte + | KWCase + | KWCasex + | KWCasez + | KWCell + | KWChandle + | KWClass + | KWClocking + | KWCmos + | KWConfig + | KWConst + | KWConstraint + | KWContext + | KWContinue + | KWCover + | KWCovergroup + | KWCoverpoint + | KWCross + | KWDeassign + | KWDefault + | KWDefparam + | KWDesign + | KWDisable + | KWDist + | KWDo + | KWEdge + | KWElse + | KWEnd + | KWEndcase + | KWEndclass + | KWEndclocking + | KWEndconfig + | KWEndfunction + | KWEndgenerate + | KWEndgroup + | KWEndinterface + | KWEndmodule + | KWEndpackage + | KWEndprimitive + | KWEndprogram + | KWEndproperty + | KWEndspecify + | KWEndsequence + | KWEndtable + | KWEndtask + | KWEnum + | KWEvent + | KWExpect + | KWExport + | KWExtends + | KWExtern + | KWFinal + | KWFirstMatch + | KWFor + | KWForce + | KWForeach + | KWForever + | KWFork + | KWForkjoin + | KWFunction + | KWFunctionPrototype + | KWGenerate + | KWGenvar + | KWHighz0 + | KWHighz1 + | KWIf + | KWIff + | KWIfnone + | KWIgnoreBins + | KWIllegalBins + | KWImport + | KWIncdir + | KWInclude + | KWInitial + | KWInout + | KWInput + | KWInside + | KWInstance + | KWInt + | KWInteger + | KWInterface + | KWIntersect + | KWJoin + | KWJoinAny + | KWJoinNone + | KWLarge + | KWLiblist + | KWLibrary + | KWLocal + | KWLocalparam + | KWLogic + | KWLongint + | KWMacromodule + | KWMatches + | KWMedium + | KWModport + | KWModule + | KWNand + | KWNegedge + | KWNew + | KWNmos + | KWNor + | KWNoshowcancelled + | KWNot + | KWNotif0 + | KWNotif1 + | KWNull + | KWOption + | KWOr + | KWOutput + | KWPackage + | KWPacked + | KWParameter + | KWPathpulseDollar + | KWPmos + | KWPosedge + | KWPrimitive + | KWPriority + | KWProgram + | KWProperty + | KWProtected + | KWPull0 + | KWPull1 + | KWPulldown + | KWPullup + | KWPulsestyleOnevent + | KWPulsestyleOndetect + | KWPure + | KWRand + | KWRandc + | KWRandcase + | KWRandsequence + | KWRcmos + | KWReal + | KWRealtime + | KWRef + | KWReg + | KWRelease + | KWRepeat + | KWReturn + | KWRnmos + | KWRpmos + | KWRtran + | KWRtranif0 + | KWRtranif1 + | KWScalared + | KWSequence + | KWShortint + | KWShortreal + | KWShowcancelled + | KWSigned + | KWSmall + | KWSolve + | KWSpecify + | KWSpecparam + | KWStatic + | KWStrength0 + | KWStrength1 + | KWString + | KWStrong0 + | KWStrong1 + | KWStruct + | KWSuper + | KWSupply0 + | KWSupply1 + | KWTable + | KWTagged + | KWTask + | KWThis + | KWThroughout + | KWTime + | KWTimeprecision + | KWTimeunit + | KWTran + | KWTranif0 + | KWTranif1 + | KWTri + | KWTri0 + | KWTri1 + | KWTriand + | KWTrior + | KWTrireg + | KWType + | KWTypedef + | KWTypeOption + | KWUnion + | KWUnique + | KWUnsigned + | KWUse + | KWVar + | KWVectored + | KWVirtual + | KWVoid + | KWWait + | KWWaitOrder + | KWWand + | KWWeak0 + | KWWeak1 + | KWWhile + | KWWildcard + | KWWire + | KWWith + | KWWithin + | KWWor + | KWXnor + | KWXor + | IdSimple + | IdEscaped + | IdSystem + | LitNumberUnsigned + | LitNumber + | LitString + | SymParenL + | SymParenR + | SymBrackL + | SymBrackR + | SymBraceL + | SymBraceR + | SymTildy + | SymBang + | SymAt + | SymPound + | SymPercent + | SymHat + | SymAmp + | SymBar + | SymAster + | SymDot + | SymComma + | SymColon + | SymSemi + | SymEq + | SymLt + | SymGt + | SymPlus + | SymDash + | SymQuestion + | SymSlash + | SymDollar + | SymSQuote + | SymTildyAmp + | SymTildyBar + | SymTildyHat + | SymHatTildy + | SymEqEq + | SymBangEq + | SymAmpAmp + | SymBarBar + | SymAsterAster + | SymLtEq + | SymGtEq + | SymGtGt + | SymLtLt + | SymPlusPlus + | SymDashDash + | SymPlusEq + | SymDashEq + | SymAsterEq + | SymSlashEq + | SymPercentEq + | SymAmpEq + | SymBarEq + | SymHatEq + | SymPlusColon + | SymDashColon + | SymColonColon + | SymDotAster + | SymDashGt + | SymColonEq + | SymColonSlash + | SymPoundPound + | SymBrackLAster + | SymBrackLEq + | SymEqGt + | SymAtAster + | SymParenLAster + | SymAsterParenR + | SymAsterGt + | SymEqEqEq + | SymBangEqEq + | SymEqQuestionEq + | SymBangQuestionEq + | SymGtGtGt + | SymLtLtLt + | SymLtLtEq + | SymGtGtEq + | SymBarDashGt + | SymBarEqGt + | SymBrackLDashGt + | SymAtAtParenL + | SymParenLAsterParenR + | SymDashGtGt + | SymAmpAmpAmp + | SymLtLtLtEq + | SymGtGtGtEq + | Unknown + deriving (Show, Eq) -- cgit From af0c7f5b8d574fc331fc9d5e56cc0a7a6c121abc Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Wed, 4 Sep 2019 20:17:41 +1000 Subject: Rename cabal file to fix nix --- verifuzz.cabal | 155 -------------------------------------------------------- verismith.cabal | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 155 insertions(+), 155 deletions(-) delete mode 100644 verifuzz.cabal create mode 100644 verismith.cabal diff --git a/verifuzz.cabal b/verifuzz.cabal deleted file mode 100644 index ef27082..0000000 --- a/verifuzz.cabal +++ /dev/null @@ -1,155 +0,0 @@ -name: verismith -version: 0.3.1.0 -synopsis: Random verilog generation and simulator testing. -description: - VeriSmith provides random verilog generation modules - implementing functions to test supported simulators. -homepage: https://github.com/ymherklotz/VeriSmith#readme -license: BSD3 -license-file: LICENSE -author: Yann Herklotz -maintainer: yann [at] yannherklotz [dot] com -copyright: 2018-2019 Yann Herklotz -category: Web -build-type: Custom -cabal-version: >=1.10 -extra-source-files: README.md - , data/*.v - -custom-setup - setup-depends: - base >= 4 && <5, - cabal-doctest >= 1 && <1.1, - Cabal >= 1.10 && <2.5 - -library - hs-source-dirs: src - default-language: Haskell2010 - build-tools: alex >=3 && <4 - other-modules: Paths_verismith - exposed-modules: VeriSmith - , VeriSmith.Circuit - , VeriSmith.Circuit.Base - , VeriSmith.Circuit.Gen - , VeriSmith.Circuit.Internal - , VeriSmith.Circuit.Random - , VeriSmith.Config - , VeriSmith.Fuzz - , VeriSmith.Generate - , VeriSmith.Internal - , VeriSmith.Reduce - , VeriSmith.Report - , VeriSmith.Result - , VeriSmith.Sim - , VeriSmith.Sim.Icarus - , VeriSmith.Sim.Identity - , VeriSmith.Sim.Internal - , VeriSmith.Sim.Quartus - , VeriSmith.Sim.Template - , VeriSmith.Sim.Vivado - , VeriSmith.Sim.XST - , VeriSmith.Sim.Yosys - , VeriSmith.Verilog - , VeriSmith.Verilog.AST - , VeriSmith.Verilog.BitVec - , VeriSmith.Verilog.CodeGen - , VeriSmith.Verilog.Eval - , VeriSmith.Verilog.Internal - , VeriSmith.Verilog.Lex - , VeriSmith.Verilog.Mutate - , VeriSmith.Verilog.Parser - , VeriSmith.Verilog.Preprocess - , VeriSmith.Verilog.Quote - , VeriSmith.Verilog.Token - build-depends: base >=4.7 && <5 - -- Cannot upgrade to 1.0 because of missing MonadGen instance for - -- StateT. - , hedgehog >= 0.5.3 && <0.7 - , fgl >=5.6 && <5.8 - , fgl-visualize >=0.1 && <0.2 - , lens >=4.16.1 && <4.18 - , random >=1.1 && <1.2 - , shakespeare >=2 && <2.1 - , shelly >=1.8.0 && <1.9 - , text >=1.2 && <1.3 - , bytestring >=0.10 && <0.11 - , filepath >=1.4.2 && <1.5 - , binary >= 0.8.5.1 && <0.9 - , cryptonite >=0.25 && <0.26 - , memory >=0.14 && <0.15 - , DRBG >=0.5 && <0.6 - , parsec >=3.1 && <3.2 - , transformers >=0.5 && <0.6 - , transformers-base >=0.4.5 && <0.5 - , tomland >=1.0 && <1.2 - , prettyprinter >=1.2.0.1 && <1.3 - , array >=0.5 && <0.6 - , recursion-schemes >=5.0.2 && <5.2 - , time >= 1.8.0.2 && <1.9 - , lifted-base >=0.2.3 && <0.3 - , monad-control >=1.0.2 && <1.1 - , gitrev >= 1.3.1 && <1.4 - , deepseq >= 1.4.3.0 && <1.5 - , template-haskell >=2.13.0 && <2.15 - , optparse-applicative >=0.14 && <0.15 - , exceptions >=0.10.0 && <0.11 - , blaze-html >=0.9.0.1 && <0.10 - , statistics >=0.14.0.2 && <0.16 - , vector >=0.12.0.1 && <0.13 - , unordered-containers >=0.2.10 && <0.3 - default-extensions: OverloadedStrings - -executable verismith - hs-source-dirs: app - main-is: Main.hs - default-language: Haskell2010 - ghc-options: -threaded - build-depends: base >= 4.7 && < 5 - , verismith - default-extensions: OverloadedStrings - -benchmark benchmark - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Benchmark.hs - build-depends: base >=4 && <5 - , verismith - , criterion >=1.5.5 && <1.6 - , lens >=4.16.1 && <4.18 - default-extensions: OverloadedStrings - -test-suite test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Test.hs - other-modules: Unit - , Property - , Reduce - , Parser - build-depends: base >=4 && <5 - , verismith - , fgl >=5.6 && <5.8 - , tasty >=1.0.1.1 && <1.3 - , tasty-hunit >=0.10 && <0.11 - , tasty-hedgehog >=0.2 && <0.3 - , hedgehog >=0.5.3 && <0.7 - , hedgehog-fn >=0.5 && <0.7 - , lens >=4.16.1 && <4.18 - , shakespeare >=2 && <2.1 - , text >=1.2 && <1.3 - , parsec >= 3.1 && < 3.2 - default-extensions: OverloadedStrings - ---test-suite doctest --- default-language: Haskell2010 --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: Doctest.hs --- other-modules: Build_doctests --- build-depends: base >=4.7 && <5 --- , doctest >=0.16 && <0.17 --- , Glob >=0.9.3 && <0.11 --- , verismith --- default-extensions: OverloadedStrings diff --git a/verismith.cabal b/verismith.cabal new file mode 100644 index 0000000..ef27082 --- /dev/null +++ b/verismith.cabal @@ -0,0 +1,155 @@ +name: verismith +version: 0.3.1.0 +synopsis: Random verilog generation and simulator testing. +description: + VeriSmith provides random verilog generation modules + implementing functions to test supported simulators. +homepage: https://github.com/ymherklotz/VeriSmith#readme +license: BSD3 +license-file: LICENSE +author: Yann Herklotz +maintainer: yann [at] yannherklotz [dot] com +copyright: 2018-2019 Yann Herklotz +category: Web +build-type: Custom +cabal-version: >=1.10 +extra-source-files: README.md + , data/*.v + +custom-setup + setup-depends: + base >= 4 && <5, + cabal-doctest >= 1 && <1.1, + Cabal >= 1.10 && <2.5 + +library + hs-source-dirs: src + default-language: Haskell2010 + build-tools: alex >=3 && <4 + other-modules: Paths_verismith + exposed-modules: VeriSmith + , VeriSmith.Circuit + , VeriSmith.Circuit.Base + , VeriSmith.Circuit.Gen + , VeriSmith.Circuit.Internal + , VeriSmith.Circuit.Random + , VeriSmith.Config + , VeriSmith.Fuzz + , VeriSmith.Generate + , VeriSmith.Internal + , VeriSmith.Reduce + , VeriSmith.Report + , VeriSmith.Result + , VeriSmith.Sim + , VeriSmith.Sim.Icarus + , VeriSmith.Sim.Identity + , VeriSmith.Sim.Internal + , VeriSmith.Sim.Quartus + , VeriSmith.Sim.Template + , VeriSmith.Sim.Vivado + , VeriSmith.Sim.XST + , VeriSmith.Sim.Yosys + , VeriSmith.Verilog + , VeriSmith.Verilog.AST + , VeriSmith.Verilog.BitVec + , VeriSmith.Verilog.CodeGen + , VeriSmith.Verilog.Eval + , VeriSmith.Verilog.Internal + , VeriSmith.Verilog.Lex + , VeriSmith.Verilog.Mutate + , VeriSmith.Verilog.Parser + , VeriSmith.Verilog.Preprocess + , VeriSmith.Verilog.Quote + , VeriSmith.Verilog.Token + build-depends: base >=4.7 && <5 + -- Cannot upgrade to 1.0 because of missing MonadGen instance for + -- StateT. + , hedgehog >= 0.5.3 && <0.7 + , fgl >=5.6 && <5.8 + , fgl-visualize >=0.1 && <0.2 + , lens >=4.16.1 && <4.18 + , random >=1.1 && <1.2 + , shakespeare >=2 && <2.1 + , shelly >=1.8.0 && <1.9 + , text >=1.2 && <1.3 + , bytestring >=0.10 && <0.11 + , filepath >=1.4.2 && <1.5 + , binary >= 0.8.5.1 && <0.9 + , cryptonite >=0.25 && <0.26 + , memory >=0.14 && <0.15 + , DRBG >=0.5 && <0.6 + , parsec >=3.1 && <3.2 + , transformers >=0.5 && <0.6 + , transformers-base >=0.4.5 && <0.5 + , tomland >=1.0 && <1.2 + , prettyprinter >=1.2.0.1 && <1.3 + , array >=0.5 && <0.6 + , recursion-schemes >=5.0.2 && <5.2 + , time >= 1.8.0.2 && <1.9 + , lifted-base >=0.2.3 && <0.3 + , monad-control >=1.0.2 && <1.1 + , gitrev >= 1.3.1 && <1.4 + , deepseq >= 1.4.3.0 && <1.5 + , template-haskell >=2.13.0 && <2.15 + , optparse-applicative >=0.14 && <0.15 + , exceptions >=0.10.0 && <0.11 + , blaze-html >=0.9.0.1 && <0.10 + , statistics >=0.14.0.2 && <0.16 + , vector >=0.12.0.1 && <0.13 + , unordered-containers >=0.2.10 && <0.3 + default-extensions: OverloadedStrings + +executable verismith + hs-source-dirs: app + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -threaded + build-depends: base >= 4.7 && < 5 + , verismith + default-extensions: OverloadedStrings + +benchmark benchmark + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Benchmark.hs + build-depends: base >=4 && <5 + , verismith + , criterion >=1.5.5 && <1.6 + , lens >=4.16.1 && <4.18 + default-extensions: OverloadedStrings + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + other-modules: Unit + , Property + , Reduce + , Parser + build-depends: base >=4 && <5 + , verismith + , fgl >=5.6 && <5.8 + , tasty >=1.0.1.1 && <1.3 + , tasty-hunit >=0.10 && <0.11 + , tasty-hedgehog >=0.2 && <0.3 + , hedgehog >=0.5.3 && <0.7 + , hedgehog-fn >=0.5 && <0.7 + , lens >=4.16.1 && <4.18 + , shakespeare >=2 && <2.1 + , text >=1.2 && <1.3 + , parsec >= 3.1 && < 3.2 + default-extensions: OverloadedStrings + +--test-suite doctest +-- default-language: Haskell2010 +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Doctest.hs +-- other-modules: Build_doctests +-- build-depends: base >=4.7 && <5 +-- , doctest >=0.16 && <0.17 +-- , Glob >=0.9.3 && <0.11 +-- , verismith +-- default-extensions: OverloadedStrings -- cgit From d14196cce14d1b4a4a9fba768b9f5238c8626624 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 6 Sep 2019 19:12:58 +0200 Subject: Small changes to .cabal --- verismith.cabal | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/verismith.cabal b/verismith.cabal index ef27082..c4f74fa 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -4,17 +4,22 @@ synopsis: Random verilog generation and simulator testing. description: VeriSmith provides random verilog generation modules implementing functions to test supported simulators. -homepage: https://github.com/ymherklotz/VeriSmith#readme +homepage: https://github.com/ymherklotz/verismith#readme license: BSD3 license-file: LICENSE author: Yann Herklotz maintainer: yann [at] yannherklotz [dot] com copyright: 2018-2019 Yann Herklotz -category: Web +category: Hardware build-type: Custom cabal-version: >=1.10 extra-source-files: README.md , data/*.v + , examples/*.v + , examples/config.toml + , nix/*.nix + , scripts/*.py + , scripts/*.sh custom-setup setup-depends: -- cgit From 8d96fd2a541a2602544ced741552ebd17714c67d Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Wed, 18 Sep 2019 19:06:32 +0200 Subject: Rename main modules --- app/Main.hs | 2 +- default.nix | 26 +- scripts/setup.sh | 6 +- src/VeriSmith.hs | 553 -------------------------------- src/VeriSmith/Circuit.hs | 45 --- src/VeriSmith/Circuit/Base.hs | 44 --- src/VeriSmith/Circuit/Gen.hs | 79 ----- src/VeriSmith/Circuit/Internal.hs | 55 ---- src/VeriSmith/Circuit/Random.hs | 67 ---- src/VeriSmith/Config.hs | 496 ---------------------------- src/VeriSmith/Fuzz.hs | 466 --------------------------- src/VeriSmith/Generate.hs | 623 ------------------------------------ src/VeriSmith/Internal.hs | 49 --- src/VeriSmith/Reduce.hs | 609 ----------------------------------- src/VeriSmith/Report.hs | 398 ----------------------- src/VeriSmith/Result.hs | 137 -------- src/VeriSmith/Sim.hs | 51 --- src/VeriSmith/Sim/Icarus.hs | 188 ----------- src/VeriSmith/Sim/Identity.hs | 51 --- src/VeriSmith/Sim/Internal.hs | 215 ------------- src/VeriSmith/Sim/Quartus.hs | 77 ----- src/VeriSmith/Sim/Template.hs | 133 -------- src/VeriSmith/Sim/Vivado.hs | 71 ---- src/VeriSmith/Sim/XST.hs | 85 ----- src/VeriSmith/Sim/Yosys.hs | 127 -------- src/VeriSmith/Verilog.hs | 106 ------ src/VeriSmith/Verilog/AST.hs | 583 --------------------------------- src/VeriSmith/Verilog/BitVec.hs | 119 ------- src/VeriSmith/Verilog/CodeGen.hs | 341 -------------------- src/VeriSmith/Verilog/Eval.hs | 119 ------- src/VeriSmith/Verilog/Internal.hs | 93 ------ src/VeriSmith/Verilog/Lex.x | 188 ----------- src/VeriSmith/Verilog/Mutate.hs | 401 ----------------------- src/VeriSmith/Verilog/Parser.hs | 511 ----------------------------- src/VeriSmith/Verilog/Preprocess.hs | 111 ------- src/VeriSmith/Verilog/Quote.hs | 50 --- src/VeriSmith/Verilog/Token.hs | 350 -------------------- src/Verismith.hs | 553 ++++++++++++++++++++++++++++++++ src/Verismith/Circuit.hs | 45 +++ src/Verismith/Circuit/Base.hs | 44 +++ src/Verismith/Circuit/Gen.hs | 79 +++++ src/Verismith/Circuit/Internal.hs | 55 ++++ src/Verismith/Circuit/Random.hs | 67 ++++ src/Verismith/Config.hs | 496 ++++++++++++++++++++++++++++ src/Verismith/Fuzz.hs | 466 +++++++++++++++++++++++++++ src/Verismith/Generate.hs | 623 ++++++++++++++++++++++++++++++++++++ src/Verismith/Internal.hs | 49 +++ src/Verismith/Reduce.hs | 609 +++++++++++++++++++++++++++++++++++ src/Verismith/Report.hs | 398 +++++++++++++++++++++++ src/Verismith/Result.hs | 137 ++++++++ src/Verismith/Sim.hs | 51 +++ src/Verismith/Sim/Icarus.hs | 188 +++++++++++ src/Verismith/Sim/Identity.hs | 51 +++ src/Verismith/Sim/Internal.hs | 215 +++++++++++++ src/Verismith/Sim/Quartus.hs | 77 +++++ src/Verismith/Sim/Template.hs | 133 ++++++++ src/Verismith/Sim/Vivado.hs | 71 ++++ src/Verismith/Sim/XST.hs | 85 +++++ src/Verismith/Sim/Yosys.hs | 127 ++++++++ src/Verismith/Verilog.hs | 106 ++++++ src/Verismith/Verilog/AST.hs | 583 +++++++++++++++++++++++++++++++++ src/Verismith/Verilog/BitVec.hs | 119 +++++++ src/Verismith/Verilog/CodeGen.hs | 341 ++++++++++++++++++++ src/Verismith/Verilog/Eval.hs | 119 +++++++ src/Verismith/Verilog/Internal.hs | 93 ++++++ src/Verismith/Verilog/Lex.x | 188 +++++++++++ src/Verismith/Verilog/Mutate.hs | 401 +++++++++++++++++++++++ src/Verismith/Verilog/Parser.hs | 511 +++++++++++++++++++++++++++++ src/Verismith/Verilog/Preprocess.hs | 111 +++++++ src/Verismith/Verilog/Quote.hs | 50 +++ src/Verismith/Verilog/Token.hs | 350 ++++++++++++++++++++ test/Benchmark.hs | 2 +- test/Parser.hs | 8 +- test/Property.hs | 8 +- test/Reduce.hs | 4 +- test/Unit.hs | 2 +- verismith.cabal | 70 ++-- 77 files changed, 7663 insertions(+), 7647 deletions(-) delete mode 100644 src/VeriSmith.hs delete mode 100644 src/VeriSmith/Circuit.hs delete mode 100644 src/VeriSmith/Circuit/Base.hs delete mode 100644 src/VeriSmith/Circuit/Gen.hs delete mode 100644 src/VeriSmith/Circuit/Internal.hs delete mode 100644 src/VeriSmith/Circuit/Random.hs delete mode 100644 src/VeriSmith/Config.hs delete mode 100644 src/VeriSmith/Fuzz.hs delete mode 100644 src/VeriSmith/Generate.hs delete mode 100644 src/VeriSmith/Internal.hs delete mode 100644 src/VeriSmith/Reduce.hs delete mode 100644 src/VeriSmith/Report.hs delete mode 100644 src/VeriSmith/Result.hs delete mode 100644 src/VeriSmith/Sim.hs delete mode 100644 src/VeriSmith/Sim/Icarus.hs delete mode 100644 src/VeriSmith/Sim/Identity.hs delete mode 100644 src/VeriSmith/Sim/Internal.hs delete mode 100644 src/VeriSmith/Sim/Quartus.hs delete mode 100644 src/VeriSmith/Sim/Template.hs delete mode 100644 src/VeriSmith/Sim/Vivado.hs delete mode 100644 src/VeriSmith/Sim/XST.hs delete mode 100644 src/VeriSmith/Sim/Yosys.hs delete mode 100644 src/VeriSmith/Verilog.hs delete mode 100644 src/VeriSmith/Verilog/AST.hs delete mode 100644 src/VeriSmith/Verilog/BitVec.hs delete mode 100644 src/VeriSmith/Verilog/CodeGen.hs delete mode 100644 src/VeriSmith/Verilog/Eval.hs delete mode 100644 src/VeriSmith/Verilog/Internal.hs delete mode 100644 src/VeriSmith/Verilog/Lex.x delete mode 100644 src/VeriSmith/Verilog/Mutate.hs delete mode 100644 src/VeriSmith/Verilog/Parser.hs delete mode 100644 src/VeriSmith/Verilog/Preprocess.hs delete mode 100644 src/VeriSmith/Verilog/Quote.hs delete mode 100644 src/VeriSmith/Verilog/Token.hs create mode 100644 src/Verismith.hs create mode 100644 src/Verismith/Circuit.hs create mode 100644 src/Verismith/Circuit/Base.hs create mode 100644 src/Verismith/Circuit/Gen.hs create mode 100644 src/Verismith/Circuit/Internal.hs create mode 100644 src/Verismith/Circuit/Random.hs create mode 100644 src/Verismith/Config.hs create mode 100644 src/Verismith/Fuzz.hs create mode 100644 src/Verismith/Generate.hs create mode 100644 src/Verismith/Internal.hs create mode 100644 src/Verismith/Reduce.hs create mode 100644 src/Verismith/Report.hs create mode 100644 src/Verismith/Result.hs create mode 100644 src/Verismith/Sim.hs create mode 100644 src/Verismith/Sim/Icarus.hs create mode 100644 src/Verismith/Sim/Identity.hs create mode 100644 src/Verismith/Sim/Internal.hs create mode 100644 src/Verismith/Sim/Quartus.hs create mode 100644 src/Verismith/Sim/Template.hs create mode 100644 src/Verismith/Sim/Vivado.hs create mode 100644 src/Verismith/Sim/XST.hs create mode 100644 src/Verismith/Sim/Yosys.hs create mode 100644 src/Verismith/Verilog.hs create mode 100644 src/Verismith/Verilog/AST.hs create mode 100644 src/Verismith/Verilog/BitVec.hs create mode 100644 src/Verismith/Verilog/CodeGen.hs create mode 100644 src/Verismith/Verilog/Eval.hs create mode 100644 src/Verismith/Verilog/Internal.hs create mode 100644 src/Verismith/Verilog/Lex.x create mode 100644 src/Verismith/Verilog/Mutate.hs create mode 100644 src/Verismith/Verilog/Parser.hs create mode 100644 src/Verismith/Verilog/Preprocess.hs create mode 100644 src/Verismith/Verilog/Quote.hs create mode 100644 src/Verismith/Verilog/Token.hs diff --git a/app/Main.hs b/app/Main.hs index 39f74aa..af5731c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main where -import VeriSmith +import Verismith main :: IO () main = defaultMain diff --git a/default.nix b/default.nix index 922037b..e8715fa 100644 --- a/default.nix +++ b/default.nix @@ -2,11 +2,27 @@ let haskellPackages = nixpkgs.pkgs.haskellPackages.override { overrides = haskellPackagesNew: haskellPackagesOld: rec { - hedgehog-fn = haskellPackagesNew.callPackage ./nix/hedgehog-fn.nix {}; - tomland = nixpkgs.pkgs.haskell.lib.dontCheck (haskellPackagesNew.callPackage ./nix/tomland.nix {}); - parser-combinators = haskellPackagesNew.callPackage ./nix/parser-combinators.nix {}; - tasty-hedgehog = haskellPackagesNew.callPackage ./nix/tasty-hedgehog.nix {}; - }; + hedgehog-fn = haskellPackages.callCabal2nix "hedgehog-fn" (builtins.fetchGit { + url = "git@github.com:qfpl/hedgehog-fn"; + rev = "723b67f54422cf1fbbdcfa23f01a2d4e37b2d110"; + }) {}; + tomland = nixpkgs.pkgs.haskell.lib.dontCheck (haskellPackages.callCabal2nix "tomland" (builtins.fetchGit { + url = "git@github.com:kowainik/tomland"; + rev = "a3feec3919e7b86275b0d937d48d153a4beda1f8"; + }) {}); + parser-combinators = haskellPackages.callCabal2nix "parser-combinators" (builtins.fetchGit { + url = "git@github.com:mrkkrp/parser-combinators"; + rev = "7003fd8425c3bba9ea25763173baedb4ebd184fd"; + }) {}; + tasty-hedgehog = haskellPackages.callCabal2nix "tasty-hedgehog" (builtins.fetchGit { + url = "git@github.com:qfpl/tasty-hedgehog"; + rev = "214f4496afb03630d12d4db606fb8953b3e02d10"; + }) {}; + hedgehog = haskellPackages.callCabal2nix "hedgehog" (builtins.fetchGit { + url = "git@github.com:hedgehogqa/haskell-hedgehog"; + rev = "38146de29c97c867cff52fb36367ff9a65306d76"; + }) {}; + }; }; variant = if doBenchmark then nixpkgs.pkgs.haskell.lib.doBenchmark else nixpkgs.pkgs.lib.id; verismith = haskellPackages.callCabal2nix "verismith" (./.) {}; diff --git a/scripts/setup.sh b/scripts/setup.sh index cef1cbc..6f6243e 100644 --- a/scripts/setup.sh +++ b/scripts/setup.sh @@ -16,14 +16,14 @@ sudo chown -R ec2-user:ec2-user /mnt/tools/home/ec2-user sudo chown -R ec2-user:ec2-user /mnt/work curl https://nixos.org/nix/install | sh -. $HOME/.nix-profile/etc/profile.d/nix.sh { cat <> $HOME/.bashrc - -source $HOME/.bashrc diff --git a/src/VeriSmith.hs b/src/VeriSmith.hs deleted file mode 100644 index 6c1a1b5..0000000 --- a/src/VeriSmith.hs +++ /dev/null @@ -1,553 +0,0 @@ -{-| -Module : VeriSmith -Description : VeriSmith -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX --} - -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -module VeriSmith - ( defaultMain - -- * Types - , Opts(..) - , SourceInfo(..) - -- * Run functions - , runEquivalence - , runSimulation - , runReduce - , draw - -- * Verilog generation functions - , procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod - -- * Extra modules - , module VeriSmith.Verilog - , module VeriSmith.Config - , module VeriSmith.Circuit - , module VeriSmith.Sim - , module VeriSmith.Fuzz - , module VeriSmith.Report - ) -where - -import Control.Concurrent -import Control.Lens hiding ((<.>)) -import Control.Monad.IO.Class (liftIO) -import qualified Crypto.Random.DRBG as C -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 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.Reduce -import VeriSmith.Report -import VeriSmith.Result -import VeriSmith.Sim -import VeriSmith.Sim.Internal -import VeriSmith.Verilog -import VeriSmith.Verilog.Parser (parseSourceInfoFile) - -data OptTool = TYosys - | TXST - | TIcarus - -instance Show OptTool where - show TYosys = "yosys" - show TXST = "xst" - show TIcarus = "icarus" - -data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text - , configFile :: !(Maybe FilePath) - , forced :: !Bool - , keepAll :: !Bool - , num :: {-# UNPACK #-} !Int - } - | Generate { mFileName :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - } - | Parse { fileName :: {-# UNPACK #-} !FilePath - } - | Reduce { fileName :: {-# UNPACK #-} !FilePath - , top :: {-# UNPACK #-} !Text - , reduceScript :: !(Maybe FilePath) - , synthesiserDesc :: ![SynthDescription] - , rerun :: Bool - } - | ConfigOpt { writeConfig :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - , doRandomise :: !Bool - } - -myForkIO :: IO () -> IO (MVar ()) -myForkIO io = do - mvar <- newEmptyMVar - _ <- forkFinally io (\_ -> putMVar mvar ()) - return mvar - -textOption :: Mod OptionFields String -> Parser Text -textOption = fmap T.pack . strOption - -optReader :: (String -> Maybe a) -> ReadM a -optReader f = eitherReader $ \arg -> case f arg of - 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 - -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 - -parseSim :: String -> Maybe OptTool -parseSim val | val == "icarus" = Just TIcarus - | otherwise = Nothing - -fuzzOpts :: Parser Opts -fuzzOpts = - Fuzz - <$> textOption - ( long "output" - <> short 'o' - <> metavar "DIR" - <> help "Output directory that the fuzz run takes place in." - <> showDefault - <> value "output" - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> (switch $ long "force" <> short 'f' <> help - "Overwrite the specified directory." - ) - <*> (switch $ long "keep" <> short 'k' <> help - "Keep all the directories." - ) - <*> ( option auto - $ long "num" - <> short 'n' - <> help "The number of fuzz runs that should be performed." - <> showDefault - <> value 1 - <> metavar "INT" - ) - -genOpts :: Parser Opts -genOpts = - Generate - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a verilog file instead." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the generation run." - ) - -parseOpts :: Parser Opts -parseOpts = Parse . fromText . T.pack <$> strArgument - (metavar "FILE" <> help "Verilog input file.") - -reduceOpts :: Parser Opts -reduceOpts = - Reduce - . fromText - . T.pack - <$> strArgument (metavar "FILE" <> help "Verilog input file.") - <*> textOption - ( short 't' - <> long "top" - <> metavar "TOP" - <> help "Name of top level module." - <> showDefault - <> value "top" - ) - <*> ( optional - . strOption - $ long "script" - <> metavar "SCRIPT" - <> help - "Script that determines if the current file is interesting, which is determined by the script returning 0." - ) - <*> ( many - . option (optReader parseSynthDesc) - $ short 's' - <> long "synth" - <> metavar "SYNTH" - <> help "Specify synthesiser to use." - ) - <*> ( switch - $ short 'r' - <> long "rerun" - <> help - "Only rerun the current synthesis file with all the synthesisers." - ) - -configOpts :: Parser Opts -configOpts = - ConfigOpt - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a TOML Config file." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> ( switch - $ long "randomise" - <> short 'r' - <> help - "Randomise the given default config, or the default config by randomly switchin on and off options." - ) - -argparse :: Parser Opts -argparse = - hsubparser - ( command - "fuzz" - (info - fuzzOpts - (progDesc - "Run fuzzing on the specified simulators and synthesisers." - ) - ) - <> metavar "fuzz" - ) - <|> hsubparser - ( command - "generate" - (info - genOpts - (progDesc "Generate a random Verilog program.") - ) - <> metavar "generate" - ) - <|> hsubparser - ( command - "parse" - (info - parseOpts - (progDesc - "Parse a verilog file and output a pretty printed version." - ) - ) - <> metavar "parse" - ) - <|> hsubparser - ( command - "reduce" - (info - reduceOpts - (progDesc - "Reduce a Verilog file by rerunning the fuzzer on the file." - ) - ) - <> metavar "reduce" - ) - <|> hsubparser - ( command - "config" - (info - configOpts - (progDesc - "Print the current configuration of the fuzzer." - ) - ) - <> metavar "config" - ) - -version :: Parser (a -> a) -version = infoOption versionInfo $ mconcat - [long "version", short 'v', help "Show version information.", hidden] - -opts :: ParserInfo Opts -opts = info - (argparse <**> helper <**> version) - ( fullDesc - <> progDesc "Fuzz different simulators and synthesisers." - <> header - "VeriSmith - A hardware simulator and synthesiser Verilog fuzzer." - ) - -getConfig :: Maybe FilePath -> IO Config -getConfig s = - maybe (return defaultConfig) parseConfigFile $ T.unpack . 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 - -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 - 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) - ) - c - d - e - where - cm = config ^. configProbability . probModItem - cs = config ^. configProbability . probStmnt - ce = config ^. configProbability . probExpr - -handleOpts :: Opts -> IO () -handleOpts (Fuzz o configF _ _ n) = do - config <- getConfig configF - _ <- runFuzz - config - defaultYosys - (fuzzMultiple n (Just $ fromText o) (proceduralSrc "top" config)) - return () -handleOpts (Generate f c) = do - config <- getConfig c - source <- proceduralIO "top" config - maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) - $ T.unpack - . toTextIgnore - <$> f -handleOpts (Parse f) = do - verilogSrc <- T.readFile file - case parseVerilog (T.pack file) verilogSrc of - Left l -> print l - Right v -> print $ GenVerilog v - where file = T.unpack . toTextIgnore $ f -handleOpts (Reduce f t _ ls' False) = do - src <- parseSourceInfoFile t (toTextIgnore f) - case descriptionToSynth <$> ls' of - a : b : _ -> do - putStrLn "Reduce with equivalence check" - shelly $ do - make dir - pop dir $ do - src' <- reduceSynth a b src - 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) - 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 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 - -defaultMain :: IO () -defaultMain = do - optsparsed <- execParser opts - handleOpts optsparsed - --- | Generate a specific number of random bytestrings of size 256. -randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] -randomByteString gen n bytes - | n == 0 = ranBytes : bytes - | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes - where Right (ranBytes, newGen) = C.genBytes 32 gen - --- | generates the specific number of bytestring with a random seed. -generateByteString :: Int -> IO [ByteString] -generateByteString n = do - gen <- C.newGenIO :: IO C.CtrDRBG - return $ randomByteString gen n [] - -makeSrcInfo :: ModDecl -> SourceInfo -makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) - --- | Draw a randomly generated DAG to a dot file and compile it to a png so it --- 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"] - --- | Function to show a bytestring in a hex format. -showBS :: ByteString -> Text -showBS = decodeUtf8 . L.toStrict . toLazyByteString . byteStringHex - --- | Run a simulation on a random DAG or a random module. -runSimulation :: IO () -runSimulation = do - -- gr <- Hog.generate $ rDups <$> Hog.resize 100 (randomDAG :: Gen (G.Gr Gate ())) - -- let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr - -- writeFile "file.dot" dot - -- shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] - -- let circ = - -- head $ (nestUpTo 30 . generateAST $ Circuit gr) ^.. getVerilog . traverse . getDescription - rand <- generateByteString 20 - rand2 <- Hog.sample (randomMod 10 100) - 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 - -checkEquivalence :: SourceInfo -> Text -> IO Bool -checkEquivalence src dir = shellyFailDir $ do - mkdir_p (fromText dir) - curr <- toTextIgnore <$> pwd - setenv "VERISMITH_ROOT" curr - cd (fromText dir) - catch_sh - ((runResultT $ runEquiv 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 seed gm t d k i = do - (_, m) <- shelly $ sampleSeed seed gm - let srcInfo = SourceInfo "top" m - rand <- generateByteString 20 - shellyFailDir $ do - mkdir_p (fromText d fromText n) - curr <- toTextIgnore <$> pwd - setenv "VERISMITH_ROOT" curr - cd (fromText "output" fromText n) - _ <- - catch_sh - ( runResultT - $ runEquiv 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 (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s diff --git a/src/VeriSmith/Circuit.hs b/src/VeriSmith/Circuit.hs deleted file mode 100644 index aee0d57..0000000 --- a/src/VeriSmith/Circuit.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-| -Module : VeriSmith.Circuit -Description : Definition of the circuit graph. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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 - -fromGraph :: Gen ModDecl -fromGraph = do - 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 deleted file mode 100644 index ddcaf65..0000000 --- a/src/VeriSmith/Circuit/Base.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-| -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(..) - ) -where - -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) - --- | Newtype for the Circuit which implements a Graph from fgl. -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 for a named edge which is empty, as it does not need a label. -newtype CEdge = CEdge { getCEdge :: LEdge () } - -instance Random Gate where - randomR (a, b) g = - case randomR (fromEnum a, fromEnum b) g of - (x, g') -> (toEnum x, g') - - random = randomR (minBound, maxBound) diff --git a/src/VeriSmith/Circuit/Gen.hs b/src/VeriSmith/Circuit/Gen.hs deleted file mode 100644 index 1c4dd37..0000000 --- a/src/VeriSmith/Circuit/Gen.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-| -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 - ) -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 - --- | Converts a 'CNode' to an 'Identifier'. -frNode :: Node -> Identifier -frNode = Identifier . fromNode - --- | Converts a 'Gate' to a 'BinaryOperator', which should be a bijective --- mapping. -fromGate :: Gate -> BinaryOperator -fromGate And = BinAnd -fromGate Or = BinOr -fromGate Xor = BinXor - -inputsC :: Circuit -> [Node] -inputsC c = inputs (getCircuit c) - -genPortsAST :: (Circuit -> [Node]) -> Circuit -> [Port] -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 g (n : ns) = BinOp wire oper <$> genAssignExpr g ns - where - wire = Id $ frNode n - oper = fromGate g - --- | Generate the continuous assignment AST for a particular node. If it does --- not have any nodes that link to it then return 'Nothing', as that means that --- the assignment will just be empty. -genContAssignAST :: Circuit -> LNode Gate -> Maybe ModItem -genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes - where - gr = getCircuit c - nodes = G.pre gr n - name = frNode n - -genAssignAST :: Circuit -> [ModItem] -genAssignAST c = catMaybes $ genContAssignAST c <$> nodes - where - gr = getCircuit c - nodes = G.labNodes gr - -genModuleDeclAST :: Circuit -> ModDecl -genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] - where - i = Identifier "gen_module" - ports = genPortsAST inputsC c - output = [] - a = genAssignAST c - yPort = Port Wire False 90 "y" - -generateAST :: Circuit -> Verilog -generateAST c = Verilog [genModuleDeclAST c] diff --git a/src/VeriSmith/Circuit/Internal.hs b/src/VeriSmith/Circuit/Internal.hs deleted file mode 100644 index b746738..0000000 --- a/src/VeriSmith/Circuit/Internal.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-| -Module : VeriSmith.Circuit.Internal -Description : Internal helpers for generation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Internal helpers for generation. --} - -module VeriSmith.Circuit.Internal - ( fromNode - , filterGr - , only - , inputs - , outputs - ) -where - -import Data.Graph.Inductive (Graph, Node) -import qualified Data.Graph.Inductive as G -import qualified Data.Text as T - --- | Convert an integer into a label. --- --- >>> fromNode 5 --- "w5" -fromNode :: Int -> T.Text -fromNode node = T.pack $ "w" <> show node - --- | General function which runs 'filter' over a graph. -filterGr :: (Graph gr) => gr n e -> (Node -> Bool) -> [Node] -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 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 --- an input themselves. -inputs :: (Graph gr) => gr n e -> [Node] -inputs graph = filterGr graph $ only graph G.indeg G.outdeg - --- | Returns all the output nodes to a graph, similar to the 'inputs' function. -outputs :: (Graph gr) => gr n e -> [Node] -outputs graph = filterGr graph $ only graph G.outdeg G.indeg diff --git a/src/VeriSmith/Circuit/Random.hs b/src/VeriSmith/Circuit/Random.hs deleted file mode 100644 index ca8cc26..0000000 --- a/src/VeriSmith/Circuit/Random.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-| -Module : VeriSmith.Circuit.Random -Description : Random generation for DAG -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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 - -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) - --- | Remove duplicates. -rDups :: (Eq a, Eq b) => Gr a b -> Gr a b -rDups g = G.buildGr $ G.ufold dupFolder [] g - --- | Remove duplicates. -rDupsCirc :: Circuit -> Circuit -rDupsCirc = Circuit . rDups . getCircuit - --- | Gen instance to create an arbitrary edge, where the edges are limited by --- `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, ()) - where - 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 = 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 - where - nodes l = zip [0 .. length l - 1] l - aE = getCEdge <$> Hog.sized arbitraryEdge - --- | Generate a random acyclic DAG with an IO instance. -genRandomDAG :: IO Circuit -genRandomDAG = Hog.sample randomDAG diff --git a/src/VeriSmith/Config.hs b/src/VeriSmith/Config.hs deleted file mode 100644 index adc3d19..0000000 --- a/src/VeriSmith/Config.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-| -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 - ( -- * TOML Configuration - -- $conf - Config(..) - , defaultConfig - -- ** Probabilities - , Probability(..) - -- *** Expression - , ProbExpr(..) - -- *** Module Item - , ProbModItem(..) - -- *** Statement - , ProbStatement(..) - -- ** ConfProperty - , ConfProperty(..) - -- ** Simulator Description - , SimDescription(..) - -- ** Synthesiser Description - , SynthDescription(..) - -- * Useful Lenses - , fromXST - , fromYosys - , fromVivado - , fromQuartus - , configProbability - , configProperty - , configSimulators - , configSynthesisers - , probModItem - , 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 - , 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 qualified Toml -import VeriSmith.Sim.Quartus -import VeriSmith.Sim.Vivado -import VeriSmith.Sim.XST -import VeriSmith.Sim.Yosys - --- $conf --- --- VeriSmith supports a TOML configuration file that can be passed using the @-c@ --- flag or using the 'parseConfig' and 'encodeConfig' functions. The --- configuration can then be manipulated using the lenses that are also provided --- in this module. --- --- The configuration file can be used to tweak the random Verilog generation by --- passing different probabilities to each of the syntax nodes in the AST. It --- can also be used to specify which simulators to fuzz with which options. A --- seed for the run can also be set, to replay a previous run using the same --- exact generation. A default value is associated with each key in the --- configuration file, which means that only the options that need overriding --- can be added to the configuration. The defaults can be observed in --- 'defaultConfig' or when running @verismith config@. --- --- == Configuration Sections --- --- There are four main configuration sections in the TOML file: --- --- [@probability@] The @probability@ section defines the probabilities at --- every node in the AST. --- --- [@property@] Controls different properties of the generation, such as --- adding a seed or the depth of the statements. --- --- [@simulator@] This is an array of tables containing descriptions of the --- different simulators that should be used. It currently only supports --- . --- --- [@synthesiser@] This is also an array of tables containing descriptions of --- the different synthesisers that should be used. The synthesisers that are --- currently supported are: --- --- - --- - --- - --- - - --- | Probability of different expressions nodes. -data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int - -- ^ 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 - -- ^ Probability of generating an identifier that is in - -- scope and of the right type. - , _probExprRangeSelect :: {-# UNPACK #-} !Int - -- ^ Probability of generating a range selection from a port. - , _probExprUnOp :: {-# UNPACK #-} !Int - -- ^ Probability of generating a unary operator. - , _probExprBinOp :: {-# UNPACK #-} !Int - -- ^ Probability of generation a binary operator. - , _probExprCond :: {-# UNPACK #-} !Int - -- ^ probability of generating a conditional ternary - -- operator. - , _probExprConcat :: {-# UNPACK #-} !Int - -- ^ Probability of generating a concatenation. - , _probExprStr :: {-# UNPACK #-} !Int - -- ^ Probability of generating a string. This is not - -- fully supported therefore currently cannot be set. - , _probExprSigned :: {-# UNPACK #-} !Int - -- ^ Probability of generating a signed function - -- @$signed(...)@. - , _probExprUnsigned :: {-# UNPACK #-} !Int - -- ^ Probability of generating an unsigned function - -- @$unsigned(...)@. - } - deriving (Eq, Show) - --- | Probability of generating different nodes inside a module declaration. -data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int - -- ^ Probability of generating an @assign@. - , _probModItemSeqAlways :: {-# UNPACK #-} !Int - -- ^ Probability of generating a sequential @always@ block. - , _probModItemCombAlways :: {-# UNPACK #-} !Int - -- ^ Probability of generating an combinational @always@ block. - , _probModItemInst :: {-# UNPACK #-} !Int - -- ^ Probability of generating a module - -- instantiation. - } - deriving (Eq, Show) - -data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int - , _probStmntNonBlock :: {-# UNPACK #-} !Int - , _probStmntCond :: {-# UNPACK #-} !Int - , _probStmntFor :: {-# UNPACK #-} !Int - } - deriving (Eq, Show) - -data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem - , _probStmnt :: {-# UNPACK #-} !ProbStatement - , _probExpr :: {-# UNPACK #-} !ProbExpr - } - deriving (Eq, Show) - -data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int - -- ^ The size of the generated Verilog. - , _propSeed :: !(Maybe Seed) - -- ^ A possible seed that could be used to - -- generate the same Verilog. - , _propStmntDepth :: {-# UNPACK #-} !Int - -- ^ The maximum statement depth that should be - -- reached. - , _propModDepth :: {-# UNPACK #-} !Int - -- ^ The maximium module depth that should be - -- reached. - , _propMaxModules :: {-# UNPACK #-} !Int - -- ^ The maximum number of modules that are - -- allowed to be created at each level. - , _propSampleMethod :: !Text - -- ^ The sampling method that should be used to - -- generate specific distributions of random - -- programs. - , _propSampleSize :: {-# UNPACK #-} !Int - -- ^ The number of samples to take for the - -- sampling method. - , _propCombine :: !Bool - -- ^ If the output should be combined into one - -- bit or not. - , _propNonDeterminism :: {-# UNPACK #-} !Int - -- ^ The frequency at which nondeterminism - -- should be generated. - , _propDeterminism :: {-# UNPACK #-} !Int - -- ^ The frequency at which determinism should - -- be generated. - } - deriving (Eq, Show) - -data Info = Info { _infoCommit :: !Text - , _infoVersion :: !Text - } - deriving (Eq, Show) - -data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text } - deriving (Eq, Show) - -data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text - , synthBin :: Maybe Text - , synthDesc :: Maybe Text - , 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 ''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 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) - -fromYosys :: Yosys -> SynthDescription -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) - -fromQuartus :: Quartus -> SynthDescription -fromQuartus (Quartus a b c) = SynthDescription "quartus" - (toTextIgnore <$> a) - (Just b) - (Just $ toTextIgnore c) - -defaultConfig :: Config -defaultConfig = Config - (Info (pack $(gitHash)) (pack $ showVersion version)) - (Probability defModItem defStmnt defExpr) - (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1) - [] - [fromYosys defaultYosys, fromVivado defaultVivado] - where - defModItem = - 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 - 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 - -twoKey :: Toml.Piece -> Toml.Piece -> Toml.Key -twoKey a b = Toml.Key (a :| [b]) - -int :: Toml.Piece -> Toml.Piece -> TomlCodec Int -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 - 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 - 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 - where - defProb i = defaultConfig ^. configProbability . probModItem . i - intM = int "moditem" - -probCodec :: TomlCodec Probability -probCodec = - Probability - <$> defaultValue (defProb probModItem) modItemCodec - .= _probModItem - <*> defaultValue (defProb probStmnt) stmntCodec - .= _probStmnt - <*> defaultValue (defProb probExpr) exprCodec - .= _probExpr - 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 - where defProp i = defaultConfig ^. configProperty . i - -simulator :: TomlCodec SimDescription -simulator = Toml.textBy pprint parseIcarus "name" - where - parseIcarus i@"icarus" = Right $ SimDescription i - parseIcarus s = Left $ "Could not match '" <> s <> "' with a simulator." - pprint (SimDescription a) = a - -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 - -infoCodec :: TomlCodec Info -infoCodec = - 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 - -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" - -encodeConfig :: Config -> Text -encodeConfig = Toml.encode configCodec - -encodeConfigFile :: FilePath -> Config -> IO () -encodeConfigFile f = T.writeFile f . encodeConfig - -versionInfo :: String -versionInfo = - "VeriSmith " - <> showVersion version - <> " (" - <> $(gitCommitDate) - <> " " - <> $(gitHash) - <> ")" diff --git a/src/VeriSmith/Fuzz.hs b/src/VeriSmith/Fuzz.hs deleted file mode 100644 index 9331a5e..0000000 --- a/src/VeriSmith/Fuzz.hs +++ /dev/null @@ -1,466 +0,0 @@ -{-| -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 FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - -module VeriSmith.Fuzz - ( Fuzz - , fuzz - , fuzzInDir - , fuzzMultiple - , runFuzz - , sampleSeed - -- * Helpers - , 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.Trans.Class (lift) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Maybe (runMaybeT) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import qualified Crypto.Random.DRBG as C -import Data.ByteString (ByteString) -import Data.List (nubBy, sort) -import Data.Maybe (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) -import Shelly.Lifted (MonadSh, liftSh) -import System.FilePath.Posix (takeBaseName) -import VeriSmith.Config -import VeriSmith.Internal -import VeriSmith.Reduce -import VeriSmith.Report -import VeriSmith.Result -import VeriSmith.Sim.Icarus -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Yosys -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] - , getSimulators :: ![SimTool] - , yosysInstance :: {-# UNPACK #-} !Yosys - } - deriving (Eq, Show) - -data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult] - , _fuzzSimResults :: ![SimResult] - , _fuzzSynthStatus :: ![SynthStatus] - } - deriving (Eq, Show) - -$(makeLenses ''FuzzState) - -type Frequency a = [(Seed, a)] -> [(Int, Gen (Seed, a))] - --- | The main type for the fuzzing, which contains an environment that can be --- read from and the current state of all the results. -type Fuzz m = StateT FuzzState (ReaderT FuzzEnv m) - -type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) - -runFuzz :: MonadIO m => Config -> Yosys -> (Config -> Fuzz Sh a) -> m a -runFuzz conf yos m = shelly $ runFuzz' conf yos m - -runFuzz' :: Monad m => Config -> Yosys -> (Config -> Fuzz m b) -> m b -runFuzz' conf yos m = runReaderT - (evalStateT (m conf) (FuzzState [] [] [])) - (FuzzEnv - ( force - $ defaultIdentitySynth - : (descriptionToSynth <$> conf ^. configSynthesisers) - ) - (force $ descriptionToSim <$> conf ^. configSimulators) - yos - ) - -synthesisers :: Monad m => Fuzz m [SynthTool] -synthesisers = lift $ asks getSynthesisers - ---simulators :: (Monad m) => Fuzz () m [SimTool] ---simulators = lift $ asks getSimulators - ---combinations :: [a] -> [b] -> [(a, b)] ---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) - -synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () -synthesis src = do - 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 - -passedSynthesis :: MonadSh m => Fuzz m [SynthTool] -passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get - where - passed (SynthStatus _ (Pass _) _) = True - 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 - toSynth (SynthStatus s _ _) = s - -make :: MonadSh m => FilePath -> m () -make f = liftSh $ do - mkdir_p f - cp_r "data" $ f fromText "data" - -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 - -applyList :: [a -> b] -> [a] -> [b] -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 a b = applyLots SynthResult a $ fmap swap b - -toolRun :: (MonadIO m, MonadSh m) => Text -> m a -> m (NominalDiffTime, a) -toolRun t m = do - logT $ "Running " <> t - (diff, res) <- timeit m - logT $ "Finished " <> t <> " (" <> showT diff <> ")" - return (diff, res) - -equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () -equivalence src = do - synth <- passedSynthesis --- let synthComb = --- nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth - let synthComb = - nubBy tupEq - . filter (uncurry (/=)) - $ (,) defaultIdentitySynth - <$> synth - resTimes <- liftSh $ mapM (uncurry equiv) synthComb - fuzzSynthResults .= toSynthResult synthComb resTimes - liftSh $ inspect resTimes - where - tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') - equiv 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 - runEquiv a b src - where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b - -simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () -simulation src = do - synth <- passEquiv - vals <- liftIO $ generateByteString 20 - ident <- liftSh $ equiv vals defaultIdentitySynth - resTimes <- liftSh $ mapM (equiv vals) $ conv <$> synth - liftSh - . inspect - $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) - <$> (ident : resTimes) - where - conv (SynthResult _ a _ _) = a - equiv b 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 defaultIcarus a src b - where dir = fromText $ "simulation_" <> toText a - --- | Generate a specific number of random bytestrings of size 256. -randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] -randomByteString gen n bytes - | n == 0 = ranBytes : bytes - | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes - where Right (ranBytes, newGen) = C.genBytes 32 gen - --- | generates the specific number of bytestring with a random seed. -generateByteString :: Int -> IO [ByteString] -generateByteString n = do - gen <- C.newGenIO :: IO C.CtrDRBG - return $ randomByteString gen n [] - -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 - -passEquiv :: (MonadSh m) => Fuzz m [SynthResult] -passEquiv = filter withIdentity . _fuzzSynthResults <$> get - where - withIdentity (SynthResult _ _ (Pass _) _) = True - withIdentity _ = False - --- | Always reduces with respect to 'Identity'. -reduction :: (MonadSh m) => SourceInfo -> Fuzz m () -reduction src = do - fails <- failEquivWithIdentity - synthFails <- failedSynthesis - _ <- liftSh $ mapM red fails - _ <- liftSh $ mapM redSynth synthFails - return () - where - red (SynthResult a b _ _) = do - make dir - pop dir $ do - s <- reduceSynth a b src - writefile (fromText ".." dir <.> "v") $ genSource s - return s - where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b - redSynth a = do - make dir - pop dir $ do - s <- reduceSynthesis a src - writefile (fromText ".." dir <.> "v") $ genSource s - return s - where dir = fromText $ "reduce_" <> toText 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) - -whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) -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) - => Fuzz m (Seed, SourceInfo) - -> Fuzz m (Seed, SourceInfo) -generateSample f = do - 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 - -hatFreqs :: Frequency a -hatFreqs l = zip hat (return <$> l) - where - h = length l `div` 2 - hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] - -meanFreqs :: Source a => Frequency a -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 - sizes = verilogSize . snd <$> l - -medianFreqs :: Frequency a -medianFreqs l = zip hat (return <$> l) - where - h = length l `div` 2 - hat = set_ <$> [1 .. length l] - set_ n = if n == h then 1 else 0 - -fuzz :: MonadFuzz m => Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzz gen conf = do - (seed', src) <- generateSample genMethod - let size = length . lines . T.unpack $ genSource src - liftSh - . writefile "config.toml" - . encodeConfig - $ conf - & configProperty - . propSeed - ?~ seed' - (tsynth, _) <- titleRun "Synthesis" $ synthesis src - (tequiv, _) <- titleRun "Equivalence Check" $ equivalence src - (_ , _) <- titleRun "Simulation" $ simulation src - fails <- failEquivWithIdentity - synthFails <- failedSynthesis - redResult <- - whenMaybe (not $ null fails && null synthFails) - . 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) - liftSh . writefile "index.html" $ printResultReport (bname currdir) report - return report - where - seed = conf ^. configProperty . propSeed - bname = T.pack . takeBaseName . T.unpack . toTextIgnore - genMethod = 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 - 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 - -fuzzInDir - :: MonadFuzz m => FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzzInDir fp src conf = do - make fp - res <- pop fp $ fuzz src conf - relativeFuzzReport res - -fuzzMultiple - :: MonadFuzz m - => Int - -> Maybe FilePath - -> Gen SourceInfo - -> Config - -> Fuzz m [FuzzReport] -fuzzMultiple n fp src conf = do - x <- case fp 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 .. n] fuzzDir' - else (: []) <$> fuzzDir' (1 :: Int) - liftSh . writefile (fromText "index" <.> "html") $ printSummary - "Fuzz Summary" - results - return results - where - fuzzDir' n' = fuzzInDir (fromText $ "fuzz_" <> showT n') src conf - seed = conf ^. configProperty . propSeed - -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 - runIdentity - . runMaybeT - . Hog.runTree - $ Hog.runGenT 30 seed gen - of - Nothing -> loop (n - 1) - Just x -> return (seed, Hog.nodeValue x) - in loop (100 :: Int) - diff --git a/src/VeriSmith/Generate.hs b/src/VeriSmith/Generate.hs deleted file mode 100644 index 095baee..0000000 --- a/src/VeriSmith/Generate.hs +++ /dev/null @@ -1,623 +0,0 @@ -{-| -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 TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} - -module VeriSmith.Generate - ( -- * Generation methods - procedural - , proceduralIO - , proceduralSrc - , proceduralSrcIO - , randomMod - -- ** Generate Functions - , gen - , 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 - ) -where - -import Control.Lens hiding (Context) -import Control.Monad (replicateM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import Data.Foldable (fold) -import Data.Functor.Foldable (cata) -import Data.List (foldl', partition) -import qualified Data.Text as T -import Hedgehog (Gen) -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 = Context { _variables :: [Port] - , _parameters :: [Parameter] - , _modules :: [ModDecl] - , _nameCounter :: {-# UNPACK #-} !Int - , _stmntDepth :: {-# UNPACK #-} !Int - , _modDepth :: {-# UNPACK #-} !Int - , _determinism :: !Bool - } - -makeLenses ''Context - -type StateGen = StateT Context (ReaderT Config Gen) - -toId :: Int -> Identifier -toId = Identifier . ("w" <>) . T.pack . show - -toPort :: Identifier -> Gen Port -toPort ident = do - i <- range - return $ wire i ident - -sumSize :: [Port] -> Range -sumSize ps = sum $ ps ^.. traverse . portSize - -random :: [Port] -> (Expr -> ContAssign) -> Gen ModItem -random ctx fun = do - 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 - -randomOrdAssigns :: [Port] -> [Port] -> [Gen ModItem] -randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids - where - generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) - -randomMod :: Int -> Int -> Gen ModDecl -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]) - [] - where - ids = toId <$> [1 .. total] - end = drop inps - start = take inps - --- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the --- 'Port'. -lvalFromPort :: Port -> LVal -lvalFromPort (Port _ _ _ i) = RegId i - --- | Returns the probability from the configuration. -probability :: Config -> Probability -probability c = c ^. configProbability - --- | Gets the current probabilities from the 'State'. -askProbability :: StateGen Probability -askProbability = lift $ asks probability - --- | Lifts a 'Gen' into the 'StateGen' monad. -gen :: Gen a -> StateGen a -gen = lift . lift - --- | Generates a random large number, which can also be negative. -largeNum :: Gen Int -largeNum = Hog.int $ Hog.linear (-100) 100 - --- | Generates a random size for a wire so that it is not too small and not too --- large. -wireSize :: Gen Int -wireSize = Hog.int $ Hog.linear 2 100 - --- | Generates a random range by using the 'wireSize' and 0 as the lower bound. -range :: Gen Range -range = Range <$> fmap fromIntegral wireSize <*> pure 0 - --- | Generate a random bit vector using 'largeNum'. -genBitVec :: Gen BitVec -genBitVec = fmap fromIntegral largeNum - --- | Return a random 'BinaryOperator'. This currently excludes 'BinDiv', --- 'BinMod' because they can take a long time to synthesis, and 'BinCEq', --- 'BinCNEq', because these are not synthesisable. 'BinPower' is also excluded --- because it can only be used in conjunction with base powers of 2 which is --- currently not enforced. -binOp :: Gen 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 - ] - --- | Generate a random 'UnaryOperator'. -unOp :: Gen UnaryOperator -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 :: [Parameter] -> ProbExpr -> Hog.Size -> Gen 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 - --- | The list of safe 'Expr', meaning that these will not recurse and will end --- the 'Expr' generation. -exprSafeList :: ProbExpr -> [(Int, Gen Expr)] -exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] - --- | List of 'Expr' that have the chance to recurse and will therefore not be --- used when the expression grows too large. -exprRecList :: ProbExpr -> (Hog.Size -> Gen Expr) -> [(Int, Gen 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) - ] - --- | Select a random port from a list of ports and generate a safe bit selection --- for that port. -rangeSelect :: [Parameter] -> [Port] -> Gen 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) - --- | Generate a random expression from the 'Context' with a guarantee that it --- will terminate using the list of safe 'Expr'. -exprWithContext :: ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> Gen 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 l n - | n == 0 - = Hog.frequency - $ (prob ^. probExprId, Id . fromPort <$> Hog.element l) - : exprSafeList prob - | 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 - --- | Runs a 'StateGen' for a random number of times, limited by an 'Int' that is --- passed to it. -someI :: Int -> StateGen a -> StateGen [a] -someI m f = do - amount <- gen $ 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 :: T.Text -> StateGen Identifier -makeIdentifier prefix = do - context <- get - let ident = Identifier $ prefix <> showT (context ^. nameCounter) - nameCounter += 1 - return ident - -getPort' :: PortType -> Identifier -> [Port] -> StateGen 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' - --- | 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 --- 'newPort'. This is used subsequently in all the functions to create a port, --- in case a port with the same name was already created. This could be because --- the generation is currently in the other branch of an if-statement. -nextPort :: PortType -> StateGen Port -nextPort pt = do - context <- get - ident <- makeIdentifier . T.toLower $ showT pt - 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 Port -newPort ident pt = do - p <- gen $ Port pt <$> Hog.bool <*> range <*> pure ident - variables %= (p :) - return p - --- | Generates an expression from variables that are currently in scope. -scopedExpr :: StateGen Expr -scopedExpr = do - context <- get - prob <- askProbability - gen - . 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 ContAssign -contAssign = do - expr <- scopedExpr - p <- nextPort Wire - return $ ContAssign (p ^. portName) expr - --- | Generate a random assignment and assign it to a random 'Reg'. -assignment :: StateGen Assign -assignment = do - expr <- scopedExpr - lval <- lvalFromPort <$> nextPort Reg - return $ Assign lval Nothing expr - --- | Generate a random 'Statement' safely, by also increasing the depth counter. -seqBlock :: StateGen Statement -seqBlock = do - 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' --- is not reused, it is left at 0, as all the 'Reg' are initialised to 0 at the --- start. -conditional :: StateGen Statement -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) - --- | Generate a random for loop by creating a new variable name for the counter --- and then generating random statements in the body. -forLoop :: StateGen Statement -forLoop = do - num <- Hog.int (Hog.linear 0 20) - var <- lvalFromPort <$> nextPort 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 Statement -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 - --- | Generate a sequential always block which is dependent on the clock. -alwaysSeq :: StateGen ModItem -alwaysSeq = Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock - --- | Should resize a port that connects to a module port if the latter is --- larger. This should not cause any problems if the same net is used as input --- 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 - --- | Instantiate a module, where the outputs are new nets that are created, and --- the inputs are taken from existing ports in the context. --- --- 1 is subtracted from the inputs for the length because the clock is not --- counted and is assumed to be there, this should be made nicer by filtering --- out the clock instead. I think that in general there should be a special --- representation for the clock. -instantiate :: ModDecl -> StateGen ModItem -instantiate (ModDecl i outP inP _ _) = do - context <- get - outs <- replicateM (length outP) (nextPort Wire) - ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) - 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) - , ModInst i ident <$> Hog.shuffle - (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) (toE $ outs <> clkPort <> ins)) - ] - 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 --- for every instance and for every level until either the deepest level is --- achieved, or the maximum number of modules are reached. --- --- If the maximum number of levels are reached, it will always pick an instance --- from the current context. The problem with this approach is that at the end --- there may be many more than the max amount of modules, as the modules are --- always set to empty when entering a new level. This is to fix recursive --- definitions of modules, which are not defined. --- --- One way to fix that is to also decrement the max modules for every level, --- depending on how many modules have already been generated. This would mean --- there would be moments when the module cannot generate a new instance but --- also not take a module from the current context. A fix for that may be to --- have a default definition of a simple module that is used instead. --- --- Another different way to handle this would be to have a probability of taking --- a module from a context or generating a new one. -modInst :: StateGen ModItem -modInst = do - prob <- lift 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 ModItem -modItem = do - conf <- lift 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 - 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 Identifier -moduleName (Just t) = return t -moduleName Nothing = makeIdentifier "module" - --- | Generate a random 'ConstExpr' by using the current context of 'Parameters'. -constExpr :: StateGen ConstExpr -constExpr = do - prob <- askProbability - context <- get - gen . 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 Parameter -parameter = do - 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 - --- | Calculate a range to an int by maybe resizing the ranges to a value. -calcRange :: [Parameter] -> Maybe Int -> Range -> Int -calcRange ps i (Range l r) = eval l - eval r + 1 - where - eval a = fromIntegral . cata (evaluateConst ps) $ maybe a (`resize` a) i - --- | Filter out a port based on it's name instead of equality of the ports. This --- is because the ports might not be equal if the sizes are being updated. -identElem :: Port -> [Port] -> Bool -identElem p = elem (p ^. portName) . toListOf (traverse . portName) - --- | Generates a module definition randomly. It always has one output port which --- is set to @y@. The size of @y@ is the total combination of all the locally --- defined wires, so that it correctly reflects the internal state of the --- module. -moduleDef :: Maybe Identifier -> StateGen ModDecl -moduleDef top = do - name <- moduleName top - portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire - mi <- Hog.list (Hog.linear 4 100) modItem - ps <- Hog.list (Hog.linear 0 10) parameter - context <- get - config <- lift ask - let (newPorts, local) = partition (`identElem` portList) $ _variables context - let - size = - evalRange (_parameters context) 32 - . sum - $ local - ^.. traverse - . portSize - let combine = config ^. configProperty . propCombine - let clock = Port Wire False 1 "clk" - let yport = - if combine then Port Wire False 1 "y" else Port Wire False size "y" - let comb = combineAssigns_ combine yport local - 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 :: T.Text -> Config -> Gen Verilog -procedural top config = do - (mainMod, st) <- Hog.resize num $ runReaderT - (runStateT (moduleDef (Just $ Identifier top)) context) - config - return . Verilog $ mainMod : st ^. modules - where - context = - Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True - num = fromIntegral $ confProp propSize - confProp i = config ^. configProperty . i - --- | Samples the 'Gen' directly to generate random 'Verilog' using the 'T.Text' as --- the name of the main module and the configuration 'Config' to influence the --- generation. -proceduralIO :: T.Text -> Config -> IO Verilog -proceduralIO t = Hog.sample . procedural t - --- | Given a 'T.Text' and a 'Config' will generate a 'SourceInfo' which has the --- top module set to the right name. -proceduralSrc :: T.Text -> Config -> Gen SourceInfo -proceduralSrc t c = SourceInfo t <$> procedural t c - --- | Sampled and wrapped into a 'SourceInfo' with the given top module name. -proceduralSrcIO :: T.Text -> Config -> IO SourceInfo -proceduralSrcIO t c = SourceInfo t <$> proceduralIO t c diff --git a/src/VeriSmith/Internal.hs b/src/VeriSmith/Internal.hs deleted file mode 100644 index 86cb1f7..0000000 --- a/src/VeriSmith/Internal.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-| -Module : VeriSmith.Internal -Description : Shared high level code used in the other modules internally. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -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) - --- | Function to show a bytestring in a hex format. -showBS :: ByteString -> Text -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 - --- | Show function for 'Text' -showT :: (Show a) => a -> Text -showT = T.pack . show - --- | Inserts commas between '[Text]' and except the last one. -comma :: [Text] -> Text -comma = T.intercalate ", " - --- | Inserts commas and newlines between '[Text]' and except the last one. -commaNL :: [Text] -> Text -commaNL = T.intercalate ",\n" diff --git a/src/VeriSmith/Reduce.hs b/src/VeriSmith/Reduce.hs deleted file mode 100644 index c57b457..0000000 --- a/src/VeriSmith/Reduce.hs +++ /dev/null @@ -1,609 +0,0 @@ -{-| -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 ScopedTypeVariables #-} - -module VeriSmith.Reduce - ( -- $strategy - reduceWithScript - , reduceSynth - , reduceSynthesis - , reduce - , reduce_ - , Replacement(..) - , halveModules - , halveModItems - , halveStatements - , halveExpr - , halveAssigns - , findActiveWires - , clean - , cleanSourceInfo - , cleanSourceInfoAll - , removeDecl - , filterExpr - ) -where - -import Control.Lens hiding ((<.>)) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -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 ((<.>)) -import qualified Shelly -import Shelly.Lifted (MonadSh, liftSh) -import VeriSmith.Internal -import VeriSmith.Result -import VeriSmith.Sim -import VeriSmith.Sim.Internal -import VeriSmith.Verilog -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.Mutate -import VeriSmith.Verilog.Parser - - --- $strategy --- The reduction strategy has multiple different steps. 'reduce' will run these --- strategies one after another, starting at the most coarse grained one. The --- supported reduction strategies are the following: --- --- [Modules] First of all, the reducer will try and remove all the modules --- except the top module. --- --- [Module Items] Then, the module items will be reduced by using standard --- delta debugging. Half of the module items will be removed, and both --- versions will be tested. If both succeed, they will be divided further and --- tested further. Finally, the shortest version will be returned. --- --- [Statements] Once the module items have been reduced, the statements will --- be reduced as well. This is done using delta debugging, just like the --- module items. --- --- [Expressions] Finally, the expressions themselves will be reduced. This is --- done by splitting the top most binary expressions in half and testing each --- half. - --- | 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) - -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 - -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 - -instance Foldable Replacement where - 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 - --- | Split a list in two halves. -halve :: Replace [a] -halve [] = Single [] -halve [_] = Single [] -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 - --- | 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 --- module. -combine :: Lens' a b -> Replace b -> Replace a -combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res - --- | Deletes Id 'Expr' if they are not part of the current scope, and replaces --- these by 0. -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 -filterExpr ids (RangeSelect i r) = - 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 -> 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 -> Bool -filterAssigns out (ModCA (ContAssign i _)) = - elem i $ out ^.. traverse . portName -filterAssigns _ _ = True - -clean :: (Mutate a) => [Identifier] -> a -> a -clean ids = mutExpr (transform $ filterExpr ids) - -cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem] -cleanUndefined ids mis = clean usedWires mis - where - usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids - -halveModAssign :: Replace ModDecl -halveModAssign m = cleanMod m $ modify <$> assigns (m ^. modItems) - where - assigns = halve . filter (filterAssigns $ m ^. modOutPorts) - modify l = m & modItems .~ l - -cleanMod :: ModDecl -> Replacement ModDecl -> Replacement ModDecl -cleanMod m newm = modify . change <$> newm - where - 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 - -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 - -halveModExpr :: Replace ModItem -halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca -halveModExpr a = Single a - --- | Remove all the undefined mod instances. -cleanModInst :: SourceInfo -> SourceInfo -cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned - where - validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId - cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped - --- | Clean all the undefined module instances in a specific module using a --- context. -cleanModInst' :: [Identifier] -> ModDecl -> ModDecl -cleanModInst' ids m = m & modItems .~ newModItem - where newModItem = filter (validModInst ids) $ m ^.. modItems . traverse - --- | Check if a mod instance is in the current context. -validModInst :: [Identifier] -> ModItem -> Bool -validModInst ids (ModInst i _ _) = i `elem` ids -validModInst _ _ = True - --- | Adds a 'ModDecl' to a 'SourceInfo'. -addMod :: ModDecl -> SourceInfo -> SourceInfo -addMod m srcInfo = srcInfo & infoSrc . _Wrapped %~ (m :) - --- | Split a module declaration in half by trying to remove assign --- statements. This is only done in the main module of the source. -halveAssigns :: Replace SourceInfo -halveAssigns = combine mainModule halveModAssign - --- | Checks if a module item is needed in the module declaration. -relevantModItem :: ModDecl -> ModItem -> Bool -relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) = - i `elem` fmap _portName out -relevantModItem _ Decl{} = True -relevantModItem _ _ = False - -isAssign :: Statement -> Bool -isAssign (BlockAssign _) = True -isAssign (NonBlockAssign _) = True -isAssign _ = False - -lValName :: LVal -> [Identifier] -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 - --- | 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 (RangeSelect i _) = [i] -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 (RangeSelect i _) = Just i -exprId _ = Nothing - -eventId :: Event -> Maybe Identifier -eventId (EId i) = Just i -eventId (EPosEdge i) = Just i -eventId (ENegEdge i) = Just i -eventId _ = Nothing - -portToId :: Port -> Identifier -portToId (Port _ _ _ i) = i - -paramToId :: Parameter -> Identifier -paramToId (Parameter i _) = i - -isModule :: Identifier -> ModDecl -> Bool -isModule i (ModDecl n _ _ _ _) = i == n - -modInstActive :: [ModDecl] -> ModItem -> [Identifier] -modInstActive decl (ModInst n _ i) = case m of - 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 _ _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName o = exprName e - | otherwise = [] -modInstActive _ _ = [] - -fixModInst :: SourceInfo -> ModItem -> ModItem -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 ..] - 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 - fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _) - | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e - | otherwise = Nothing -fixModInst _ a = a - -findActiveWires :: Identifier -> SourceInfo -> [Identifier] -findActiveWires t src = - 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) - allStat = filter isAssign . concat $ fmap universe stat - stat = - (m ^.. modItems . traverse . _Initial) - <> (m ^.. modItems . traverse . _Always) - modinstwires = - 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 --- 'SourceInfo', otherwise it will crash. -cleanSourceInfo :: Identifier -> SourceInfo -> SourceInfo -cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) - -cleanSourceInfoAll :: SourceInfo -> SourceInfo -cleanSourceInfoAll src = foldr cleanSourceInfo src allMods - where allMods = src ^.. infoSrc . _Wrapped . traverse . modId - --- | Returns true if the text matches the name of a module. -matchesModName :: Identifier -> ModDecl -> Bool -matchesModName top (ModDecl i _ _ _ _) = top == i - -halveStatement :: Replace Statement -halveStatement (SeqBlock [s]) = halveStatement s -halveStatement (SeqBlock s) = SeqBlock <$> halve s -halveStatement (CondStmnt _ (Just s1) (Just s2)) = Dual s1 s2 -halveStatement (CondStmnt _ (Just s1) Nothing) = Single s1 -halveStatement (CondStmnt _ Nothing (Just s1)) = Single s1 -halveStatement (EventCtrl e (Just s)) = EventCtrl e . Just <$> halveStatement s -halveStatement (TimeCtrl e (Just s)) = TimeCtrl e . Just <$> halveStatement s -halveStatement a = Single a - -halveAlways :: Replace ModItem -halveAlways (Always s) = Always <$> halveStatement s -halveAlways a = Single a - --- | Removes half the modules randomly, until it reaches a minimal amount of --- modules. This is done by doing a binary search on the list of modules and --- removing the instantiations from the main module body. -halveModules :: Replace SourceInfo -halveModules srcInfo@(SourceInfo top _) = - cleanSourceInfoAll - . cleanModInst - . addMod main - <$> combine (infoSrc . _Wrapped) repl srcInfo - where - repl = halve . filter (not . matchesModName (Identifier top)) - main = srcInfo ^. mainModule - -moduleBot :: SourceInfo -> Bool -moduleBot (SourceInfo _ (Verilog [] )) = True -moduleBot (SourceInfo _ (Verilog [_])) = True -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 -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 - addRelevant = aModule t . modItems %~ (relevant ++) - -modItemBot :: Identifier -> SourceInfo -> Bool -modItemBot t srcInfo | length modItemsNoDecl > 2 = False - | otherwise = True - where - modItemsNoDecl = - filter noDecl $ srcInfo ^.. aModule t . modItems . traverse - noDecl Decl{} = False - noDecl _ = True - -halveStatements :: Identifier -> Replace SourceInfo -halveStatements t m = - cleanSourceInfo t <$> combine (aModule t . modItems) halves m - where halves = traverse halveAlways - --- | Reduce expressions by splitting them in half and keeping the half that --- succeeds. -halveExpr :: Identifier -> Replace SourceInfo -halveExpr t = combine contexpr $ traverse halveModExpr - where - contexpr :: Lens' SourceInfo [ModItem] - contexpr = aModule t . modItems - -toIds :: [Expr] -> [Identifier] -toIds = nub . mapMaybe exprId . concatMap universe - -toIdsConst :: [ConstExpr] -> [Identifier] -toIdsConst = toIds . fmap constToExpr - -toIdsEvent :: [Event] -> [Identifier] -toIdsEvent = nub . mapMaybe eventId . concatMap universe - -allStatIds' :: Statement -> [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) - eventProcessedIds = toIdsEvent $ s ^.. statEvent - -allStatIds :: Statement -> [Identifier] -allStatIds s = nub . concat $ allStatIds' <$> universe s - -fromRange :: Range -> [ConstExpr] -fromRange r = [rangeMSB r, rangeLSB r] - -allExprIds :: ModDecl -> [Identifier] -allExprIds m = - nub - $ contAssignIds - <> modInstIds - <> modInitialIds - <> modAlwaysIds - <> modPortIds - <> modDeclIds - <> paramIds - where - contAssignIds = - toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr - modInstIds = - toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr - modInitialIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial - modAlwaysIds = - nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always - modPortIds = - 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 - ) - -isUsedDecl :: [Identifier] -> ModItem -> Bool -isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids -isUsedDecl _ _ = True - -isUsedParam :: [Identifier] -> Parameter -> Bool -isUsedParam ids (Parameter i _) = i `elem` ids - -isUsedPort :: [Identifier] -> Port -> Bool -isUsedPort ids (Port _ _ _ i) = i `elem` ids - -removeDecl :: SourceInfo -> SourceInfo -removeDecl src = foldr fix removed allMods - where - removeDecl' t src' = - 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) - allMods = src ^.. infoSrc . _Wrapped . traverse . modId - fix t a = a & aModule t . modItems %~ fmap (fixModInst a) - removed = foldr removeDecl' src allMods - -defaultBot :: SourceInfo -> Bool -defaultBot = const False - --- | Reduction using custom reduction strategies. -reduce_ - :: MonadSh m - => Text - -> Replace SourceInfo - -> (SourceInfo -> Bool) - -> (SourceInfo -> m Bool) - -> SourceInfo - -> m SourceInfo -reduce_ title repl bot eval src = do - 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 src - else case repl src of - Single s -> do - red <- eval s - if red - then if cond s then recReduction s else return s - else return src - Dual l r -> do - red <- eval l - if red - then if cond l then recReduction l else return l - else do - red' <- eval r - if red' - then if cond r then recReduction r else return r - else return src - None -> return src - where - cond s = s /= src - recReduction = reduce_ title repl bot eval - --- | Reduce an input to a minimal representation. It follows the reduction --- strategy mentioned above. -reduce - :: MonadSh m - => (SourceInfo -> m Bool) -- ^ Failed or not. - -> SourceInfo -- ^ Input verilog source to be reduced. - -> m SourceInfo -- ^ Reduced output. -reduce eval src = - fmap removeDecl - $ red "Modules" moduleBot halveModules src - >>= redAll "Module Items" modItemBot halveModItems - >>= redAll "Statements" (const defaultBot) halveStatements - -- >>= redAll "Expressions" (const defaultBot) halveExpr - where - red s bot a = reduce_ s a bot eval - red' s bot a t = reduce_ s (a t) (bot t) eval - redAll s bot halve' src' = foldrM - (\t -> red' (s <> " (" <> getIdentifier t <> ")") bot halve' t) - src' - (src' ^.. infoSrc . _Wrapped . traverse . modId) - -runScript - :: MonadSh m => Shelly.FilePath -> Shelly.FilePath -> SourceInfo -> 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 - --- | Reduce using a script that is passed to it -reduceWithScript - :: (MonadSh m, MonadIO m) - => Text - -> Shelly.FilePath - -> Shelly.FilePath - -> m () -reduceWithScript top script file = do - liftSh . Shelly.cp file $ file <.> "original" - srcInfo <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file - void $ reduce (runScript script file) srcInfo - --- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it. -reduceSynth - :: (Synthesiser a, Synthesiser b, MonadSh m) - => a - -> b - -> SourceInfo - -> m SourceInfo -reduceSynth a b = reduce synth - where - synth src' = liftSh $ do - r <- runResultT $ do - runSynth a src' - runSynth b src' - runEquiv a b src' - return $ case r of - Fail EquivFail -> True - Fail _ -> False - Pass _ -> False - -reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo -> m SourceInfo -reduceSynthesis a = reduce synth - where - synth src = liftSh $ do - r <- runResultT $ runSynth a src - return $ case r of - Fail SynthFail -> True - Fail _ -> False - Pass _ -> False diff --git a/src/VeriSmith/Report.hs b/src/VeriSmith/Report.hs deleted file mode 100644 index fe680c3..0000000 --- a/src/VeriSmith/Report.hs +++ /dev/null @@ -1,398 +0,0 @@ -{-# 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 TemplateHaskell #-} - -module VeriSmith.Report - ( SynthTool(..) - , SynthStatus(..) - , SynthResult(..) - , SimResult(..) - , SimTool(..) - , FuzzReport(..) - , printResultReport - , printSummary - , synthResults - , simResults - , synthStatus - , equivTime - , fuzzDir - , fileLines - , reducTime - , synthTime - , defaultIcarusSim - , defaultVivadoSynth - , defaultYosysSynth - , defaultXSTSynth - , defaultQuartusSynth - , 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 Data.Vector (fromList) -import Prelude hiding (FilePath) -import Shelly (FilePath, fromText, - toTextIgnore, (<.>), ()) -import Statistics.Sample (meanVariance) -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.Sim -import VeriSmith.Sim.Internal - --- | Common type alias for synthesis results -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 - | 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 (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 (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 (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 (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 (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 (IdentitySynth identity) = IdentitySynth . setSynthOutput identity - -defaultYosysSynth :: SynthTool -defaultYosysSynth = YosysSynth defaultYosys - -defaultQuartusSynth :: SynthTool -defaultQuartusSynth = QuartusSynth defaultQuartus - -defaultVivadoSynth :: SynthTool -defaultVivadoSynth = VivadoSynth defaultVivado - -defaultXSTSynth :: SynthTool -defaultXSTSynth = XSTSynth defaultXST - -defaultIdentitySynth :: SynthTool -defaultIdentitySynth = IdentitySynth defaultIdentity - -newtype SimTool = IcarusSim Icarus - deriving (Eq) - -instance NFData SimTool where - rnf (IcarusSim a) = rnf a - -instance Tool SimTool where - toText (IcarusSim icarus) = toText icarus - -instance Simulator SimTool where - runSim (IcarusSim icarus) = runSim icarus - runSimWithFile (IcarusSim icarus) = runSimWithFile icarus - -instance Show SimTool where - show (IcarusSim icarus) = show icarus - -defaultIcarusSim :: SimTool -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 !BResult !NominalDiffTime - 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 <> ")" - -getSimResult :: SimResult -> UResult -getSimResult (SimResult _ _ (Pass _) _) = Pass () -getSimResult (SimResult _ _ (Fail b) _) = Fail b - --- | The results of comparing the synthesised outputs of two files using a --- 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) - -instance Show SynthResult where - show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" - -getSynthResult :: SynthResult -> UResult -getSynthResult (SynthResult _ _ a _) = a - --- | The status of the synthesis using a simulator. This will be checked before --- attempting to run the equivalence checks on the simulator, as that would be --- unnecessary otherwise. -data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime - 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 <> ")" - --- | The complete state that will be used during fuzzing, which contains the --- results from all the operations. -data FuzzReport = FuzzReport { _fuzzDir :: !FilePath - , _synthResults :: ![SynthResult] - , _simResults :: ![SimResult] - , _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 <> "'" - --- | 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 -descriptionToSynth (SynthDescription "vivado" bin desc 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 -descriptionToSynth (SynthDescription "quartus" bin desc out) = - QuartusSynth - . Quartus (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 -descriptionToSynth 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 (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" - -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 - -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 - -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" - -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 - -resultStatus :: Result a b -> Html -resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" -resultStatus (Fail _) = H.td ! A.class_ "is-danger" $ "Failed" - -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 = fromList . 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 - ! A.href - ( H.textValue - $ toTextIgnore (dir fromText "index" <.> "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 - ] - 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 - -printResultReport :: Text -> FuzzReport -> Text -printResultReport t f = toStrict . renderHtml $ resultReport t f - -printSummary :: Text -> [FuzzReport] -> Text -printSummary t f = toStrict . renderHtml $ summary t f diff --git a/src/VeriSmith/Result.hs b/src/VeriSmith/Result.hs deleted file mode 100644 index 7bfbf9b..0000000 --- a/src/VeriSmith/Result.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-| -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 MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module VeriSmith.Result - ( Result(..) - , ResultT(..) - , () - , annotate - ) -where - -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, liftSh) - --- | 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) - -instance Semigroup (Result a b) where - Pass _ <> a = a - a <> _ = a - -instance (Monoid b) => Monoid (Result a b) where - mempty = Pass mempty - -instance Functor (Result a) where - 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 - -instance Monad (Result a) where - Pass a >>= f = f a - Fail b >>= _ = Fail b - -instance MonadBase (Result a) (Result a) where - liftBase = id - -instance Bifunctor Result where - 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) } - -instance Functor f => Functor (ResultT a f) where - 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) - -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) - -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)) - -instance MonadIO m => MonadIO (ResultT a m) where - liftIO s = ResultT $ Pass <$> liftIO s - -instance MonadBase b m => MonadBase b (ResultT a m) where - liftBase = liftBaseDefault - -instance MonadTrans (ResultT e) where - 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 #-} - -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 #-} - -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 - -annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b -annotate = flip () diff --git a/src/VeriSmith/Sim.hs b/src/VeriSmith/Sim.hs deleted file mode 100644 index f0489d3..0000000 --- a/src/VeriSmith/Sim.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : VeriSmith.Sim -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.Sim - ( - -- * Simulators - -- ** Icarus - Icarus(..) - , defaultIcarus - -- * Synthesisers - -- ** Yosys - , Yosys(..) - , defaultYosys - -- ** Vivado - , Vivado(..) - , defaultVivado - -- ** XST - , XST(..) - , defaultXST - -- ** Quartus - , Quartus(..) - , defaultQuartus - -- ** Identity - , Identity(..) - , defaultIdentity - -- * Equivalence - , runEquiv - -- * Simulation - , runSim - -- * Synthesis - , runSynth - , logger - ) -where - -import VeriSmith.Sim.Icarus -import VeriSmith.Sim.Identity -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Quartus -import VeriSmith.Sim.Vivado -import VeriSmith.Sim.XST -import VeriSmith.Sim.Yosys diff --git a/src/VeriSmith/Sim/Icarus.hs b/src/VeriSmith/Sim/Icarus.hs deleted file mode 100644 index f104630..0000000 --- a/src/VeriSmith/Sim/Icarus.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-| -Module : VeriSmith.Sim.Icarus -Description : Icarus verilog module. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Icarus verilog module. --} - -module VeriSmith.Sim.Icarus - ( Icarus(..) - , defaultIcarus - , runSimIc - ) -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.Sim.Internal -import VeriSmith.Sim.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) - -instance Show Icarus where - show _ = "iverilog" - -instance Tool Icarus where - toText _ = "iverilog" - -instance Simulator Icarus where - runSim = runSimIcarus - runSimWithFile = runSimIcarusWithFile - -instance NFData Icarus where - rnf = rwhnf - -defaultIcarus :: Icarus -defaultIcarus = Icarus "iverilog" "vvp" - -addDisplay :: [Statement] -> [Statement] -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 -assignFunc inp bs = - 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 - -mask :: Text -> Text -mask = T.replace "x" "0" - -callback :: ByteString -> Text -> ByteString -callback b t = b <> convert (mask t) - -runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss - where m = rinfo ^. mainModule - -runSimIcarusWithFile - :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString -runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) - -fromBytes :: ByteString -> Integer -fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b - -runSimIc - :: (Synthesiser b) - => Icarus - -> b - -> SourceInfo - -> [ByteString] - -> ResultSh ByteString -runSimIc sim1 synth1 srcInfo bss = do - dir <- liftSh pwd - let top = srcInfo ^. mainModule - let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) - let - tb = 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 - ) - <> (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"] - ] - [] - - liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 - liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] - liftSh - $ B.take 8 - . BA.convert - . (hash :: ByteString -> Digest SHA256) - <$> logCommand - dir - "vvp" - (runFoldLines (mempty :: ByteString) - callback - (vvpPath sim1) - ["main"] - ) - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriSmith/Sim/Identity.hs b/src/VeriSmith/Sim/Identity.hs deleted file mode 100644 index cac230f..0000000 --- a/src/VeriSmith/Sim/Identity.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Identity - ( 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.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text - , identityOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Identity where - toText (Identity d _) = d - -instance Show Identity where - show t = unpack $ toText t - -instance Synthesiser Identity where - runSynth = runSynthIdentity - synthOutput = identityOutput - setSynthOutput (Identity a _) = Identity a - -instance NFData Identity where - rnf = rwhnf - -runSynthIdentity :: Identity -> SourceInfo -> ResultSh () -runSynthIdentity (Identity _ out) = writefile out . genSource - -defaultIdentity :: Identity -defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/VeriSmith/Sim/Internal.hs b/src/VeriSmith/Sim/Internal.hs deleted file mode 100644 index 017faad..0000000 --- a/src/VeriSmith/Sim/Internal.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| -Module : VeriSmith.Sim.Internal -Description : Class of the simulator. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Class of the simulator and the synthesize tool. --} - -{-# LANGUAGE DeriveFunctor #-} - -module VeriSmith.Sim.Internal - ( 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.Internal -import VeriSmith.Result -import VeriSmith.Verilog.AST - --- | Tool class. -class Tool a where - toText :: a -> Text - --- | Simulation type class. -class Tool a => Simulator a where - runSim :: a -- ^ Simulator instance - -> SourceInfo -- ^ 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 - | EquivError - | SimFail - | SynthFail - | TimeoutError - deriving (Eq, Show) - -instance Semigroup Failed where - EmptyFail <> a = a - b <> _ = b - -instance Monoid Failed where - mempty = EmptyFail - --- | Synthesiser type class. -class Tool a => Synthesiser a where - runSynth :: a -- ^ Synthesiser tool instance - -> SourceInfo -- ^ Run information - -> ResultSh () -- ^ does not return any values - synthOutput :: a -> FilePath - setSynthOutput :: a -> FilePath -> a - -renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo -renameSource a src = - 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 --- with also has those instances. -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' - -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 - --- | 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 -> Sh [Text] -checkPresentModules fp (SourceInfo _ src) = do - 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] - --- | 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 --- should find all the instantiations and definitions. This could again be made --- much simpler if the parser works. -replaceMods :: FilePath -> Text -> SourceInfo -> Sh () -replaceMods fp t (SourceInfo _ src) = - 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" - -timeout :: FilePath -> [Text] -> Sh Text -timeout = command1 "timeout" ["300"] . toTextIgnore -{-# INLINE timeout #-} - -timeout_ :: FilePath -> [Text] -> Sh () -timeout_ = command1_ "timeout" ["300"] . toTextIgnore -{-# INLINE timeout_ #-} - --- | Helper function to convert bytestrings to integers -bsToI :: ByteString -> Integer -bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 -{-# INLINE bsToI #-} - -noPrint :: Sh a -> Sh a -noPrint = print_stdout False . print_stderr False -{-# INLINE noPrint #-} - -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 - -logCommand :: FilePath -> Text -> Sh a -> Sh a -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" - file s = T.unpack (toTextIgnore $ fp fromText name) <> s - -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 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 () -execute_ a b c d = void . execute a b c d diff --git a/src/VeriSmith/Sim/Quartus.hs b/src/VeriSmith/Sim/Quartus.hs deleted file mode 100644 index 6837133..0000000 --- a/src/VeriSmith/Sim/Quartus.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Quartus - ( 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.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Quartus = Quartus { quartusBin :: !(Maybe FilePath) - , quartusDesc :: {-# UNPACK #-} !Text - , quartusOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Quartus where - toText (Quartus _ t _) = t - -instance Show Quartus where - show t = unpack $ toText t - -instance Synthesiser Quartus where - runSynth = runSynthQuartus - synthOutput = quartusOutput - setSynthOutput (Quartus a b _) = Quartus a b - -instance NFData Quartus where - rnf = rwhnf - -defaultQuartus :: Quartus -defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" - -runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () -runSynthQuartus sim (SourceInfo top src) = do - dir <- liftSh pwd - let ex = execute_ SynthFail dir "quartus" - liftSh . writefile inpf $ genSource src - liftSh . noPrint $ run_ - "sed" - [ "-i" - , "s/^module/(* multstyle = \"logic\" *) module/;" - , toTextIgnore inpf - ] - ex (exec "quartus_map") - [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] - ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] - ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] - 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/Sim/Template.hs b/src/VeriSmith/Sim/Template.hs deleted file mode 100644 index d232420..0000000 --- a/src/VeriSmith/Sim/Template.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Template - ( yosysSatConfig - , yosysSimConfig - , xstSynthConfig - , vivadoSynthConfig - , sbyConfig - , icarusTestbench - ) -where - -import Control.Lens ((^..)) -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (FilePath) -import Shelly -import Text.Shakespeare.Text (st) -import VeriSmith.Sim.Internal -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -rename :: Text -> [Text] -> Text -rename end entries = - T.intercalate "\n" - $ flip mappend end - . mappend "rename " - . doubleName - <$> entries -{-# INLINE rename #-} - -doubleName :: Text -> Text -doubleName n = n <> " " <> n -{-# INLINE doubleName #-} - -outputText :: Synthesiser a => a -> Text -outputText = toTextIgnore . synthOutput - --- brittany-disable-next-binding -yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 - --- brittany-disable-next-binding -yosysSimConfig :: Text -yosysSimConfig = [st|read_verilog rtl.v; proc;; -rename mod mod_rtl -|] - --- brittany-disable-next-binding -xstSynthConfig :: Text -> Text -xstSynthConfig top = [st|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" -|] - --- brittany-disable-next-binding -vivadoSynthConfig :: Text -> Text -> Text -vivadoSynthConfig top outf = [st| -# 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} -|] - --- brittany-disable-next-binding -sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] -multiclock on -mode prove - -[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 - . (fromText "data" ) - . fromText - <$> deps - readL = T.intercalate "\n" $ mappend "read -formal " <$> deps - -icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text -icarusTestbench t synth1 = [st| -`include "data/cells_cmos.v" -`include "data/cells_cyclone_v.v" -`include "data/cells_verific.v" -`include "data/cells_xilinx_7.v" -`include "data/cells_yosys.v" -`include "#{toTextIgnore $ synthOutput synth1}" - -#{genSource t} -|] diff --git a/src/VeriSmith/Sim/Vivado.hs b/src/VeriSmith/Sim/Vivado.hs deleted file mode 100644 index e8d8f0d..0000000 --- a/src/VeriSmith/Sim/Vivado.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-| -Module : VeriSmith.Sim.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.Sim.Vivado - ( 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.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) - , vivadoDesc :: {-# UNPACK #-} !Text - , vivadoOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Vivado where - toText (Vivado _ t _) = t - -instance Show Vivado where - show t = unpack $ toText t - -instance Synthesiser Vivado where - runSynth = runSynthVivado - synthOutput = vivadoOutput - setSynthOutput (Vivado a b _) = Vivado a b - -instance NFData Vivado where - rnf = rwhnf - -defaultVivado :: Vivado -defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" - -runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/VeriSmith/Sim/XST.hs b/src/VeriSmith/Sim/XST.hs deleted file mode 100644 index 30a4b0b..0000000 --- a/src/VeriSmith/Sim/XST.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| -Module : VeriSmith.Sim.XST -Description : XST (ise) simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -XST (ise) simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module VeriSmith.Sim.XST - ( 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 Text.Shakespeare.Text (st) -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen - -data XST = XST { xstBin :: !(Maybe FilePath) - , xstDesc :: {-# UNPACK #-} !Text - , xstOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool XST where - toText (XST _ t _) = t - -instance Show XST where - show t = unpack $ toText t - -instance Synthesiser XST where - runSynth = runSynthXST - synthOutput = xstOutput - setSynthOutput (XST a b _) = XST a b - -instance NFData XST where - rnf = rwhnf - -defaultXST :: XST -defaultXST = XST Nothing "xst" "syn_xst.v" - -runSynthXST :: XST -> SourceInfo -> 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 [st|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" - prjFile = modFile <.> "prj" diff --git a/src/VeriSmith/Sim/Yosys.hs b/src/VeriSmith/Sim/Yosys.hs deleted file mode 100644 index 1f583a8..0000000 --- a/src/VeriSmith/Sim/Yosys.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-| -Module : VeriSmith.Sim.Yosys -Description : Yosys simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Yosys simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module VeriSmith.Sim.Yosys - ( Yosys(..) - , defaultYosys - , runEquiv - , runEquivYosys - ) -where - -import Control.DeepSeq (NFData, rnf, rwhnf) -import Control.Lens -import Control.Monad (void) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Text.Shakespeare.Text (st) -import VeriSmith.Result -import VeriSmith.Sim.Internal -import VeriSmith.Sim.Template -import VeriSmith.Verilog.AST -import VeriSmith.Verilog.CodeGen -import VeriSmith.Verilog.Mutate - -data Yosys = Yosys { yosysBin :: !(Maybe FilePath) - , yosysDesc :: {-# UNPACK #-} !Text - , yosysOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Yosys where - toText (Yosys _ t _) = t - -instance Show Yosys where - show t = unpack $ toText t - -instance Synthesiser Yosys where - runSynth = runSynthYosys - synthOutput = yosysOutput - setSynthOutput (Yosys a b _) = Yosys a b - -instance NFData Yosys where - rnf = rwhnf - -defaultYosys :: Yosys -defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" - -yosysPath :: Yosys -> FilePath -yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim - -runSynthYosys :: Yosys -> SourceInfo -> ResultSh () -runSynthYosys sim (SourceInfo _ src) = do - dir <- liftSh $ do - dir' <- pwd - 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 = toTextIgnore inpf - out = toTextIgnore $ synthOutput sim - -runEquivYosys - :: (Synthesiser a, Synthesiser b) - => Yosys - -> a - -> b - -> SourceInfo - -> ResultSh () -runEquivYosys yosys sim1 sim2 srcInfo = do - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTop 2 - $ srcInfo - ^. mainModule - writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo - runSynth sim1 srcInfo - runSynth sim2 srcInfo - liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] - where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] - -runEquiv - :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () -runEquiv sim1 sim2 srcInfo = do - dir <- liftSh pwd - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTopAssert - $ srcInfo - ^. mainModule - replaceMods (synthOutput sim1) "_1" srcInfo - replaceMods (synthOutput sim2) "_2" srcInfo - writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo - e <- liftSh $ do - exe dir "symbiyosys" "sby" ["-f", "proof.sby"] - lastExitCode - case e of - 0 -> ResultT . return $ Pass () - 2 -> ResultT . return $ Fail EquivFail - 124 -> ResultT . return $ Fail TimeoutError - _ -> ResultT . return $ Fail EquivError - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/VeriSmith/Verilog.hs b/src/VeriSmith/Verilog.hs deleted file mode 100644 index 6e7851c..0000000 --- a/src/VeriSmith/Verilog.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-| -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 - ( SourceInfo(..) - , Verilog(..) - , parseVerilog - , GenVerilog(..) - , genSource - -- * Primitives - -- ** Identifier - , Identifier(..) - -- ** Control - , Delay(..) - , Event(..) - -- ** Operators - , BinaryOperator(..) - , UnaryOperator(..) - -- ** Task - , Task(..) - , taskName - , taskExpr - -- ** Left hand side value - , LVal(..) - , regId - , regExprId - , regExpr - , regSizeId - , regSizeRange - , regConc - -- ** Ports - , PortDir(..) - , PortType(..) - , Port(..) - , portType - , portSigned - , portSize - , portName - -- * Expression - , Expr(..) - , ConstExpr(..) - , constToExpr - , exprToConst - , constNum - -- * Assignment - , Assign(..) - , assignReg - , assignDelay - , assignExpr - , ContAssign(..) - , contAssignNetLVal - , contAssignExpr - -- * Statment - , 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 - -- * Useful Lenses and Traversals - , getModule - , getSourceId - -- * Quote - , verilog - ) -where - -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 deleted file mode 100644 index 78bad45..0000000 --- a/src/VeriSmith/Verilog/AST.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-| -Module : VeriSmith.Verilog.AST -Description : Definition of the Verilog AST types. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module VeriSmith.Verilog.AST - ( -- * Top level types - SourceInfo(..) - , infoTop - , infoSrc - , Verilog(..) - -- * Primitives - -- ** Identifier - , Identifier(..) - -- ** Control - , Delay(..) - , Event(..) - -- ** Operators - , BinaryOperator(..) - , UnaryOperator(..) - -- ** Task - , Task(..) - , taskName - , taskExpr - -- ** Left hand side value - , LVal(..) - , regId - , regExprId - , regExpr - , regSizeId - , regSizeRange - , regConc - -- ** Ports - , 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 - -- * Assignment - , Assign(..) - , assignReg - , assignDelay - , assignExpr - , ContAssign(..) - , contAssignNetLVal - , contAssignExpr - -- ** Parameters - , Parameter(..) - , paramIdent - , paramValue - , LocalParam(..) - , localParamIdent - , localParamValue - -- * Statment - , Statement(..) - , statDelay - , statDStat - , statEvent - , statEStat - , statements - , stmntBA - , stmntNBA - , stmntTask - , stmntSysTask - , stmntCondExpr - , stmntCondTrue - , stmntCondFalse - , 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 - -- * Useful Lenses and Traversals - , aModule - , getModule - , getSourceId - , mainModule - ) -where - -import Control.DeepSeq (NFData) -import Control.Lens hiding ((<|)) -import Data.Data -import Data.Data.Lens -import Data.Functor.Foldable.TH (makeBaseFunctor) -import Data.List.NonEmpty (NonEmpty (..), (<|)) -import Data.String (IsString, fromString) -import Data.Text (Text, pack) -import Data.Traversable (sequenceA) -import GHC.Generics (Generic) -import VeriSmith.Verilog.BitVec - --- | 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) - -instance IsString Identifier where - fromString = Identifier . pack - -instance Semigroup Identifier where - Identifier a <> Identifier b = Identifier $ a <> b - -instance Monoid Identifier where - mempty = Identifier mempty - --- | Verilog syntax for adding a delay, which is represented as @#num@. -newtype Delay = Delay { _getDelay :: Int } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Num Delay where - Delay a + Delay b = Delay $ a + b - Delay a - Delay b = Delay $ a - b - Delay a * Delay b = Delay $ a * b - negate (Delay a) = Delay $ negate a - abs (Delay a) = Delay $ abs a - signum (Delay a) = Delay $ signum a - fromInteger = Delay . fromInteger - --- | 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) - -instance Plated Event where - 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) - --- | 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) - --- | Verilog expression, which can either be a primary expression, unary --- expression, binary operator expression or a conditional expression. -data Expr = Number {-# UNPACK #-} !BitVec - -- ^ Number implementation containing the size and the value itself - | Id {-# UNPACK #-} !Identifier - | VecSelect {-# UNPACK #-} !Identifier !Expr - | RangeSelect {-# UNPACK #-} !Identifier !Range - -- ^ Symbols - | Concat !(NonEmpty Expr) - -- ^ Bit-wise concatenation of expressions represented by braces. - | UnOp !UnaryOperator !Expr - | BinOp !Expr !BinaryOperator !Expr - | Cond !Expr !Expr !Expr - | Appl !Identifier !Expr - | Str {-# UNPACK #-} !Text - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Num Expr where - a + b = BinOp a BinPlus b - a - b = BinOp a BinMinus b - a * b = BinOp a BinTimes b - negate = UnOp UnMinus - abs = undefined - signum = undefined - fromInteger = Number . fromInteger - -instance Semigroup Expr where - (Concat a) <> (Concat b) = Concat $ a <> b - (Concat a) <> b = Concat $ a <> (b :| []) - a <> (Concat b) = Concat $ a <| b - a <> b = Concat $ a <| b :| [] - -instance Monoid Expr where - mempty = Number 0 - -instance IsString Expr where - fromString = Str . fromString - -instance Plated Expr where - plate = uniplate - --- | 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) - -constToExpr :: ConstExpr -> Expr -constToExpr (ConstNum a ) = Number a -constToExpr (ParamId a ) = Id a -constToExpr (ConstConcat a ) = Concat $ fmap constToExpr a -constToExpr (ConstUnOp a b ) = UnOp a $ constToExpr b -constToExpr (ConstBinOp a b c) = BinOp (constToExpr a) b $ constToExpr c -constToExpr (ConstCond a b c) = - Cond (constToExpr a) (constToExpr b) $ constToExpr c -constToExpr (ConstStr a) = Str a - -exprToConst :: Expr -> ConstExpr -exprToConst (Number a ) = ConstNum a -exprToConst (Id a ) = ParamId a -exprToConst (Concat a ) = ConstConcat $ fmap exprToConst a -exprToConst (UnOp a b ) = ConstUnOp a $ exprToConst b -exprToConst (BinOp a b c) = ConstBinOp (exprToConst a) b $ exprToConst c -exprToConst (Cond a b c) = - ConstCond (exprToConst a) (exprToConst b) $ exprToConst c -exprToConst (Str a) = ConstStr a -exprToConst _ = error "Not a constant expression" - -instance Num ConstExpr where - a + b = ConstBinOp a BinPlus b - a - b = ConstBinOp a BinMinus b - a * b = ConstBinOp a BinTimes b - negate = ConstUnOp UnMinus - abs = undefined - signum = undefined - fromInteger = ConstNum . fromInteger - -instance Semigroup ConstExpr where - (ConstConcat a) <> (ConstConcat b) = ConstConcat $ a <> b - (ConstConcat a) <> b = ConstConcat $ a <> (b :| []) - a <> (ConstConcat b) = ConstConcat $ a <| b - a <> b = ConstConcat $ a <| b :| [] - -instance Monoid ConstExpr where - mempty = ConstNum 0 - -instance IsString ConstExpr where - fromString = ConstStr . fromString - -instance Plated ConstExpr where - plate = uniplate - -data Task = Task { _taskName :: {-# UNPACK #-} !Identifier - , _taskExpr :: [Expr] - } deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | Type that represents the left hand side of an assignment, which can be a --- concatenation such as in: --- --- @ --- {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) - -instance IsString LVal where - fromString = RegId . fromString - --- | Different port direction that are supported in Verilog. -data PortDir = PortIn -- ^ Input direction for port (@input@). - | PortOut -- ^ Output direction for port (@output@). - | PortInOut -- ^ Inout direction for port (@inout@). - 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) - --- | 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) - -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 - --- | 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 --- an input or output port. However, this is not always necessary and was more --- cumbersome than useful, as a lot of ports can be declared without input and --- output port. --- --- This is now implemented inside 'ModDecl' 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) - --- | This is currently a type because direct module declaration should also be --- added: --- --- @ --- 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 ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier - , _contAssignExpr :: !Expr - } deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | Statements in Verilog. -data Statement = TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay - , _statDStat :: Maybe Statement - } -- ^ Time control (@#NUM@) - | EventCtrl { _statEvent :: !Event - , _statEStat :: Maybe Statement - } - | SeqBlock { _statements :: [Statement] } -- ^ Sequential block (@begin ... end@) - | BlockAssign { _stmntBA :: !Assign } -- ^ blocking assignment (@=@) - | NonBlockAssign { _stmntNBA :: !Assign } -- ^ Non blocking assignment (@<=@) - | TaskEnable { _stmntTask :: !Task } - | SysTaskEnable { _stmntSysTask :: !Task } - | CondStmnt { _stmntCondExpr :: Expr - , _stmntCondTrue :: Maybe Statement - , _stmntCondFalse :: Maybe Statement - } - | ForLoop { _forAssign :: !Assign - , _forExpr :: Expr - , _forIncr :: !Assign - , _forStmnt :: Statement - } -- ^ Loop bounds shall be statically computable for a for loop. - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Plated Statement where - plate = uniplate - -instance Semigroup Statement where - (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b - (SeqBlock a) <> b = SeqBlock $ a <> [b] - a <> (SeqBlock b) = SeqBlock $ a : b - a <> b = SeqBlock [a, b] - -instance Monoid Statement where - mempty = SeqBlock [] - --- | 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) - --- | 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) - --- | Module item which is the body of the module expression. -data ModItem = ModCA { _modContAssign :: !ContAssign } - | ModInst { _modInstId :: {-# UNPACK #-} !Identifier - , _modInstName :: {-# UNPACK #-} !Identifier - , _modInstConns :: [ModConn] - } - | Initial !Statement - | Always !Statement - | Decl { _declDir :: !(Maybe PortDir) - , _declPort :: !Port - , _declVal :: Maybe ConstExpr - } - | ParamDecl { _paramDecl :: NonEmpty Parameter } - | LocalParamDecl { _localParamDecl :: NonEmpty LocalParam } - deriving (Eq, Show, Ord, Data, Generic, NFData) - --- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module' -data ModDecl = ModDecl { _modId :: {-# UNPACK #-} !Identifier - , _modOutPorts :: ![Port] - , _modInPorts :: ![Port] - , _modItems :: ![ModItem] - , _modParams :: ![Parameter] - } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn -traverseModConn f (ModConn e ) = ModConn <$> f e -traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e - -traverseModItem :: (Applicative f) => (Expr -> f Expr) -> ModItem -> f ModItem -traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e -traverseModItem f (ModInst a b e) = - ModInst a b <$> sequenceA (traverseModConn f <$> e) -traverseModItem _ e = pure e - --- | The complete sourcetext for the Verilog module. -newtype Verilog = Verilog { getVerilog :: [ModDecl] } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -instance Semigroup Verilog where - Verilog a <> Verilog b = Verilog $ a <> b - -instance Monoid Verilog where - mempty = Verilog mempty - -data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text - , _infoSrc :: !Verilog - } - deriving (Eq, Show, Ord, Data, Generic, NFData) - -$(makeLenses ''Expr) -$(makeLenses ''ConstExpr) -$(makeLenses ''Task) -$(makeLenses ''LVal) -$(makeLenses ''PortType) -$(makeLenses ''Port) -$(makeLenses ''ModConn) -$(makeLenses ''Assign) -$(makeLenses ''ContAssign) -$(makeLenses ''Statement) -$(makeLenses ''ModItem) -$(makeLenses ''Parameter) -$(makeLenses ''LocalParam) -$(makeLenses ''ModDecl) -$(makeLenses ''SourceInfo) -$(makeWrapped ''Verilog) -$(makeWrapped ''Identifier) -$(makeWrapped ''Delay) -$(makePrisms ''ModItem) - -$(makeBaseFunctor ''Event) -$(makeBaseFunctor ''Expr) -$(makeBaseFunctor ''ConstExpr) - -getModule :: Traversal' Verilog ModDecl -getModule = _Wrapped . traverse -{-# INLINE getModule #-} - -getSourceId :: Traversal' Verilog Text -getSourceId = getModule . modId . _Wrapped -{-# INLINE getSourceId #-} - --- | May need to change this to Traversal to be safe. For now it will fail when --- the main has not been properly set with. -aModule :: Identifier -> Lens' SourceInfo ModDecl -aModule t = lens get_ set_ - where - set_ (SourceInfo top main) v = - SourceInfo top (main & getModule %~ update (getIdentifier t) v) - update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v - | otherwise = m - get_ (SourceInfo _ main) = - head . filter (f $ getIdentifier t) $ main ^.. getModule - f top (ModDecl (Identifier i) _ _ _ _) = i == top - - --- | 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 ModDecl -mainModule = lens get_ set_ - where - set_ (SourceInfo top main) v = - SourceInfo top (main & getModule %~ update top v) - update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v - | otherwise = m - get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule - f top (ModDecl (Identifier i) _ _ _ _) = i == top diff --git a/src/VeriSmith/Verilog/BitVec.hs b/src/VeriSmith/Verilog/BitVec.hs deleted file mode 100644 index dab9e2c..0000000 --- a/src/VeriSmith/Verilog/BitVec.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-| -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 DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} - -module VeriSmith.Verilog.BitVec - ( BitVecF(..) - , BitVec - , bitVec - , select - ) -where - -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) - --- | 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 - -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 - -instance (Integral a, Bits a) => Real (BitVecF a) where - 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 - -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 - -instance (Num a, Bits a) => FiniteBits (BitVecF a) where - finiteBitSize (BitVec w _) = w - -instance Bits a => Semigroup (BitVecF a) where - (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) - -instance Bits a => Monoid (BitVecF a) where - 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 (BitVec _ v) (msb, lsb) = - 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 - 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 - where - 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 deleted file mode 100644 index 1e94472..0000000 --- a/src/VeriSmith/Verilog/CodeGen.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-| -Module : VeriSmith.Verilog.CodeGen -Description : Code generation for Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 #-} - -module VeriSmith.Verilog.CodeGen - ( -- * 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 - --- | '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 --- can then be processed further. -class Source a where - genSource :: a -> Text - --- | Map a 'Maybe Statement' to 'Text'. If it is 'Just statement', the generated --- statements are returned. If it is 'Nothing', then @;\n@ is returned. -defMap :: Maybe Statement -> Doc a -defMap = maybe semi statement - --- | Convert the 'Verilog' type to 'Text' so that it can be rendered. -verilogSrc :: Verilog -> Doc a -verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules - --- | Generate the 'ModDecl' for a module and convert it to 'Text'. -moduleDecl :: ModDecl -> Doc a -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 - outIn = outP ++ inP - params [] = "" - params (p : pps) = hcat ["#", paramList (p :| pps)] - --- | Generates a parameter list. Can only be called with a 'NonEmpty' list. -paramList :: NonEmpty Parameter -> Doc a -paramList ps = tupled . toList $ parameter <$> ps - --- | Generates a localparam list. Can only be called with a 'NonEmpty' list. -localParamList :: NonEmpty LocalParam -> Doc a -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] - --- | Generates the assignment for a 'LocalParam'. -localParam :: LocalParam -> Doc a -localParam (LocalParam name val) = - hsep ["localparameter", identifier name, "=", constExpr val] - -identifier :: Identifier -> Doc a -identifier (Identifier i) = pretty i - --- | Conversts 'Port' to 'Text' for the module list, which means it only --- generates a list of identifiers. -modPort :: Port -> Doc a -modPort (Port _ _ _ i) = identifier i - --- | Generate the 'Port' description. -port :: Port -> Doc a -port (Port tp sgn r name) = hsep [t, sign, range r, identifier name] - where - t = pType tp - sign = signed sgn - -range :: Range -> Doc a -range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] - -signed :: Bool -> Doc a -signed True = "signed" -signed _ = mempty - --- | Convert the 'PortDir' type to 'Text'. -portDir :: PortDir -> Doc a -portDir PortIn = "input" -portDir PortOut = "output" -portDir PortInOut = "inout" - --- | Generate a 'ModItem'. -moduleItem :: ModItem -> Doc a -moduleItem (ModCA ca ) = contAssign ca -moduleItem (ModInst i name conn) = hsep - [ identifier i - , identifier name - , parens . hsep $ punctuate comma (mConn <$> conn) - , semi - ] -moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat] -moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat] -moduleItem (Decl dir p ini) = hsep - [maybe mempty makePort dir, port p, maybe mempty makeIni ini, semi] - where - makePort = portDir - makeIni = ("=" <+>) . constExpr -moduleItem (ParamDecl p) = hcat [paramList p, semi] -moduleItem (LocalParamDecl p) = hcat [localParamList p, semi] - -mConn :: ModConn -> Doc a -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) = - hsep ["assign", identifier val, "=", align $ expr e, semi] - --- | 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 (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c) -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]] -expr (Appl f e) = hcat [identifier f, parens $ expr e] -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) "")] - where - minus | signum n >= 0 = mempty - | otherwise = "-" - -constExpr :: ConstExpr -> Doc a -constExpr (ConstNum b) = showNum b -constExpr (ParamId i) = identifier i -constExpr (ConstConcat 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] -constExpr (ConstCond l t 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 BinXNorInv = "~^" -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 UnNxorInv = "^~" - -event :: Event -> Doc a -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 (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] - --- | Generates verilog code for a 'Delay'. -delay :: Delay -> Doc a -delay (Delay i) = "#" <> pretty i - --- | Generate the verilog code for an 'LVal'. -lVal :: LVal -> Doc a -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" - -genAssign :: Text -> Assign -> Doc a -genAssign op (Assign r d e) = - hsep [lVal r, pretty op, maybe mempty delay d, expr e] - -statement :: Statement -> Doc a -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] -statement (NonBlockAssign a) = hcat [genAssign "<=" a, 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] -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 - [ hsep - [ "for" - , parens . hsep $ punctuate - semi - [genAssign "=" a, expr e, genAssign "=" incr] - ] - , indent 2 $ statement stmnt - ] - -task :: Task -> Doc a -task (Task i 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 () -render = print . genSource - --- Instances - -instance Source Identifier where - genSource = showT . identifier - -instance Source Task where - genSource = showT . task - -instance Source Statement where - genSource = showT . statement - -instance Source PortType where - genSource = showT . pType - -instance Source ConstExpr where - genSource = showT . constExpr - -instance Source LVal where - genSource = showT . lVal - -instance Source Delay where - genSource = showT . delay - -instance Source Event where - genSource = showT . event - -instance Source UnaryOperator where - genSource = showT . unaryOp - -instance Source Expr where - genSource = showT . expr - -instance Source ContAssign where - genSource = showT . contAssign - -instance Source ModItem where - genSource = showT . moduleItem - -instance Source PortDir where - genSource = showT . portDir - -instance Source Port where - genSource = showT . port - -instance Source ModDecl where - genSource = showT . moduleDecl - -instance Source Verilog where - genSource = showT . verilogSrc - -instance Source SourceInfo where - genSource (SourceInfo _ src) = genSource src - -newtype GenVerilog a = GenVerilog { unGenVerilog :: a } - deriving (Eq, Ord, Data) - -instance (Source a) => Show (GenVerilog a) where - show = T.unpack . genSource . unGenVerilog diff --git a/src/VeriSmith/Verilog/Eval.hs b/src/VeriSmith/Verilog/Eval.hs deleted file mode 100644 index 1ebaa80..0000000 --- a/src/VeriSmith/Verilog/Eval.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-| -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 - ) -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 - -type Bindings = [Parameter] - -paramIdent_ :: Parameter -> Identifier -paramIdent_ (Parameter i _) = i - -paramValue_ :: Parameter -> ConstExpr -paramValue_ (Parameter _ v) = v - -applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a -applyUnary UnPlus a = a -applyUnary UnMinus a = negate a -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 - -compXor :: Bits c => c -> c -> c -compXor a = complement . xor a - -toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p -toIntegral a b c = if a b c then 1 else 0 - -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 BinXNorInv = compXor -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 -evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b -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 (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c -applyBitVec f (ConstBinOp a binop 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 -applyBitVec _ a = a - --- | This probably could be implemented using some recursion scheme in the --- future. It would also be fixed by having a polymorphic expression type. -resize :: Int -> ConstExpr -> ConstExpr -resize n = applyBitVec (resize' n) where resize' n' (BitVec _ a) = BitVec n' a diff --git a/src/VeriSmith/Verilog/Internal.hs b/src/VeriSmith/Verilog/Internal.hs deleted file mode 100644 index ed91b12..0000000 --- a/src/VeriSmith/Verilog/Internal.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-| -Module : VeriSmith.Verilog.Internal -Description : Defaults and common functions. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ) -where - -import Control.Lens -import Data.Text (Text) -import VeriSmith.Verilog.AST - -regDecl :: Identifier -> ModItem -regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing - -wireDecl :: Identifier -> ModItem -wireDecl i = Decl Nothing (Port Wire False (Range 1 0) i) Nothing - --- | Create an empty module. -emptyMod :: ModDecl -emptyMod = ModDecl "" [] [] [] [] - --- | Set a module name for a module declaration. -setModName :: Text -> ModDecl -> ModDecl -setModName str = modId .~ Identifier str - --- | Add a input port to the module declaration. -addModPort :: Port -> ModDecl -> ModDecl -addModPort port = modInPorts %~ (:) port - -addModDecl :: ModDecl -> Verilog -> Verilog -addModDecl desc = _Wrapped %~ (:) desc - -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 - ] - ] - [] - -addTestBench :: Verilog -> Verilog -addTestBench = addModDecl testBench - -defaultPort :: Identifier -> Port -defaultPort = Port Wire False (Range 1 0) - -portToExpr :: Port -> Expr -portToExpr (Port _ _ _ i) = Id i - -modName :: ModDecl -> Text -modName = getIdentifier . view modId - -yPort :: Identifier -> Port -yPort = Port Wire False (Range 90 0) - -wire :: Range -> Identifier -> Port -wire = Port Wire False - -reg :: Range -> Identifier -> Port -reg = Port Reg False diff --git a/src/VeriSmith/Verilog/Lex.x b/src/VeriSmith/Verilog/Lex.x deleted file mode 100644 index 3d1dd8d..0000000 --- a/src/VeriSmith/Verilog/Lex.x +++ /dev/null @@ -1,188 +0,0 @@ --- -*- haskell -*- -{ -{-# OPTIONS_GHC -w #-} -module VeriSmith.Verilog.Lex - ( alexScanTokens - ) where - -import VeriSmith.Verilog.Token - -} - -%wrapper "posn" - --- Numbers - -$nonZeroDecimalDigit = [1-9] -$decimalDigit = [0-9] -@binaryDigit = [0-1] -@octalDigit = [0-7] -@hexDigit = [0-9a-fA-F] - -@decimalBase = "'" [dD] -@binaryBase = "'" [bB] -@octalBase = "'" [oO] -@hexBase = "'" [hH] - -@binaryValue = @binaryDigit ("_" | @binaryDigit)* -@octalValue = @octalDigit ("_" | @octalDigit)* -@hexValue = @hexDigit ("_" | @hexDigit)* - -@unsignedNumber = $decimalDigit ("_" | $decimalDigit)* - -@size = @unsignedNumber - -@decimalNumber - = @unsignedNumber - | @size? @decimalBase @unsignedNumber - -@binaryNumber = @size? @binaryBase @binaryValue -@octalNumber = @size? @octalBase @octalValue -@hexNumber = @size? @hexBase @hexValue - --- $exp = [eE] --- $sign = [\+\-] --- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber -@number = @decimalNumber | @octalNumber | @binaryNumber | @hexNumber - --- Strings - -@string = \" [^\r\n]* \" - --- Identifiers - -@escapedIdentifier = "\" ($printable # $white)+ $white -@simpleIdentifier = [a-zA-Z_] [a-zA-Z0-9_\$]* -@systemIdentifier = "$" [a-zA-Z0-9_\$]+ - - -tokens :- - - "always" { tok KWAlways } - "assign" { tok KWAssign } - "begin" { tok KWBegin } - "case" { tok KWCase } - "default" { tok KWDefault } - "else" { tok KWElse } - "end" { tok KWEnd } - "endcase" { tok KWEndcase } - "endmodule" { tok KWEndmodule } - "for" { tok KWFor } - "if" { tok KWIf } - "initial" { tok KWInitial } - "inout" { tok KWInout } - "input" { tok KWInput } - "integer" { tok KWInteger } - "localparam" { tok KWLocalparam } - "module" { tok KWModule } - "negedge" { tok KWNegedge } - "or" { tok KWOr } - "output" { tok KWOutput } - "parameter" { tok KWParameter } - "posedge" { tok KWPosedge } - "reg" { tok KWReg } - "wire" { tok KWWire } - "signed" { tok KWSigned } - - @simpleIdentifier { tok IdSimple } - @escapedIdentifier { tok IdEscaped } - @systemIdentifier { tok IdSystem } - - @number { tok LitNumber } - @string { tok LitString } - - "(" { tok SymParenL } - ")" { tok SymParenR } - "[" { tok SymBrackL } - "]" { tok SymBrackR } - "{" { tok SymBraceL } - "}" { tok SymBraceR } - "~" { tok SymTildy } - "!" { tok SymBang } - "@" { tok SymAt } - "#" { tok SymPound } - "%" { tok SymPercent } - "^" { tok SymHat } - "&" { tok SymAmp } - "|" { tok SymBar } - "*" { tok SymAster } - "." { tok SymDot } - "," { tok SymComma } - ":" { tok SymColon } - ";" { tok SymSemi } - "=" { tok SymEq } - "<" { tok SymLt } - ">" { tok SymGt } - "+" { tok SymPlus } - "-" { tok SymDash } - "?" { tok SymQuestion } - "/" { tok SymSlash } - "$" { tok SymDollar } - "'" { tok SymSQuote } - - "~&" { tok SymTildyAmp } - "~|" { tok SymTildyBar } - "~^" { tok SymTildyHat } - "^~" { tok SymHatTildy } - "==" { tok SymEqEq } - "!=" { tok SymBangEq } - "&&" { tok SymAmpAmp } - "||" { tok SymBarBar } - "**" { tok SymAsterAster } - "<=" { tok SymLtEq } - ">=" { tok SymGtEq } - ">>" { tok SymGtGt } - "<<" { tok SymLtLt } - "++" { tok SymPlusPlus } - "--" { tok SymDashDash } - "+=" { tok SymPlusEq } - "-=" { tok SymDashEq } - "*=" { tok SymAsterEq } - "/=" { tok SymSlashEq } - "%=" { tok SymPercentEq } - "&=" { tok SymAmpEq } - "|=" { tok SymBarEq } - "^=" { tok SymHatEq } - "+:" { tok SymPlusColon } - "-:" { tok SymDashColon } - "::" { tok SymColonColon } - ".*" { tok SymDotAster } - "->" { tok SymDashGt } - ":=" { tok SymColonEq } - ":/" { tok SymColonSlash } - "##" { tok SymPoundPound } - "[*" { tok SymBrackLAster } - "[=" { tok SymBrackLEq } - "=>" { tok SymEqGt } - "@*" { tok SymAtAster } - "(*" { tok SymParenLAster } - "*)" { tok SymAsterParenR } - "*>" { tok SymAsterGt } - - "===" { tok SymEqEqEq } - "!==" { tok SymBangEqEq } - "=?=" { tok SymEqQuestionEq } - "!?=" { tok SymBangQuestionEq } - ">>>" { tok SymGtGtGt } - "<<<" { tok SymLtLtLt } - "<<=" { tok SymLtLtEq } - ">>=" { tok SymGtGtEq } - "|->" { tok SymBarDashGt } - "|=>" { tok SymBarEqGt } - "[->" { tok SymBrackLDashGt } - "@@(" { tok SymAtAtParenL } - "(*)" { tok SymParenLAsterParenR } - "->>" { tok SymDashGtGt } - "&&&" { tok SymAmpAmpAmp } - - "<<<=" { tok SymLtLtLtEq } - ">>>=" { tok SymGtGtGtEq } - - $white ; - - . { tok Unknown } - -{ -tok :: TokenName -> AlexPosn -> String -> Token -tok t (AlexPn _ l c) s = Token t s $ Position "" l c -} diff --git a/src/VeriSmith/Verilog/Mutate.hs b/src/VeriSmith/Verilog/Mutate.hs deleted file mode 100644 index 58675e3..0000000 --- a/src/VeriSmith/Verilog/Mutate.hs +++ /dev/null @@ -1,401 +0,0 @@ -{-| -Module : VeriSmith.Verilog.Mutate -Description : Functions to mutate the Verilog AST. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-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 - ( 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 - -class Mutate a where - mutExpr :: (Expr -> Expr) -> a -> a - -instance Mutate Identifier where - mutExpr _ = id - -instance Mutate Delay where - mutExpr _ = id - -instance Mutate Event where - mutExpr f (EExpr e) = EExpr $ f e - mutExpr _ a = a - -instance Mutate BinaryOperator where - mutExpr _ = id - -instance Mutate UnaryOperator where - mutExpr _ = id - -instance Mutate Expr where - mutExpr f = f - -instance Mutate ConstExpr where - mutExpr _ = id - -instance Mutate Task where - 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 - -instance Mutate PortDir where - mutExpr _ = id - -instance Mutate PortType where - mutExpr _ = id - -instance Mutate Range where - mutExpr _ = id - -instance Mutate Port where - mutExpr _ = id - -instance Mutate ModConn where - 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 - -instance Mutate ContAssign where - mutExpr f (ContAssign a e) = ContAssign a $ f e - -instance Mutate Statement 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 (mutExpr f a1) (f e) (mutExpr f a2) $ mutExpr f s - -instance Mutate Parameter where - mutExpr _ = id - -instance Mutate LocalParam where - mutExpr _ = id - -instance Mutate ModItem 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 _ d@Decl{} = d - mutExpr _ p@ParamDecl{} = p - mutExpr _ l@LocalParamDecl{} = l - -instance Mutate ModDecl 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) - -instance Mutate Verilog where - mutExpr f (Verilog a) = Verilog $ mutExpr f a - -instance Mutate SourceInfo where - mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b - -instance Mutate a => Mutate [a] where - mutExpr f a = mutExpr f <$> a - -instance Mutate a => Mutate (Maybe a) where - mutExpr f a = mutExpr f <$> a - -instance Mutate a => Mutate (GenVerilog a) where - mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a - --- | Return if the 'Identifier' is in a 'ModDecl'. -inPort :: Identifier -> ModDecl -> Bool -inPort i m = inInput - where - inInput = - 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] -> Maybe Expr -findAssign i items = safe last . catMaybes $ isAssign <$> items - where - 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 _ _ e = e - --- | Replaces the identifier recursively in an expression. -replace :: Identifier -> Expr -> Expr -> Expr -replace = (transform .) . idTrans - --- | Nest expressions for a specific 'Identifier'. If the 'Identifier' is not --- found, the AST is not changed. --- --- This could be improved by instead of only using the last assignment to the --- wire that one finds, to use the assignment to the wire before the current --- expression. This would require a different approach though. -nestId :: Identifier -> ModDecl -> ModDecl -nestId i 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 - --- | Replaces an identifier by a expression in all the module declaration. -nestSource :: Identifier -> Verilog -> Verilog -nestSource i src = src & getModule %~ nestId i - --- | Nest variables in the format @w[0-9]*@ up to a certain number. -nestUpTo :: Int -> Verilog -> Verilog -nestUpTo i src = - foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] - -allVars :: ModDecl -> [Identifier] -allVars m = - (m ^.. modOutPorts . traverse . portName) - <> (m ^.. modInPorts . traverse . portName) - --- $setup --- >>> import VeriSmith.Verilog.CodeGen --- >>> let m = (ModDecl (Identifier "m") [Port Wire False 5 (Identifier "y")] [Port Wire False 5 "x"] [] []) --- >>> let main = (ModDecl "main" [] [] [] []) - --- | Add a Module Instantiation using 'ModInst' from the first module passed to --- it to the body of the second module. It first has to make all the inputs into --- @reg@. --- --- >>> render $ instantiateMod m main --- module main; --- wire [(3'h4):(1'h0)] y; --- reg [(3'h4):(1'h0)] x; --- m m1(y, x); --- endmodule --- --- -instantiateMod :: ModDecl -> ModDecl -> ModDecl -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 - count = - length - . filter (== m ^. modId) - $ main - ^.. modItems - . traverse - . modInstId - conns = ModConn . Id <$> allVars m - --- | Instantiate without adding wire declarations. It also does not count the --- current instantiations of the same module. --- --- >>> GenVerilog $ instantiateMod_ m --- m m(y, x); --- -instantiateMod_ :: ModDecl -> ModItem -instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns - where - conns = - 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. --- --- >>> GenVerilog $ instantiateModSpec_ "_" m --- m m(.y(y), .x(x)); --- -instantiateModSpec_ :: Text -> ModDecl -> ModItem -instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns - where - 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) - --- | Initialise all the inputs and outputs to a module. --- --- >>> GenVerilog $ initMod m --- module m(y, x); --- output wire [(3'h4):(1'h0)] y; --- input wire [(3'h4):(1'h0)] x; --- endmodule --- --- -initMod :: ModDecl -> ModDecl -initMod m = m & modItems %~ ((out ++ inp) ++) - where - out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing - inp = Decl (Just PortIn) <$> (m ^. modInPorts) <*> pure Nothing - --- | Make an 'Identifier' from and existing Identifier and an object with a --- 'Show' instance to make it unique. -makeIdFrom :: (Show a) => a -> Identifier -> Identifier -makeIdFrom a i = (i <>) . Identifier . ("_" <>) $ showT a - --- | Make top level module for equivalence verification. Also takes in how many --- modules to instantiate. -makeTop :: Int -> ModDecl -> ModDecl -makeTop i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] - where - ys = yPort . flip makeIdFrom "y" <$> [1 .. i] - modIt = instantiateModSpec_ "_" . modN <$> [1 .. i] - modN n = - 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 -> ModDecl -makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2 - where - 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 --- registers, it should assign them to 0. -declareMod :: [Port] -> ModDecl -> ModDecl -declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) - where - decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0) - 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 --- no more changes were made to the expression. --- --- >>> GenVerilog . simplify $ (Id "x") + 0 --- x --- --- >>> 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 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 - --- | 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 --- simplified further. --- --- >>> GenVerilog . removeId ["x"] $ Id "x" + Id "y" --- (x + (1'h0)) -removeId :: [Identifier] -> Expr -> Expr -removeId i = transform trans - where - trans (Id ident) | ident `notElem` i = Number 0 - | otherwise = Id ident - trans e = e - -combineAssigns :: Port -> [ModItem] -> [ModItem] -combineAssigns p a = - a - <> [ ModCA - . ContAssign (p ^. portName) - . UnOp UnXor - . fold - $ Id - <$> assigns - ] - where assigns = a ^.. traverse . modContAssign . contAssignNetLVal - -combineAssigns_ :: Bool -> Port -> [Port] -> ModItem -combineAssigns_ comb p ps = - 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 deleted file mode 100644 index 8d2b729..0000000 --- a/src/VeriSmith/Verilog/Parser.hs +++ /dev/null @@ -1,511 +0,0 @@ -{-| -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 - -- ** Internal parsers - , 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 - -type Parser = Parsec [Token] () - -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 - --- | This parser succeeds whenever the given predicate returns true when called --- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'. -satisfy :: (Token -> Bool) -> Parser TokenName -satisfy f = tokenPrim show nextPos tokeq - where - tokeq :: Token -> Maybe TokenName - tokeq t@(Token t' _ _) = if f t then Just t' else Nothing - -satisfy' :: (Token -> Maybe a) -> Parser a -satisfy' = tokenPrim show nextPos - -nextPos :: SourcePos -> Token -> [Token] -> SourcePos -nextPos pos _ (Token _ _ (Position _ l c) : _) = - setSourceColumn (setSourceLine pos l) c -nextPos pos _ [] = pos - --- | Parses given `TokenName`. -tok :: TokenName -> Parser TokenName -tok t = satisfy (\(Token t' _ _) -> t' == t) show t - --- | Parse without returning the `TokenName`. -tok' :: TokenName -> Parser () -tok' p = void $ tok p - -parens :: Parser a -> Parser a -parens = between (tok SymParenL) (tok SymParenR) - -brackets :: Parser a -> Parser a -brackets = between (tok SymBrackL) (tok SymBrackR) - -braces :: Parser a -> Parser a -braces = between (tok SymBraceL) (tok SymBraceR) - -sBinOp :: BinaryOperator -> Expr -> Expr -> Expr -sBinOp = sOp BinOp where sOp f b a = f a b - -parseExpr' :: Parser Expr -parseExpr' = buildExpressionParser parseTable parseTerm "expr" - -decToExpr :: Decimal -> Expr -decToExpr (Decimal s n) = Number $ bitVec s n - --- | Parse a Number depending on if it is in a hex or decimal form. Octal and --- binary are not supported yet. -parseNum :: Parser Expr -parseNum = decToExpr <$> number - -parseVar :: Parser Expr -parseVar = Id <$> identifier - -parseVecSelect :: Parser Expr -parseVecSelect = do - i <- identifier - expr <- brackets parseExpr - return $ VecSelect i expr - -parseRangeSelect :: Parser Expr -parseRangeSelect = do - i <- identifier - range <- parseRange - return $ RangeSelect i range - -systemFunc :: Parser String -systemFunc = satisfy' matchId - where - matchId (Token IdSystem s _) = Just s - matchId _ = Nothing - -parseFun :: Parser Expr -parseFun = do - 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." - -parseTerm :: Parser Expr -parseTerm = - 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 - -parseExpr :: Parser Expr -parseExpr = do - e <- parseExpr' - option e . try $ parseCond e - -parseConstExpr :: Parser ConstExpr -parseConstExpr = fmap exprToConst parseExpr - --- | Table of binary and unary operators that encode the right precedence for --- 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] - ] - -binary :: TokenName -> (a -> a -> a) -> Assoc -> ParseOperator a -binary name fun = Infix ((tok name "binary") >> return fun) - -prefix :: TokenName -> (a -> a) -> ParseOperator a -prefix name fun = Prefix ((tok name "prefix") >> return fun) - -commaSep :: Parser a -> Parser [a] -commaSep = flip sepBy $ tok SymComma - -parseContAssign :: Parser ContAssign -parseContAssign = do - 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 - -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 - 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' - --- toInteger' :: Decimal -> Integer --- toInteger' (Decimal _ n) = n - -toInt' :: Decimal -> Int -toInt' (Decimal _ n) = fromInteger n - --- | Parse a range and return the total size. As it is inclusive, 1 has to be --- added to the difference. -parseRange :: Parser Range -parseRange = do - 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 IdEscaped s _) = Just s - matchId _ = Nothing - -identifier :: Parser Identifier -identifier = Identifier . T.pack <$> strId - -parseNetDecl :: Maybe PortDir -> Parser ModItem -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 - -parsePortDir :: Parser PortDir -parsePortDir = - tok KWOutput - $> PortOut - <|> tok KWInput - $> PortIn - <|> tok KWInout - $> PortInOut - -parseDecl :: Parser ModItem -parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing - -parseConditional :: Parser Statement -parseConditional = do - 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)) - ex i = do - e <- tok' SymBrackL *> parseExpr - tok' SymBrackR - return $ RegExpr i e - sz i = RegSize i <$> parseRange - -parseDelay :: Parser Delay -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 - -parseLoop :: Parser Statement -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 - -eventList :: TokenName -> Parser [Event] -eventList t = do - 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)) - -parseEvent' :: Parser Event -parseEvent' = - try (tok' KWPosedge *> fmap EPosEdge identifier) - <|> try (tok' KWNegedge *> fmap ENegEdge identifier) - <|> try (fmap EId identifier) - <|> try (fmap EExpr parseExpr) - -parseEventCtrl :: Parser Statement -parseEventCtrl = do - event <- parseEvent - statement <- option Nothing maybeEmptyStatement - return $ EventCtrl event statement - -parseDelayCtrl :: Parser Statement -parseDelayCtrl = do - delay <- parseDelay - statement <- option Nothing maybeEmptyStatement - return $ TimeCtrl delay statement - -parseBlocking :: Parser Statement -parseBlocking = do - a <- parseAssign SymEq - tok' SymSemi - return $ BlockAssign a - -parseNonBlocking :: Parser Statement -parseNonBlocking = do - a <- parseAssign SymLtEq - tok' SymSemi - return $ NonBlockAssign a - -parseSeq :: Parser Statement -parseSeq = do - seq' <- tok' KWBegin *> many parseStatement - tok' KWEnd - return $ SeqBlock seq' - -parseStatement :: Parser Statement -parseStatement = - parseSeq - <|> parseConditional - <|> parseLoop - <|> parseEventCtrl - <|> parseDelayCtrl - <|> try parseBlocking - <|> parseNonBlocking - -maybeEmptyStatement :: Parser (Maybe Statement) -maybeEmptyStatement = - (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) - -parseAlways :: Parser ModItem -parseAlways = tok' KWAlways *> (Always <$> parseStatement) - -parseInitial :: Parser ModItem -parseInitial = tok' KWInitial *> (Initial <$> parseStatement) - -namedModConn :: Parser ModConn -namedModConn = do - target <- tok' SymDot *> identifier - expr <- parens parseExpr - return $ ModConnNamed target expr - -parseModConn :: Parser ModConn -parseModConn = try (fmap ModConn parseExpr) <|> namedModConn - -parseModInst :: Parser ModItem -parseModInst = do - m <- identifier - name <- identifier - modconns <- parens (commaSep parseModConn) - tok' SymSemi - return $ ModInst m name modconns - -parseModItem :: Parser ModItem -parseModItem = - try (ModCA <$> parseContAssign) - <|> try parseDecl - <|> parseAlways - <|> parseInitial - <|> parseModInst - -parseModList :: Parser [Identifier] -parseModList = list <|> return [] where list = parens $ commaSep identifier - -filterDecl :: PortDir -> ModItem -> Bool -filterDecl p (Decl (Just p') _ _) = p == p' -filterDecl _ _ = False - -modPorts :: PortDir -> [ModItem] -> [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 - -parseParams :: Parser [Parameter] -parseParams = tok' SymPound *> parens (commaSep parseParam) - -parseModDecl :: Parser ModDecl -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 - --- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace --- and then parsing multiple Verilog source. -parseVerilogSrc :: Parser Verilog -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 -- ^ Returns 'String' with error - -- message if parse fails. -parseVerilog s = - bimap showT id - . parse parseVerilogSrc (T.unpack s) - . alexScanTokens - . preprocess [] (T.unpack s) - . T.unpack - -parseVerilogFile :: Text -> IO Verilog -parseVerilogFile file = do - 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 -parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile diff --git a/src/VeriSmith/Verilog/Preprocess.hs b/src/VeriSmith/Verilog/Preprocess.hs deleted file mode 100644 index c30252b..0000000 --- a/src/VeriSmith/Verilog/Preprocess.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-| -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 - ) -where - --- | Remove comments from code. There is no difference between @(* *)@ and --- @/* */@, therefore in this implementation, @*/@ could close @(*@ and vice-versa, --- This will be fixed in an upcoming version. -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 - - removeEOL a = case a of - "" -> "" - '\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 - - 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 - - ignoreString a = case a of - "" -> 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 - where - pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String] - 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 - -ppLine :: [(String, String)] -> String -> String -ppLine _ "" = "" -ppLine env ('`' : a) = case lookup name env of - Just value -> value ++ ppLine env rest - Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env - where - name = takeWhile - (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) - a - rest = drop (length name) a -ppLine env (a : b) = a : ppLine env b diff --git a/src/VeriSmith/Verilog/Quote.hs b/src/VeriSmith/Verilog/Quote.hs deleted file mode 100644 index 3815fe6..0000000 --- a/src/VeriSmith/Verilog/Quote.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-| -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 - ( 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 - -liftDataWithText :: Data a => a -> Q Exp -liftDataWithText = dataToExpQ $ fmap liftText . cast - -liftText :: T.Text -> Q Exp -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 - } - -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 diff --git a/src/VeriSmith/Verilog/Token.hs b/src/VeriSmith/Verilog/Token.hs deleted file mode 100644 index 590672e..0000000 --- a/src/VeriSmith/Verilog/Token.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-| -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 - ) -where - -import Text.Printf - -tokenString :: Token -> String -tokenString (Token _ s _) = s - -data Position = Position String Int Int deriving Eq - -instance Show Position where - show (Position f l c) = printf "%s:%d:%d" f l c - -data Token = Token TokenName String Position deriving (Show, Eq) - -data TokenName - = KWAlias - | KWAlways - | KWAlwaysComb - | KWAlwaysFf - | KWAlwaysLatch - | KWAnd - | KWAssert - | KWAssign - | KWAssume - | KWAutomatic - | KWBefore - | KWBegin - | KWBind - | KWBins - | KWBinsof - | KWBit - | KWBreak - | KWBuf - | KWBufif0 - | KWBufif1 - | KWByte - | KWCase - | KWCasex - | KWCasez - | KWCell - | KWChandle - | KWClass - | KWClocking - | KWCmos - | KWConfig - | KWConst - | KWConstraint - | KWContext - | KWContinue - | KWCover - | KWCovergroup - | KWCoverpoint - | KWCross - | KWDeassign - | KWDefault - | KWDefparam - | KWDesign - | KWDisable - | KWDist - | KWDo - | KWEdge - | KWElse - | KWEnd - | KWEndcase - | KWEndclass - | KWEndclocking - | KWEndconfig - | KWEndfunction - | KWEndgenerate - | KWEndgroup - | KWEndinterface - | KWEndmodule - | KWEndpackage - | KWEndprimitive - | KWEndprogram - | KWEndproperty - | KWEndspecify - | KWEndsequence - | KWEndtable - | KWEndtask - | KWEnum - | KWEvent - | KWExpect - | KWExport - | KWExtends - | KWExtern - | KWFinal - | KWFirstMatch - | KWFor - | KWForce - | KWForeach - | KWForever - | KWFork - | KWForkjoin - | KWFunction - | KWFunctionPrototype - | KWGenerate - | KWGenvar - | KWHighz0 - | KWHighz1 - | KWIf - | KWIff - | KWIfnone - | KWIgnoreBins - | KWIllegalBins - | KWImport - | KWIncdir - | KWInclude - | KWInitial - | KWInout - | KWInput - | KWInside - | KWInstance - | KWInt - | KWInteger - | KWInterface - | KWIntersect - | KWJoin - | KWJoinAny - | KWJoinNone - | KWLarge - | KWLiblist - | KWLibrary - | KWLocal - | KWLocalparam - | KWLogic - | KWLongint - | KWMacromodule - | KWMatches - | KWMedium - | KWModport - | KWModule - | KWNand - | KWNegedge - | KWNew - | KWNmos - | KWNor - | KWNoshowcancelled - | KWNot - | KWNotif0 - | KWNotif1 - | KWNull - | KWOption - | KWOr - | KWOutput - | KWPackage - | KWPacked - | KWParameter - | KWPathpulseDollar - | KWPmos - | KWPosedge - | KWPrimitive - | KWPriority - | KWProgram - | KWProperty - | KWProtected - | KWPull0 - | KWPull1 - | KWPulldown - | KWPullup - | KWPulsestyleOnevent - | KWPulsestyleOndetect - | KWPure - | KWRand - | KWRandc - | KWRandcase - | KWRandsequence - | KWRcmos - | KWReal - | KWRealtime - | KWRef - | KWReg - | KWRelease - | KWRepeat - | KWReturn - | KWRnmos - | KWRpmos - | KWRtran - | KWRtranif0 - | KWRtranif1 - | KWScalared - | KWSequence - | KWShortint - | KWShortreal - | KWShowcancelled - | KWSigned - | KWSmall - | KWSolve - | KWSpecify - | KWSpecparam - | KWStatic - | KWStrength0 - | KWStrength1 - | KWString - | KWStrong0 - | KWStrong1 - | KWStruct - | KWSuper - | KWSupply0 - | KWSupply1 - | KWTable - | KWTagged - | KWTask - | KWThis - | KWThroughout - | KWTime - | KWTimeprecision - | KWTimeunit - | KWTran - | KWTranif0 - | KWTranif1 - | KWTri - | KWTri0 - | KWTri1 - | KWTriand - | KWTrior - | KWTrireg - | KWType - | KWTypedef - | KWTypeOption - | KWUnion - | KWUnique - | KWUnsigned - | KWUse - | KWVar - | KWVectored - | KWVirtual - | KWVoid - | KWWait - | KWWaitOrder - | KWWand - | KWWeak0 - | KWWeak1 - | KWWhile - | KWWildcard - | KWWire - | KWWith - | KWWithin - | KWWor - | KWXnor - | KWXor - | IdSimple - | IdEscaped - | IdSystem - | LitNumberUnsigned - | LitNumber - | LitString - | SymParenL - | SymParenR - | SymBrackL - | SymBrackR - | SymBraceL - | SymBraceR - | SymTildy - | SymBang - | SymAt - | SymPound - | SymPercent - | SymHat - | SymAmp - | SymBar - | SymAster - | SymDot - | SymComma - | SymColon - | SymSemi - | SymEq - | SymLt - | SymGt - | SymPlus - | SymDash - | SymQuestion - | SymSlash - | SymDollar - | SymSQuote - | SymTildyAmp - | SymTildyBar - | SymTildyHat - | SymHatTildy - | SymEqEq - | SymBangEq - | SymAmpAmp - | SymBarBar - | SymAsterAster - | SymLtEq - | SymGtEq - | SymGtGt - | SymLtLt - | SymPlusPlus - | SymDashDash - | SymPlusEq - | SymDashEq - | SymAsterEq - | SymSlashEq - | SymPercentEq - | SymAmpEq - | SymBarEq - | SymHatEq - | SymPlusColon - | SymDashColon - | SymColonColon - | SymDotAster - | SymDashGt - | SymColonEq - | SymColonSlash - | SymPoundPound - | SymBrackLAster - | SymBrackLEq - | SymEqGt - | SymAtAster - | SymParenLAster - | SymAsterParenR - | SymAsterGt - | SymEqEqEq - | SymBangEqEq - | SymEqQuestionEq - | SymBangQuestionEq - | SymGtGtGt - | SymLtLtLt - | SymLtLtEq - | SymGtGtEq - | SymBarDashGt - | SymBarEqGt - | SymBrackLDashGt - | SymAtAtParenL - | SymParenLAsterParenR - | SymDashGtGt - | SymAmpAmpAmp - | SymLtLtLtEq - | SymGtGtGtEq - | Unknown - deriving (Show, Eq) diff --git a/src/Verismith.hs b/src/Verismith.hs new file mode 100644 index 0000000..e7d3ce6 --- /dev/null +++ b/src/Verismith.hs @@ -0,0 +1,553 @@ +{-| +Module : Verismith +Description : Verismith +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX +-} + +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Verismith + ( defaultMain + -- * Types + , Opts(..) + , SourceInfo(..) + -- * Run functions + , runEquivalence + , runSimulation + , runReduce + , draw + -- * Verilog generation functions + , procedural + , proceduralIO + , proceduralSrc + , proceduralSrcIO + , randomMod + -- * Extra modules + , module Verismith.Verilog + , module Verismith.Config + , module Verismith.Circuit + , module Verismith.Sim + , module Verismith.Fuzz + , module Verismith.Report + ) +where + +import Control.Concurrent +import Control.Lens hiding ((<.>)) +import Control.Monad.IO.Class (liftIO) +import qualified Crypto.Random.DRBG as C +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 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.Reduce +import Verismith.Report +import Verismith.Result +import Verismith.Sim +import Verismith.Sim.Internal +import Verismith.Verilog +import Verismith.Verilog.Parser (parseSourceInfoFile) + +data OptTool = TYosys + | TXST + | TIcarus + +instance Show OptTool where + show TYosys = "yosys" + show TXST = "xst" + show TIcarus = "icarus" + +data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text + , configFile :: !(Maybe FilePath) + , forced :: !Bool + , keepAll :: !Bool + , num :: {-# UNPACK #-} !Int + } + | Generate { mFileName :: !(Maybe FilePath) + , configFile :: !(Maybe FilePath) + } + | Parse { fileName :: {-# UNPACK #-} !FilePath + } + | Reduce { fileName :: {-# UNPACK #-} !FilePath + , top :: {-# UNPACK #-} !Text + , reduceScript :: !(Maybe FilePath) + , synthesiserDesc :: ![SynthDescription] + , rerun :: Bool + } + | ConfigOpt { writeConfig :: !(Maybe FilePath) + , configFile :: !(Maybe FilePath) + , doRandomise :: !Bool + } + +myForkIO :: IO () -> IO (MVar ()) +myForkIO io = do + mvar <- newEmptyMVar + _ <- forkFinally io (\_ -> putMVar mvar ()) + return mvar + +textOption :: Mod OptionFields String -> Parser Text +textOption = fmap T.pack . strOption + +optReader :: (String -> Maybe a) -> ReadM a +optReader f = eitherReader $ \arg -> case f arg of + 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 + +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 + +parseSim :: String -> Maybe OptTool +parseSim val | val == "icarus" = Just TIcarus + | otherwise = Nothing + +fuzzOpts :: Parser Opts +fuzzOpts = + Fuzz + <$> textOption + ( long "output" + <> short 'o' + <> metavar "DIR" + <> help "Output directory that the fuzz run takes place in." + <> showDefault + <> value "output" + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the current fuzz run." + ) + <*> (switch $ long "force" <> short 'f' <> help + "Overwrite the specified directory." + ) + <*> (switch $ long "keep" <> short 'k' <> help + "Keep all the directories." + ) + <*> ( option auto + $ long "num" + <> short 'n' + <> help "The number of fuzz runs that should be performed." + <> showDefault + <> value 1 + <> metavar "INT" + ) + +genOpts :: Parser Opts +genOpts = + Generate + <$> ( optional + . strOption + $ long "output" + <> short 'o' + <> metavar "FILE" + <> help "Output to a verilog file instead." + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the generation run." + ) + +parseOpts :: Parser Opts +parseOpts = Parse . fromText . T.pack <$> strArgument + (metavar "FILE" <> help "Verilog input file.") + +reduceOpts :: Parser Opts +reduceOpts = + Reduce + . fromText + . T.pack + <$> strArgument (metavar "FILE" <> help "Verilog input file.") + <*> textOption + ( short 't' + <> long "top" + <> metavar "TOP" + <> help "Name of top level module." + <> showDefault + <> value "top" + ) + <*> ( optional + . strOption + $ long "script" + <> metavar "SCRIPT" + <> help + "Script that determines if the current file is interesting, which is determined by the script returning 0." + ) + <*> ( many + . option (optReader parseSynthDesc) + $ short 's' + <> long "synth" + <> metavar "SYNTH" + <> help "Specify synthesiser to use." + ) + <*> ( switch + $ short 'r' + <> long "rerun" + <> help + "Only rerun the current synthesis file with all the synthesisers." + ) + +configOpts :: Parser Opts +configOpts = + ConfigOpt + <$> ( optional + . strOption + $ long "output" + <> short 'o' + <> metavar "FILE" + <> help "Output to a TOML Config file." + ) + <*> ( optional + . strOption + $ long "config" + <> short 'c' + <> metavar "FILE" + <> help "Config file for the current fuzz run." + ) + <*> ( switch + $ long "randomise" + <> short 'r' + <> help + "Randomise the given default config, or the default config by randomly switchin on and off options." + ) + +argparse :: Parser Opts +argparse = + hsubparser + ( command + "fuzz" + (info + fuzzOpts + (progDesc + "Run fuzzing on the specified simulators and synthesisers." + ) + ) + <> metavar "fuzz" + ) + <|> hsubparser + ( command + "generate" + (info + genOpts + (progDesc "Generate a random Verilog program.") + ) + <> metavar "generate" + ) + <|> hsubparser + ( command + "parse" + (info + parseOpts + (progDesc + "Parse a verilog file and output a pretty printed version." + ) + ) + <> metavar "parse" + ) + <|> hsubparser + ( command + "reduce" + (info + reduceOpts + (progDesc + "Reduce a Verilog file by rerunning the fuzzer on the file." + ) + ) + <> metavar "reduce" + ) + <|> hsubparser + ( command + "config" + (info + configOpts + (progDesc + "Print the current configuration of the fuzzer." + ) + ) + <> metavar "config" + ) + +version :: Parser (a -> a) +version = infoOption versionInfo $ mconcat + [long "version", short 'v', help "Show version information.", hidden] + +opts :: ParserInfo Opts +opts = info + (argparse <**> helper <**> version) + ( fullDesc + <> progDesc "Fuzz different simulators and synthesisers." + <> header + "Verismith - A hardware simulator and synthesiser Verilog fuzzer." + ) + +getConfig :: Maybe FilePath -> IO Config +getConfig s = + maybe (return defaultConfig) parseConfigFile $ T.unpack . 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 + +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 + 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) + ) + c + d + e + where + cm = config ^. configProbability . probModItem + cs = config ^. configProbability . probStmnt + ce = config ^. configProbability . probExpr + +handleOpts :: Opts -> IO () +handleOpts (Fuzz o configF _ _ n) = do + config <- getConfig configF + _ <- runFuzz + config + defaultYosys + (fuzzMultiple n (Just $ fromText o) (proceduralSrc "top" config)) + return () +handleOpts (Generate f c) = do + config <- getConfig c + source <- proceduralIO "top" config + maybe (T.putStrLn $ genSource source) (flip T.writeFile $ genSource source) + $ T.unpack + . toTextIgnore + <$> f +handleOpts (Parse f) = do + verilogSrc <- T.readFile file + case parseVerilog (T.pack file) verilogSrc of + Left l -> print l + Right v -> print $ GenVerilog v + where file = T.unpack . toTextIgnore $ f +handleOpts (Reduce f t _ ls' False) = do + src <- parseSourceInfoFile t (toTextIgnore f) + case descriptionToSynth <$> ls' of + a : b : _ -> do + putStrLn "Reduce with equivalence check" + shelly $ do + make dir + pop dir $ do + src' <- reduceSynth a b src + 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) + 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 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 + +defaultMain :: IO () +defaultMain = do + optsparsed <- execParser opts + handleOpts optsparsed + +-- | Generate a specific number of random bytestrings of size 256. +randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] +randomByteString gen n bytes + | n == 0 = ranBytes : bytes + | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes + where Right (ranBytes, newGen) = C.genBytes 32 gen + +-- | generates the specific number of bytestring with a random seed. +generateByteString :: Int -> IO [ByteString] +generateByteString n = do + gen <- C.newGenIO :: IO C.CtrDRBG + return $ randomByteString gen n [] + +makeSrcInfo :: ModDecl -> SourceInfo +makeSrcInfo m = SourceInfo (getIdentifier $ m ^. modId) (Verilog [m]) + +-- | Draw a randomly generated DAG to a dot file and compile it to a png so it +-- 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"] + +-- | Function to show a bytestring in a hex format. +showBS :: ByteString -> Text +showBS = decodeUtf8 . L.toStrict . toLazyByteString . byteStringHex + +-- | Run a simulation on a random DAG or a random module. +runSimulation :: IO () +runSimulation = do + -- gr <- Hog.generate $ rDups <$> Hog.resize 100 (randomDAG :: Gen (G.Gr Gate ())) + -- let dot = G.showDot . G.fglToDotString $ G.nemap show (const "") gr + -- writeFile "file.dot" dot + -- shelly $ run_ "dot" ["-Tpng", "-o", "file.png", "file.dot"] + -- let circ = + -- head $ (nestUpTo 30 . generateAST $ Circuit gr) ^.. getVerilog . traverse . getDescription + rand <- generateByteString 20 + rand2 <- Hog.sample (randomMod 10 100) + 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 + +checkEquivalence :: SourceInfo -> Text -> IO Bool +checkEquivalence src dir = shellyFailDir $ do + mkdir_p (fromText dir) + curr <- toTextIgnore <$> pwd + setenv "VERISMITH_ROOT" curr + cd (fromText dir) + catch_sh + ((runResultT $ runEquiv 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 seed gm t d k i = do + (_, m) <- shelly $ sampleSeed seed gm + let srcInfo = SourceInfo "top" m + rand <- generateByteString 20 + shellyFailDir $ do + mkdir_p (fromText d fromText n) + curr <- toTextIgnore <$> pwd + setenv "VERISMITH_ROOT" curr + cd (fromText "output" fromText n) + _ <- + catch_sh + ( runResultT + $ runEquiv 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 (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s diff --git a/src/Verismith/Circuit.hs b/src/Verismith/Circuit.hs new file mode 100644 index 0000000..81eec12 --- /dev/null +++ b/src/Verismith/Circuit.hs @@ -0,0 +1,45 @@ +{-| +Module : Verismith.Circuit +Description : Definition of the circuit graph. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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 + +fromGraph :: Gen ModDecl +fromGraph = do + 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 new file mode 100644 index 0000000..9a5ab34 --- /dev/null +++ b/src/Verismith/Circuit/Base.hs @@ -0,0 +1,44 @@ +{-| +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(..) + ) +where + +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) + +-- | Newtype for the Circuit which implements a Graph from fgl. +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 for a named edge which is empty, as it does not need a label. +newtype CEdge = CEdge { getCEdge :: LEdge () } + +instance Random Gate where + randomR (a, b) g = + case randomR (fromEnum a, fromEnum b) g of + (x, g') -> (toEnum x, g') + + random = randomR (minBound, maxBound) diff --git a/src/Verismith/Circuit/Gen.hs b/src/Verismith/Circuit/Gen.hs new file mode 100644 index 0000000..c5cb697 --- /dev/null +++ b/src/Verismith/Circuit/Gen.hs @@ -0,0 +1,79 @@ +{-| +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 + ) +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 + +-- | Converts a 'CNode' to an 'Identifier'. +frNode :: Node -> Identifier +frNode = Identifier . fromNode + +-- | Converts a 'Gate' to a 'BinaryOperator', which should be a bijective +-- mapping. +fromGate :: Gate -> BinaryOperator +fromGate And = BinAnd +fromGate Or = BinOr +fromGate Xor = BinXor + +inputsC :: Circuit -> [Node] +inputsC c = inputs (getCircuit c) + +genPortsAST :: (Circuit -> [Node]) -> Circuit -> [Port] +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 g (n : ns) = BinOp wire oper <$> genAssignExpr g ns + where + wire = Id $ frNode n + oper = fromGate g + +-- | Generate the continuous assignment AST for a particular node. If it does +-- not have any nodes that link to it then return 'Nothing', as that means that +-- the assignment will just be empty. +genContAssignAST :: Circuit -> LNode Gate -> Maybe ModItem +genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes + where + gr = getCircuit c + nodes = G.pre gr n + name = frNode n + +genAssignAST :: Circuit -> [ModItem] +genAssignAST c = catMaybes $ genContAssignAST c <$> nodes + where + gr = getCircuit c + nodes = G.labNodes gr + +genModuleDeclAST :: Circuit -> ModDecl +genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] + where + i = Identifier "gen_module" + ports = genPortsAST inputsC c + output = [] + a = genAssignAST c + yPort = Port Wire False 90 "y" + +generateAST :: Circuit -> Verilog +generateAST c = Verilog [genModuleDeclAST c] diff --git a/src/Verismith/Circuit/Internal.hs b/src/Verismith/Circuit/Internal.hs new file mode 100644 index 0000000..4de2252 --- /dev/null +++ b/src/Verismith/Circuit/Internal.hs @@ -0,0 +1,55 @@ +{-| +Module : Verismith.Circuit.Internal +Description : Internal helpers for generation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Internal helpers for generation. +-} + +module Verismith.Circuit.Internal + ( fromNode + , filterGr + , only + , inputs + , outputs + ) +where + +import Data.Graph.Inductive (Graph, Node) +import qualified Data.Graph.Inductive as G +import qualified Data.Text as T + +-- | Convert an integer into a label. +-- +-- >>> fromNode 5 +-- "w5" +fromNode :: Int -> T.Text +fromNode node = T.pack $ "w" <> show node + +-- | General function which runs 'filter' over a graph. +filterGr :: (Graph gr) => gr n e -> (Node -> Bool) -> [Node] +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 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 +-- an input themselves. +inputs :: (Graph gr) => gr n e -> [Node] +inputs graph = filterGr graph $ only graph G.indeg G.outdeg + +-- | Returns all the output nodes to a graph, similar to the 'inputs' function. +outputs :: (Graph gr) => gr n e -> [Node] +outputs graph = filterGr graph $ only graph G.outdeg G.indeg diff --git a/src/Verismith/Circuit/Random.hs b/src/Verismith/Circuit/Random.hs new file mode 100644 index 0000000..0eabf56 --- /dev/null +++ b/src/Verismith/Circuit/Random.hs @@ -0,0 +1,67 @@ +{-| +Module : Verismith.Circuit.Random +Description : Random generation for DAG +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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 + +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) + +-- | Remove duplicates. +rDups :: (Eq a, Eq b) => Gr a b -> Gr a b +rDups g = G.buildGr $ G.ufold dupFolder [] g + +-- | Remove duplicates. +rDupsCirc :: Circuit -> Circuit +rDupsCirc = Circuit . rDups . getCircuit + +-- | Gen instance to create an arbitrary edge, where the edges are limited by +-- `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, ()) + where + 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 = 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 + where + nodes l = zip [0 .. length l - 1] l + aE = getCEdge <$> Hog.sized arbitraryEdge + +-- | Generate a random acyclic DAG with an IO instance. +genRandomDAG :: IO Circuit +genRandomDAG = Hog.sample randomDAG diff --git a/src/Verismith/Config.hs b/src/Verismith/Config.hs new file mode 100644 index 0000000..9d37fd2 --- /dev/null +++ b/src/Verismith/Config.hs @@ -0,0 +1,496 @@ +{-| +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 + ( -- * TOML Configuration + -- $conf + Config(..) + , defaultConfig + -- ** Probabilities + , Probability(..) + -- *** Expression + , ProbExpr(..) + -- *** Module Item + , ProbModItem(..) + -- *** Statement + , ProbStatement(..) + -- ** ConfProperty + , ConfProperty(..) + -- ** Simulator Description + , SimDescription(..) + -- ** Synthesiser Description + , SynthDescription(..) + -- * Useful Lenses + , fromXST + , fromYosys + , fromVivado + , fromQuartus + , configProbability + , configProperty + , configSimulators + , configSynthesisers + , probModItem + , 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 + , 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 qualified Toml +import Verismith.Sim.Quartus +import Verismith.Sim.Vivado +import Verismith.Sim.XST +import Verismith.Sim.Yosys + +-- $conf +-- +-- Verismith supports a TOML configuration file that can be passed using the @-c@ +-- flag or using the 'parseConfig' and 'encodeConfig' functions. The +-- configuration can then be manipulated using the lenses that are also provided +-- in this module. +-- +-- The configuration file can be used to tweak the random Verilog generation by +-- passing different probabilities to each of the syntax nodes in the AST. It +-- can also be used to specify which simulators to fuzz with which options. A +-- seed for the run can also be set, to replay a previous run using the same +-- exact generation. A default value is associated with each key in the +-- configuration file, which means that only the options that need overriding +-- can be added to the configuration. The defaults can be observed in +-- 'defaultConfig' or when running @verismith config@. +-- +-- == Configuration Sections +-- +-- There are four main configuration sections in the TOML file: +-- +-- [@probability@] The @probability@ section defines the probabilities at +-- every node in the AST. +-- +-- [@property@] Controls different properties of the generation, such as +-- adding a seed or the depth of the statements. +-- +-- [@simulator@] This is an array of tables containing descriptions of the +-- different simulators that should be used. It currently only supports +-- . +-- +-- [@synthesiser@] This is also an array of tables containing descriptions of +-- the different synthesisers that should be used. The synthesisers that are +-- currently supported are: +-- +-- - +-- - +-- - +-- - + +-- | Probability of different expressions nodes. +data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int + -- ^ 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 + -- ^ Probability of generating an identifier that is in + -- scope and of the right type. + , _probExprRangeSelect :: {-# UNPACK #-} !Int + -- ^ Probability of generating a range selection from a port. + , _probExprUnOp :: {-# UNPACK #-} !Int + -- ^ Probability of generating a unary operator. + , _probExprBinOp :: {-# UNPACK #-} !Int + -- ^ Probability of generation a binary operator. + , _probExprCond :: {-# UNPACK #-} !Int + -- ^ probability of generating a conditional ternary + -- operator. + , _probExprConcat :: {-# UNPACK #-} !Int + -- ^ Probability of generating a concatenation. + , _probExprStr :: {-# UNPACK #-} !Int + -- ^ Probability of generating a string. This is not + -- fully supported therefore currently cannot be set. + , _probExprSigned :: {-# UNPACK #-} !Int + -- ^ Probability of generating a signed function + -- @$signed(...)@. + , _probExprUnsigned :: {-# UNPACK #-} !Int + -- ^ Probability of generating an unsigned function + -- @$unsigned(...)@. + } + deriving (Eq, Show) + +-- | Probability of generating different nodes inside a module declaration. +data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int + -- ^ Probability of generating an @assign@. + , _probModItemSeqAlways :: {-# UNPACK #-} !Int + -- ^ Probability of generating a sequential @always@ block. + , _probModItemCombAlways :: {-# UNPACK #-} !Int + -- ^ Probability of generating an combinational @always@ block. + , _probModItemInst :: {-# UNPACK #-} !Int + -- ^ Probability of generating a module + -- instantiation. + } + deriving (Eq, Show) + +data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int + , _probStmntNonBlock :: {-# UNPACK #-} !Int + , _probStmntCond :: {-# UNPACK #-} !Int + , _probStmntFor :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) + +data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem + , _probStmnt :: {-# UNPACK #-} !ProbStatement + , _probExpr :: {-# UNPACK #-} !ProbExpr + } + deriving (Eq, Show) + +data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int + -- ^ The size of the generated Verilog. + , _propSeed :: !(Maybe Seed) + -- ^ A possible seed that could be used to + -- generate the same Verilog. + , _propStmntDepth :: {-# UNPACK #-} !Int + -- ^ The maximum statement depth that should be + -- reached. + , _propModDepth :: {-# UNPACK #-} !Int + -- ^ The maximium module depth that should be + -- reached. + , _propMaxModules :: {-# UNPACK #-} !Int + -- ^ The maximum number of modules that are + -- allowed to be created at each level. + , _propSampleMethod :: !Text + -- ^ The sampling method that should be used to + -- generate specific distributions of random + -- programs. + , _propSampleSize :: {-# UNPACK #-} !Int + -- ^ The number of samples to take for the + -- sampling method. + , _propCombine :: !Bool + -- ^ If the output should be combined into one + -- bit or not. + , _propNonDeterminism :: {-# UNPACK #-} !Int + -- ^ The frequency at which nondeterminism + -- should be generated. + , _propDeterminism :: {-# UNPACK #-} !Int + -- ^ The frequency at which determinism should + -- be generated. + } + deriving (Eq, Show) + +data Info = Info { _infoCommit :: !Text + , _infoVersion :: !Text + } + deriving (Eq, Show) + +data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text } + deriving (Eq, Show) + +data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text + , synthBin :: Maybe Text + , synthDesc :: Maybe Text + , 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 ''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 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) + +fromYosys :: Yosys -> SynthDescription +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) + +fromQuartus :: Quartus -> SynthDescription +fromQuartus (Quartus a b c) = SynthDescription "quartus" + (toTextIgnore <$> a) + (Just b) + (Just $ toTextIgnore c) + +defaultConfig :: Config +defaultConfig = Config + (Info (pack $(gitHash)) (pack $ showVersion version)) + (Probability defModItem defStmnt defExpr) + (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1) + [] + [fromYosys defaultYosys, fromVivado defaultVivado] + where + defModItem = + 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 + 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 + +twoKey :: Toml.Piece -> Toml.Piece -> Toml.Key +twoKey a b = Toml.Key (a :| [b]) + +int :: Toml.Piece -> Toml.Piece -> TomlCodec Int +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 + 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 + 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 + where + defProb i = defaultConfig ^. configProbability . probModItem . i + intM = int "moditem" + +probCodec :: TomlCodec Probability +probCodec = + Probability + <$> defaultValue (defProb probModItem) modItemCodec + .= _probModItem + <*> defaultValue (defProb probStmnt) stmntCodec + .= _probStmnt + <*> defaultValue (defProb probExpr) exprCodec + .= _probExpr + 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 + where defProp i = defaultConfig ^. configProperty . i + +simulator :: TomlCodec SimDescription +simulator = Toml.textBy pprint parseIcarus "name" + where + parseIcarus i@"icarus" = Right $ SimDescription i + parseIcarus s = Left $ "Could not match '" <> s <> "' with a simulator." + pprint (SimDescription a) = a + +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 + +infoCodec :: TomlCodec Info +infoCodec = + 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 + +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" + +encodeConfig :: Config -> Text +encodeConfig = Toml.encode configCodec + +encodeConfigFile :: FilePath -> Config -> IO () +encodeConfigFile f = T.writeFile f . encodeConfig + +versionInfo :: String +versionInfo = + "Verismith " + <> showVersion version + <> " (" + <> $(gitCommitDate) + <> " " + <> $(gitHash) + <> ")" diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs new file mode 100644 index 0000000..2e0c95f --- /dev/null +++ b/src/Verismith/Fuzz.hs @@ -0,0 +1,466 @@ +{-| +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 FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +module Verismith.Fuzz + ( Fuzz + , fuzz + , fuzzInDir + , fuzzMultiple + , runFuzz + , sampleSeed + -- * Helpers + , 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.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Maybe (runMaybeT) +import Control.Monad.Trans.Reader hiding (local) +import Control.Monad.Trans.State.Strict +import qualified Crypto.Random.DRBG as C +import Data.ByteString (ByteString) +import Data.List (nubBy, sort) +import Data.Maybe (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) +import Shelly.Lifted (MonadSh, liftSh) +import System.FilePath.Posix (takeBaseName) +import Verismith.Config +import Verismith.Internal +import Verismith.Reduce +import Verismith.Report +import Verismith.Result +import Verismith.Sim.Icarus +import Verismith.Sim.Internal +import Verismith.Sim.Yosys +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] + , getSimulators :: ![SimTool] + , yosysInstance :: {-# UNPACK #-} !Yosys + } + deriving (Eq, Show) + +data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult] + , _fuzzSimResults :: ![SimResult] + , _fuzzSynthStatus :: ![SynthStatus] + } + deriving (Eq, Show) + +$(makeLenses ''FuzzState) + +type Frequency a = [(Seed, a)] -> [(Int, Gen (Seed, a))] + +-- | The main type for the fuzzing, which contains an environment that can be +-- read from and the current state of all the results. +type Fuzz m = StateT FuzzState (ReaderT FuzzEnv m) + +type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) + +runFuzz :: MonadIO m => Config -> Yosys -> (Config -> Fuzz Sh a) -> m a +runFuzz conf yos m = shelly $ runFuzz' conf yos m + +runFuzz' :: Monad m => Config -> Yosys -> (Config -> Fuzz m b) -> m b +runFuzz' conf yos m = runReaderT + (evalStateT (m conf) (FuzzState [] [] [])) + (FuzzEnv + ( force + $ defaultIdentitySynth + : (descriptionToSynth <$> conf ^. configSynthesisers) + ) + (force $ descriptionToSim <$> conf ^. configSimulators) + yos + ) + +synthesisers :: Monad m => Fuzz m [SynthTool] +synthesisers = lift $ asks getSynthesisers + +--simulators :: (Monad m) => Fuzz () m [SimTool] +--simulators = lift $ asks getSimulators + +--combinations :: [a] -> [b] -> [(a, b)] +--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) + +synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () +synthesis src = do + 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 + +passedSynthesis :: MonadSh m => Fuzz m [SynthTool] +passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get + where + passed (SynthStatus _ (Pass _) _) = True + 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 + toSynth (SynthStatus s _ _) = s + +make :: MonadSh m => FilePath -> m () +make f = liftSh $ do + mkdir_p f + cp_r "data" $ f fromText "data" + +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 + +applyList :: [a -> b] -> [a] -> [b] +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 a b = applyLots SynthResult a $ fmap swap b + +toolRun :: (MonadIO m, MonadSh m) => Text -> m a -> m (NominalDiffTime, a) +toolRun t m = do + logT $ "Running " <> t + (diff, res) <- timeit m + logT $ "Finished " <> t <> " (" <> showT diff <> ")" + return (diff, res) + +equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () +equivalence src = do + synth <- passedSynthesis +-- let synthComb = +-- nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth + let synthComb = + nubBy tupEq + . filter (uncurry (/=)) + $ (,) defaultIdentitySynth + <$> synth + resTimes <- liftSh $ mapM (uncurry equiv) synthComb + fuzzSynthResults .= toSynthResult synthComb resTimes + liftSh $ inspect resTimes + where + tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') + equiv 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 + runEquiv a b src + where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b + +simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () +simulation src = do + synth <- passEquiv + vals <- liftIO $ generateByteString 20 + ident <- liftSh $ equiv vals defaultIdentitySynth + resTimes <- liftSh $ mapM (equiv vals) $ conv <$> synth + liftSh + . inspect + $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) + <$> (ident : resTimes) + where + conv (SynthResult _ a _ _) = a + equiv b 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 defaultIcarus a src b + where dir = fromText $ "simulation_" <> toText a + +-- | Generate a specific number of random bytestrings of size 256. +randomByteString :: C.CtrDRBG -> Int -> [ByteString] -> [ByteString] +randomByteString gen n bytes + | n == 0 = ranBytes : bytes + | otherwise = randomByteString newGen (n - 1) $ ranBytes : bytes + where Right (ranBytes, newGen) = C.genBytes 32 gen + +-- | generates the specific number of bytestring with a random seed. +generateByteString :: Int -> IO [ByteString] +generateByteString n = do + gen <- C.newGenIO :: IO C.CtrDRBG + return $ randomByteString gen n [] + +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 + +passEquiv :: (MonadSh m) => Fuzz m [SynthResult] +passEquiv = filter withIdentity . _fuzzSynthResults <$> get + where + withIdentity (SynthResult _ _ (Pass _) _) = True + withIdentity _ = False + +-- | Always reduces with respect to 'Identity'. +reduction :: (MonadSh m) => SourceInfo -> Fuzz m () +reduction src = do + fails <- failEquivWithIdentity + synthFails <- failedSynthesis + _ <- liftSh $ mapM red fails + _ <- liftSh $ mapM redSynth synthFails + return () + where + red (SynthResult a b _ _) = do + make dir + pop dir $ do + s <- reduceSynth a b src + writefile (fromText ".." dir <.> "v") $ genSource s + return s + where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b + redSynth a = do + make dir + pop dir $ do + s <- reduceSynthesis a src + writefile (fromText ".." dir <.> "v") $ genSource s + return s + where dir = fromText $ "reduce_" <> toText 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) + +whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) +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) + => Fuzz m (Seed, SourceInfo) + -> Fuzz m (Seed, SourceInfo) +generateSample f = do + 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 + +hatFreqs :: Frequency a +hatFreqs l = zip hat (return <$> l) + where + h = length l `div` 2 + hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] + +meanFreqs :: Source a => Frequency a +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 + sizes = verilogSize . snd <$> l + +medianFreqs :: Frequency a +medianFreqs l = zip hat (return <$> l) + where + h = length l `div` 2 + hat = set_ <$> [1 .. length l] + set_ n = if n == h then 1 else 0 + +fuzz :: MonadFuzz m => Gen SourceInfo -> Config -> Fuzz m FuzzReport +fuzz gen conf = do + (seed', src) <- generateSample genMethod + let size = length . lines . T.unpack $ genSource src + liftSh + . writefile "config.toml" + . encodeConfig + $ conf + & configProperty + . propSeed + ?~ seed' + (tsynth, _) <- titleRun "Synthesis" $ synthesis src + (tequiv, _) <- titleRun "Equivalence Check" $ equivalence src + (_ , _) <- titleRun "Simulation" $ simulation src + fails <- failEquivWithIdentity + synthFails <- failedSynthesis + redResult <- + whenMaybe (not $ null fails && null synthFails) + . 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) + liftSh . writefile "index.html" $ printResultReport (bname currdir) report + return report + where + seed = conf ^. configProperty . propSeed + bname = T.pack . takeBaseName . T.unpack . toTextIgnore + genMethod = 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 + 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 + +fuzzInDir + :: MonadFuzz m => FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport +fuzzInDir fp src conf = do + make fp + res <- pop fp $ fuzz src conf + relativeFuzzReport res + +fuzzMultiple + :: MonadFuzz m + => Int + -> Maybe FilePath + -> Gen SourceInfo + -> Config + -> Fuzz m [FuzzReport] +fuzzMultiple n fp src conf = do + x <- case fp 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 .. n] fuzzDir' + else (: []) <$> fuzzDir' (1 :: Int) + liftSh . writefile (fromText "index" <.> "html") $ printSummary + "Fuzz Summary" + results + return results + where + fuzzDir' n' = fuzzInDir (fromText $ "fuzz_" <> showT n') src conf + seed = conf ^. configProperty . propSeed + +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 + runIdentity + . runMaybeT + . Hog.runTree + $ Hog.runGenT 30 seed gen + of + Nothing -> loop (n - 1) + Just x -> return (seed, Hog.nodeValue x) + in loop (100 :: Int) + diff --git a/src/Verismith/Generate.hs b/src/Verismith/Generate.hs new file mode 100644 index 0000000..205a54a --- /dev/null +++ b/src/Verismith/Generate.hs @@ -0,0 +1,623 @@ +{-| +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 TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Verismith.Generate + ( -- * Generation methods + procedural + , proceduralIO + , proceduralSrc + , proceduralSrcIO + , randomMod + -- ** Generate Functions + , gen + , 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 + ) +where + +import Control.Lens hiding (Context) +import Control.Monad (replicateM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader hiding (local) +import Control.Monad.Trans.State.Strict +import Data.Foldable (fold) +import Data.Functor.Foldable (cata) +import Data.List (foldl', partition) +import qualified Data.Text as T +import Hedgehog (Gen) +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 = Context { _variables :: [Port] + , _parameters :: [Parameter] + , _modules :: [ModDecl] + , _nameCounter :: {-# UNPACK #-} !Int + , _stmntDepth :: {-# UNPACK #-} !Int + , _modDepth :: {-# UNPACK #-} !Int + , _determinism :: !Bool + } + +makeLenses ''Context + +type StateGen = StateT Context (ReaderT Config Gen) + +toId :: Int -> Identifier +toId = Identifier . ("w" <>) . T.pack . show + +toPort :: Identifier -> Gen Port +toPort ident = do + i <- range + return $ wire i ident + +sumSize :: [Port] -> Range +sumSize ps = sum $ ps ^.. traverse . portSize + +random :: [Port] -> (Expr -> ContAssign) -> Gen ModItem +random ctx fun = do + 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 + +randomOrdAssigns :: [Port] -> [Port] -> [Gen ModItem] +randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids + where + generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) + +randomMod :: Int -> Int -> Gen ModDecl +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]) + [] + where + ids = toId <$> [1 .. total] + end = drop inps + start = take inps + +-- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the +-- 'Port'. +lvalFromPort :: Port -> LVal +lvalFromPort (Port _ _ _ i) = RegId i + +-- | Returns the probability from the configuration. +probability :: Config -> Probability +probability c = c ^. configProbability + +-- | Gets the current probabilities from the 'State'. +askProbability :: StateGen Probability +askProbability = lift $ asks probability + +-- | Lifts a 'Gen' into the 'StateGen' monad. +gen :: Gen a -> StateGen a +gen = lift . lift + +-- | Generates a random large number, which can also be negative. +largeNum :: Gen Int +largeNum = Hog.int $ Hog.linear (-100) 100 + +-- | Generates a random size for a wire so that it is not too small and not too +-- large. +wireSize :: Gen Int +wireSize = Hog.int $ Hog.linear 2 100 + +-- | Generates a random range by using the 'wireSize' and 0 as the lower bound. +range :: Gen Range +range = Range <$> fmap fromIntegral wireSize <*> pure 0 + +-- | Generate a random bit vector using 'largeNum'. +genBitVec :: Gen BitVec +genBitVec = fmap fromIntegral largeNum + +-- | Return a random 'BinaryOperator'. This currently excludes 'BinDiv', +-- 'BinMod' because they can take a long time to synthesis, and 'BinCEq', +-- 'BinCNEq', because these are not synthesisable. 'BinPower' is also excluded +-- because it can only be used in conjunction with base powers of 2 which is +-- currently not enforced. +binOp :: Gen 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 + ] + +-- | Generate a random 'UnaryOperator'. +unOp :: Gen UnaryOperator +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 :: [Parameter] -> ProbExpr -> Hog.Size -> Gen 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 + +-- | The list of safe 'Expr', meaning that these will not recurse and will end +-- the 'Expr' generation. +exprSafeList :: ProbExpr -> [(Int, Gen Expr)] +exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] + +-- | List of 'Expr' that have the chance to recurse and will therefore not be +-- used when the expression grows too large. +exprRecList :: ProbExpr -> (Hog.Size -> Gen Expr) -> [(Int, Gen 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) + ] + +-- | Select a random port from a list of ports and generate a safe bit selection +-- for that port. +rangeSelect :: [Parameter] -> [Port] -> Gen 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) + +-- | Generate a random expression from the 'Context' with a guarantee that it +-- will terminate using the list of safe 'Expr'. +exprWithContext :: ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> Gen 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 l n + | n == 0 + = Hog.frequency + $ (prob ^. probExprId, Id . fromPort <$> Hog.element l) + : exprSafeList prob + | 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 + +-- | Runs a 'StateGen' for a random number of times, limited by an 'Int' that is +-- passed to it. +someI :: Int -> StateGen a -> StateGen [a] +someI m f = do + amount <- gen $ 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 :: T.Text -> StateGen Identifier +makeIdentifier prefix = do + context <- get + let ident = Identifier $ prefix <> showT (context ^. nameCounter) + nameCounter += 1 + return ident + +getPort' :: PortType -> Identifier -> [Port] -> StateGen 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' + +-- | 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 +-- 'newPort'. This is used subsequently in all the functions to create a port, +-- in case a port with the same name was already created. This could be because +-- the generation is currently in the other branch of an if-statement. +nextPort :: PortType -> StateGen Port +nextPort pt = do + context <- get + ident <- makeIdentifier . T.toLower $ showT pt + 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 Port +newPort ident pt = do + p <- gen $ Port pt <$> Hog.bool <*> range <*> pure ident + variables %= (p :) + return p + +-- | Generates an expression from variables that are currently in scope. +scopedExpr :: StateGen Expr +scopedExpr = do + context <- get + prob <- askProbability + gen + . 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 ContAssign +contAssign = do + expr <- scopedExpr + p <- nextPort Wire + return $ ContAssign (p ^. portName) expr + +-- | Generate a random assignment and assign it to a random 'Reg'. +assignment :: StateGen Assign +assignment = do + expr <- scopedExpr + lval <- lvalFromPort <$> nextPort Reg + return $ Assign lval Nothing expr + +-- | Generate a random 'Statement' safely, by also increasing the depth counter. +seqBlock :: StateGen Statement +seqBlock = do + 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' +-- is not reused, it is left at 0, as all the 'Reg' are initialised to 0 at the +-- start. +conditional :: StateGen Statement +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) + +-- | Generate a random for loop by creating a new variable name for the counter +-- and then generating random statements in the body. +forLoop :: StateGen Statement +forLoop = do + num <- Hog.int (Hog.linear 0 20) + var <- lvalFromPort <$> nextPort 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 Statement +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 + +-- | Generate a sequential always block which is dependent on the clock. +alwaysSeq :: StateGen ModItem +alwaysSeq = Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock + +-- | Should resize a port that connects to a module port if the latter is +-- larger. This should not cause any problems if the same net is used as input +-- 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 + +-- | Instantiate a module, where the outputs are new nets that are created, and +-- the inputs are taken from existing ports in the context. +-- +-- 1 is subtracted from the inputs for the length because the clock is not +-- counted and is assumed to be there, this should be made nicer by filtering +-- out the clock instead. I think that in general there should be a special +-- representation for the clock. +instantiate :: ModDecl -> StateGen ModItem +instantiate (ModDecl i outP inP _ _) = do + context <- get + outs <- replicateM (length outP) (nextPort Wire) + ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) + 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) + , ModInst i ident <$> Hog.shuffle + (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) (toE $ outs <> clkPort <> ins)) + ] + 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 +-- for every instance and for every level until either the deepest level is +-- achieved, or the maximum number of modules are reached. +-- +-- If the maximum number of levels are reached, it will always pick an instance +-- from the current context. The problem with this approach is that at the end +-- there may be many more than the max amount of modules, as the modules are +-- always set to empty when entering a new level. This is to fix recursive +-- definitions of modules, which are not defined. +-- +-- One way to fix that is to also decrement the max modules for every level, +-- depending on how many modules have already been generated. This would mean +-- there would be moments when the module cannot generate a new instance but +-- also not take a module from the current context. A fix for that may be to +-- have a default definition of a simple module that is used instead. +-- +-- Another different way to handle this would be to have a probability of taking +-- a module from a context or generating a new one. +modInst :: StateGen ModItem +modInst = do + prob <- lift 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 ModItem +modItem = do + conf <- lift 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 + 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 Identifier +moduleName (Just t) = return t +moduleName Nothing = makeIdentifier "module" + +-- | Generate a random 'ConstExpr' by using the current context of 'Parameters'. +constExpr :: StateGen ConstExpr +constExpr = do + prob <- askProbability + context <- get + gen . 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 Parameter +parameter = do + 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 + +-- | Calculate a range to an int by maybe resizing the ranges to a value. +calcRange :: [Parameter] -> Maybe Int -> Range -> Int +calcRange ps i (Range l r) = eval l - eval r + 1 + where + eval a = fromIntegral . cata (evaluateConst ps) $ maybe a (`resize` a) i + +-- | Filter out a port based on it's name instead of equality of the ports. This +-- is because the ports might not be equal if the sizes are being updated. +identElem :: Port -> [Port] -> Bool +identElem p = elem (p ^. portName) . toListOf (traverse . portName) + +-- | Generates a module definition randomly. It always has one output port which +-- is set to @y@. The size of @y@ is the total combination of all the locally +-- defined wires, so that it correctly reflects the internal state of the +-- module. +moduleDef :: Maybe Identifier -> StateGen ModDecl +moduleDef top = do + name <- moduleName top + portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire + mi <- Hog.list (Hog.linear 4 100) modItem + ps <- Hog.list (Hog.linear 0 10) parameter + context <- get + config <- lift ask + let (newPorts, local) = partition (`identElem` portList) $ _variables context + let + size = + evalRange (_parameters context) 32 + . sum + $ local + ^.. traverse + . portSize + let combine = config ^. configProperty . propCombine + let clock = Port Wire False 1 "clk" + let yport = + if combine then Port Wire False 1 "y" else Port Wire False size "y" + let comb = combineAssigns_ combine yport local + 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 :: T.Text -> Config -> Gen Verilog +procedural top config = do + (mainMod, st) <- Hog.resize num $ runReaderT + (runStateT (moduleDef (Just $ Identifier top)) context) + config + return . Verilog $ mainMod : st ^. modules + where + context = + Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True + num = fromIntegral $ confProp propSize + confProp i = config ^. configProperty . i + +-- | Samples the 'Gen' directly to generate random 'Verilog' using the 'T.Text' as +-- the name of the main module and the configuration 'Config' to influence the +-- generation. +proceduralIO :: T.Text -> Config -> IO Verilog +proceduralIO t = Hog.sample . procedural t + +-- | Given a 'T.Text' and a 'Config' will generate a 'SourceInfo' which has the +-- top module set to the right name. +proceduralSrc :: T.Text -> Config -> Gen SourceInfo +proceduralSrc t c = SourceInfo t <$> procedural t c + +-- | Sampled and wrapped into a 'SourceInfo' with the given top module name. +proceduralSrcIO :: T.Text -> Config -> IO SourceInfo +proceduralSrcIO t c = SourceInfo t <$> proceduralIO t c diff --git a/src/Verismith/Internal.hs b/src/Verismith/Internal.hs new file mode 100644 index 0000000..b47c924 --- /dev/null +++ b/src/Verismith/Internal.hs @@ -0,0 +1,49 @@ +{-| +Module : Verismith.Internal +Description : Shared high level code used in the other modules internally. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +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) + +-- | Function to show a bytestring in a hex format. +showBS :: ByteString -> Text +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 + +-- | Show function for 'Text' +showT :: (Show a) => a -> Text +showT = T.pack . show + +-- | Inserts commas between '[Text]' and except the last one. +comma :: [Text] -> Text +comma = T.intercalate ", " + +-- | Inserts commas and newlines between '[Text]' and except the last one. +commaNL :: [Text] -> Text +commaNL = T.intercalate ",\n" diff --git a/src/Verismith/Reduce.hs b/src/Verismith/Reduce.hs new file mode 100644 index 0000000..69674cc --- /dev/null +++ b/src/Verismith/Reduce.hs @@ -0,0 +1,609 @@ +{-| +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 ScopedTypeVariables #-} + +module Verismith.Reduce + ( -- $strategy + reduceWithScript + , reduceSynth + , reduceSynthesis + , reduce + , reduce_ + , Replacement(..) + , halveModules + , halveModItems + , halveStatements + , halveExpr + , halveAssigns + , findActiveWires + , clean + , cleanSourceInfo + , cleanSourceInfoAll + , removeDecl + , filterExpr + ) +where + +import Control.Lens hiding ((<.>)) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +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 ((<.>)) +import qualified Shelly +import Shelly.Lifted (MonadSh, liftSh) +import Verismith.Internal +import Verismith.Result +import Verismith.Sim +import Verismith.Sim.Internal +import Verismith.Verilog +import Verismith.Verilog.AST +import Verismith.Verilog.Mutate +import Verismith.Verilog.Parser + + +-- $strategy +-- The reduction strategy has multiple different steps. 'reduce' will run these +-- strategies one after another, starting at the most coarse grained one. The +-- supported reduction strategies are the following: +-- +-- [Modules] First of all, the reducer will try and remove all the modules +-- except the top module. +-- +-- [Module Items] Then, the module items will be reduced by using standard +-- delta debugging. Half of the module items will be removed, and both +-- versions will be tested. If both succeed, they will be divided further and +-- tested further. Finally, the shortest version will be returned. +-- +-- [Statements] Once the module items have been reduced, the statements will +-- be reduced as well. This is done using delta debugging, just like the +-- module items. +-- +-- [Expressions] Finally, the expressions themselves will be reduced. This is +-- done by splitting the top most binary expressions in half and testing each +-- half. + +-- | 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) + +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 + +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 + +instance Foldable Replacement where + 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 + +-- | Split a list in two halves. +halve :: Replace [a] +halve [] = Single [] +halve [_] = Single [] +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 + +-- | 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 +-- module. +combine :: Lens' a b -> Replace b -> Replace a +combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res + +-- | Deletes Id 'Expr' if they are not part of the current scope, and replaces +-- these by 0. +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 +filterExpr ids (RangeSelect i r) = + 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 -> 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 -> Bool +filterAssigns out (ModCA (ContAssign i _)) = + elem i $ out ^.. traverse . portName +filterAssigns _ _ = True + +clean :: (Mutate a) => [Identifier] -> a -> a +clean ids = mutExpr (transform $ filterExpr ids) + +cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem] +cleanUndefined ids mis = clean usedWires mis + where + usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids + +halveModAssign :: Replace ModDecl +halveModAssign m = cleanMod m $ modify <$> assigns (m ^. modItems) + where + assigns = halve . filter (filterAssigns $ m ^. modOutPorts) + modify l = m & modItems .~ l + +cleanMod :: ModDecl -> Replacement ModDecl -> Replacement ModDecl +cleanMod m newm = modify . change <$> newm + where + 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 + +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 + +halveModExpr :: Replace ModItem +halveModExpr (ModCA ca) = ModCA <$> combine contAssignExpr halveIndExpr ca +halveModExpr a = Single a + +-- | Remove all the undefined mod instances. +cleanModInst :: SourceInfo -> SourceInfo +cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned + where + validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId + cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped + +-- | Clean all the undefined module instances in a specific module using a +-- context. +cleanModInst' :: [Identifier] -> ModDecl -> ModDecl +cleanModInst' ids m = m & modItems .~ newModItem + where newModItem = filter (validModInst ids) $ m ^.. modItems . traverse + +-- | Check if a mod instance is in the current context. +validModInst :: [Identifier] -> ModItem -> Bool +validModInst ids (ModInst i _ _) = i `elem` ids +validModInst _ _ = True + +-- | Adds a 'ModDecl' to a 'SourceInfo'. +addMod :: ModDecl -> SourceInfo -> SourceInfo +addMod m srcInfo = srcInfo & infoSrc . _Wrapped %~ (m :) + +-- | Split a module declaration in half by trying to remove assign +-- statements. This is only done in the main module of the source. +halveAssigns :: Replace SourceInfo +halveAssigns = combine mainModule halveModAssign + +-- | Checks if a module item is needed in the module declaration. +relevantModItem :: ModDecl -> ModItem -> Bool +relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) = + i `elem` fmap _portName out +relevantModItem _ Decl{} = True +relevantModItem _ _ = False + +isAssign :: Statement -> Bool +isAssign (BlockAssign _) = True +isAssign (NonBlockAssign _) = True +isAssign _ = False + +lValName :: LVal -> [Identifier] +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 + +-- | 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 (RangeSelect i _) = [i] +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 (RangeSelect i _) = Just i +exprId _ = Nothing + +eventId :: Event -> Maybe Identifier +eventId (EId i) = Just i +eventId (EPosEdge i) = Just i +eventId (ENegEdge i) = Just i +eventId _ = Nothing + +portToId :: Port -> Identifier +portToId (Port _ _ _ i) = i + +paramToId :: Parameter -> Identifier +paramToId (Parameter i _) = i + +isModule :: Identifier -> ModDecl -> Bool +isModule i (ModDecl n _ _ _ _) = i == n + +modInstActive :: [ModDecl] -> ModItem -> [Identifier] +modInstActive decl (ModInst n _ i) = case m of + 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 _ _ _) (ModConnNamed i' e, _) + | i' `elem` fmap _portName o = exprName e + | otherwise = [] +modInstActive _ _ = [] + +fixModInst :: SourceInfo -> ModItem -> ModItem +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 ..] + 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 + fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _) + | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e + | otherwise = Nothing +fixModInst _ a = a + +findActiveWires :: Identifier -> SourceInfo -> [Identifier] +findActiveWires t src = + 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) + allStat = filter isAssign . concat $ fmap universe stat + stat = + (m ^.. modItems . traverse . _Initial) + <> (m ^.. modItems . traverse . _Always) + modinstwires = + 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 +-- 'SourceInfo', otherwise it will crash. +cleanSourceInfo :: Identifier -> SourceInfo -> SourceInfo +cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) + +cleanSourceInfoAll :: SourceInfo -> SourceInfo +cleanSourceInfoAll src = foldr cleanSourceInfo src allMods + where allMods = src ^.. infoSrc . _Wrapped . traverse . modId + +-- | Returns true if the text matches the name of a module. +matchesModName :: Identifier -> ModDecl -> Bool +matchesModName top (ModDecl i _ _ _ _) = top == i + +halveStatement :: Replace Statement +halveStatement (SeqBlock [s]) = halveStatement s +halveStatement (SeqBlock s) = SeqBlock <$> halve s +halveStatement (CondStmnt _ (Just s1) (Just s2)) = Dual s1 s2 +halveStatement (CondStmnt _ (Just s1) Nothing) = Single s1 +halveStatement (CondStmnt _ Nothing (Just s1)) = Single s1 +halveStatement (EventCtrl e (Just s)) = EventCtrl e . Just <$> halveStatement s +halveStatement (TimeCtrl e (Just s)) = TimeCtrl e . Just <$> halveStatement s +halveStatement a = Single a + +halveAlways :: Replace ModItem +halveAlways (Always s) = Always <$> halveStatement s +halveAlways a = Single a + +-- | Removes half the modules randomly, until it reaches a minimal amount of +-- modules. This is done by doing a binary search on the list of modules and +-- removing the instantiations from the main module body. +halveModules :: Replace SourceInfo +halveModules srcInfo@(SourceInfo top _) = + cleanSourceInfoAll + . cleanModInst + . addMod main + <$> combine (infoSrc . _Wrapped) repl srcInfo + where + repl = halve . filter (not . matchesModName (Identifier top)) + main = srcInfo ^. mainModule + +moduleBot :: SourceInfo -> Bool +moduleBot (SourceInfo _ (Verilog [] )) = True +moduleBot (SourceInfo _ (Verilog [_])) = True +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 +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 + addRelevant = aModule t . modItems %~ (relevant ++) + +modItemBot :: Identifier -> SourceInfo -> Bool +modItemBot t srcInfo | length modItemsNoDecl > 2 = False + | otherwise = True + where + modItemsNoDecl = + filter noDecl $ srcInfo ^.. aModule t . modItems . traverse + noDecl Decl{} = False + noDecl _ = True + +halveStatements :: Identifier -> Replace SourceInfo +halveStatements t m = + cleanSourceInfo t <$> combine (aModule t . modItems) halves m + where halves = traverse halveAlways + +-- | Reduce expressions by splitting them in half and keeping the half that +-- succeeds. +halveExpr :: Identifier -> Replace SourceInfo +halveExpr t = combine contexpr $ traverse halveModExpr + where + contexpr :: Lens' SourceInfo [ModItem] + contexpr = aModule t . modItems + +toIds :: [Expr] -> [Identifier] +toIds = nub . mapMaybe exprId . concatMap universe + +toIdsConst :: [ConstExpr] -> [Identifier] +toIdsConst = toIds . fmap constToExpr + +toIdsEvent :: [Event] -> [Identifier] +toIdsEvent = nub . mapMaybe eventId . concatMap universe + +allStatIds' :: Statement -> [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) + eventProcessedIds = toIdsEvent $ s ^.. statEvent + +allStatIds :: Statement -> [Identifier] +allStatIds s = nub . concat $ allStatIds' <$> universe s + +fromRange :: Range -> [ConstExpr] +fromRange r = [rangeMSB r, rangeLSB r] + +allExprIds :: ModDecl -> [Identifier] +allExprIds m = + nub + $ contAssignIds + <> modInstIds + <> modInitialIds + <> modAlwaysIds + <> modPortIds + <> modDeclIds + <> paramIds + where + contAssignIds = + toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr + modInstIds = + toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr + modInitialIds = + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial + modAlwaysIds = + nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always + modPortIds = + 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 + ) + +isUsedDecl :: [Identifier] -> ModItem -> Bool +isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids +isUsedDecl _ _ = True + +isUsedParam :: [Identifier] -> Parameter -> Bool +isUsedParam ids (Parameter i _) = i `elem` ids + +isUsedPort :: [Identifier] -> Port -> Bool +isUsedPort ids (Port _ _ _ i) = i `elem` ids + +removeDecl :: SourceInfo -> SourceInfo +removeDecl src = foldr fix removed allMods + where + removeDecl' t src' = + 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) + allMods = src ^.. infoSrc . _Wrapped . traverse . modId + fix t a = a & aModule t . modItems %~ fmap (fixModInst a) + removed = foldr removeDecl' src allMods + +defaultBot :: SourceInfo -> Bool +defaultBot = const False + +-- | Reduction using custom reduction strategies. +reduce_ + :: MonadSh m + => Text + -> Replace SourceInfo + -> (SourceInfo -> Bool) + -> (SourceInfo -> m Bool) + -> SourceInfo + -> m SourceInfo +reduce_ title repl bot eval src = do + 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 src + else case repl src of + Single s -> do + red <- eval s + if red + then if cond s then recReduction s else return s + else return src + Dual l r -> do + red <- eval l + if red + then if cond l then recReduction l else return l + else do + red' <- eval r + if red' + then if cond r then recReduction r else return r + else return src + None -> return src + where + cond s = s /= src + recReduction = reduce_ title repl bot eval + +-- | Reduce an input to a minimal representation. It follows the reduction +-- strategy mentioned above. +reduce + :: MonadSh m + => (SourceInfo -> m Bool) -- ^ Failed or not. + -> SourceInfo -- ^ Input verilog source to be reduced. + -> m SourceInfo -- ^ Reduced output. +reduce eval src = + fmap removeDecl + $ red "Modules" moduleBot halveModules src + >>= redAll "Module Items" modItemBot halveModItems + >>= redAll "Statements" (const defaultBot) halveStatements + -- >>= redAll "Expressions" (const defaultBot) halveExpr + where + red s bot a = reduce_ s a bot eval + red' s bot a t = reduce_ s (a t) (bot t) eval + redAll s bot halve' src' = foldrM + (\t -> red' (s <> " (" <> getIdentifier t <> ")") bot halve' t) + src' + (src' ^.. infoSrc . _Wrapped . traverse . modId) + +runScript + :: MonadSh m => Shelly.FilePath -> Shelly.FilePath -> SourceInfo -> 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 + +-- | Reduce using a script that is passed to it +reduceWithScript + :: (MonadSh m, MonadIO m) + => Text + -> Shelly.FilePath + -> Shelly.FilePath + -> m () +reduceWithScript top script file = do + liftSh . Shelly.cp file $ file <.> "original" + srcInfo <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file + void $ reduce (runScript script file) srcInfo + +-- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it. +reduceSynth + :: (Synthesiser a, Synthesiser b, MonadSh m) + => a + -> b + -> SourceInfo + -> m SourceInfo +reduceSynth a b = reduce synth + where + synth src' = liftSh $ do + r <- runResultT $ do + runSynth a src' + runSynth b src' + runEquiv a b src' + return $ case r of + Fail EquivFail -> True + Fail _ -> False + Pass _ -> False + +reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo -> m SourceInfo +reduceSynthesis a = reduce synth + where + synth src = liftSh $ do + r <- runResultT $ runSynth a src + return $ case r of + Fail SynthFail -> True + Fail _ -> False + Pass _ -> False diff --git a/src/Verismith/Report.hs b/src/Verismith/Report.hs new file mode 100644 index 0000000..b074be4 --- /dev/null +++ b/src/Verismith/Report.hs @@ -0,0 +1,398 @@ +{-# 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 TemplateHaskell #-} + +module Verismith.Report + ( SynthTool(..) + , SynthStatus(..) + , SynthResult(..) + , SimResult(..) + , SimTool(..) + , FuzzReport(..) + , printResultReport + , printSummary + , synthResults + , simResults + , synthStatus + , equivTime + , fuzzDir + , fileLines + , reducTime + , synthTime + , defaultIcarusSim + , defaultVivadoSynth + , defaultYosysSynth + , defaultXSTSynth + , defaultQuartusSynth + , 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 Data.Vector (fromList) +import Prelude hiding (FilePath) +import Shelly (FilePath, fromText, + toTextIgnore, (<.>), ()) +import Statistics.Sample (meanVariance) +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.Sim +import Verismith.Sim.Internal + +-- | Common type alias for synthesis results +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 + | 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 (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 (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 (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 (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 (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 (IdentitySynth identity) = IdentitySynth . setSynthOutput identity + +defaultYosysSynth :: SynthTool +defaultYosysSynth = YosysSynth defaultYosys + +defaultQuartusSynth :: SynthTool +defaultQuartusSynth = QuartusSynth defaultQuartus + +defaultVivadoSynth :: SynthTool +defaultVivadoSynth = VivadoSynth defaultVivado + +defaultXSTSynth :: SynthTool +defaultXSTSynth = XSTSynth defaultXST + +defaultIdentitySynth :: SynthTool +defaultIdentitySynth = IdentitySynth defaultIdentity + +newtype SimTool = IcarusSim Icarus + deriving (Eq) + +instance NFData SimTool where + rnf (IcarusSim a) = rnf a + +instance Tool SimTool where + toText (IcarusSim icarus) = toText icarus + +instance Simulator SimTool where + runSim (IcarusSim icarus) = runSim icarus + runSimWithFile (IcarusSim icarus) = runSimWithFile icarus + +instance Show SimTool where + show (IcarusSim icarus) = show icarus + +defaultIcarusSim :: SimTool +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 !BResult !NominalDiffTime + 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 <> ")" + +getSimResult :: SimResult -> UResult +getSimResult (SimResult _ _ (Pass _) _) = Pass () +getSimResult (SimResult _ _ (Fail b) _) = Fail b + +-- | The results of comparing the synthesised outputs of two files using a +-- 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) + +instance Show SynthResult where + show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" + +getSynthResult :: SynthResult -> UResult +getSynthResult (SynthResult _ _ a _) = a + +-- | The status of the synthesis using a simulator. This will be checked before +-- attempting to run the equivalence checks on the simulator, as that would be +-- unnecessary otherwise. +data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime + 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 <> ")" + +-- | The complete state that will be used during fuzzing, which contains the +-- results from all the operations. +data FuzzReport = FuzzReport { _fuzzDir :: !FilePath + , _synthResults :: ![SynthResult] + , _simResults :: ![SimResult] + , _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 <> "'" + +-- | 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 +descriptionToSynth (SynthDescription "vivado" bin desc 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 +descriptionToSynth (SynthDescription "quartus" bin desc out) = + QuartusSynth + . Quartus (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 +descriptionToSynth 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 (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" + +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 + +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 + +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" + +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 + +resultStatus :: Result a b -> Html +resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" +resultStatus (Fail _) = H.td ! A.class_ "is-danger" $ "Failed" + +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 = fromList . 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 + ! A.href + ( H.textValue + $ toTextIgnore (dir fromText "index" <.> "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 + ] + 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 + +printResultReport :: Text -> FuzzReport -> Text +printResultReport t f = toStrict . renderHtml $ resultReport t f + +printSummary :: Text -> [FuzzReport] -> Text +printSummary t f = toStrict . renderHtml $ summary t f diff --git a/src/Verismith/Result.hs b/src/Verismith/Result.hs new file mode 100644 index 0000000..d8efd2f --- /dev/null +++ b/src/Verismith/Result.hs @@ -0,0 +1,137 @@ +{-| +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 MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Verismith.Result + ( Result(..) + , ResultT(..) + , () + , annotate + ) +where + +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, liftSh) + +-- | 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) + +instance Semigroup (Result a b) where + Pass _ <> a = a + a <> _ = a + +instance (Monoid b) => Monoid (Result a b) where + mempty = Pass mempty + +instance Functor (Result a) where + 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 + +instance Monad (Result a) where + Pass a >>= f = f a + Fail b >>= _ = Fail b + +instance MonadBase (Result a) (Result a) where + liftBase = id + +instance Bifunctor Result where + 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) } + +instance Functor f => Functor (ResultT a f) where + 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) + +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) + +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)) + +instance MonadIO m => MonadIO (ResultT a m) where + liftIO s = ResultT $ Pass <$> liftIO s + +instance MonadBase b m => MonadBase b (ResultT a m) where + liftBase = liftBaseDefault + +instance MonadTrans (ResultT e) where + 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 #-} + +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 #-} + +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 + +annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b +annotate = flip () diff --git a/src/Verismith/Sim.hs b/src/Verismith/Sim.hs new file mode 100644 index 0000000..5e31985 --- /dev/null +++ b/src/Verismith/Sim.hs @@ -0,0 +1,51 @@ +{-| +Module : Verismith.Sim +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.Sim + ( + -- * Simulators + -- ** Icarus + Icarus(..) + , defaultIcarus + -- * Synthesisers + -- ** Yosys + , Yosys(..) + , defaultYosys + -- ** Vivado + , Vivado(..) + , defaultVivado + -- ** XST + , XST(..) + , defaultXST + -- ** Quartus + , Quartus(..) + , defaultQuartus + -- ** Identity + , Identity(..) + , defaultIdentity + -- * Equivalence + , runEquiv + -- * Simulation + , runSim + -- * Synthesis + , runSynth + , logger + ) +where + +import Verismith.Sim.Icarus +import Verismith.Sim.Identity +import Verismith.Sim.Internal +import Verismith.Sim.Quartus +import Verismith.Sim.Vivado +import Verismith.Sim.XST +import Verismith.Sim.Yosys diff --git a/src/Verismith/Sim/Icarus.hs b/src/Verismith/Sim/Icarus.hs new file mode 100644 index 0000000..003f1de --- /dev/null +++ b/src/Verismith/Sim/Icarus.hs @@ -0,0 +1,188 @@ +{-| +Module : Verismith.Sim.Icarus +Description : Icarus verilog module. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Icarus verilog module. +-} + +module Verismith.Sim.Icarus + ( Icarus(..) + , defaultIcarus + , runSimIc + ) +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.Sim.Internal +import Verismith.Sim.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) + +instance Show Icarus where + show _ = "iverilog" + +instance Tool Icarus where + toText _ = "iverilog" + +instance Simulator Icarus where + runSim = runSimIcarus + runSimWithFile = runSimIcarusWithFile + +instance NFData Icarus where + rnf = rwhnf + +defaultIcarus :: Icarus +defaultIcarus = Icarus "iverilog" "vvp" + +addDisplay :: [Statement] -> [Statement] +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 +assignFunc inp bs = + 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 + +mask :: Text -> Text +mask = T.replace "x" "0" + +callback :: ByteString -> Text -> ByteString +callback b t = b <> convert (mask t) + +runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss + where m = rinfo ^. mainModule + +runSimIcarusWithFile + :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString +runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) + +fromBytes :: ByteString -> Integer +fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b + +runSimIc + :: (Synthesiser b) + => Icarus + -> b + -> SourceInfo + -> [ByteString] + -> ResultSh ByteString +runSimIc sim1 synth1 srcInfo bss = do + dir <- liftSh pwd + let top = srcInfo ^. mainModule + let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) + let + tb = 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 + ) + <> (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"] + ] + [] + + liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 + liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] + liftSh + $ B.take 8 + . BA.convert + . (hash :: ByteString -> Digest SHA256) + <$> logCommand + dir + "vvp" + (runFoldLines (mempty :: ByteString) + callback + (vvpPath sim1) + ["main"] + ) + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Sim/Identity.hs b/src/Verismith/Sim/Identity.hs new file mode 100644 index 0000000..89c6b36 --- /dev/null +++ b/src/Verismith/Sim/Identity.hs @@ -0,0 +1,51 @@ +{-| +Module : Verismith.Sim.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.Sim.Identity + ( 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.Sim.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text + , identityOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Identity where + toText (Identity d _) = d + +instance Show Identity where + show t = unpack $ toText t + +instance Synthesiser Identity where + runSynth = runSynthIdentity + synthOutput = identityOutput + setSynthOutput (Identity a _) = Identity a + +instance NFData Identity where + rnf = rwhnf + +runSynthIdentity :: Identity -> SourceInfo -> ResultSh () +runSynthIdentity (Identity _ out) = writefile out . genSource + +defaultIdentity :: Identity +defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/Verismith/Sim/Internal.hs b/src/Verismith/Sim/Internal.hs new file mode 100644 index 0000000..bcbc3af --- /dev/null +++ b/src/Verismith/Sim/Internal.hs @@ -0,0 +1,215 @@ +{-| +Module : Verismith.Sim.Internal +Description : Class of the simulator. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Class of the simulator and the synthesize tool. +-} + +{-# LANGUAGE DeriveFunctor #-} + +module Verismith.Sim.Internal + ( 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.Internal +import Verismith.Result +import Verismith.Verilog.AST + +-- | Tool class. +class Tool a where + toText :: a -> Text + +-- | Simulation type class. +class Tool a => Simulator a where + runSim :: a -- ^ Simulator instance + -> SourceInfo -- ^ 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 + | EquivError + | SimFail + | SynthFail + | TimeoutError + deriving (Eq, Show) + +instance Semigroup Failed where + EmptyFail <> a = a + b <> _ = b + +instance Monoid Failed where + mempty = EmptyFail + +-- | Synthesiser type class. +class Tool a => Synthesiser a where + runSynth :: a -- ^ Synthesiser tool instance + -> SourceInfo -- ^ Run information + -> ResultSh () -- ^ does not return any values + synthOutput :: a -> FilePath + setSynthOutput :: a -> FilePath -> a + +renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo +renameSource a src = + 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 +-- with also has those instances. +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' + +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 + +-- | 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 -> Sh [Text] +checkPresentModules fp (SourceInfo _ src) = do + 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] + +-- | 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 +-- should find all the instantiations and definitions. This could again be made +-- much simpler if the parser works. +replaceMods :: FilePath -> Text -> SourceInfo -> Sh () +replaceMods fp t (SourceInfo _ src) = + 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" + +timeout :: FilePath -> [Text] -> Sh Text +timeout = command1 "timeout" ["300"] . toTextIgnore +{-# INLINE timeout #-} + +timeout_ :: FilePath -> [Text] -> Sh () +timeout_ = command1_ "timeout" ["300"] . toTextIgnore +{-# INLINE timeout_ #-} + +-- | Helper function to convert bytestrings to integers +bsToI :: ByteString -> Integer +bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 +{-# INLINE bsToI #-} + +noPrint :: Sh a -> Sh a +noPrint = print_stdout False . print_stderr False +{-# INLINE noPrint #-} + +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 + +logCommand :: FilePath -> Text -> Sh a -> Sh a +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" + file s = T.unpack (toTextIgnore $ fp fromText name) <> s + +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 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 () +execute_ a b c d = void . execute a b c d diff --git a/src/Verismith/Sim/Quartus.hs b/src/Verismith/Sim/Quartus.hs new file mode 100644 index 0000000..5fb1e49 --- /dev/null +++ b/src/Verismith/Sim/Quartus.hs @@ -0,0 +1,77 @@ +{-| +Module : Verismith.Sim.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.Sim.Quartus + ( 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.Sim.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data Quartus = Quartus { quartusBin :: !(Maybe FilePath) + , quartusDesc :: {-# UNPACK #-} !Text + , quartusOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Quartus where + toText (Quartus _ t _) = t + +instance Show Quartus where + show t = unpack $ toText t + +instance Synthesiser Quartus where + runSynth = runSynthQuartus + synthOutput = quartusOutput + setSynthOutput (Quartus a b _) = Quartus a b + +instance NFData Quartus where + rnf = rwhnf + +defaultQuartus :: Quartus +defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" + +runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () +runSynthQuartus sim (SourceInfo top src) = do + dir <- liftSh pwd + let ex = execute_ SynthFail dir "quartus" + liftSh . writefile inpf $ genSource src + liftSh . noPrint $ run_ + "sed" + [ "-i" + , "s/^module/(* multstyle = \"logic\" *) module/;" + , toTextIgnore inpf + ] + ex (exec "quartus_map") + [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] + ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] + ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] + 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/Sim/Template.hs b/src/Verismith/Sim/Template.hs new file mode 100644 index 0000000..071e040 --- /dev/null +++ b/src/Verismith/Sim/Template.hs @@ -0,0 +1,133 @@ +{-| +Module : Verismith.Sim.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.Sim.Template + ( yosysSatConfig + , yosysSimConfig + , xstSynthConfig + , vivadoSynthConfig + , sbyConfig + , icarusTestbench + ) +where + +import Control.Lens ((^..)) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (FilePath) +import Shelly +import Text.Shakespeare.Text (st) +import Verismith.Sim.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +rename :: Text -> [Text] -> Text +rename end entries = + T.intercalate "\n" + $ flip mappend end + . mappend "rename " + . doubleName + <$> entries +{-# INLINE rename #-} + +doubleName :: Text -> Text +doubleName n = n <> " " <> n +{-# INLINE doubleName #-} + +outputText :: Synthesiser a => a -> Text +outputText = toTextIgnore . synthOutput + +-- brittany-disable-next-binding +yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 + +-- brittany-disable-next-binding +yosysSimConfig :: Text +yosysSimConfig = [st|read_verilog rtl.v; proc;; +rename mod mod_rtl +|] + +-- brittany-disable-next-binding +xstSynthConfig :: Text -> Text +xstSynthConfig top = [st|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" +|] + +-- brittany-disable-next-binding +vivadoSynthConfig :: Text -> Text -> Text +vivadoSynthConfig top outf = [st| +# 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} +|] + +-- brittany-disable-next-binding +sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] +multiclock on +mode prove + +[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 + . (fromText "data" ) + . fromText + <$> deps + readL = T.intercalate "\n" $ mappend "read -formal " <$> deps + +icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text +icarusTestbench t synth1 = [st| +`include "data/cells_cmos.v" +`include "data/cells_cyclone_v.v" +`include "data/cells_verific.v" +`include "data/cells_xilinx_7.v" +`include "data/cells_yosys.v" +`include "#{toTextIgnore $ synthOutput synth1}" + +#{genSource t} +|] diff --git a/src/Verismith/Sim/Vivado.hs b/src/Verismith/Sim/Vivado.hs new file mode 100644 index 0000000..2dad87d --- /dev/null +++ b/src/Verismith/Sim/Vivado.hs @@ -0,0 +1,71 @@ +{-| +Module : Verismith.Sim.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.Sim.Vivado + ( 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.Sim.Internal +import Verismith.Sim.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) + , vivadoDesc :: {-# UNPACK #-} !Text + , vivadoOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Vivado where + toText (Vivado _ t _) = t + +instance Show Vivado where + show t = unpack $ toText t + +instance Synthesiser Vivado where + runSynth = runSynthVivado + synthOutput = vivadoOutput + setSynthOutput (Vivado a b _) = Vivado a b + +instance NFData Vivado where + rnf = rwhnf + +defaultVivado :: Vivado +defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" + +runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/Verismith/Sim/XST.hs b/src/Verismith/Sim/XST.hs new file mode 100644 index 0000000..9144ba7 --- /dev/null +++ b/src/Verismith/Sim/XST.hs @@ -0,0 +1,85 @@ +{-| +Module : Verismith.Sim.XST +Description : XST (ise) simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +XST (ise) simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module Verismith.Sim.XST + ( 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 Text.Shakespeare.Text (st) +import Verismith.Sim.Internal +import Verismith.Sim.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data XST = XST { xstBin :: !(Maybe FilePath) + , xstDesc :: {-# UNPACK #-} !Text + , xstOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool XST where + toText (XST _ t _) = t + +instance Show XST where + show t = unpack $ toText t + +instance Synthesiser XST where + runSynth = runSynthXST + synthOutput = xstOutput + setSynthOutput (XST a b _) = XST a b + +instance NFData XST where + rnf = rwhnf + +defaultXST :: XST +defaultXST = XST Nothing "xst" "syn_xst.v" + +runSynthXST :: XST -> SourceInfo -> 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 [st|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" + prjFile = modFile <.> "prj" diff --git a/src/Verismith/Sim/Yosys.hs b/src/Verismith/Sim/Yosys.hs new file mode 100644 index 0000000..9805140 --- /dev/null +++ b/src/Verismith/Sim/Yosys.hs @@ -0,0 +1,127 @@ +{-| +Module : Verismith.Sim.Yosys +Description : Yosys simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Yosys simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module Verismith.Sim.Yosys + ( Yosys(..) + , defaultYosys + , runEquiv + , runEquivYosys + ) +where + +import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.Lens +import Control.Monad (void) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) +import Shelly +import Shelly.Lifted (liftSh) +import Text.Shakespeare.Text (st) +import Verismith.Result +import Verismith.Sim.Internal +import Verismith.Sim.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Mutate + +data Yosys = Yosys { yosysBin :: !(Maybe FilePath) + , yosysDesc :: {-# UNPACK #-} !Text + , yosysOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Yosys where + toText (Yosys _ t _) = t + +instance Show Yosys where + show t = unpack $ toText t + +instance Synthesiser Yosys where + runSynth = runSynthYosys + synthOutput = yosysOutput + setSynthOutput (Yosys a b _) = Yosys a b + +instance NFData Yosys where + rnf = rwhnf + +defaultYosys :: Yosys +defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" + +yosysPath :: Yosys -> FilePath +yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim + +runSynthYosys :: Yosys -> SourceInfo -> ResultSh () +runSynthYosys sim (SourceInfo _ src) = do + dir <- liftSh $ do + dir' <- pwd + 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 = toTextIgnore inpf + out = toTextIgnore $ synthOutput sim + +runEquivYosys + :: (Synthesiser a, Synthesiser b) + => Yosys + -> a + -> b + -> SourceInfo + -> ResultSh () +runEquivYosys yosys sim1 sim2 srcInfo = do + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTop 2 + $ srcInfo + ^. mainModule + writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo + runSynth sim1 srcInfo + runSynth sim2 srcInfo + liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] + where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] + +runEquiv + :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () +runEquiv sim1 sim2 srcInfo = do + dir <- liftSh pwd + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTopAssert + $ srcInfo + ^. mainModule + replaceMods (synthOutput sim1) "_1" srcInfo + replaceMods (synthOutput sim2) "_2" srcInfo + writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo + e <- liftSh $ do + exe dir "symbiyosys" "sby" ["-f", "proof.sby"] + lastExitCode + case e of + 0 -> ResultT . return $ Pass () + 2 -> ResultT . return $ Fail EquivFail + 124 -> ResultT . return $ Fail TimeoutError + _ -> ResultT . return $ Fail EquivError + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Verilog.hs b/src/Verismith/Verilog.hs new file mode 100644 index 0000000..f3d9e85 --- /dev/null +++ b/src/Verismith/Verilog.hs @@ -0,0 +1,106 @@ +{-| +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 + ( SourceInfo(..) + , Verilog(..) + , parseVerilog + , GenVerilog(..) + , genSource + -- * Primitives + -- ** Identifier + , Identifier(..) + -- ** Control + , Delay(..) + , Event(..) + -- ** Operators + , BinaryOperator(..) + , UnaryOperator(..) + -- ** Task + , Task(..) + , taskName + , taskExpr + -- ** Left hand side value + , LVal(..) + , regId + , regExprId + , regExpr + , regSizeId + , regSizeRange + , regConc + -- ** Ports + , PortDir(..) + , PortType(..) + , Port(..) + , portType + , portSigned + , portSize + , portName + -- * Expression + , Expr(..) + , ConstExpr(..) + , constToExpr + , exprToConst + , constNum + -- * Assignment + , Assign(..) + , assignReg + , assignDelay + , assignExpr + , ContAssign(..) + , contAssignNetLVal + , contAssignExpr + -- * Statment + , 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 + -- * Useful Lenses and Traversals + , getModule + , getSourceId + -- * Quote + , verilog + ) +where + +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 new file mode 100644 index 0000000..699d87a --- /dev/null +++ b/src/Verismith/Verilog/AST.hs @@ -0,0 +1,583 @@ +{-| +Module : Verismith.Verilog.AST +Description : Definition of the Verilog AST types. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Verismith.Verilog.AST + ( -- * Top level types + SourceInfo(..) + , infoTop + , infoSrc + , Verilog(..) + -- * Primitives + -- ** Identifier + , Identifier(..) + -- ** Control + , Delay(..) + , Event(..) + -- ** Operators + , BinaryOperator(..) + , UnaryOperator(..) + -- ** Task + , Task(..) + , taskName + , taskExpr + -- ** Left hand side value + , LVal(..) + , regId + , regExprId + , regExpr + , regSizeId + , regSizeRange + , regConc + -- ** Ports + , 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 + -- * Assignment + , Assign(..) + , assignReg + , assignDelay + , assignExpr + , ContAssign(..) + , contAssignNetLVal + , contAssignExpr + -- ** Parameters + , Parameter(..) + , paramIdent + , paramValue + , LocalParam(..) + , localParamIdent + , localParamValue + -- * Statment + , Statement(..) + , statDelay + , statDStat + , statEvent + , statEStat + , statements + , stmntBA + , stmntNBA + , stmntTask + , stmntSysTask + , stmntCondExpr + , stmntCondTrue + , stmntCondFalse + , 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 + -- * Useful Lenses and Traversals + , aModule + , getModule + , getSourceId + , mainModule + ) +where + +import Control.DeepSeq (NFData) +import Control.Lens hiding ((<|)) +import Data.Data +import Data.Data.Lens +import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.String (IsString, fromString) +import Data.Text (Text, pack) +import Data.Traversable (sequenceA) +import GHC.Generics (Generic) +import Verismith.Verilog.BitVec + +-- | 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) + +instance IsString Identifier where + fromString = Identifier . pack + +instance Semigroup Identifier where + Identifier a <> Identifier b = Identifier $ a <> b + +instance Monoid Identifier where + mempty = Identifier mempty + +-- | Verilog syntax for adding a delay, which is represented as @#num@. +newtype Delay = Delay { _getDelay :: Int } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Num Delay where + Delay a + Delay b = Delay $ a + b + Delay a - Delay b = Delay $ a - b + Delay a * Delay b = Delay $ a * b + negate (Delay a) = Delay $ negate a + abs (Delay a) = Delay $ abs a + signum (Delay a) = Delay $ signum a + fromInteger = Delay . fromInteger + +-- | 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) + +instance Plated Event where + 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) + +-- | 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) + +-- | Verilog expression, which can either be a primary expression, unary +-- expression, binary operator expression or a conditional expression. +data Expr = Number {-# UNPACK #-} !BitVec + -- ^ Number implementation containing the size and the value itself + | Id {-# UNPACK #-} !Identifier + | VecSelect {-# UNPACK #-} !Identifier !Expr + | RangeSelect {-# UNPACK #-} !Identifier !Range + -- ^ Symbols + | Concat !(NonEmpty Expr) + -- ^ Bit-wise concatenation of expressions represented by braces. + | UnOp !UnaryOperator !Expr + | BinOp !Expr !BinaryOperator !Expr + | Cond !Expr !Expr !Expr + | Appl !Identifier !Expr + | Str {-# UNPACK #-} !Text + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Num Expr where + a + b = BinOp a BinPlus b + a - b = BinOp a BinMinus b + a * b = BinOp a BinTimes b + negate = UnOp UnMinus + abs = undefined + signum = undefined + fromInteger = Number . fromInteger + +instance Semigroup Expr where + (Concat a) <> (Concat b) = Concat $ a <> b + (Concat a) <> b = Concat $ a <> (b :| []) + a <> (Concat b) = Concat $ a <| b + a <> b = Concat $ a <| b :| [] + +instance Monoid Expr where + mempty = Number 0 + +instance IsString Expr where + fromString = Str . fromString + +instance Plated Expr where + plate = uniplate + +-- | 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) + +constToExpr :: ConstExpr -> Expr +constToExpr (ConstNum a ) = Number a +constToExpr (ParamId a ) = Id a +constToExpr (ConstConcat a ) = Concat $ fmap constToExpr a +constToExpr (ConstUnOp a b ) = UnOp a $ constToExpr b +constToExpr (ConstBinOp a b c) = BinOp (constToExpr a) b $ constToExpr c +constToExpr (ConstCond a b c) = + Cond (constToExpr a) (constToExpr b) $ constToExpr c +constToExpr (ConstStr a) = Str a + +exprToConst :: Expr -> ConstExpr +exprToConst (Number a ) = ConstNum a +exprToConst (Id a ) = ParamId a +exprToConst (Concat a ) = ConstConcat $ fmap exprToConst a +exprToConst (UnOp a b ) = ConstUnOp a $ exprToConst b +exprToConst (BinOp a b c) = ConstBinOp (exprToConst a) b $ exprToConst c +exprToConst (Cond a b c) = + ConstCond (exprToConst a) (exprToConst b) $ exprToConst c +exprToConst (Str a) = ConstStr a +exprToConst _ = error "Not a constant expression" + +instance Num ConstExpr where + a + b = ConstBinOp a BinPlus b + a - b = ConstBinOp a BinMinus b + a * b = ConstBinOp a BinTimes b + negate = ConstUnOp UnMinus + abs = undefined + signum = undefined + fromInteger = ConstNum . fromInteger + +instance Semigroup ConstExpr where + (ConstConcat a) <> (ConstConcat b) = ConstConcat $ a <> b + (ConstConcat a) <> b = ConstConcat $ a <> (b :| []) + a <> (ConstConcat b) = ConstConcat $ a <| b + a <> b = ConstConcat $ a <| b :| [] + +instance Monoid ConstExpr where + mempty = ConstNum 0 + +instance IsString ConstExpr where + fromString = ConstStr . fromString + +instance Plated ConstExpr where + plate = uniplate + +data Task = Task { _taskName :: {-# UNPACK #-} !Identifier + , _taskExpr :: [Expr] + } deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | Type that represents the left hand side of an assignment, which can be a +-- concatenation such as in: +-- +-- @ +-- {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) + +instance IsString LVal where + fromString = RegId . fromString + +-- | Different port direction that are supported in Verilog. +data PortDir = PortIn -- ^ Input direction for port (@input@). + | PortOut -- ^ Output direction for port (@output@). + | PortInOut -- ^ Inout direction for port (@inout@). + 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) + +-- | 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) + +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 + +-- | 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 +-- an input or output port. However, this is not always necessary and was more +-- cumbersome than useful, as a lot of ports can be declared without input and +-- output port. +-- +-- This is now implemented inside 'ModDecl' 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) + +-- | This is currently a type because direct module declaration should also be +-- added: +-- +-- @ +-- 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 ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier + , _contAssignExpr :: !Expr + } deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | Statements in Verilog. +data Statement = TimeCtrl { _statDelay :: {-# UNPACK #-} !Delay + , _statDStat :: Maybe Statement + } -- ^ Time control (@#NUM@) + | EventCtrl { _statEvent :: !Event + , _statEStat :: Maybe Statement + } + | SeqBlock { _statements :: [Statement] } -- ^ Sequential block (@begin ... end@) + | BlockAssign { _stmntBA :: !Assign } -- ^ blocking assignment (@=@) + | NonBlockAssign { _stmntNBA :: !Assign } -- ^ Non blocking assignment (@<=@) + | TaskEnable { _stmntTask :: !Task } + | SysTaskEnable { _stmntSysTask :: !Task } + | CondStmnt { _stmntCondExpr :: Expr + , _stmntCondTrue :: Maybe Statement + , _stmntCondFalse :: Maybe Statement + } + | ForLoop { _forAssign :: !Assign + , _forExpr :: Expr + , _forIncr :: !Assign + , _forStmnt :: Statement + } -- ^ Loop bounds shall be statically computable for a for loop. + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Plated Statement where + plate = uniplate + +instance Semigroup Statement where + (SeqBlock a) <> (SeqBlock b) = SeqBlock $ a <> b + (SeqBlock a) <> b = SeqBlock $ a <> [b] + a <> (SeqBlock b) = SeqBlock $ a : b + a <> b = SeqBlock [a, b] + +instance Monoid Statement where + mempty = SeqBlock [] + +-- | 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) + +-- | 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) + +-- | Module item which is the body of the module expression. +data ModItem = ModCA { _modContAssign :: !ContAssign } + | ModInst { _modInstId :: {-# UNPACK #-} !Identifier + , _modInstName :: {-# UNPACK #-} !Identifier + , _modInstConns :: [ModConn] + } + | Initial !Statement + | Always !Statement + | Decl { _declDir :: !(Maybe PortDir) + , _declPort :: !Port + , _declVal :: Maybe ConstExpr + } + | ParamDecl { _paramDecl :: NonEmpty Parameter } + | LocalParamDecl { _localParamDecl :: NonEmpty LocalParam } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +-- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module' +data ModDecl = ModDecl { _modId :: {-# UNPACK #-} !Identifier + , _modOutPorts :: ![Port] + , _modInPorts :: ![Port] + , _modItems :: ![ModItem] + , _modParams :: ![Parameter] + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +traverseModConn :: (Applicative f) => (Expr -> f Expr) -> ModConn -> f ModConn +traverseModConn f (ModConn e ) = ModConn <$> f e +traverseModConn f (ModConnNamed a e) = ModConnNamed a <$> f e + +traverseModItem :: (Applicative f) => (Expr -> f Expr) -> ModItem -> f ModItem +traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e +traverseModItem f (ModInst a b e) = + ModInst a b <$> sequenceA (traverseModConn f <$> e) +traverseModItem _ e = pure e + +-- | The complete sourcetext for the Verilog module. +newtype Verilog = Verilog { getVerilog :: [ModDecl] } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +instance Semigroup Verilog where + Verilog a <> Verilog b = Verilog $ a <> b + +instance Monoid Verilog where + mempty = Verilog mempty + +data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text + , _infoSrc :: !Verilog + } + deriving (Eq, Show, Ord, Data, Generic, NFData) + +$(makeLenses ''Expr) +$(makeLenses ''ConstExpr) +$(makeLenses ''Task) +$(makeLenses ''LVal) +$(makeLenses ''PortType) +$(makeLenses ''Port) +$(makeLenses ''ModConn) +$(makeLenses ''Assign) +$(makeLenses ''ContAssign) +$(makeLenses ''Statement) +$(makeLenses ''ModItem) +$(makeLenses ''Parameter) +$(makeLenses ''LocalParam) +$(makeLenses ''ModDecl) +$(makeLenses ''SourceInfo) +$(makeWrapped ''Verilog) +$(makeWrapped ''Identifier) +$(makeWrapped ''Delay) +$(makePrisms ''ModItem) + +$(makeBaseFunctor ''Event) +$(makeBaseFunctor ''Expr) +$(makeBaseFunctor ''ConstExpr) + +getModule :: Traversal' Verilog ModDecl +getModule = _Wrapped . traverse +{-# INLINE getModule #-} + +getSourceId :: Traversal' Verilog Text +getSourceId = getModule . modId . _Wrapped +{-# INLINE getSourceId #-} + +-- | May need to change this to Traversal to be safe. For now it will fail when +-- the main has not been properly set with. +aModule :: Identifier -> Lens' SourceInfo ModDecl +aModule t = lens get_ set_ + where + set_ (SourceInfo top main) v = + SourceInfo top (main & getModule %~ update (getIdentifier t) v) + update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v + | otherwise = m + get_ (SourceInfo _ main) = + head . filter (f $ getIdentifier t) $ main ^.. getModule + f top (ModDecl (Identifier i) _ _ _ _) = i == top + + +-- | 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 ModDecl +mainModule = lens get_ set_ + where + set_ (SourceInfo top main) v = + SourceInfo top (main & getModule %~ update top v) + update top v m@(ModDecl (Identifier i) _ _ _ _) | i == top = v + | otherwise = m + get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule + f top (ModDecl (Identifier i) _ _ _ _) = i == top diff --git a/src/Verismith/Verilog/BitVec.hs b/src/Verismith/Verilog/BitVec.hs new file mode 100644 index 0000000..bc594a3 --- /dev/null +++ b/src/Verismith/Verilog/BitVec.hs @@ -0,0 +1,119 @@ +{-| +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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + +module Verismith.Verilog.BitVec + ( BitVecF(..) + , BitVec + , bitVec + , select + ) +where + +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) + +-- | 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 + +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 + +instance (Integral a, Bits a) => Real (BitVecF a) where + 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 + +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 + +instance (Num a, Bits a) => FiniteBits (BitVecF a) where + finiteBitSize (BitVec w _) = w + +instance Bits a => Semigroup (BitVecF a) where + (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2) + +instance Bits a => Monoid (BitVecF a) where + 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 (BitVec _ v) (msb, lsb) = + 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 + 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 + where + 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 new file mode 100644 index 0000000..ca48a33 --- /dev/null +++ b/src/Verismith/Verilog/CodeGen.hs @@ -0,0 +1,341 @@ +{-| +Module : Verismith.Verilog.CodeGen +Description : Code generation for Verilog AST. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 #-} + +module Verismith.Verilog.CodeGen + ( -- * 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 + +-- | '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 +-- can then be processed further. +class Source a where + genSource :: a -> Text + +-- | Map a 'Maybe Statement' to 'Text'. If it is 'Just statement', the generated +-- statements are returned. If it is 'Nothing', then @;\n@ is returned. +defMap :: Maybe Statement -> Doc a +defMap = maybe semi statement + +-- | Convert the 'Verilog' type to 'Text' so that it can be rendered. +verilogSrc :: Verilog -> Doc a +verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules + +-- | Generate the 'ModDecl' for a module and convert it to 'Text'. +moduleDecl :: ModDecl -> Doc a +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 + outIn = outP ++ inP + params [] = "" + params (p : pps) = hcat ["#", paramList (p :| pps)] + +-- | Generates a parameter list. Can only be called with a 'NonEmpty' list. +paramList :: NonEmpty Parameter -> Doc a +paramList ps = tupled . toList $ parameter <$> ps + +-- | Generates a localparam list. Can only be called with a 'NonEmpty' list. +localParamList :: NonEmpty LocalParam -> Doc a +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] + +-- | Generates the assignment for a 'LocalParam'. +localParam :: LocalParam -> Doc a +localParam (LocalParam name val) = + hsep ["localparameter", identifier name, "=", constExpr val] + +identifier :: Identifier -> Doc a +identifier (Identifier i) = pretty i + +-- | Conversts 'Port' to 'Text' for the module list, which means it only +-- generates a list of identifiers. +modPort :: Port -> Doc a +modPort (Port _ _ _ i) = identifier i + +-- | Generate the 'Port' description. +port :: Port -> Doc a +port (Port tp sgn r name) = hsep [t, sign, range r, identifier name] + where + t = pType tp + sign = signed sgn + +range :: Range -> Doc a +range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] + +signed :: Bool -> Doc a +signed True = "signed" +signed _ = mempty + +-- | Convert the 'PortDir' type to 'Text'. +portDir :: PortDir -> Doc a +portDir PortIn = "input" +portDir PortOut = "output" +portDir PortInOut = "inout" + +-- | Generate a 'ModItem'. +moduleItem :: ModItem -> Doc a +moduleItem (ModCA ca ) = contAssign ca +moduleItem (ModInst i name conn) = hsep + [ identifier i + , identifier name + , parens . hsep $ punctuate comma (mConn <$> conn) + , semi + ] +moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat] +moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat] +moduleItem (Decl dir p ini) = hsep + [maybe mempty makePort dir, port p, maybe mempty makeIni ini, semi] + where + makePort = portDir + makeIni = ("=" <+>) . constExpr +moduleItem (ParamDecl p) = hcat [paramList p, semi] +moduleItem (LocalParamDecl p) = hcat [localParamList p, semi] + +mConn :: ModConn -> Doc a +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) = + hsep ["assign", identifier val, "=", align $ expr e, semi] + +-- | 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 (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c) +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]] +expr (Appl f e) = hcat [identifier f, parens $ expr e] +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) "")] + where + minus | signum n >= 0 = mempty + | otherwise = "-" + +constExpr :: ConstExpr -> Doc a +constExpr (ConstNum b) = showNum b +constExpr (ParamId i) = identifier i +constExpr (ConstConcat 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] +constExpr (ConstCond l t 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 BinXNorInv = "~^" +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 UnNxorInv = "^~" + +event :: Event -> Doc a +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 (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] + +-- | Generates verilog code for a 'Delay'. +delay :: Delay -> Doc a +delay (Delay i) = "#" <> pretty i + +-- | Generate the verilog code for an 'LVal'. +lVal :: LVal -> Doc a +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" + +genAssign :: Text -> Assign -> Doc a +genAssign op (Assign r d e) = + hsep [lVal r, pretty op, maybe mempty delay d, expr e] + +statement :: Statement -> Doc a +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] +statement (NonBlockAssign a) = hcat [genAssign "<=" a, 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] +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 + [ hsep + [ "for" + , parens . hsep $ punctuate + semi + [genAssign "=" a, expr e, genAssign "=" incr] + ] + , indent 2 $ statement stmnt + ] + +task :: Task -> Doc a +task (Task i 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 () +render = print . genSource + +-- Instances + +instance Source Identifier where + genSource = showT . identifier + +instance Source Task where + genSource = showT . task + +instance Source Statement where + genSource = showT . statement + +instance Source PortType where + genSource = showT . pType + +instance Source ConstExpr where + genSource = showT . constExpr + +instance Source LVal where + genSource = showT . lVal + +instance Source Delay where + genSource = showT . delay + +instance Source Event where + genSource = showT . event + +instance Source UnaryOperator where + genSource = showT . unaryOp + +instance Source Expr where + genSource = showT . expr + +instance Source ContAssign where + genSource = showT . contAssign + +instance Source ModItem where + genSource = showT . moduleItem + +instance Source PortDir where + genSource = showT . portDir + +instance Source Port where + genSource = showT . port + +instance Source ModDecl where + genSource = showT . moduleDecl + +instance Source Verilog where + genSource = showT . verilogSrc + +instance Source SourceInfo where + genSource (SourceInfo _ src) = genSource src + +newtype GenVerilog a = GenVerilog { unGenVerilog :: a } + deriving (Eq, Ord, Data) + +instance (Source a) => Show (GenVerilog a) where + show = T.unpack . genSource . unGenVerilog diff --git a/src/Verismith/Verilog/Eval.hs b/src/Verismith/Verilog/Eval.hs new file mode 100644 index 0000000..cbc2563 --- /dev/null +++ b/src/Verismith/Verilog/Eval.hs @@ -0,0 +1,119 @@ +{-| +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 + ) +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 + +type Bindings = [Parameter] + +paramIdent_ :: Parameter -> Identifier +paramIdent_ (Parameter i _) = i + +paramValue_ :: Parameter -> ConstExpr +paramValue_ (Parameter _ v) = v + +applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a +applyUnary UnPlus a = a +applyUnary UnMinus a = negate a +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 + +compXor :: Bits c => c -> c -> c +compXor a = complement . xor a + +toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p +toIntegral a b c = if a b c then 1 else 0 + +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 BinXNorInv = compXor +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 +evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b +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 (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c +applyBitVec f (ConstBinOp a binop 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 +applyBitVec _ a = a + +-- | This probably could be implemented using some recursion scheme in the +-- future. It would also be fixed by having a polymorphic expression type. +resize :: Int -> ConstExpr -> ConstExpr +resize n = applyBitVec (resize' n) where resize' n' (BitVec _ a) = BitVec n' a diff --git a/src/Verismith/Verilog/Internal.hs b/src/Verismith/Verilog/Internal.hs new file mode 100644 index 0000000..b3bf07a --- /dev/null +++ b/src/Verismith/Verilog/Internal.hs @@ -0,0 +1,93 @@ +{-| +Module : Verismith.Verilog.Internal +Description : Defaults and common functions. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ) +where + +import Control.Lens +import Data.Text (Text) +import Verismith.Verilog.AST + +regDecl :: Identifier -> ModItem +regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing + +wireDecl :: Identifier -> ModItem +wireDecl i = Decl Nothing (Port Wire False (Range 1 0) i) Nothing + +-- | Create an empty module. +emptyMod :: ModDecl +emptyMod = ModDecl "" [] [] [] [] + +-- | Set a module name for a module declaration. +setModName :: Text -> ModDecl -> ModDecl +setModName str = modId .~ Identifier str + +-- | Add a input port to the module declaration. +addModPort :: Port -> ModDecl -> ModDecl +addModPort port = modInPorts %~ (:) port + +addModDecl :: ModDecl -> Verilog -> Verilog +addModDecl desc = _Wrapped %~ (:) desc + +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 + ] + ] + [] + +addTestBench :: Verilog -> Verilog +addTestBench = addModDecl testBench + +defaultPort :: Identifier -> Port +defaultPort = Port Wire False (Range 1 0) + +portToExpr :: Port -> Expr +portToExpr (Port _ _ _ i) = Id i + +modName :: ModDecl -> Text +modName = getIdentifier . view modId + +yPort :: Identifier -> Port +yPort = Port Wire False (Range 90 0) + +wire :: Range -> Identifier -> Port +wire = Port Wire False + +reg :: Range -> Identifier -> Port +reg = Port Reg False diff --git a/src/Verismith/Verilog/Lex.x b/src/Verismith/Verilog/Lex.x new file mode 100644 index 0000000..9892714 --- /dev/null +++ b/src/Verismith/Verilog/Lex.x @@ -0,0 +1,188 @@ +-- -*- haskell -*- +{ +{-# OPTIONS_GHC -w #-} +module Verismith.Verilog.Lex + ( alexScanTokens + ) where + +import Verismith.Verilog.Token + +} + +%wrapper "posn" + +-- Numbers + +$nonZeroDecimalDigit = [1-9] +$decimalDigit = [0-9] +@binaryDigit = [0-1] +@octalDigit = [0-7] +@hexDigit = [0-9a-fA-F] + +@decimalBase = "'" [dD] +@binaryBase = "'" [bB] +@octalBase = "'" [oO] +@hexBase = "'" [hH] + +@binaryValue = @binaryDigit ("_" | @binaryDigit)* +@octalValue = @octalDigit ("_" | @octalDigit)* +@hexValue = @hexDigit ("_" | @hexDigit)* + +@unsignedNumber = $decimalDigit ("_" | $decimalDigit)* + +@size = @unsignedNumber + +@decimalNumber + = @unsignedNumber + | @size? @decimalBase @unsignedNumber + +@binaryNumber = @size? @binaryBase @binaryValue +@octalNumber = @size? @octalBase @octalValue +@hexNumber = @size? @hexBase @hexValue + +-- $exp = [eE] +-- $sign = [\+\-] +-- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber +@number = @decimalNumber | @octalNumber | @binaryNumber | @hexNumber + +-- Strings + +@string = \" [^\r\n]* \" + +-- Identifiers + +@escapedIdentifier = "\" ($printable # $white)+ $white +@simpleIdentifier = [a-zA-Z_] [a-zA-Z0-9_\$]* +@systemIdentifier = "$" [a-zA-Z0-9_\$]+ + + +tokens :- + + "always" { tok KWAlways } + "assign" { tok KWAssign } + "begin" { tok KWBegin } + "case" { tok KWCase } + "default" { tok KWDefault } + "else" { tok KWElse } + "end" { tok KWEnd } + "endcase" { tok KWEndcase } + "endmodule" { tok KWEndmodule } + "for" { tok KWFor } + "if" { tok KWIf } + "initial" { tok KWInitial } + "inout" { tok KWInout } + "input" { tok KWInput } + "integer" { tok KWInteger } + "localparam" { tok KWLocalparam } + "module" { tok KWModule } + "negedge" { tok KWNegedge } + "or" { tok KWOr } + "output" { tok KWOutput } + "parameter" { tok KWParameter } + "posedge" { tok KWPosedge } + "reg" { tok KWReg } + "wire" { tok KWWire } + "signed" { tok KWSigned } + + @simpleIdentifier { tok IdSimple } + @escapedIdentifier { tok IdEscaped } + @systemIdentifier { tok IdSystem } + + @number { tok LitNumber } + @string { tok LitString } + + "(" { tok SymParenL } + ")" { tok SymParenR } + "[" { tok SymBrackL } + "]" { tok SymBrackR } + "{" { tok SymBraceL } + "}" { tok SymBraceR } + "~" { tok SymTildy } + "!" { tok SymBang } + "@" { tok SymAt } + "#" { tok SymPound } + "%" { tok SymPercent } + "^" { tok SymHat } + "&" { tok SymAmp } + "|" { tok SymBar } + "*" { tok SymAster } + "." { tok SymDot } + "," { tok SymComma } + ":" { tok SymColon } + ";" { tok SymSemi } + "=" { tok SymEq } + "<" { tok SymLt } + ">" { tok SymGt } + "+" { tok SymPlus } + "-" { tok SymDash } + "?" { tok SymQuestion } + "/" { tok SymSlash } + "$" { tok SymDollar } + "'" { tok SymSQuote } + + "~&" { tok SymTildyAmp } + "~|" { tok SymTildyBar } + "~^" { tok SymTildyHat } + "^~" { tok SymHatTildy } + "==" { tok SymEqEq } + "!=" { tok SymBangEq } + "&&" { tok SymAmpAmp } + "||" { tok SymBarBar } + "**" { tok SymAsterAster } + "<=" { tok SymLtEq } + ">=" { tok SymGtEq } + ">>" { tok SymGtGt } + "<<" { tok SymLtLt } + "++" { tok SymPlusPlus } + "--" { tok SymDashDash } + "+=" { tok SymPlusEq } + "-=" { tok SymDashEq } + "*=" { tok SymAsterEq } + "/=" { tok SymSlashEq } + "%=" { tok SymPercentEq } + "&=" { tok SymAmpEq } + "|=" { tok SymBarEq } + "^=" { tok SymHatEq } + "+:" { tok SymPlusColon } + "-:" { tok SymDashColon } + "::" { tok SymColonColon } + ".*" { tok SymDotAster } + "->" { tok SymDashGt } + ":=" { tok SymColonEq } + ":/" { tok SymColonSlash } + "##" { tok SymPoundPound } + "[*" { tok SymBrackLAster } + "[=" { tok SymBrackLEq } + "=>" { tok SymEqGt } + "@*" { tok SymAtAster } + "(*" { tok SymParenLAster } + "*)" { tok SymAsterParenR } + "*>" { tok SymAsterGt } + + "===" { tok SymEqEqEq } + "!==" { tok SymBangEqEq } + "=?=" { tok SymEqQuestionEq } + "!?=" { tok SymBangQuestionEq } + ">>>" { tok SymGtGtGt } + "<<<" { tok SymLtLtLt } + "<<=" { tok SymLtLtEq } + ">>=" { tok SymGtGtEq } + "|->" { tok SymBarDashGt } + "|=>" { tok SymBarEqGt } + "[->" { tok SymBrackLDashGt } + "@@(" { tok SymAtAtParenL } + "(*)" { tok SymParenLAsterParenR } + "->>" { tok SymDashGtGt } + "&&&" { tok SymAmpAmpAmp } + + "<<<=" { tok SymLtLtLtEq } + ">>>=" { tok SymGtGtGtEq } + + $white ; + + . { tok Unknown } + +{ +tok :: TokenName -> AlexPosn -> String -> Token +tok t (AlexPn _ l c) s = Token t s $ Position "" l c +} diff --git a/src/Verismith/Verilog/Mutate.hs b/src/Verismith/Verilog/Mutate.hs new file mode 100644 index 0000000..2f17de5 --- /dev/null +++ b/src/Verismith/Verilog/Mutate.hs @@ -0,0 +1,401 @@ +{-| +Module : Verismith.Verilog.Mutate +Description : Functions to mutate the Verilog AST. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ( 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 + +class Mutate a where + mutExpr :: (Expr -> Expr) -> a -> a + +instance Mutate Identifier where + mutExpr _ = id + +instance Mutate Delay where + mutExpr _ = id + +instance Mutate Event where + mutExpr f (EExpr e) = EExpr $ f e + mutExpr _ a = a + +instance Mutate BinaryOperator where + mutExpr _ = id + +instance Mutate UnaryOperator where + mutExpr _ = id + +instance Mutate Expr where + mutExpr f = f + +instance Mutate ConstExpr where + mutExpr _ = id + +instance Mutate Task where + 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 + +instance Mutate PortDir where + mutExpr _ = id + +instance Mutate PortType where + mutExpr _ = id + +instance Mutate Range where + mutExpr _ = id + +instance Mutate Port where + mutExpr _ = id + +instance Mutate ModConn where + 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 + +instance Mutate ContAssign where + mutExpr f (ContAssign a e) = ContAssign a $ f e + +instance Mutate Statement 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 (mutExpr f a1) (f e) (mutExpr f a2) $ mutExpr f s + +instance Mutate Parameter where + mutExpr _ = id + +instance Mutate LocalParam where + mutExpr _ = id + +instance Mutate ModItem 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 _ d@Decl{} = d + mutExpr _ p@ParamDecl{} = p + mutExpr _ l@LocalParamDecl{} = l + +instance Mutate ModDecl 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) + +instance Mutate Verilog where + mutExpr f (Verilog a) = Verilog $ mutExpr f a + +instance Mutate SourceInfo where + mutExpr f (SourceInfo a b) = SourceInfo a $ mutExpr f b + +instance Mutate a => Mutate [a] where + mutExpr f a = mutExpr f <$> a + +instance Mutate a => Mutate (Maybe a) where + mutExpr f a = mutExpr f <$> a + +instance Mutate a => Mutate (GenVerilog a) where + mutExpr f (GenVerilog a) = GenVerilog $ mutExpr f a + +-- | Return if the 'Identifier' is in a 'ModDecl'. +inPort :: Identifier -> ModDecl -> Bool +inPort i m = inInput + where + inInput = + 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] -> Maybe Expr +findAssign i items = safe last . catMaybes $ isAssign <$> items + where + 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 _ _ e = e + +-- | Replaces the identifier recursively in an expression. +replace :: Identifier -> Expr -> Expr -> Expr +replace = (transform .) . idTrans + +-- | Nest expressions for a specific 'Identifier'. If the 'Identifier' is not +-- found, the AST is not changed. +-- +-- This could be improved by instead of only using the last assignment to the +-- wire that one finds, to use the assignment to the wire before the current +-- expression. This would require a different approach though. +nestId :: Identifier -> ModDecl -> ModDecl +nestId i 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 + +-- | Replaces an identifier by a expression in all the module declaration. +nestSource :: Identifier -> Verilog -> Verilog +nestSource i src = src & getModule %~ nestId i + +-- | Nest variables in the format @w[0-9]*@ up to a certain number. +nestUpTo :: Int -> Verilog -> Verilog +nestUpTo i src = + foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] + +allVars :: ModDecl -> [Identifier] +allVars m = + (m ^.. modOutPorts . traverse . portName) + <> (m ^.. modInPorts . traverse . portName) + +-- $setup +-- >>> import Verismith.Verilog.CodeGen +-- >>> let m = (ModDecl (Identifier "m") [Port Wire False 5 (Identifier "y")] [Port Wire False 5 "x"] [] []) +-- >>> let main = (ModDecl "main" [] [] [] []) + +-- | Add a Module Instantiation using 'ModInst' from the first module passed to +-- it to the body of the second module. It first has to make all the inputs into +-- @reg@. +-- +-- >>> render $ instantiateMod m main +-- module main; +-- wire [(3'h4):(1'h0)] y; +-- reg [(3'h4):(1'h0)] x; +-- m m1(y, x); +-- endmodule +-- +-- +instantiateMod :: ModDecl -> ModDecl -> ModDecl +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 + count = + length + . filter (== m ^. modId) + $ main + ^.. modItems + . traverse + . modInstId + conns = ModConn . Id <$> allVars m + +-- | Instantiate without adding wire declarations. It also does not count the +-- current instantiations of the same module. +-- +-- >>> GenVerilog $ instantiateMod_ m +-- m m(y, x); +-- +instantiateMod_ :: ModDecl -> ModItem +instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns + where + conns = + 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. +-- +-- >>> GenVerilog $ instantiateModSpec_ "_" m +-- m m(.y(y), .x(x)); +-- +instantiateModSpec_ :: Text -> ModDecl -> ModItem +instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns + where + 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) + +-- | Initialise all the inputs and outputs to a module. +-- +-- >>> GenVerilog $ initMod m +-- module m(y, x); +-- output wire [(3'h4):(1'h0)] y; +-- input wire [(3'h4):(1'h0)] x; +-- endmodule +-- +-- +initMod :: ModDecl -> ModDecl +initMod m = m & modItems %~ ((out ++ inp) ++) + where + out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing + inp = Decl (Just PortIn) <$> (m ^. modInPorts) <*> pure Nothing + +-- | Make an 'Identifier' from and existing Identifier and an object with a +-- 'Show' instance to make it unique. +makeIdFrom :: (Show a) => a -> Identifier -> Identifier +makeIdFrom a i = (i <>) . Identifier . ("_" <>) $ showT a + +-- | Make top level module for equivalence verification. Also takes in how many +-- modules to instantiate. +makeTop :: Int -> ModDecl -> ModDecl +makeTop i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] + where + ys = yPort . flip makeIdFrom "y" <$> [1 .. i] + modIt = instantiateModSpec_ "_" . modN <$> [1 .. i] + modN n = + 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 -> ModDecl +makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2 + where + 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 +-- registers, it should assign them to 0. +declareMod :: [Port] -> ModDecl -> ModDecl +declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) + where + decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0) + 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 +-- no more changes were made to the expression. +-- +-- >>> GenVerilog . simplify $ (Id "x") + 0 +-- x +-- +-- >>> 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 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 + +-- | 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 +-- simplified further. +-- +-- >>> GenVerilog . removeId ["x"] $ Id "x" + Id "y" +-- (x + (1'h0)) +removeId :: [Identifier] -> Expr -> Expr +removeId i = transform trans + where + trans (Id ident) | ident `notElem` i = Number 0 + | otherwise = Id ident + trans e = e + +combineAssigns :: Port -> [ModItem] -> [ModItem] +combineAssigns p a = + a + <> [ ModCA + . ContAssign (p ^. portName) + . UnOp UnXor + . fold + $ Id + <$> assigns + ] + where assigns = a ^.. traverse . modContAssign . contAssignNetLVal + +combineAssigns_ :: Bool -> Port -> [Port] -> ModItem +combineAssigns_ comb p ps = + 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 new file mode 100644 index 0000000..a6eaf24 --- /dev/null +++ b/src/Verismith/Verilog/Parser.hs @@ -0,0 +1,511 @@ +{-| +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 + -- ** Internal parsers + , 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 + +type Parser = Parsec [Token] () + +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 + +-- | This parser succeeds whenever the given predicate returns true when called +-- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'. +satisfy :: (Token -> Bool) -> Parser TokenName +satisfy f = tokenPrim show nextPos tokeq + where + tokeq :: Token -> Maybe TokenName + tokeq t@(Token t' _ _) = if f t then Just t' else Nothing + +satisfy' :: (Token -> Maybe a) -> Parser a +satisfy' = tokenPrim show nextPos + +nextPos :: SourcePos -> Token -> [Token] -> SourcePos +nextPos pos _ (Token _ _ (Position _ l c) : _) = + setSourceColumn (setSourceLine pos l) c +nextPos pos _ [] = pos + +-- | Parses given `TokenName`. +tok :: TokenName -> Parser TokenName +tok t = satisfy (\(Token t' _ _) -> t' == t) show t + +-- | Parse without returning the `TokenName`. +tok' :: TokenName -> Parser () +tok' p = void $ tok p + +parens :: Parser a -> Parser a +parens = between (tok SymParenL) (tok SymParenR) + +brackets :: Parser a -> Parser a +brackets = between (tok SymBrackL) (tok SymBrackR) + +braces :: Parser a -> Parser a +braces = between (tok SymBraceL) (tok SymBraceR) + +sBinOp :: BinaryOperator -> Expr -> Expr -> Expr +sBinOp = sOp BinOp where sOp f b a = f a b + +parseExpr' :: Parser Expr +parseExpr' = buildExpressionParser parseTable parseTerm "expr" + +decToExpr :: Decimal -> Expr +decToExpr (Decimal s n) = Number $ bitVec s n + +-- | Parse a Number depending on if it is in a hex or decimal form. Octal and +-- binary are not supported yet. +parseNum :: Parser Expr +parseNum = decToExpr <$> number + +parseVar :: Parser Expr +parseVar = Id <$> identifier + +parseVecSelect :: Parser Expr +parseVecSelect = do + i <- identifier + expr <- brackets parseExpr + return $ VecSelect i expr + +parseRangeSelect :: Parser Expr +parseRangeSelect = do + i <- identifier + range <- parseRange + return $ RangeSelect i range + +systemFunc :: Parser String +systemFunc = satisfy' matchId + where + matchId (Token IdSystem s _) = Just s + matchId _ = Nothing + +parseFun :: Parser Expr +parseFun = do + 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." + +parseTerm :: Parser Expr +parseTerm = + 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 + +parseExpr :: Parser Expr +parseExpr = do + e <- parseExpr' + option e . try $ parseCond e + +parseConstExpr :: Parser ConstExpr +parseConstExpr = fmap exprToConst parseExpr + +-- | Table of binary and unary operators that encode the right precedence for +-- 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] + ] + +binary :: TokenName -> (a -> a -> a) -> Assoc -> ParseOperator a +binary name fun = Infix ((tok name "binary") >> return fun) + +prefix :: TokenName -> (a -> a) -> ParseOperator a +prefix name fun = Prefix ((tok name "prefix") >> return fun) + +commaSep :: Parser a -> Parser [a] +commaSep = flip sepBy $ tok SymComma + +parseContAssign :: Parser ContAssign +parseContAssign = do + 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 + +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 + 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' + +-- toInteger' :: Decimal -> Integer +-- toInteger' (Decimal _ n) = n + +toInt' :: Decimal -> Int +toInt' (Decimal _ n) = fromInteger n + +-- | Parse a range and return the total size. As it is inclusive, 1 has to be +-- added to the difference. +parseRange :: Parser Range +parseRange = do + 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 IdEscaped s _) = Just s + matchId _ = Nothing + +identifier :: Parser Identifier +identifier = Identifier . T.pack <$> strId + +parseNetDecl :: Maybe PortDir -> Parser ModItem +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 + +parsePortDir :: Parser PortDir +parsePortDir = + tok KWOutput + $> PortOut + <|> tok KWInput + $> PortIn + <|> tok KWInout + $> PortInOut + +parseDecl :: Parser ModItem +parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing + +parseConditional :: Parser Statement +parseConditional = do + 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)) + ex i = do + e <- tok' SymBrackL *> parseExpr + tok' SymBrackR + return $ RegExpr i e + sz i = RegSize i <$> parseRange + +parseDelay :: Parser Delay +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 + +parseLoop :: Parser Statement +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 + +eventList :: TokenName -> Parser [Event] +eventList t = do + 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)) + +parseEvent' :: Parser Event +parseEvent' = + try (tok' KWPosedge *> fmap EPosEdge identifier) + <|> try (tok' KWNegedge *> fmap ENegEdge identifier) + <|> try (fmap EId identifier) + <|> try (fmap EExpr parseExpr) + +parseEventCtrl :: Parser Statement +parseEventCtrl = do + event <- parseEvent + statement <- option Nothing maybeEmptyStatement + return $ EventCtrl event statement + +parseDelayCtrl :: Parser Statement +parseDelayCtrl = do + delay <- parseDelay + statement <- option Nothing maybeEmptyStatement + return $ TimeCtrl delay statement + +parseBlocking :: Parser Statement +parseBlocking = do + a <- parseAssign SymEq + tok' SymSemi + return $ BlockAssign a + +parseNonBlocking :: Parser Statement +parseNonBlocking = do + a <- parseAssign SymLtEq + tok' SymSemi + return $ NonBlockAssign a + +parseSeq :: Parser Statement +parseSeq = do + seq' <- tok' KWBegin *> many parseStatement + tok' KWEnd + return $ SeqBlock seq' + +parseStatement :: Parser Statement +parseStatement = + parseSeq + <|> parseConditional + <|> parseLoop + <|> parseEventCtrl + <|> parseDelayCtrl + <|> try parseBlocking + <|> parseNonBlocking + +maybeEmptyStatement :: Parser (Maybe Statement) +maybeEmptyStatement = + (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) + +parseAlways :: Parser ModItem +parseAlways = tok' KWAlways *> (Always <$> parseStatement) + +parseInitial :: Parser ModItem +parseInitial = tok' KWInitial *> (Initial <$> parseStatement) + +namedModConn :: Parser ModConn +namedModConn = do + target <- tok' SymDot *> identifier + expr <- parens parseExpr + return $ ModConnNamed target expr + +parseModConn :: Parser ModConn +parseModConn = try (fmap ModConn parseExpr) <|> namedModConn + +parseModInst :: Parser ModItem +parseModInst = do + m <- identifier + name <- identifier + modconns <- parens (commaSep parseModConn) + tok' SymSemi + return $ ModInst m name modconns + +parseModItem :: Parser ModItem +parseModItem = + try (ModCA <$> parseContAssign) + <|> try parseDecl + <|> parseAlways + <|> parseInitial + <|> parseModInst + +parseModList :: Parser [Identifier] +parseModList = list <|> return [] where list = parens $ commaSep identifier + +filterDecl :: PortDir -> ModItem -> Bool +filterDecl p (Decl (Just p') _ _) = p == p' +filterDecl _ _ = False + +modPorts :: PortDir -> [ModItem] -> [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 + +parseParams :: Parser [Parameter] +parseParams = tok' SymPound *> parens (commaSep parseParam) + +parseModDecl :: Parser ModDecl +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 + +-- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace +-- and then parsing multiple Verilog source. +parseVerilogSrc :: Parser Verilog +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 -- ^ Returns 'String' with error + -- message if parse fails. +parseVerilog s = + bimap showT id + . parse parseVerilogSrc (T.unpack s) + . alexScanTokens + . preprocess [] (T.unpack s) + . T.unpack + +parseVerilogFile :: Text -> IO Verilog +parseVerilogFile file = do + 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 +parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile diff --git a/src/Verismith/Verilog/Preprocess.hs b/src/Verismith/Verilog/Preprocess.hs new file mode 100644 index 0000000..91356f1 --- /dev/null +++ b/src/Verismith/Verilog/Preprocess.hs @@ -0,0 +1,111 @@ +{-| +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 + ) +where + +-- | Remove comments from code. There is no difference between @(* *)@ and +-- @/* */@, therefore in this implementation, @*/@ could close @(*@ and vice-versa, +-- This will be fixed in an upcoming version. +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 + + removeEOL a = case a of + "" -> "" + '\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 + + 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 + + ignoreString a = case a of + "" -> 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 + where + pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String] + 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 + +ppLine :: [(String, String)] -> String -> String +ppLine _ "" = "" +ppLine env ('`' : a) = case lookup name env of + Just value -> value ++ ppLine env rest + Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env + where + name = takeWhile + (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) + a + rest = drop (length name) a +ppLine env (a : b) = a : ppLine env b diff --git a/src/Verismith/Verilog/Quote.hs b/src/Verismith/Verilog/Quote.hs new file mode 100644 index 0000000..879b8fd --- /dev/null +++ b/src/Verismith/Verilog/Quote.hs @@ -0,0 +1,50 @@ +{-| +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 + ( 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 + +liftDataWithText :: Data a => a -> Q Exp +liftDataWithText = dataToExpQ $ fmap liftText . cast + +liftText :: T.Text -> Q Exp +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 + } + +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 diff --git a/src/Verismith/Verilog/Token.hs b/src/Verismith/Verilog/Token.hs new file mode 100644 index 0000000..b303e18 --- /dev/null +++ b/src/Verismith/Verilog/Token.hs @@ -0,0 +1,350 @@ +{-| +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 + ) +where + +import Text.Printf + +tokenString :: Token -> String +tokenString (Token _ s _) = s + +data Position = Position String Int Int deriving Eq + +instance Show Position where + show (Position f l c) = printf "%s:%d:%d" f l c + +data Token = Token TokenName String Position deriving (Show, Eq) + +data TokenName + = KWAlias + | KWAlways + | KWAlwaysComb + | KWAlwaysFf + | KWAlwaysLatch + | KWAnd + | KWAssert + | KWAssign + | KWAssume + | KWAutomatic + | KWBefore + | KWBegin + | KWBind + | KWBins + | KWBinsof + | KWBit + | KWBreak + | KWBuf + | KWBufif0 + | KWBufif1 + | KWByte + | KWCase + | KWCasex + | KWCasez + | KWCell + | KWChandle + | KWClass + | KWClocking + | KWCmos + | KWConfig + | KWConst + | KWConstraint + | KWContext + | KWContinue + | KWCover + | KWCovergroup + | KWCoverpoint + | KWCross + | KWDeassign + | KWDefault + | KWDefparam + | KWDesign + | KWDisable + | KWDist + | KWDo + | KWEdge + | KWElse + | KWEnd + | KWEndcase + | KWEndclass + | KWEndclocking + | KWEndconfig + | KWEndfunction + | KWEndgenerate + | KWEndgroup + | KWEndinterface + | KWEndmodule + | KWEndpackage + | KWEndprimitive + | KWEndprogram + | KWEndproperty + | KWEndspecify + | KWEndsequence + | KWEndtable + | KWEndtask + | KWEnum + | KWEvent + | KWExpect + | KWExport + | KWExtends + | KWExtern + | KWFinal + | KWFirstMatch + | KWFor + | KWForce + | KWForeach + | KWForever + | KWFork + | KWForkjoin + | KWFunction + | KWFunctionPrototype + | KWGenerate + | KWGenvar + | KWHighz0 + | KWHighz1 + | KWIf + | KWIff + | KWIfnone + | KWIgnoreBins + | KWIllegalBins + | KWImport + | KWIncdir + | KWInclude + | KWInitial + | KWInout + | KWInput + | KWInside + | KWInstance + | KWInt + | KWInteger + | KWInterface + | KWIntersect + | KWJoin + | KWJoinAny + | KWJoinNone + | KWLarge + | KWLiblist + | KWLibrary + | KWLocal + | KWLocalparam + | KWLogic + | KWLongint + | KWMacromodule + | KWMatches + | KWMedium + | KWModport + | KWModule + | KWNand + | KWNegedge + | KWNew + | KWNmos + | KWNor + | KWNoshowcancelled + | KWNot + | KWNotif0 + | KWNotif1 + | KWNull + | KWOption + | KWOr + | KWOutput + | KWPackage + | KWPacked + | KWParameter + | KWPathpulseDollar + | KWPmos + | KWPosedge + | KWPrimitive + | KWPriority + | KWProgram + | KWProperty + | KWProtected + | KWPull0 + | KWPull1 + | KWPulldown + | KWPullup + | KWPulsestyleOnevent + | KWPulsestyleOndetect + | KWPure + | KWRand + | KWRandc + | KWRandcase + | KWRandsequence + | KWRcmos + | KWReal + | KWRealtime + | KWRef + | KWReg + | KWRelease + | KWRepeat + | KWReturn + | KWRnmos + | KWRpmos + | KWRtran + | KWRtranif0 + | KWRtranif1 + | KWScalared + | KWSequence + | KWShortint + | KWShortreal + | KWShowcancelled + | KWSigned + | KWSmall + | KWSolve + | KWSpecify + | KWSpecparam + | KWStatic + | KWStrength0 + | KWStrength1 + | KWString + | KWStrong0 + | KWStrong1 + | KWStruct + | KWSuper + | KWSupply0 + | KWSupply1 + | KWTable + | KWTagged + | KWTask + | KWThis + | KWThroughout + | KWTime + | KWTimeprecision + | KWTimeunit + | KWTran + | KWTranif0 + | KWTranif1 + | KWTri + | KWTri0 + | KWTri1 + | KWTriand + | KWTrior + | KWTrireg + | KWType + | KWTypedef + | KWTypeOption + | KWUnion + | KWUnique + | KWUnsigned + | KWUse + | KWVar + | KWVectored + | KWVirtual + | KWVoid + | KWWait + | KWWaitOrder + | KWWand + | KWWeak0 + | KWWeak1 + | KWWhile + | KWWildcard + | KWWire + | KWWith + | KWWithin + | KWWor + | KWXnor + | KWXor + | IdSimple + | IdEscaped + | IdSystem + | LitNumberUnsigned + | LitNumber + | LitString + | SymParenL + | SymParenR + | SymBrackL + | SymBrackR + | SymBraceL + | SymBraceR + | SymTildy + | SymBang + | SymAt + | SymPound + | SymPercent + | SymHat + | SymAmp + | SymBar + | SymAster + | SymDot + | SymComma + | SymColon + | SymSemi + | SymEq + | SymLt + | SymGt + | SymPlus + | SymDash + | SymQuestion + | SymSlash + | SymDollar + | SymSQuote + | SymTildyAmp + | SymTildyBar + | SymTildyHat + | SymHatTildy + | SymEqEq + | SymBangEq + | SymAmpAmp + | SymBarBar + | SymAsterAster + | SymLtEq + | SymGtEq + | SymGtGt + | SymLtLt + | SymPlusPlus + | SymDashDash + | SymPlusEq + | SymDashEq + | SymAsterEq + | SymSlashEq + | SymPercentEq + | SymAmpEq + | SymBarEq + | SymHatEq + | SymPlusColon + | SymDashColon + | SymColonColon + | SymDotAster + | SymDashGt + | SymColonEq + | SymColonSlash + | SymPoundPound + | SymBrackLAster + | SymBrackLEq + | SymEqGt + | SymAtAster + | SymParenLAster + | SymAsterParenR + | SymAsterGt + | SymEqEqEq + | SymBangEqEq + | SymEqQuestionEq + | SymBangQuestionEq + | SymGtGtGt + | SymLtLtLt + | SymLtLtEq + | SymGtGtEq + | SymBarDashGt + | SymBarEqGt + | SymBrackLDashGt + | SymAtAtParenL + | SymParenLAsterParenR + | SymDashGtGt + | SymAmpAmpAmp + | SymLtLtLtEq + | SymGtGtGtEq + | Unknown + deriving (Show, Eq) diff --git a/test/Benchmark.hs b/test/Benchmark.hs index 7d59e2d..9c81049 100644 --- a/test/Benchmark.hs +++ b/test/Benchmark.hs @@ -2,7 +2,7 @@ module Main where import Control.Lens ((&), (.~)) import Criterion.Main (bench, bgroup, defaultMain, nfAppIO) -import VeriSmith (configProperty, defaultConfig, proceduralIO, +import Verismith (configProperty, defaultConfig, proceduralIO, propSize, propStmntDepth) main :: IO () diff --git a/test/Parser.hs b/test/Parser.hs index b372bbe..959c09b 100644 --- a/test/Parser.hs +++ b/test/Parser.hs @@ -25,10 +25,10 @@ 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 +import Verismith.Internal +import Verismith.Verilog.Lex +import Verismith.Verilog.Parser smallConfig :: Config smallConfig = defaultConfig & configProperty . propSize .~ 5 diff --git a/test/Property.hs b/test/Property.hs index afb1d11..bec740c 100644 --- a/test/Property.hs +++ b/test/Property.hs @@ -24,10 +24,10 @@ 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 Verismith +import Verismith.Result +import Verismith.Verilog.Lex +import Verismith.Verilog.Parser randomDAG' :: Gen Circuit randomDAG' = Hog.resize 30 randomDAG diff --git a/test/Reduce.hs b/test/Reduce.hs index f3ddf5c..fcc10aa 100644 --- a/test/Reduce.hs +++ b/test/Reduce.hs @@ -20,8 +20,8 @@ where import Data.List ((\\)) import Test.Tasty import Test.Tasty.HUnit -import VeriSmith -import VeriSmith.Reduce +import Verismith +import Verismith.Reduce reduceUnitTests :: TestTree reduceUnitTests = testGroup diff --git a/test/Unit.hs b/test/Unit.hs index f9283be..f761c68 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -9,7 +9,7 @@ import Parser (parseUnitTests) import Reduce (reduceUnitTests) import Test.Tasty import Test.Tasty.HUnit -import VeriSmith +import Verismith unitTests :: TestTree unitTests = testGroup diff --git a/verismith.cabal b/verismith.cabal index c4f74fa..2367c04 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -2,7 +2,7 @@ name: verismith version: 0.3.1.0 synopsis: Random verilog generation and simulator testing. description: - VeriSmith provides random verilog generation modules + Verismith provides random verilog generation modules implementing functions to test supported simulators. homepage: https://github.com/ymherklotz/verismith#readme license: BSD3 @@ -32,40 +32,40 @@ library default-language: Haskell2010 build-tools: alex >=3 && <4 other-modules: Paths_verismith - exposed-modules: VeriSmith - , VeriSmith.Circuit - , VeriSmith.Circuit.Base - , VeriSmith.Circuit.Gen - , VeriSmith.Circuit.Internal - , VeriSmith.Circuit.Random - , VeriSmith.Config - , VeriSmith.Fuzz - , VeriSmith.Generate - , VeriSmith.Internal - , VeriSmith.Reduce - , VeriSmith.Report - , VeriSmith.Result - , VeriSmith.Sim - , VeriSmith.Sim.Icarus - , VeriSmith.Sim.Identity - , VeriSmith.Sim.Internal - , VeriSmith.Sim.Quartus - , VeriSmith.Sim.Template - , VeriSmith.Sim.Vivado - , VeriSmith.Sim.XST - , VeriSmith.Sim.Yosys - , VeriSmith.Verilog - , VeriSmith.Verilog.AST - , VeriSmith.Verilog.BitVec - , VeriSmith.Verilog.CodeGen - , VeriSmith.Verilog.Eval - , VeriSmith.Verilog.Internal - , VeriSmith.Verilog.Lex - , VeriSmith.Verilog.Mutate - , VeriSmith.Verilog.Parser - , VeriSmith.Verilog.Preprocess - , VeriSmith.Verilog.Quote - , VeriSmith.Verilog.Token + exposed-modules: Verismith + , Verismith.Circuit + , Verismith.Circuit.Base + , Verismith.Circuit.Gen + , Verismith.Circuit.Internal + , Verismith.Circuit.Random + , Verismith.Config + , Verismith.Fuzz + , Verismith.Generate + , Verismith.Internal + , Verismith.Reduce + , Verismith.Report + , Verismith.Result + , Verismith.Sim + , Verismith.Sim.Icarus + , Verismith.Sim.Identity + , Verismith.Sim.Internal + , Verismith.Sim.Quartus + , Verismith.Sim.Template + , Verismith.Sim.Vivado + , Verismith.Sim.XST + , Verismith.Sim.Yosys + , Verismith.Verilog + , Verismith.Verilog.AST + , Verismith.Verilog.BitVec + , Verismith.Verilog.CodeGen + , Verismith.Verilog.Eval + , Verismith.Verilog.Internal + , Verismith.Verilog.Lex + , Verismith.Verilog.Mutate + , Verismith.Verilog.Parser + , Verismith.Verilog.Preprocess + , Verismith.Verilog.Quote + , Verismith.Verilog.Token build-depends: base >=4.7 && <5 -- Cannot upgrade to 1.0 because of missing MonadGen instance for -- StateT. -- cgit From 7377b2e83143fc45f83b0abc974aafbf6b6a3dfe Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Wed, 18 Sep 2019 19:06:44 +0200 Subject: Add more scripts --- scripts/config.toml | 40 ++++++++++++++++++++ scripts/main.v | 27 ++++++++++++++ scripts/parallelsets.py | 97 +++++++++++++++++++++++++++++++++++++++++++++++++ scripts/scale.py | 26 +++++++++++++ 4 files changed, 190 insertions(+) create mode 100644 scripts/config.toml create mode 100644 scripts/main.v create mode 100755 scripts/parallelsets.py create mode 100755 scripts/scale.py diff --git a/scripts/config.toml b/scripts/config.toml new file mode 100644 index 0000000..edc094d --- /dev/null +++ b/scripts/config.toml @@ -0,0 +1,40 @@ + +[info] + commit = "562f0da77e0464bfc21e8753070aec1cf9e60cf2" + version = "0.2.0.0" + +[probability] + expr.binary = 5 + expr.concatenation = 3 + expr.number = 1 + expr.rangeselect = 5 + expr.signed = 5 + expr.string = 0 + expr.ternary = 5 + expr.unary = 5 + expr.unsigned = 5 + expr.variable = 5 + moditem.assign = 5 + moditem.combinational = 1 + moditem.instantiation = 1 + moditem.sequential = 1 + statement.blocking = 0 + statement.conditional = 1 + statement.forloop = 0 + statement.nonblocking = 3 + +[property] + module.depth = 2 + module.max = 1 + size = 10 + statement.depth = 3 + +[[synthesiser]] + description = "yosys" + name = "yosys" + output = "syn_yosys.v" + +[[synthesiser]] + description = "vivado" + name = "vivado" + output = "syn_vivado.v" diff --git a/scripts/main.v b/scripts/main.v new file mode 100644 index 0000000..452d2bf --- /dev/null +++ b/scripts/main.v @@ -0,0 +1,27 @@ +module top +#( parameter param9 = ((~(((8'ha3) >= (8'ha4)) <= (~&(8'ha4)))) ? ((((8'h9e) ? (8'h9c) : (8'h9c)) ? {(8'hb0)} : ((8'ha2) ? (8'ha8) : (8'hae))) ? (((8'h9c) ? (8'h9d) : (8'hae)) >>> ((8'hae) ? (8'had) : (8'h9e))) : (((8'ha1) ? (8'ha8) : (8'h9c)) < ((8'h9f) <= (8'hb0)))) : (!(!(8'hb0)))) +, parameter param10 = param9 +, parameter param11 = (param9 >= (8'ha1)) +, parameter param12 = {((param11 != (8'h9f)) ? (^(^~(8'ha9))) : (+{param11}))} ) +(y, clk, wire0, wire1); + output wire [(32'h34):(32'h0)] y ; + input wire [(1'h0):(1'h0)] clk ; + input wire [(4'h9):(1'h0)] wire0 ; + input wire [(3'h7):(1'h0)] wire1 ; + wire signed [(3'h4):(1'h0)] wire8 ; + wire signed [(4'h8):(1'h0)] wire7 ; + wire [(3'h7):(1'h0)] wire6 ; + wire signed [(4'ha):(1'h0)] wire5 ; + wire [(4'h8):(1'h0)] wire4 ; + wire [(4'h9):(1'h0)] wire3 ; + wire signed [(3'h5):(1'h0)] wire2 ; + assign wire2 = ((^wire0) >> $signed(wire1[(3'h4):(1'h0)])) ; + assign wire3 = (~|$signed(wire0)) ; + assign wire4 = $signed({wire0}) ; + assign wire5 = (&($unsigned((wire4 <<< wire4)) ^ $unsigned(((8'ha3) * wire0)))) ; + assign wire6 = $signed(({(wire5 ? + wire2 : wire1)} >>> (^~((8'hac) + wire3)))) ; + assign wire7 = wire4[(2'h3):(1'h1)] ; + assign wire8 = {{wire0}} ; + assign y = {wire8, wire7, wire6, wire5, wire4, wire3, wire2, (1'h0)} ; +endmodule \ No newline at end of file diff --git a/scripts/parallelsets.py b/scripts/parallelsets.py new file mode 100755 index 0000000..d7d4636 --- /dev/null +++ b/scripts/parallelsets.py @@ -0,0 +1,97 @@ +#!/usr/bin/env python3 + +import os +import re +from pathlib import Path +import itertools +import subprocess + +def iterdir(currdir): + return [x for x in currdir.iterdir() if x.is_dir()] + +def identify_vivado(current, name): + v2018 = re.compile(".*2018.2") + v2017 = re.compile(".*2017.4") + v20161 = re.compile(".*2016.1") + v20162 = re.compile(".*2016.2") + + if v2018.match(name): + current[3] = 1 + elif v2017.match(name): + current[2] = 1 + elif v20162.match(name): + current[1] = 1 + elif v20161.match(name): + current[0] = 1 + + return current + +def identify_general(current, name): + yosys = re.compile(".*yosys") + vivado = re.compile(".*vivado") + xst = re.compile(".*xst") + quartus = re.compile(".*quartus") + + if yosys.match(name): + current[3] = 1 + elif vivado.match(name): + current[2] = 1 + elif xst.match(name): + current[1] = 1 + elif quartus.match(name): + current[0] = 1 + + return current + +def get_group(val): + return val[0] + +def get_freq(val): + return val[1] + +def timeout_present(directory): + return subprocess.run([ "grep", "-r", "--include", "symbiyosys.log" + , "-m", "1", "-q", "Keyboard interrupt" + , directory.as_posix() + ]).returncode == 0 + +def find_reduce_dirs(start_dir=".", prefix="reduce"): + matcher = re.compile(prefix + ".*") + fuzzmatch = re.compile("fuzz.*") + initdir = Path(start_dir) + + sets = [] + for dirlevel1 in iterdir(initdir): + for dirlevel2 in iterdir(dirlevel1): + current_set = [0, 0, 0, 0] + update = True + for dirlevel3 in iterdir(dirlevel2): + if matcher.match(dirlevel3.name): + if timeout_present(dirlevel2): + current_set = [2, 2, 2, 2] + continue + current_set = identify_vivado( + current_set, dirlevel3.name) + elif fuzzmatch.match(dirlevel3.name): + current_set = [0, 0, 0, 0] + for dirlevel4 in iterdir(dirlevel3): + if timeout_present(dirlevel3): + current_set = [2, 2, 2, 2] + break + if matcher.match(dirlevel4.name): + current_set = identify_vivado( + current_set, dirlevel4.name) + sets.append((current_set, dirlevel3)) + update = False + if update: + sets.append((current_set, dirlevel2)) + freqs = [(x, len(list(y))) for x, y in + itertools.groupby(sorted(sets, key=get_group), + get_group)] + print(sorted(freqs, key=get_freq)) + +def main(): + find_reduce_dirs(".", "reduce") + +if __name__ == "__main__": + main() diff --git a/scripts/scale.py b/scripts/scale.py new file mode 100755 index 0000000..7dbc155 --- /dev/null +++ b/scripts/scale.py @@ -0,0 +1,26 @@ +#!/usr/bin/env python3 + +import csv +import sys +import random + +def main(filename, output_file): + with open(filename, "r") as f: + reader = list(csv.reader(f)) + newreader = [] + for row in reader: + try: + if float(row[4]) > 900: + row[4] = "900" + if float(row[3]) > 900: + row[3] = "900" + if random.random() < 0.25: + newreader.append(row) + except: + newreader.append(row) + with open(output_file, "w") as f: + writer = csv.writer(f) + writer.writerows(newreader) + +if __name__ == "__main__": + main(sys.argv[1], sys.argv[2]) -- cgit From 5815e527f7e3b65078e2ad19df3538bb701ec7ac Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 22:40:06 +0100 Subject: [Fix #63] Make build pass again --- default.nix | 28 +------------- src/Verismith/Fuzz.hs | 14 +++---- src/Verismith/Generate.hs | 97 ++++++++++++++++++++++++----------------------- test/Property.hs | 26 ------------- verismith.cabal | 7 ++-- 5 files changed, 59 insertions(+), 113 deletions(-) diff --git a/default.nix b/default.nix index e8715fa..7a9f04f 100644 --- a/default.nix +++ b/default.nix @@ -1,30 +1,6 @@ { nixpkgs ? import {}, compiler ? "ghc865", doBenchmark ? false } : let - haskellPackages = nixpkgs.pkgs.haskellPackages.override { - overrides = haskellPackagesNew: haskellPackagesOld: rec { - hedgehog-fn = haskellPackages.callCabal2nix "hedgehog-fn" (builtins.fetchGit { - url = "git@github.com:qfpl/hedgehog-fn"; - rev = "723b67f54422cf1fbbdcfa23f01a2d4e37b2d110"; - }) {}; - tomland = nixpkgs.pkgs.haskell.lib.dontCheck (haskellPackages.callCabal2nix "tomland" (builtins.fetchGit { - url = "git@github.com:kowainik/tomland"; - rev = "a3feec3919e7b86275b0d937d48d153a4beda1f8"; - }) {}); - parser-combinators = haskellPackages.callCabal2nix "parser-combinators" (builtins.fetchGit { - url = "git@github.com:mrkkrp/parser-combinators"; - rev = "7003fd8425c3bba9ea25763173baedb4ebd184fd"; - }) {}; - tasty-hedgehog = haskellPackages.callCabal2nix "tasty-hedgehog" (builtins.fetchGit { - url = "git@github.com:qfpl/tasty-hedgehog"; - rev = "214f4496afb03630d12d4db606fb8953b3e02d10"; - }) {}; - hedgehog = haskellPackages.callCabal2nix "hedgehog" (builtins.fetchGit { - url = "git@github.com:hedgehogqa/haskell-hedgehog"; - rev = "38146de29c97c867cff52fb36367ff9a65306d76"; - }) {}; - }; - }; variant = if doBenchmark then nixpkgs.pkgs.haskell.lib.doBenchmark else nixpkgs.pkgs.lib.id; - verismith = haskellPackages.callCabal2nix "verismith" (./.) {}; + verismith = nixpkgs.pkgs.haskellPackages.callCabal2nix "verismith" (./.) {}; in - variant verismith +variant verismith diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index 2e0c95f..1f86739 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -454,13 +454,9 @@ sampleSeed s gen = "Hedgehog.Gen.sample: too many discards, could not generate a sample" else do seed <- maybe Hog.random return s - case - runIdentity - . runMaybeT - . Hog.runTree - $ Hog.runGenT 30 seed gen - of - Nothing -> loop (n - 1) - Just x -> return (seed, Hog.nodeValue x) + 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 205a54a..a896c3e 100644 --- a/src/Verismith/Generate.hs +++ b/src/Verismith/Generate.hs @@ -21,7 +21,6 @@ module Verismith.Generate , proceduralSrcIO , randomMod -- ** Generate Functions - , gen , largeNum , wireSize , range @@ -70,7 +69,8 @@ import Data.Foldable (fold) import Data.Functor.Foldable (cata) import Data.List (foldl', partition) import qualified Data.Text as T -import Hedgehog (Gen) +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 @@ -92,12 +92,12 @@ data Context = Context { _variables :: [Port] makeLenses ''Context -type StateGen = StateT Context (ReaderT Config Gen) +type StateGen = ReaderT Config (GenT (State Context)) toId :: Int -> Identifier toId = Identifier . ("w" <>) . T.pack . show -toPort :: Identifier -> Gen Port +toPort :: (MonadGen m) => Identifier -> m Port toPort ident = do i <- range return $ wire i ident @@ -105,7 +105,7 @@ toPort ident = do sumSize :: [Port] -> Range sumSize ps = sum $ ps ^.. traverse . portSize -random :: [Port] -> (Expr -> ContAssign) -> Gen ModItem +random :: (MonadGen m) => [Port] -> (Expr -> ContAssign) -> m ModItem random ctx fun = do expr <- Hog.sized (exprWithContext (ProbExpr 1 1 0 1 1 1 1 0 1 1) [] ctx) return . ModCA $ fun expr @@ -113,12 +113,12 @@ random ctx fun = do --randomAssigns :: [Identifier] -> [Gen ModItem] --randomAssigns ids = random ids . ContAssign <$> ids -randomOrdAssigns :: [Port] -> [Port] -> [Gen ModItem] +randomOrdAssigns :: (MonadGen m) => [Port] -> [Port] -> [m ModItem] randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids where generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) -randomMod :: Int -> Int -> Gen ModDecl +randomMod :: (MonadGen m) => Int -> Int -> m ModDecl randomMod inps total = do ident <- sequence $ toPort <$> ids x <- sequence $ randomOrdAssigns (start ident) (end ident) @@ -147,27 +147,29 @@ probability c = c ^. configProbability -- | Gets the current probabilities from the 'State'. askProbability :: StateGen Probability -askProbability = lift $ asks probability +askProbability = asks probability --- | Lifts a 'Gen' into the 'StateGen' monad. -gen :: Gen a -> StateGen a -gen = lift . lift +rask :: StateGen Config +rask = ask + +lget :: StateGen Context +lget = lift . lift $ get -- | Generates a random large number, which can also be negative. -largeNum :: Gen Int +largeNum :: (MonadGen m) => m Int largeNum = Hog.int $ Hog.linear (-100) 100 -- | Generates a random size for a wire so that it is not too small and not too -- large. -wireSize :: Gen Int +wireSize :: (MonadGen m) => m Int wireSize = Hog.int $ Hog.linear 2 100 -- | Generates a random range by using the 'wireSize' and 0 as the lower bound. -range :: Gen Range +range :: (MonadGen m) => m Range range = Range <$> fmap fromIntegral wireSize <*> pure 0 -- | Generate a random bit vector using 'largeNum'. -genBitVec :: Gen BitVec +genBitVec :: (MonadGen m) => m BitVec genBitVec = fmap fromIntegral largeNum -- | Return a random 'BinaryOperator'. This currently excludes 'BinDiv', @@ -175,7 +177,7 @@ genBitVec = fmap fromIntegral largeNum -- 'BinCNEq', because these are not synthesisable. 'BinPower' is also excluded -- because it can only be used in conjunction with base powers of 2 which is -- currently not enforced. -binOp :: Gen BinaryOperator +binOp :: (MonadGen m) => m BinaryOperator binOp = Hog.element [ BinPlus , BinMinus @@ -205,7 +207,7 @@ binOp = Hog.element ] -- | Generate a random 'UnaryOperator'. -unOp :: Gen UnaryOperator +unOp :: (MonadGen m) => m UnaryOperator unOp = Hog.element [ UnPlus , UnMinus @@ -221,7 +223,7 @@ unOp = Hog.element ] -- | Generate a random 'ConstExpr' by using the current context of 'Parameter'. -constExprWithContext :: [Parameter] -> ProbExpr -> Hog.Size -> Gen ConstExpr +constExprWithContext :: (MonadGen m) => [Parameter] -> ProbExpr -> Hog.Size -> m ConstExpr constExprWithContext ps prob size | size == 0 = Hog.frequency [ (prob ^. probExprNum, ConstNum <$> genBitVec) @@ -250,12 +252,12 @@ constExprWithContext ps prob size -- | The list of safe 'Expr', meaning that these will not recurse and will end -- the 'Expr' generation. -exprSafeList :: ProbExpr -> [(Int, Gen Expr)] +exprSafeList :: (MonadGen m) => ProbExpr -> [(Int, m Expr)] exprSafeList prob = [(prob ^. probExprNum, Number <$> genBitVec)] -- | List of 'Expr' that have the chance to recurse and will therefore not be -- used when the expression grows too large. -exprRecList :: ProbExpr -> (Hog.Size -> Gen Expr) -> [(Int, Gen Expr)] +exprRecList :: (MonadGen m) => ProbExpr -> (Hog.Size -> m Expr) -> [(Int, m Expr)] exprRecList prob subexpr = [ (prob ^. probExprNum, Number <$> genBitVec) , ( prob ^. probExprConcat @@ -271,7 +273,7 @@ exprRecList prob subexpr = -- | Select a random port from a list of ports and generate a safe bit selection -- for that port. -rangeSelect :: [Parameter] -> [Port] -> Gen Expr +rangeSelect :: (MonadGen m) => [Parameter] -> [Port] -> m Expr rangeSelect ps ports = do p <- Hog.element ports let s = calcRange ps (Just 32) $ _portSize p @@ -282,7 +284,7 @@ rangeSelect ps ports = do -- | Generate a random expression from the 'Context' with a guarantee that it -- will terminate using the list of safe 'Expr'. -exprWithContext :: ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> Gen 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 @@ -305,14 +307,14 @@ exprWithContext prob ps l n -- passed to it. someI :: Int -> StateGen a -> StateGen [a] someI m f = do - amount <- gen $ Hog.int (Hog.linear 1 m) + 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 :: T.Text -> StateGen Identifier makeIdentifier prefix = do - context <- get + context <- lget let ident = Identifier $ prefix <> showT (context ^. nameCounter) nameCounter += 1 return ident @@ -330,7 +332,7 @@ getPort' pt i c = case filter portId c of -- the generation is currently in the other branch of an if-statement. nextPort :: PortType -> StateGen Port nextPort pt = do - context <- get + context <- lget ident <- makeIdentifier . T.toLower $ showT pt getPort' pt ident (_variables context) @@ -338,17 +340,16 @@ nextPort pt = do -- current context. newPort :: Identifier -> PortType -> StateGen Port newPort ident pt = do - p <- gen $ Port pt <$> Hog.bool <*> range <*> pure ident + p <- Port pt <$> Hog.bool <*> range <*> pure ident variables %= (p :) return p -- | Generates an expression from variables that are currently in scope. scopedExpr :: StateGen Expr scopedExpr = do - context <- get + context <- lget prob <- askProbability - gen - . Hog.sized + Hog.sized . exprWithContext (_probExpr prob) (_parameters context) $ _variables context @@ -382,12 +383,12 @@ seqBlock = do conditional :: StateGen Statement conditional = do expr <- scopedExpr - nc <- _nameCounter <$> get + nc <- _nameCounter <$> lget tstat <- seqBlock - nc' <- _nameCounter <$> get + nc' <- _nameCounter <$> lget nameCounter .= nc fstat <- seqBlock - nc'' <- _nameCounter <$> get + nc'' <- _nameCounter <$> lget nameCounter .= max nc' nc'' return $ CondStmnt expr (Just tstat) (Just fstat) @@ -407,7 +408,7 @@ forLoop = do statement :: StateGen Statement statement = do prob <- askProbability - cont <- get + cont <- lget let defProb i = prob ^. probStmnt . i Hog.frequency [ (defProb probStmntBlock , BlockAssign <$> assignment) @@ -441,12 +442,12 @@ resizePort ps i ra = foldl' func [] -- representation for the clock. instantiate :: ModDecl -> StateGen ModItem instantiate (ModDecl i outP inP _ _) = do - context <- get + context <- lget outs <- replicateM (length outP) (nextPort Wire) ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables) mapM_ (uncurry process) . zip (ins ^.. traverse . portName) $ inpFixed ^.. traverse . portSize ident <- makeIdentifier "modinst" - vs <- view variables <$> get + vs <- view variables <$> lget Hog.choice [ return . ModInst i ident $ ModConn <$> toE (outs <> clkPort <> ins) , ModInst i ident <$> Hog.shuffle @@ -459,7 +460,7 @@ instantiate (ModDecl i outP inP _ _) = do | n == "clk" = False | otherwise = True process p r = do - params <- view parameters <$> get + params <- view parameters <$> lget variables %= resizePort params p r -- | Generates a module instance by also generating a new module if there are @@ -483,8 +484,8 @@ instantiate (ModDecl i outP inP _ _) = do -- a module from a context or generating a new one. modInst :: StateGen ModItem modInst = do - prob <- lift ask - context <- get + prob <- rask + context <- lget let maxMods = prob ^. configProperty . propMaxModules if length (context ^. modules) < maxMods then do @@ -496,7 +497,7 @@ modInst = do parameters .= [] modDepth -= 1 chosenMod <- moduleDef Nothing - ncont <- get + ncont <- lget let genMods = ncont ^. modules modDepth += 1 parameters .= params @@ -508,9 +509,9 @@ modInst = do -- | Generate a random module item. modItem :: StateGen ModItem modItem = do - conf <- lift ask + conf <- rask let prob = conf ^. configProbability - context <- get + context <- lget let defProb i = prob ^. probModItem . i det <- Hog.frequency [ (conf ^. configProperty . propDeterminism, return True) , (conf ^. configProperty . propNonDeterminism, return False) ] @@ -532,8 +533,8 @@ moduleName Nothing = makeIdentifier "module" constExpr :: StateGen ConstExpr constExpr = do prob <- askProbability - context <- get - gen . Hog.sized $ constExprWithContext (context ^. parameters) + context <- lget + Hog.sized $ constExprWithContext (context ^. parameters) (prob ^. probExpr) -- | Generate a random 'Parameter' and assign it to a constant expression which @@ -573,8 +574,8 @@ moduleDef top = do portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire mi <- Hog.list (Hog.linear 4 100) modItem ps <- Hog.list (Hog.linear 0 10) parameter - context <- get - config <- lift ask + context <- lget + config <- rask let (newPorts, local) = partition (`identElem` portList) $ _variables context let size = @@ -597,9 +598,9 @@ moduleDef top = do -- 'State' to keep track of the current Verilog code structure. procedural :: T.Text -> Config -> Gen Verilog procedural top config = do - (mainMod, st) <- Hog.resize num $ runReaderT - (runStateT (moduleDef (Just $ Identifier top)) context) - config + (mainMod, st) <- Hog.resize num $ runStateT + (Hog.distributeT (runReaderT (moduleDef (Just $ Identifier top)) config)) + context return . Verilog $ mainMod : st ^. modules where context = diff --git a/test/Property.hs b/test/Property.hs index bec740c..a57f92c 100644 --- a/test/Property.hs +++ b/test/Property.hs @@ -16,8 +16,6 @@ import qualified Data.Graph.Inductive as G import Data.Text (Text) import Hedgehog (Gen, Property, (===)) import qualified Hedgehog as Hog -import Hedgehog.Function (Arg, Vary) -import qualified Hedgehog.Function as Hog import qualified Hedgehog.Gen as Hog import qualified Hedgehog.Range as Hog import Parser (parserTests) @@ -45,30 +43,6 @@ acyclicGraph = Hog.property $ do . getCircuit $ g -type GenFunctor f a b c = - ( Functor f - , Show (f a) - , Show a, Arg a, Vary a - , Show b, Arg b, Vary b - , Show c - , Eq (f c) - , Show (f c) - ) - -mapCompose - :: forall f a b c - . GenFunctor f a b c - => (forall x . Gen x -> Gen (f x)) - -> Gen a - -> Gen b - -> Gen c - -> Property -mapCompose genF genA genB genC = Hog.property $ do - g <- Hog.forAllFn $ Hog.fn @a genB - f <- Hog.forAllFn $ Hog.fn @b genC - xs <- Hog.forAll $ genF genA - fmap (f . g) xs === fmap f (fmap g xs) - propertyResultInterrupted :: Property propertyResultInterrupted = do mapCompose genResult diff --git a/verismith.cabal b/verismith.cabal index 2367c04..b9203b9 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -69,7 +69,7 @@ library build-depends: base >=4.7 && <5 -- Cannot upgrade to 1.0 because of missing MonadGen instance for -- StateT. - , hedgehog >= 0.5.3 && <0.7 + , hedgehog >=1.0 && <1.2 , fgl >=5.6 && <5.8 , fgl-visualize >=0.1 && <0.2 , lens >=4.16.1 && <4.18 @@ -138,9 +138,8 @@ test-suite test , fgl >=5.6 && <5.8 , tasty >=1.0.1.1 && <1.3 , tasty-hunit >=0.10 && <0.11 - , tasty-hedgehog >=0.2 && <0.3 - , hedgehog >=0.5.3 && <0.7 - , hedgehog-fn >=0.5 && <0.7 + , tasty-hedgehog >=1.0 && <1.1 + , hedgehog >=1.0 && <1.2 , lens >=4.16.1 && <4.18 , shakespeare >=2 && <2.1 , text >=1.2 && <1.3 -- cgit From 09fde96bb166b0e6b428aff9034b14f9b31f24eb Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 22:41:34 +0100 Subject: Test cases pass again --- test/Property.hs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/test/Property.hs b/test/Property.hs index a57f92c..7e1911e 100644 --- a/test/Property.hs +++ b/test/Property.hs @@ -43,21 +43,9 @@ acyclicGraph = Hog.property $ do . getCircuit $ g -propertyResultInterrupted :: Property -propertyResultInterrupted = do - mapCompose genResult - (Hog.int (Hog.linear 0 100)) - (Hog.int (Hog.linear 0 100)) - (Hog.int (Hog.linear 0 100)) - where - genResult :: Gen a -> Gen (Result Text a) - genResult a = Hog.choice - [Pass <$> a, Fail <$> Hog.text (Hog.linear 1 100) Hog.unicode] - propertyTests :: TestTree propertyTests = testGroup "Property Tests" [ testProperty "acyclic graph generation check" acyclicGraph - , testProperty "fmap for Result" propertyResultInterrupted , parserTests ] -- cgit From 920e4ae07800e793d83df8c9dca05ce62f2943c7 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 22:55:11 +0100 Subject: Change benchmark information Generation became ~8x slower because of the StateT Context Gen ==> GenT (State Context) change. --- README.md | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index fcb5402..7b88543 100644 --- a/README.md +++ b/README.md @@ -155,25 +155,26 @@ Current benchmark results to compare against. ``` text benchmarking generation/default -time 21.16 ms (17.34 ms .. 24.27 ms) - 0.877 R² (0.742 R² .. 0.977 R²) -mean 20.74 ms (18.40 ms .. 22.70 ms) -std dev 4.741 ms (3.372 ms .. 7.002 ms) -variance introduced by outliers: 85% (severely inflated) +time 65.16 ms (42.67 ms .. 84.90 ms) + 0.837 R² (0.722 R² .. 0.966 R²) +mean 82.87 ms (71.13 ms .. 105.9 ms) +std dev 27.59 ms (15.80 ms .. 42.35 ms) +variance introduced by outliers: 90% (severely inflated) benchmarking generation/depth -time 155.9 ms (90.11 ms .. 209.1 ms) - 0.855 R² (0.680 R² .. 0.983 R²) -mean 92.37 ms (67.36 ms .. 118.2 ms) -std dev 40.56 ms (33.70 ms .. 49.28 ms) -variance introduced by outliers: 88% (severely inflated) +time 860.8 ms (2.031 ms .. 1.488 s) + 0.900 R² (0.668 R² .. 1.000 R²) +mean 483.9 ms (254.1 ms .. 647.6 ms) +std dev 224.4 ms (100.8 ms .. 283.5 ms) +variance introduced by outliers: 74% (severely inflated) benchmarking generation/size -time 117.9 ms (10.21 ms .. 209.1 ms) - 0.616 R² (0.030 R² .. 0.992 R²) -mean 160.5 ms (126.2 ms .. 187.1 ms) -std dev 45.03 ms (27.55 ms .. 68.66 ms) -variance introduced by outliers: 70% (severely inflated) +time 541.1 ms (-749.1 ms .. 1.263 s) + 0.568 R² (0.005 R² .. 1.000 R²) +mean 698.8 ms (498.2 ms .. 897.5 ms) +std dev 229.8 ms (195.0 ms .. 239.7 ms) +variance introduced by outliers: 73% (severely inflated) + ``` ## Acknowledgement -- cgit From ebe4ed7c3eeecc3c17d2832294bdb190279939ca Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 22:59:55 +0100 Subject: Fix spelling in readme --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 7b88543..5666dca 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ -# VeriSmith [![Build Status](https://travis-ci.com/ymherklotz/verismith.svg?token=qfBKKGwxeWkjDsy7e16x&branch=master)](https://travis-ci.com/ymherklotz/verismith) +# Verismith [![Build Status](https://travis-ci.com/ymherklotz/verismith.svg?token=qfBKKGwxeWkjDsy7e16x&branch=master)](https://travis-ci.com/ymherklotz/verismith) Verilog Fuzzer to test the major verilog compilers by generating random, valid and deterministic Verilog. There is a -[presentation](https://yannherklotz.com/docs/presentation.pdf) about VeriSmith +[presentation](https://yannherklotz.com/docs/presentation.pdf) about Verismith and a [thesis](https://yannherklotz.com/docs/thesis.pdf) which goes over all the details of the implementation and results that were found. @@ -110,7 +110,7 @@ the actual project itself. ## Configuration -VeriSmith can be configured using a [TOML](https://github.com/toml-lang/toml) +Verismith can be configured using a [TOML](https://github.com/toml-lang/toml) file. There are four main sections in the configuration file, an example can be seen [here](/examples/config.toml). -- cgit From 41c88cd7cad64761a6fe783c5225a1de187c5d87 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 23:19:19 +0100 Subject: Pin the nix repository --- default.nix | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index 7a9f04f..1a135c0 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,16 @@ -{ nixpkgs ? import {}, compiler ? "ghc865", doBenchmark ? false } : +{ nixpkgs ? null, compiler ? "ghc865", doBenchmark ? false } : let - variant = if doBenchmark then nixpkgs.pkgs.haskell.lib.doBenchmark else nixpkgs.pkgs.lib.id; - verismith = nixpkgs.pkgs.haskellPackages.callCabal2nix "verismith" (./.) {}; + sysPkg = import { }; + pinnedPkg = builtins.fetchGit { + name = "nixos-unstable-2019-10-06"; + url = https://github.com/nixos/nixpkgs/; + rev = "271fef8a4eb03cd9de0c1fe2f0b7f4a16c2de49a"; + }; + npkgs = if nixpkgs == null then + import pinnedPkg {} + else + import nixpkgs {}; + variant = if doBenchmark then npkgs.pkgs.haskell.lib.doBenchmark else npkgs.pkgs.lib.id; + verismith = npkgs.pkgs.haskellPackages.callCabal2nix "verismith" (./.) {}; in variant verismith -- cgit From b78750746ac0e4d082e38bda70db4d5ec41817e3 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 6 Oct 2019 23:29:55 +0100 Subject: Fix cabal file --- verismith.cabal | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/verismith.cabal b/verismith.cabal index b9203b9..b850b28 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -1,5 +1,5 @@ name: verismith -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Random verilog generation and simulator testing. description: Verismith provides random verilog generation modules @@ -21,6 +21,15 @@ extra-source-files: README.md , scripts/*.py , scripts/*.sh +source-repository head + type: git + location: https://github.com/ymherklotz/verismith + +source-repository this + type: git + location: https://github.com/ymherklotz/verismith + tag: v0.4.0.0 + custom-setup setup-depends: base >= 4 && <5, -- cgit From 5e0e1a2a2b06c17a818805a13261425438020e15 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 7 Oct 2019 09:57:36 +0100 Subject: Remove nix folder --- nix/hedgehog-fn.nix | 17 ----------------- nix/parser-combinators.nix | 10 ---------- nix/tasty-hedgehog.nix | 17 ----------------- nix/tomland.nix | 33 --------------------------------- 4 files changed, 77 deletions(-) delete mode 100644 nix/hedgehog-fn.nix delete mode 100644 nix/parser-combinators.nix delete mode 100644 nix/tasty-hedgehog.nix delete mode 100644 nix/tomland.nix diff --git a/nix/hedgehog-fn.nix b/nix/hedgehog-fn.nix deleted file mode 100644 index 0bf9279..0000000 --- a/nix/hedgehog-fn.nix +++ /dev/null @@ -1,17 +0,0 @@ -{ mkDerivation, base, contravariant, hedgehog, stdenv, transformers -}: -mkDerivation { - pname = "hedgehog-fn"; - version = "0.6"; - sha256 = "fb02b67fba97e24c226feba010d2b308934c54e20a0723b6ea7e4eb199f02176"; - revision = "1"; - editedCabalFile = "19v7amg8l6s1gadnya8nxkcbi0vd3wqc7h6gvqvs099qaqm7zbb1"; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - base contravariant hedgehog transformers - ]; - homepage = "https://github.com/qfpl/hedgehog-fn"; - description = "Function generation for `hedgehog`"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/nix/parser-combinators.nix b/nix/parser-combinators.nix deleted file mode 100644 index d1baab9..0000000 --- a/nix/parser-combinators.nix +++ /dev/null @@ -1,10 +0,0 @@ -{ mkDerivation, base, stdenv }: -mkDerivation { - pname = "parser-combinators"; - version = "1.1.0"; - sha256 = "ac7642972b18a47c575d2bcd0b2f6c34f33ca2ed3adb28034420d09ced823e91"; - libraryHaskellDepends = [ base ]; - homepage = "https://github.com/mrkkrp/parser-combinators"; - description = "Lightweight package providing commonly useful parser combinators"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/nix/tasty-hedgehog.nix b/nix/tasty-hedgehog.nix deleted file mode 100644 index e9a937d..0000000 --- a/nix/tasty-hedgehog.nix +++ /dev/null @@ -1,17 +0,0 @@ -{ mkDerivation, base, hedgehog, stdenv, tagged, tasty -, tasty-expected-failure -}: -mkDerivation { - pname = "tasty-hedgehog"; - version = "0.2.0.0"; - sha256 = "5a107fc3094efc50663e4634331a296281318b38c9902969c2d2d215d754a182"; - revision = "6"; - editedCabalFile = "0d7s1474pvnyad6ilr5rvpama7s468ya9ns4ksbl0827z9vvga43"; - libraryHaskellDepends = [ base hedgehog tagged tasty ]; - testHaskellDepends = [ - base hedgehog tasty tasty-expected-failure - ]; - homepage = "https://github.com/qfpl/tasty-hedgehog"; - description = "Integration for tasty and hedgehog"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/nix/tomland.nix b/nix/tomland.nix deleted file mode 100644 index e771e20..0000000 --- a/nix/tomland.nix +++ /dev/null @@ -1,33 +0,0 @@ -{ mkDerivation, aeson, base, bytestring, containers, deepseq -, directory, gauge, hashable, hedgehog, hspec-megaparsec, htoml -, htoml-megaparsec, markdown-unlit, megaparsec, mtl, parsec -, parser-combinators, stdenv, tasty, tasty-discover, tasty-hedgehog -, tasty-hspec, tasty-silver, text, time, toml-parser, transformers -, unordered-containers -}: -mkDerivation { - pname = "tomland"; - version = "1.1.0.1"; - sha256 = "51cde31c25056c6a0714758eb782bda0c019bdd2ef58f29baf6364cbf6451f46"; - isLibrary = true; - isExecutable = true; - libraryHaskellDepends = [ - base bytestring containers deepseq hashable megaparsec mtl - parser-combinators text time transformers unordered-containers - ]; - executableHaskellDepends = [ base text time unordered-containers ]; - executableToolDepends = [ markdown-unlit ]; - testHaskellDepends = [ - base bytestring containers directory hashable hedgehog - hspec-megaparsec megaparsec tasty tasty-hedgehog tasty-hspec - tasty-silver text time unordered-containers - ]; - testToolDepends = [ tasty-discover ]; - benchmarkHaskellDepends = [ - aeson base deepseq gauge htoml htoml-megaparsec parsec text time - toml-parser - ]; - homepage = "https://github.com/kowainik/tomland"; - description = "Bidirectional TOML serialization"; - license = stdenv.lib.licenses.mpl20; -} -- cgit From 8c02d755cc947a27d1f2f035cf5b05cb63baba0d Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 7 Oct 2019 09:59:47 +0100 Subject: Clean up default.nix file --- default.nix | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/default.nix b/default.nix index 1a135c0..9093557 100644 --- a/default.nix +++ b/default.nix @@ -1,15 +1,13 @@ { nixpkgs ? null, compiler ? "ghc865", doBenchmark ? false } : let - sysPkg = import { }; pinnedPkg = builtins.fetchGit { name = "nixos-unstable-2019-10-06"; url = https://github.com/nixos/nixpkgs/; rev = "271fef8a4eb03cd9de0c1fe2f0b7f4a16c2de49a"; }; - npkgs = if nixpkgs == null then - import pinnedPkg {} - else - import nixpkgs {}; + npkgs = if nixpkgs == null + then import pinnedPkg {} + else import nixpkgs {}; variant = if doBenchmark then npkgs.pkgs.haskell.lib.doBenchmark else npkgs.pkgs.lib.id; verismith = npkgs.pkgs.haskellPackages.callCabal2nix "verismith" (./.) {}; in -- cgit From f7edca801cd006ab4129f48b8b94fb6ab38df74e Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 7 Oct 2019 10:23:30 +0100 Subject: Remove reference to nix files --- verismith.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/verismith.cabal b/verismith.cabal index b850b28..36a7777 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -17,7 +17,6 @@ extra-source-files: README.md , data/*.v , examples/*.v , examples/config.toml - , nix/*.nix , scripts/*.py , scripts/*.sh -- cgit From 3c0f80bebe8411f978da81dbba058d3a96d31ee5 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 14:28:33 +0100 Subject: Update runner --- scripts/run.py | 37 ++++++++++++++++++++++--------------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/scripts/run.py b/scripts/run.py index 636e1c3..3930ca7 100755 --- a/scripts/run.py +++ b/scripts/run.py @@ -2,21 +2,28 @@ import subprocess import os +import sys +import datetime -def main(): - i = 0 - name = "mediumB" - config = "experiments/config_yosys.toml" - iterations = 50 - directory = "yosys_all" - if not os.path.exists(directory): - os.makedirs(directory) - while True: - subprocess.call(["verismith", "fuzz" - , "-o", directory + "/" + name + str(i) - , "-c", config - , "-n", str(iterations)]) - i += 1 +def main(run_id): + i = 0 + name = "medium_{}_".format(run_id) + config = "config.toml" + iterations = 100 + directory = "yosys_all" + try: + os.makedirs(directory) + except IOError: + pass + while True: + output_directory = directory + "/" + name + str(i) + print("{} :: {}".format(datetime.datetime.now(), output_directory)) + with open(output_directory + ".log", "w") as f: + subprocess.call(["cabal", "run", "-O2", "verismith", "--", "fuzz" + , "-o", output_directory + , "-c", config + , "-n", str(iterations)], stdout=f) + i += 1 if __name__ == '__main__': - main() + main(sys.argv[1]) -- cgit From 349c1fa290c068a0f4100469e7485d062dd995ce Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 14:28:43 +0100 Subject: Update default configuration --- scripts/config.toml | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/scripts/config.toml b/scripts/config.toml index edc094d..15e961f 100644 --- a/scripts/config.toml +++ b/scripts/config.toml @@ -14,27 +14,24 @@ expr.unary = 5 expr.unsigned = 5 expr.variable = 5 - moditem.assign = 5 - moditem.combinational = 1 + moditem.assign = 2 + moditem.combinational = 0 moditem.instantiation = 1 - moditem.sequential = 1 + moditem.sequential = 3 statement.blocking = 0 statement.conditional = 1 - statement.forloop = 0 - statement.nonblocking = 3 + statement.forloop = 1 + statement.nonblocking = 2 [property] module.depth = 2 - module.max = 1 - size = 10 - statement.depth = 3 + module.max = 5 + size = 20 + statement.depth = 5 + sample.method = "hat" + sample.size = 10 [[synthesiser]] description = "yosys" name = "yosys" output = "syn_yosys.v" - -[[synthesiser]] - description = "vivado" - name = "vivado" - output = "syn_vivado.v" -- cgit From e7f57642f068650ea362201b239efad1c9a841d9 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 14:29:07 +0100 Subject: Rename Sim to Tool --- src/Verismith.hs | 6 +- src/Verismith/Config.hs | 8 +- src/Verismith/Fuzz.hs | 37 +++---- src/Verismith/Reduce.hs | 4 +- src/Verismith/Report.hs | 4 +- src/Verismith/Sim.hs | 51 ---------- src/Verismith/Sim/Icarus.hs | 188 ----------------------------------- src/Verismith/Sim/Identity.hs | 51 ---------- src/Verismith/Sim/Internal.hs | 215 ----------------------------------------- src/Verismith/Sim/Quartus.hs | 77 --------------- src/Verismith/Sim/Template.hs | 133 ------------------------- src/Verismith/Sim/Vivado.hs | 71 -------------- src/Verismith/Sim/XST.hs | 85 ---------------- src/Verismith/Sim/Yosys.hs | 127 ------------------------ src/Verismith/Tool.hs | 51 ++++++++++ src/Verismith/Tool/Icarus.hs | 188 +++++++++++++++++++++++++++++++++++ src/Verismith/Tool/Identity.hs | 51 ++++++++++ src/Verismith/Tool/Internal.hs | 215 +++++++++++++++++++++++++++++++++++++++++ src/Verismith/Tool/Quartus.hs | 77 +++++++++++++++ src/Verismith/Tool/Template.hs | 133 +++++++++++++++++++++++++ src/Verismith/Tool/Vivado.hs | 71 ++++++++++++++ src/Verismith/Tool/XST.hs | 85 ++++++++++++++++ src/Verismith/Tool/Yosys.hs | 127 ++++++++++++++++++++++++ verismith.cabal | 18 ++-- 24 files changed, 1034 insertions(+), 1039 deletions(-) delete mode 100644 src/Verismith/Sim.hs delete mode 100644 src/Verismith/Sim/Icarus.hs delete mode 100644 src/Verismith/Sim/Identity.hs delete mode 100644 src/Verismith/Sim/Internal.hs delete mode 100644 src/Verismith/Sim/Quartus.hs delete mode 100644 src/Verismith/Sim/Template.hs delete mode 100644 src/Verismith/Sim/Vivado.hs delete mode 100644 src/Verismith/Sim/XST.hs delete mode 100644 src/Verismith/Sim/Yosys.hs create mode 100644 src/Verismith/Tool.hs create mode 100644 src/Verismith/Tool/Icarus.hs create mode 100644 src/Verismith/Tool/Identity.hs create mode 100644 src/Verismith/Tool/Internal.hs create mode 100644 src/Verismith/Tool/Quartus.hs create mode 100644 src/Verismith/Tool/Template.hs create mode 100644 src/Verismith/Tool/Vivado.hs create mode 100644 src/Verismith/Tool/XST.hs create mode 100644 src/Verismith/Tool/Yosys.hs diff --git a/src/Verismith.hs b/src/Verismith.hs index e7d3ce6..85deca3 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -30,7 +30,7 @@ module Verismith , module Verismith.Verilog , module Verismith.Config , module Verismith.Circuit - , module Verismith.Sim + , module Verismith.Tool , module Verismith.Fuzz , module Verismith.Report ) @@ -65,8 +65,8 @@ import Verismith.Generate import Verismith.Reduce import Verismith.Report import Verismith.Result -import Verismith.Sim -import Verismith.Sim.Internal +import Verismith.Tool +import Verismith.Tool.Internal import Verismith.Verilog import Verismith.Verilog.Parser (parseSourceInfoFile) diff --git a/src/Verismith/Config.hs b/src/Verismith/Config.hs index 9d37fd2..decf1fb 100644 --- a/src/Verismith/Config.hs +++ b/src/Verismith/Config.hs @@ -92,10 +92,10 @@ import Paths_verismith (version) import Shelly (toTextIgnore) import Toml (TomlCodec, (.=)) import qualified Toml -import Verismith.Sim.Quartus -import Verismith.Sim.Vivado -import Verismith.Sim.XST -import Verismith.Sim.Yosys +import Verismith.Tool.Quartus +import Verismith.Tool.Vivado +import Verismith.Tool.XST +import Verismith.Tool.Yosys -- $conf -- diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index 1f86739..81c00a0 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -59,9 +59,9 @@ import Verismith.Internal import Verismith.Reduce import Verismith.Report import Verismith.Result -import Verismith.Sim.Icarus -import Verismith.Sim.Internal -import Verismith.Sim.Yosys +import Verismith.Tool.Icarus +import Verismith.Tool.Internal +import Verismith.Tool.Yosys import Verismith.Verilog.AST import Verismith.Verilog.CodeGen @@ -194,24 +194,19 @@ equivalence src = do equiv 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 - runEquiv a b src + $ 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 + runEquiv a b src where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () diff --git a/src/Verismith/Reduce.hs b/src/Verismith/Reduce.hs index 69674cc..88f0b42 100644 --- a/src/Verismith/Reduce.hs +++ b/src/Verismith/Reduce.hs @@ -49,8 +49,8 @@ import qualified Shelly import Shelly.Lifted (MonadSh, liftSh) import Verismith.Internal import Verismith.Result -import Verismith.Sim -import Verismith.Sim.Internal +import Verismith.Tool +import Verismith.Tool.Internal import Verismith.Verilog import Verismith.Verilog.AST import Verismith.Verilog.Mutate diff --git a/src/Verismith/Report.hs b/src/Verismith/Report.hs index b074be4..6c25f5c 100644 --- a/src/Verismith/Report.hs +++ b/src/Verismith/Report.hs @@ -63,8 +63,8 @@ import qualified Text.Blaze.Html5.Attributes as A import Verismith.Config import Verismith.Internal import Verismith.Result -import Verismith.Sim -import Verismith.Sim.Internal +import Verismith.Tool +import Verismith.Tool.Internal -- | Common type alias for synthesis results type UResult = Result Failed () diff --git a/src/Verismith/Sim.hs b/src/Verismith/Sim.hs deleted file mode 100644 index 5e31985..0000000 --- a/src/Verismith/Sim.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : Verismith.Sim -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.Sim - ( - -- * Simulators - -- ** Icarus - Icarus(..) - , defaultIcarus - -- * Synthesisers - -- ** Yosys - , Yosys(..) - , defaultYosys - -- ** Vivado - , Vivado(..) - , defaultVivado - -- ** XST - , XST(..) - , defaultXST - -- ** Quartus - , Quartus(..) - , defaultQuartus - -- ** Identity - , Identity(..) - , defaultIdentity - -- * Equivalence - , runEquiv - -- * Simulation - , runSim - -- * Synthesis - , runSynth - , logger - ) -where - -import Verismith.Sim.Icarus -import Verismith.Sim.Identity -import Verismith.Sim.Internal -import Verismith.Sim.Quartus -import Verismith.Sim.Vivado -import Verismith.Sim.XST -import Verismith.Sim.Yosys diff --git a/src/Verismith/Sim/Icarus.hs b/src/Verismith/Sim/Icarus.hs deleted file mode 100644 index 003f1de..0000000 --- a/src/Verismith/Sim/Icarus.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-| -Module : Verismith.Sim.Icarus -Description : Icarus verilog module. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Icarus verilog module. --} - -module Verismith.Sim.Icarus - ( Icarus(..) - , defaultIcarus - , runSimIc - ) -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.Sim.Internal -import Verismith.Sim.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) - -instance Show Icarus where - show _ = "iverilog" - -instance Tool Icarus where - toText _ = "iverilog" - -instance Simulator Icarus where - runSim = runSimIcarus - runSimWithFile = runSimIcarusWithFile - -instance NFData Icarus where - rnf = rwhnf - -defaultIcarus :: Icarus -defaultIcarus = Icarus "iverilog" "vvp" - -addDisplay :: [Statement] -> [Statement] -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 -assignFunc inp bs = - 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 - -mask :: Text -> Text -mask = T.replace "x" "0" - -callback :: ByteString -> Text -> ByteString -callback b t = b <> convert (mask t) - -runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss - where m = rinfo ^. mainModule - -runSimIcarusWithFile - :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString -runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) - -fromBytes :: ByteString -> Integer -fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b - -runSimIc - :: (Synthesiser b) - => Icarus - -> b - -> SourceInfo - -> [ByteString] - -> ResultSh ByteString -runSimIc sim1 synth1 srcInfo bss = do - dir <- liftSh pwd - let top = srcInfo ^. mainModule - let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) - let - tb = 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 - ) - <> (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"] - ] - [] - - liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 - liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] - liftSh - $ B.take 8 - . BA.convert - . (hash :: ByteString -> Digest SHA256) - <$> logCommand - dir - "vvp" - (runFoldLines (mempty :: ByteString) - callback - (vvpPath sim1) - ["main"] - ) - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Sim/Identity.hs b/src/Verismith/Sim/Identity.hs deleted file mode 100644 index 89c6b36..0000000 --- a/src/Verismith/Sim/Identity.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : Verismith.Sim.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.Sim.Identity - ( 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.Sim.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text - , identityOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Identity where - toText (Identity d _) = d - -instance Show Identity where - show t = unpack $ toText t - -instance Synthesiser Identity where - runSynth = runSynthIdentity - synthOutput = identityOutput - setSynthOutput (Identity a _) = Identity a - -instance NFData Identity where - rnf = rwhnf - -runSynthIdentity :: Identity -> SourceInfo -> ResultSh () -runSynthIdentity (Identity _ out) = writefile out . genSource - -defaultIdentity :: Identity -defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/Verismith/Sim/Internal.hs b/src/Verismith/Sim/Internal.hs deleted file mode 100644 index bcbc3af..0000000 --- a/src/Verismith/Sim/Internal.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-| -Module : Verismith.Sim.Internal -Description : Class of the simulator. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Class of the simulator and the synthesize tool. --} - -{-# LANGUAGE DeriveFunctor #-} - -module Verismith.Sim.Internal - ( 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.Internal -import Verismith.Result -import Verismith.Verilog.AST - --- | Tool class. -class Tool a where - toText :: a -> Text - --- | Simulation type class. -class Tool a => Simulator a where - runSim :: a -- ^ Simulator instance - -> SourceInfo -- ^ 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 - | EquivError - | SimFail - | SynthFail - | TimeoutError - deriving (Eq, Show) - -instance Semigroup Failed where - EmptyFail <> a = a - b <> _ = b - -instance Monoid Failed where - mempty = EmptyFail - --- | Synthesiser type class. -class Tool a => Synthesiser a where - runSynth :: a -- ^ Synthesiser tool instance - -> SourceInfo -- ^ Run information - -> ResultSh () -- ^ does not return any values - synthOutput :: a -> FilePath - setSynthOutput :: a -> FilePath -> a - -renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo -renameSource a src = - 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 --- with also has those instances. -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' - -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 - --- | 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 -> Sh [Text] -checkPresentModules fp (SourceInfo _ src) = do - 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] - --- | 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 --- should find all the instantiations and definitions. This could again be made --- much simpler if the parser works. -replaceMods :: FilePath -> Text -> SourceInfo -> Sh () -replaceMods fp t (SourceInfo _ src) = - 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" - -timeout :: FilePath -> [Text] -> Sh Text -timeout = command1 "timeout" ["300"] . toTextIgnore -{-# INLINE timeout #-} - -timeout_ :: FilePath -> [Text] -> Sh () -timeout_ = command1_ "timeout" ["300"] . toTextIgnore -{-# INLINE timeout_ #-} - --- | Helper function to convert bytestrings to integers -bsToI :: ByteString -> Integer -bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 -{-# INLINE bsToI #-} - -noPrint :: Sh a -> Sh a -noPrint = print_stdout False . print_stderr False -{-# INLINE noPrint #-} - -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 - -logCommand :: FilePath -> Text -> Sh a -> Sh a -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" - file s = T.unpack (toTextIgnore $ fp fromText name) <> s - -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 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 () -execute_ a b c d = void . execute a b c d diff --git a/src/Verismith/Sim/Quartus.hs b/src/Verismith/Sim/Quartus.hs deleted file mode 100644 index 5fb1e49..0000000 --- a/src/Verismith/Sim/Quartus.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-| -Module : Verismith.Sim.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.Sim.Quartus - ( 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.Sim.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -data Quartus = Quartus { quartusBin :: !(Maybe FilePath) - , quartusDesc :: {-# UNPACK #-} !Text - , quartusOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Quartus where - toText (Quartus _ t _) = t - -instance Show Quartus where - show t = unpack $ toText t - -instance Synthesiser Quartus where - runSynth = runSynthQuartus - synthOutput = quartusOutput - setSynthOutput (Quartus a b _) = Quartus a b - -instance NFData Quartus where - rnf = rwhnf - -defaultQuartus :: Quartus -defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" - -runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () -runSynthQuartus sim (SourceInfo top src) = do - dir <- liftSh pwd - let ex = execute_ SynthFail dir "quartus" - liftSh . writefile inpf $ genSource src - liftSh . noPrint $ run_ - "sed" - [ "-i" - , "s/^module/(* multstyle = \"logic\" *) module/;" - , toTextIgnore inpf - ] - ex (exec "quartus_map") - [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] - ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] - ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] - 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/Sim/Template.hs b/src/Verismith/Sim/Template.hs deleted file mode 100644 index 071e040..0000000 --- a/src/Verismith/Sim/Template.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-| -Module : Verismith.Sim.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.Sim.Template - ( yosysSatConfig - , yosysSimConfig - , xstSynthConfig - , vivadoSynthConfig - , sbyConfig - , icarusTestbench - ) -where - -import Control.Lens ((^..)) -import Data.Text (Text) -import qualified Data.Text as T -import Prelude hiding (FilePath) -import Shelly -import Text.Shakespeare.Text (st) -import Verismith.Sim.Internal -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -rename :: Text -> [Text] -> Text -rename end entries = - T.intercalate "\n" - $ flip mappend end - . mappend "rename " - . doubleName - <$> entries -{-# INLINE rename #-} - -doubleName :: Text -> Text -doubleName n = n <> " " <> n -{-# INLINE doubleName #-} - -outputText :: Synthesiser a => a -> Text -outputText = toTextIgnore . synthOutput - --- brittany-disable-next-binding -yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 - --- brittany-disable-next-binding -yosysSimConfig :: Text -yosysSimConfig = [st|read_verilog rtl.v; proc;; -rename mod mod_rtl -|] - --- brittany-disable-next-binding -xstSynthConfig :: Text -> Text -xstSynthConfig top = [st|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" -|] - --- brittany-disable-next-binding -vivadoSynthConfig :: Text -> Text -> Text -vivadoSynthConfig top outf = [st| -# 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} -|] - --- brittany-disable-next-binding -sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] -multiclock on -mode prove - -[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 - . (fromText "data" ) - . fromText - <$> deps - readL = T.intercalate "\n" $ mappend "read -formal " <$> deps - -icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text -icarusTestbench t synth1 = [st| -`include "data/cells_cmos.v" -`include "data/cells_cyclone_v.v" -`include "data/cells_verific.v" -`include "data/cells_xilinx_7.v" -`include "data/cells_yosys.v" -`include "#{toTextIgnore $ synthOutput synth1}" - -#{genSource t} -|] diff --git a/src/Verismith/Sim/Vivado.hs b/src/Verismith/Sim/Vivado.hs deleted file mode 100644 index 2dad87d..0000000 --- a/src/Verismith/Sim/Vivado.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-| -Module : Verismith.Sim.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.Sim.Vivado - ( 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.Sim.Internal -import Verismith.Sim.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) - , vivadoDesc :: {-# UNPACK #-} !Text - , vivadoOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Vivado where - toText (Vivado _ t _) = t - -instance Show Vivado where - show t = unpack $ toText t - -instance Synthesiser Vivado where - runSynth = runSynthVivado - synthOutput = vivadoOutput - setSynthOutput (Vivado a b _) = Vivado a b - -instance NFData Vivado where - rnf = rwhnf - -defaultVivado :: Vivado -defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" - -runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/Verismith/Sim/XST.hs b/src/Verismith/Sim/XST.hs deleted file mode 100644 index 9144ba7..0000000 --- a/src/Verismith/Sim/XST.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| -Module : Verismith.Sim.XST -Description : XST (ise) simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -XST (ise) simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module Verismith.Sim.XST - ( 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 Text.Shakespeare.Text (st) -import Verismith.Sim.Internal -import Verismith.Sim.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen - -data XST = XST { xstBin :: !(Maybe FilePath) - , xstDesc :: {-# UNPACK #-} !Text - , xstOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool XST where - toText (XST _ t _) = t - -instance Show XST where - show t = unpack $ toText t - -instance Synthesiser XST where - runSynth = runSynthXST - synthOutput = xstOutput - setSynthOutput (XST a b _) = XST a b - -instance NFData XST where - rnf = rwhnf - -defaultXST :: XST -defaultXST = XST Nothing "xst" "syn_xst.v" - -runSynthXST :: XST -> SourceInfo -> 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 [st|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" - prjFile = modFile <.> "prj" diff --git a/src/Verismith/Sim/Yosys.hs b/src/Verismith/Sim/Yosys.hs deleted file mode 100644 index 9805140..0000000 --- a/src/Verismith/Sim/Yosys.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-| -Module : Verismith.Sim.Yosys -Description : Yosys simulator implementation. -Copyright : (c) 2018-2019, Yann Herklotz -License : BSD-3 -Maintainer : yann [at] yannherklotz [dot] com -Stability : experimental -Portability : POSIX - -Yosys simulator implementation. --} - -{-# LANGUAGE QuasiQuotes #-} - -module Verismith.Sim.Yosys - ( Yosys(..) - , defaultYosys - , runEquiv - , runEquivYosys - ) -where - -import Control.DeepSeq (NFData, rnf, rwhnf) -import Control.Lens -import Control.Monad (void) -import Data.Text (Text, unpack) -import Prelude hiding (FilePath) -import Shelly -import Shelly.Lifted (liftSh) -import Text.Shakespeare.Text (st) -import Verismith.Result -import Verismith.Sim.Internal -import Verismith.Sim.Template -import Verismith.Verilog.AST -import Verismith.Verilog.CodeGen -import Verismith.Verilog.Mutate - -data Yosys = Yosys { yosysBin :: !(Maybe FilePath) - , yosysDesc :: {-# UNPACK #-} !Text - , yosysOutput :: {-# UNPACK #-} !FilePath - } - deriving (Eq) - -instance Tool Yosys where - toText (Yosys _ t _) = t - -instance Show Yosys where - show t = unpack $ toText t - -instance Synthesiser Yosys where - runSynth = runSynthYosys - synthOutput = yosysOutput - setSynthOutput (Yosys a b _) = Yosys a b - -instance NFData Yosys where - rnf = rwhnf - -defaultYosys :: Yosys -defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" - -yosysPath :: Yosys -> FilePath -yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim - -runSynthYosys :: Yosys -> SourceInfo -> ResultSh () -runSynthYosys sim (SourceInfo _ src) = do - dir <- liftSh $ do - dir' <- pwd - 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 = toTextIgnore inpf - out = toTextIgnore $ synthOutput sim - -runEquivYosys - :: (Synthesiser a, Synthesiser b) - => Yosys - -> a - -> b - -> SourceInfo - -> ResultSh () -runEquivYosys yosys sim1 sim2 srcInfo = do - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTop 2 - $ srcInfo - ^. mainModule - writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo - runSynth sim1 srcInfo - runSynth sim2 srcInfo - liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] - where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] - -runEquiv - :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () -runEquiv sim1 sim2 srcInfo = do - dir <- liftSh pwd - liftSh $ do - writefile "top.v" - . genSource - . initMod - . makeTopAssert - $ srcInfo - ^. mainModule - replaceMods (synthOutput sim1) "_1" srcInfo - replaceMods (synthOutput sim2) "_2" srcInfo - writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo - e <- liftSh $ do - exe dir "symbiyosys" "sby" ["-f", "proof.sby"] - lastExitCode - case e of - 0 -> ResultT . return $ Pass () - 2 -> ResultT . return $ Fail EquivFail - 124 -> ResultT . return $ Fail TimeoutError - _ -> ResultT . return $ Fail EquivError - where - exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Tool.hs b/src/Verismith/Tool.hs new file mode 100644 index 0000000..7e41180 --- /dev/null +++ b/src/Verismith/Tool.hs @@ -0,0 +1,51 @@ +{-| +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 + -- ** Icarus + Icarus(..) + , defaultIcarus + -- * Synthesisers + -- ** Yosys + , Yosys(..) + , defaultYosys + -- ** Vivado + , Vivado(..) + , defaultVivado + -- ** XST + , XST(..) + , defaultXST + -- ** Quartus + , Quartus(..) + , defaultQuartus + -- ** Identity + , Identity(..) + , defaultIdentity + -- * Equivalence + , runEquiv + -- * Simulation + , runSim + -- * Synthesis + , runSynth + , logger + ) +where + +import Verismith.Tool.Icarus +import Verismith.Tool.Identity +import Verismith.Tool.Internal +import Verismith.Tool.Quartus +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 new file mode 100644 index 0000000..b783033 --- /dev/null +++ b/src/Verismith/Tool/Icarus.hs @@ -0,0 +1,188 @@ +{-| +Module : Verismith.Tool.Icarus +Description : Icarus verilog module. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Icarus verilog module. +-} + +module Verismith.Tool.Icarus + ( Icarus(..) + , defaultIcarus + , runSimIc + ) +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.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) + +instance Show Icarus where + show _ = "iverilog" + +instance Tool Icarus where + toText _ = "iverilog" + +instance Simulator Icarus where + runSim = runSimIcarus + runSimWithFile = runSimIcarusWithFile + +instance NFData Icarus where + rnf = rwhnf + +defaultIcarus :: Icarus +defaultIcarus = Icarus "iverilog" "vvp" + +addDisplay :: [Statement] -> [Statement] +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 +assignFunc inp bs = + 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 + +mask :: Text -> Text +mask = T.replace "x" "0" + +callback :: ByteString -> Text -> ByteString +callback b t = b <> convert (mask t) + +runSimIcarus :: Icarus -> SourceInfo -> [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 $ runSimWithFile sim "main.v" bss + where m = rinfo ^. mainModule + +runSimIcarusWithFile + :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString +runSimIcarusWithFile sim f _ = annotate SimFail . 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"]) + +fromBytes :: ByteString -> Integer +fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b + +runSimIc + :: (Synthesiser b) + => Icarus + -> b + -> SourceInfo + -> [ByteString] + -> ResultSh ByteString +runSimIc sim1 synth1 srcInfo bss = do + dir <- liftSh pwd + let top = srcInfo ^. mainModule + let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) + let + tb = 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 + ) + <> (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"] + ] + [] + + liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 + liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] + liftSh + $ B.take 8 + . BA.convert + . (hash :: ByteString -> Digest SHA256) + <$> logCommand + dir + "vvp" + (runFoldLines (mempty :: ByteString) + callback + (vvpPath sim1) + ["main"] + ) + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/src/Verismith/Tool/Identity.hs b/src/Verismith/Tool/Identity.hs new file mode 100644 index 0000000..93b05d5 --- /dev/null +++ b/src/Verismith/Tool/Identity.hs @@ -0,0 +1,51 @@ +{-| +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 + ) +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 :: {-# UNPACK #-} !Text + , identityOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Identity where + toText (Identity d _) = d + +instance Show Identity where + show t = unpack $ toText t + +instance Synthesiser Identity where + runSynth = runSynthIdentity + synthOutput = identityOutput + setSynthOutput (Identity a _) = Identity a + +instance NFData Identity where + rnf = rwhnf + +runSynthIdentity :: Identity -> SourceInfo -> ResultSh () +runSynthIdentity (Identity _ out) = writefile out . genSource + +defaultIdentity :: Identity +defaultIdentity = Identity "identity" "syn_identity.v" diff --git a/src/Verismith/Tool/Internal.hs b/src/Verismith/Tool/Internal.hs new file mode 100644 index 0000000..c2e3a0c --- /dev/null +++ b/src/Verismith/Tool/Internal.hs @@ -0,0 +1,215 @@ +{-| +Module : Verismith.Tool.Internal +Description : Class of the simulator. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-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 + ( 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.Internal +import Verismith.Result +import Verismith.Verilog.AST + +-- | Tool class. +class Tool a where + toText :: a -> Text + +-- | Simulation type class. +class Tool a => Simulator a where + runSim :: a -- ^ Simulator instance + -> SourceInfo -- ^ 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 + | EquivError + | SimFail + | SynthFail + | TimeoutError + deriving (Eq, Show) + +instance Semigroup Failed where + EmptyFail <> a = a + b <> _ = b + +instance Monoid Failed where + mempty = EmptyFail + +-- | Synthesiser type class. +class Tool a => Synthesiser a where + runSynth :: a -- ^ Synthesiser tool instance + -> SourceInfo -- ^ Run information + -> ResultSh () -- ^ does not return any values + synthOutput :: a -> FilePath + setSynthOutput :: a -> FilePath -> a + +renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo +renameSource a src = + 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 +-- with also has those instances. +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' + +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 + +-- | 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 -> Sh [Text] +checkPresentModules fp (SourceInfo _ src) = do + 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] + +-- | 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 +-- should find all the instantiations and definitions. This could again be made +-- much simpler if the parser works. +replaceMods :: FilePath -> Text -> SourceInfo -> Sh () +replaceMods fp t (SourceInfo _ src) = + 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" + +timeout :: FilePath -> [Text] -> Sh Text +timeout = command1 "timeout" ["300"] . toTextIgnore +{-# INLINE timeout #-} + +timeout_ :: FilePath -> [Text] -> Sh () +timeout_ = command1_ "timeout" ["300"] . toTextIgnore +{-# INLINE timeout_ #-} + +-- | Helper function to convert bytestrings to integers +bsToI :: ByteString -> Integer +bsToI = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 +{-# INLINE bsToI #-} + +noPrint :: Sh a -> Sh a +noPrint = print_stdout False . print_stderr False +{-# INLINE noPrint #-} + +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 + +logCommand :: FilePath -> Text -> Sh a -> Sh a +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" + file s = T.unpack (toTextIgnore $ fp fromText name) <> s + +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 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 () +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 new file mode 100644 index 0000000..109d46c --- /dev/null +++ b/src/Verismith/Tool/Quartus.hs @@ -0,0 +1,77 @@ +{-| +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 + ) +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.Verilog.AST +import Verismith.Verilog.CodeGen + +data Quartus = Quartus { quartusBin :: !(Maybe FilePath) + , quartusDesc :: {-# UNPACK #-} !Text + , quartusOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Quartus where + toText (Quartus _ t _) = t + +instance Show Quartus where + show t = unpack $ toText t + +instance Synthesiser Quartus where + runSynth = runSynthQuartus + synthOutput = quartusOutput + setSynthOutput (Quartus a b _) = Quartus a b + +instance NFData Quartus where + rnf = rwhnf + +defaultQuartus :: Quartus +defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" + +runSynthQuartus :: Quartus -> SourceInfo -> ResultSh () +runSynthQuartus sim (SourceInfo top src) = do + dir <- liftSh pwd + let ex = execute_ SynthFail dir "quartus" + liftSh . writefile inpf $ genSource src + liftSh . noPrint $ run_ + "sed" + [ "-i" + , "s/^module/(* multstyle = \"logic\" *) module/;" + , toTextIgnore inpf + ] + ex (exec "quartus_map") + [top, "--source=" <> toTextIgnore inpf, "--family=Cyclone V"] + ex (exec "quartus_fit") [top, "--part=5CGXFC7D6F31C6"] + ex (exec "quartus_eda") [top, "--simulation", "--tool=vcs"] + 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/Template.hs b/src/Verismith/Tool/Template.hs new file mode 100644 index 0000000..c0cbfe1 --- /dev/null +++ b/src/Verismith/Tool/Template.hs @@ -0,0 +1,133 @@ +{-| +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 + ( yosysSatConfig + , yosysSimConfig + , xstSynthConfig + , vivadoSynthConfig + , sbyConfig + , icarusTestbench + ) +where + +import Control.Lens ((^..)) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (FilePath) +import Shelly +import Text.Shakespeare.Text (st) +import Verismith.Tool.Internal +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +rename :: Text -> [Text] -> Text +rename end entries = + T.intercalate "\n" + $ flip mappend end + . mappend "rename " + . doubleName + <$> entries +{-# INLINE rename #-} + +doubleName :: Text -> Text +doubleName n = n <> " " <> n +{-# INLINE doubleName #-} + +outputText :: Synthesiser a => a -> Text +outputText = toTextIgnore . synthOutput + +-- brittany-disable-next-binding +yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +yosysSatConfig sim1 sim2 (SourceInfo top src) = [st|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 + +-- brittany-disable-next-binding +yosysSimConfig :: Text +yosysSimConfig = [st|read_verilog rtl.v; proc;; +rename mod mod_rtl +|] + +-- brittany-disable-next-binding +xstSynthConfig :: Text -> Text +xstSynthConfig top = [st|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" +|] + +-- brittany-disable-next-binding +vivadoSynthConfig :: Text -> Text -> Text +vivadoSynthConfig top outf = [st| +# 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} +|] + +-- brittany-disable-next-binding +sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text +sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] +multiclock on +mode prove + +[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 + . (fromText "data" ) + . fromText + <$> deps + readL = T.intercalate "\n" $ mappend "read -formal " <$> deps + +icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text +icarusTestbench t synth1 = [st| +`include "data/cells_cmos.v" +`include "data/cells_cyclone_v.v" +`include "data/cells_verific.v" +`include "data/cells_xilinx_7.v" +`include "data/cells_yosys.v" +`include "#{toTextIgnore $ synthOutput synth1}" + +#{genSource t} +|] diff --git a/src/Verismith/Tool/Vivado.hs b/src/Verismith/Tool/Vivado.hs new file mode 100644 index 0000000..272311e --- /dev/null +++ b/src/Verismith/Tool/Vivado.hs @@ -0,0 +1,71 @@ +{-| +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 + ) +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 + +data Vivado = Vivado { vivadoBin :: !(Maybe FilePath) + , vivadoDesc :: {-# UNPACK #-} !Text + , vivadoOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Vivado where + toText (Vivado _ t _) = t + +instance Show Vivado where + show t = unpack $ toText t + +instance Synthesiser Vivado where + runSynth = runSynthVivado + synthOutput = vivadoOutput + setSynthOutput (Vivado a b _) = Vivado a b + +instance NFData Vivado where + rnf = rwhnf + +defaultVivado :: Vivado +defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" + +runSynthVivado :: Vivado -> SourceInfo -> 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" diff --git a/src/Verismith/Tool/XST.hs b/src/Verismith/Tool/XST.hs new file mode 100644 index 0000000..c713e0b --- /dev/null +++ b/src/Verismith/Tool/XST.hs @@ -0,0 +1,85 @@ +{-| +Module : Verismith.Tool.XST +Description : XST (ise) simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +XST (ise) simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module Verismith.Tool.XST + ( 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 Text.Shakespeare.Text (st) +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen + +data XST = XST { xstBin :: !(Maybe FilePath) + , xstDesc :: {-# UNPACK #-} !Text + , xstOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool XST where + toText (XST _ t _) = t + +instance Show XST where + show t = unpack $ toText t + +instance Synthesiser XST where + runSynth = runSynthXST + synthOutput = xstOutput + setSynthOutput (XST a b _) = XST a b + +instance NFData XST where + rnf = rwhnf + +defaultXST :: XST +defaultXST = XST Nothing "xst" "syn_xst.v" + +runSynthXST :: XST -> SourceInfo -> 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 [st|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" + prjFile = modFile <.> "prj" diff --git a/src/Verismith/Tool/Yosys.hs b/src/Verismith/Tool/Yosys.hs new file mode 100644 index 0000000..9c0a864 --- /dev/null +++ b/src/Verismith/Tool/Yosys.hs @@ -0,0 +1,127 @@ +{-| +Module : Verismith.Tool.Yosys +Description : Yosys simulator implementation. +Copyright : (c) 2018-2019, Yann Herklotz +License : BSD-3 +Maintainer : yann [at] yannherklotz [dot] com +Stability : experimental +Portability : POSIX + +Yosys simulator implementation. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module Verismith.Tool.Yosys + ( Yosys(..) + , defaultYosys + , runEquiv + , runEquivYosys + ) +where + +import Control.DeepSeq (NFData, rnf, rwhnf) +import Control.Lens +import Control.Monad (void) +import Data.Text (Text, unpack) +import Prelude hiding (FilePath) +import Shelly +import Shelly.Lifted (liftSh) +import Text.Shakespeare.Text (st) +import Verismith.Result +import Verismith.Tool.Internal +import Verismith.Tool.Template +import Verismith.Verilog.AST +import Verismith.Verilog.CodeGen +import Verismith.Verilog.Mutate + +data Yosys = Yosys { yosysBin :: !(Maybe FilePath) + , yosysDesc :: {-# UNPACK #-} !Text + , yosysOutput :: {-# UNPACK #-} !FilePath + } + deriving (Eq) + +instance Tool Yosys where + toText (Yosys _ t _) = t + +instance Show Yosys where + show t = unpack $ toText t + +instance Synthesiser Yosys where + runSynth = runSynthYosys + synthOutput = yosysOutput + setSynthOutput (Yosys a b _) = Yosys a b + +instance NFData Yosys where + rnf = rwhnf + +defaultYosys :: Yosys +defaultYosys = Yosys Nothing "yosys" "syn_yosys.v" + +yosysPath :: Yosys -> FilePath +yosysPath sim = maybe (fromText "yosys") ( fromText "yosys") $ yosysBin sim + +runSynthYosys :: Yosys -> SourceInfo -> ResultSh () +runSynthYosys sim (SourceInfo _ src) = do + dir <- liftSh $ do + dir' <- pwd + 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 = toTextIgnore inpf + out = toTextIgnore $ synthOutput sim + +runEquivYosys + :: (Synthesiser a, Synthesiser b) + => Yosys + -> a + -> b + -> SourceInfo + -> ResultSh () +runEquivYosys yosys sim1 sim2 srcInfo = do + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTop 2 + $ srcInfo + ^. mainModule + writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo + runSynth sim1 srcInfo + runSynth sim2 srcInfo + liftSh $ run_ (yosysPath yosys) [toTextIgnore checkFile] + where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] + +runEquiv + :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () +runEquiv sim1 sim2 srcInfo = do + dir <- liftSh pwd + liftSh $ do + writefile "top.v" + . genSource + . initMod + . makeTopAssert + $ srcInfo + ^. mainModule + replaceMods (synthOutput sim1) "_1" srcInfo + replaceMods (synthOutput sim2) "_2" srcInfo + writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo + e <- liftSh $ do + exe dir "symbiyosys" "sby" ["-f", "proof.sby"] + lastExitCode + case e of + 0 -> ResultT . return $ Pass () + 2 -> ResultT . return $ Fail EquivFail + 124 -> ResultT . return $ Fail TimeoutError + _ -> ResultT . return $ Fail EquivError + where + exe dir name e = void . errExit False . logCommand dir name . timeout e diff --git a/verismith.cabal b/verismith.cabal index 36a7777..7afb640 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -53,15 +53,15 @@ library , Verismith.Reduce , Verismith.Report , Verismith.Result - , Verismith.Sim - , Verismith.Sim.Icarus - , Verismith.Sim.Identity - , Verismith.Sim.Internal - , Verismith.Sim.Quartus - , Verismith.Sim.Template - , Verismith.Sim.Vivado - , Verismith.Sim.XST - , Verismith.Sim.Yosys + , Verismith.Tool + , Verismith.Tool.Icarus + , Verismith.Tool.Identity + , Verismith.Tool.Internal + , Verismith.Tool.Quartus + , Verismith.Tool.Template + , Verismith.Tool.Vivado + , Verismith.Tool.XST + , Verismith.Tool.Yosys , Verismith.Verilog , Verismith.Verilog.AST , Verismith.Verilog.BitVec -- cgit From e014fac05e6aab6bf686d3a002ca21e7adb13072 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 14:29:14 +0100 Subject: Edit .envrc for nix --- .envrc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.envrc b/.envrc index e2e9592..af2d402 100644 --- a/.envrc +++ b/.envrc @@ -81,4 +81,4 @@ use_nix() { fi } -use nix +use_nix -- cgit From 945c7435a41b93ff243b69f18a9c0216a7b70e24 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 14:59:56 +0100 Subject: Add -k functionality --- src/Verismith.hs | 4 ++-- src/Verismith/Fuzz.hs | 30 ++++++++++++++++++++++++++---- src/Verismith/Report.hs | 6 +++--- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/Verismith.hs b/src/Verismith.hs index 85deca3..a3d3d03 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -363,12 +363,12 @@ randomise config@(Config a _ c d e) = do ce = config ^. configProbability . probExpr handleOpts :: Opts -> IO () -handleOpts (Fuzz o configF _ _ n) = do +handleOpts (Fuzz o configF _ k n) = do config <- getConfig configF _ <- runFuzz config defaultYosys - (fuzzMultiple n (Just $ fromText o) (proceduralSrc "top" config)) + (fuzzMultiple n k (Just $ fromText o) (proceduralSrc "top" config)) return () handleOpts (Generate f c) = do config <- getConfig c diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index 81c00a0..f26630a 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -402,21 +402,43 @@ relativeFuzzReport fr@(FuzzReport dir _ _ _ _ _ _ _) = liftSh $ do newPath <- relPath dir return $ (fuzzDir .~ newPath) fr +filterSynth :: SynthResult -> Bool +filterSynth (SynthResult _ _ (Pass _) _) = True +filterSynth _ = False + +filterSim :: SimResult -> Bool +filterSim (SimResult _ _ (Pass _) _) = True +filterSim _ = False + +filterSynthStat :: SynthStatus -> Bool +filterSynthStat (SynthStatus _ (Pass _) _) = True +filterSynthStat _ = False + +passedFuzz :: FuzzReport -> Bool +passedFuzz (FuzzReport _ synth sim synthstat _ _ _ _) = + (passedSynth + passedSim + passedSynthStat) == 0 + where + passedSynth = length $ filter (not . filterSynth) synth + passedSim = length $ filter (not . filterSim) sim + passedSynthStat = length $ filter (not . filterSynthStat) synthstat + fuzzInDir - :: MonadFuzz m => FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzzInDir fp src conf = do + :: MonadFuzz m => Bool -> FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport +fuzzInDir k fp src conf = do make fp res <- pop fp $ fuzz src conf + liftSh . when (passedFuzz res && not k) $ rm_rf fp relativeFuzzReport res fuzzMultiple :: MonadFuzz m => Int + -> Bool -> Maybe FilePath -> Gen SourceInfo -> Config -> Fuzz m [FuzzReport] -fuzzMultiple n fp src conf = do +fuzzMultiple n k fp src conf = do x <- case fp of Nothing -> do ct <- liftIO getZonedTime @@ -436,7 +458,7 @@ fuzzMultiple n fp src conf = do results return results where - fuzzDir' n' = fuzzInDir (fromText $ "fuzz_" <> showT n') src conf + fuzzDir' n' = fuzzInDir k (fromText $ "fuzz_" <> showT n') src conf seed = conf ^. configProperty . propSeed sampleSeed :: MonadSh m => Maybe Seed -> Gen a -> m (Seed, a) diff --git a/src/Verismith/Report.hs b/src/Verismith/Report.hs index 6c25f5c..f0608f2 100644 --- a/src/Verismith/Report.hs +++ b/src/Verismith/Report.hs @@ -192,9 +192,9 @@ instance Show SynthStatus where -- | The complete state that will be used during fuzzing, which contains the -- results from all the operations. data FuzzReport = FuzzReport { _fuzzDir :: !FilePath - , _synthResults :: ![SynthResult] - , _simResults :: ![SimResult] - , _synthStatus :: ![SynthStatus] + , _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 -- cgit From 85a017f3d4c8cc3efb876e0864da8d6a033f88dc Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 18 Oct 2019 15:13:25 +0100 Subject: Change location of the html reports --- src/Verismith/Fuzz.hs | 8 +++++--- src/Verismith/Report.hs | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index f26630a..a4b74b1 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -377,11 +377,9 @@ fuzz gen conf = do tsynth tequiv (getTime redResult) - liftSh . writefile "index.html" $ printResultReport (bname currdir) report return report where seed = conf ^. configProperty . propSeed - bname = T.pack . takeBaseName . T.unpack . toTextIgnore genMethod = case T.toLower $ conf ^. configProperty . propSampleMethod of "hat" -> do logT "Using the hat function" @@ -427,8 +425,12 @@ fuzzInDir fuzzInDir k fp src conf = do make fp res <- pop fp $ fuzz src conf - liftSh . when (passedFuzz res && not k) $ rm_rf fp + liftSh $ do + writefile (fp <.> "html") $ printResultReport (bname fp) res + when (passedFuzz res && not k) $ rm_rf fp relativeFuzzReport res + where + bname = T.pack . takeBaseName . T.unpack . toTextIgnore fuzzMultiple :: MonadFuzz m diff --git a/src/Verismith/Report.hs b/src/Verismith/Report.hs index f0608f2..196e891 100644 --- a/src/Verismith/Report.hs +++ b/src/Verismith/Report.hs @@ -316,7 +316,7 @@ fuzzStatus name (FuzzReport dir s1 s2 s3 sz t1 t2 t3) = H.tr $ do . ( H.a ! A.href ( H.textValue - $ toTextIgnore (dir fromText "index" <.> "html") + $ toTextIgnore (dir <.> "html") ) ) $ H.toHtml name -- cgit From 2b461deaf32e065a71d83235f3c5648eea93fb19 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 09:05:31 +0100 Subject: Fix subtle issue with module generation --- src/Verismith/Generate.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Verismith/Generate.hs b/src/Verismith/Generate.hs index a896c3e..25b9306 100644 --- a/src/Verismith/Generate.hs +++ b/src/Verismith/Generate.hs @@ -445,6 +445,7 @@ instantiate (ModDecl i outP inP _ _) = do context <- lget outs <- replicateM (length outP) (nextPort 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 <$> lget -- cgit From 9906b22bffd73b7d305f6836a4b606b6849b4487 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 09:12:03 +0100 Subject: Add the literal list to the mod instantiation --- src/Verismith/Generate.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Verismith/Generate.hs b/src/Verismith/Generate.hs index 25b9306..9bf7c58 100644 --- a/src/Verismith/Generate.hs +++ b/src/Verismith/Generate.hs @@ -450,9 +450,10 @@ instantiate (ModDecl i outP inP _ _) = do ident <- makeIdentifier "modinst" vs <- view variables <$> lget Hog.choice - [ return . ModInst i ident $ ModConn <$> toE (outs <> clkPort <> ins) + [ 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)) + (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed) + (toE (outs <> clkPort <> ins) <> insLit)) ] where toE ins = Id . view portName <$> ins -- cgit From a33c485f49a445d51f7ff5857d081dc0e093f181 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 17:03:32 +0100 Subject: Update README with current build procedure --- README.md | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 5666dca..cf36810 100644 --- a/README.md +++ b/README.md @@ -35,8 +35,7 @@ following: ## Reported bugs -21 bugs were found in total over the course of a month. 8 of those bugs were -reported and 3 were fixed. +9 bugs have been reported and confirmed to be bugs by the vendors, out of which 4 have been fixed. ### Yosys @@ -57,7 +56,7 @@ reported and 3 were fixed. | Mis-synthesis | [Forum 982518](https://forums.xilinx.com/t5/Synthesis/Vivado-2019-1-Signed-with-shift-in-condition-synthesis-mistmatch/td-p/982518) | ✓ | 𐄂 | | Mis-synthesis | [Forum 982419](https://forums.xilinx.com/t5/Synthesis/Vivado-2019-1-Bit-selection-synthesis-mismatch/td-p/982419) | ✓ | 𐄂 | -## Build the Fuzzer +## Install the Fuzzer The fuzzer now supports building with [nix](https://nixos.org/nix/manual/), which pulls in all the extra dependencies that are needed to build the @@ -79,13 +78,26 @@ it may not have all the right versions of the dependencies that are needed. Instead, stack could be used and the `stack.yaml` file could contain the overrides that are used by nix. -### Build with nix +### Build from hackage + +A stable version of Verismith is available on +[hackage](https://hackage.haskell.org/package/verismith) and can be installed +using cabal directly without having to build the project from the repository: + +``` shell +cabal install verismith +``` + +It will be placed under the `bin` cabal folder which can be added to your path +to run Verismith. + +### Build with nix from source Nix build is completely supported, therefore if nix is installed, building the project is as simple as ``` shell -nix-build release.nix +nix-build ``` If one wants to work in the project with all the right dependencies loaded, one @@ -95,18 +107,24 @@ can use nix-shell ``` -### Build with cabal and nix +and use cabal to build and run the program. + +### Build with cabal from source After entering a development environment with `nix-shell`, the project can -safely be built with `cabal-install`. +safely be built with `cabal-install`. However, even without `nix`, the project +can still be built with cabal alone using: ``` shell -cabal v2-configure -cabal v2-build +cabal configure +cabal build ``` -This should not have to download any extra dependencies and just have to build -the actual project itself. +Verismith can then be run using: + +``` shell +cabal run verismith +``` ## Configuration -- cgit From 74d659752eb082371da88abacb9fc4164ca5b931 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 17:03:51 +0100 Subject: Add comment to code generation --- src/Verismith/Verilog/CodeGen.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Verismith/Verilog/CodeGen.hs b/src/Verismith/Verilog/CodeGen.hs index ca48a33..842394d 100644 --- a/src/Verismith/Verilog/CodeGen.hs +++ b/src/Verismith/Verilog/CodeGen.hs @@ -45,7 +45,7 @@ defMap = maybe semi statement -- | Convert the 'Verilog' type to 'Text' so that it can be rendered. verilogSrc :: Verilog -> Doc a -verilogSrc (Verilog modules) = vsep . punctuate line $ moduleDecl <$> modules +verilogSrc (Verilog modules) = vsep . ("// -*- mode: verilog -*-" :) . punctuate line $ moduleDecl <$> modules -- | Generate the 'ModDecl' for a module and convert it to 'Text'. moduleDecl :: ModDecl -> Doc a -- cgit From 13a3183213fc8abe7563520af8b49857d80da953 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 19:27:20 +0100 Subject: Change to one line --- README.md | 78 ++++++++++++++------------------------------------------------- 1 file changed, 17 insertions(+), 61 deletions(-) diff --git a/README.md b/README.md index cf36810..96f7d62 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,6 @@ # Verismith [![Build Status](https://travis-ci.com/ymherklotz/verismith.svg?token=qfBKKGwxeWkjDsy7e16x&branch=master)](https://travis-ci.com/ymherklotz/verismith) -Verilog Fuzzer to test the major verilog compilers by generating random, valid -and deterministic Verilog. There is a -[presentation](https://yannherklotz.com/docs/presentation.pdf) about Verismith -and a [thesis](https://yannherklotz.com/docs/thesis.pdf) which goes over all the -details of the implementation and results that were found. +Verilog Fuzzer to test the major verilog compilers by generating random, valid and deterministic Verilog. There is a [presentation](https://yannherklotz.com/docs/presentation.pdf) about Verismith and a [thesis](https://yannherklotz.com/docs/thesis.pdf) which goes over all the details of the implementation and results that were found. It currently supports the following synthesis tools: @@ -19,9 +15,7 @@ and the following simulator: ## Supported Verilog Constructs -The fuzzer generates combinational and behavioural Verilog to test the various -tools. The most notable constructs that are supported and generated are the -following: +The fuzzer generates combinational and behavioural Verilog to test the various tools. The most notable constructs that are supported and generated are the following: - module definitions with parameter definitions, inputs and outputs - module items, such as instantiations, continuous assignment, always blocks, @@ -58,9 +52,7 @@ following: ## Install the Fuzzer -The fuzzer now supports building with [nix](https://nixos.org/nix/manual/), -which pulls in all the extra dependencies that are needed to build the -project. The main files and their functions are described below: +The fuzzer now supports building with [nix](https://nixos.org/nix/manual/), which pulls in all the extra dependencies that are needed to build the project. The main files and their functions are described below: - `default.nix`: describes the main Haskell package and it's dependencies that have to be pulled in. @@ -71,37 +63,29 @@ project. The main files and their functions are described below: dependencies so that everything builds nicely. The exact versions of the packages that should be overridden are in [nix](/nix). -It may be possible to build it purely with -[cabal-install](https://hackage.haskell.org/package/cabal-install), however -it may not have all the right versions of the dependencies that are needed. +It may be possible to build it purely with [cabal-install](https://hackage.haskell.org/package/cabal-install), however it may not have all the right versions of the dependencies that are needed. -Instead, stack could be used and the `stack.yaml` file could contain the -overrides that are used by nix. +Instead, stack could be used and the `stack.yaml` file could contain the overrides that are used by nix. ### Build from hackage -A stable version of Verismith is available on -[hackage](https://hackage.haskell.org/package/verismith) and can be installed -using cabal directly without having to build the project from the repository: +A stable version of Verismith is available on [hackage](https://hackage.haskell.org/package/verismith) and can be installed using cabal directly without having to build the project from the repository: ``` shell cabal install verismith ``` -It will be placed under the `bin` cabal folder which can be added to your path -to run Verismith. +It will be placed under the `bin` cabal folder which can be added to your path to run Verismith. ### Build with nix from source -Nix build is completely supported, therefore if nix is installed, building the -project is as simple as +Nix build is completely supported, therefore if nix is installed, building the project is as simple as ``` shell nix-build ``` -If one wants to work in the project with all the right dependencies loaded, one -can use +If one wants to work in the project with all the right dependencies loaded, one can use ``` shell nix-shell @@ -111,9 +95,7 @@ and use cabal to build and run the program. ### Build with cabal from source -After entering a development environment with `nix-shell`, the project can -safely be built with `cabal-install`. However, even without `nix`, the project -can still be built with cabal alone using: +After entering a development environment with `nix-shell`, the project can safely be built with `cabal-install`. However, even without `nix`, the project can still be built with cabal alone using: ``` shell cabal configure @@ -128,44 +110,23 @@ cabal run verismith ## Configuration -Verismith can be configured using a [TOML](https://github.com/toml-lang/toml) -file. There are four main sections in the configuration file, an example can be -seen [here](/examples/config.toml). +Verismith can be configured using a [TOML](https://github.com/toml-lang/toml) file. There are four main sections in the configuration file, an example can be seen [here](/examples/config.toml). ### Information section -Contains information about the command line tool being used, such as the hash of -the commit it was compiled with and the version of the tool. The tool then -verifies that these match the current configuration, and will emit a warning if -they do not. This ensures that if one wants a deterministic run and is therefore -passing a seed to the generation, that it will always give the same -result. Different versions might change some aspects of the Verilog generation, -which would affect how a seed would generate Verilog. +Contains information about the command line tool being used, such as the hash of the commit it was compiled with and the version of the tool. The tool then verifies that these match the current configuration, and will emit a warning if they do not. This ensures that if one wants a deterministic run and is therefore passing a seed to the generation, that it will always give the same result. Different versions might change some aspects of the Verilog generation, which would affect how a seed would generate Verilog. ### Probability section -Provides a way to assign frequency values to each of the nodes in the -AST. During the state-based generation, each node is chosen randomly based on -those probabilities. This provides a simple way to drastically change the -Verilog that is generated, by changing how often a construct is chosen or by not -generating a construct at all. +Provides a way to assign frequency values to each of the nodes in the AST. During the state-based generation, each node is chosen randomly based on those probabilities. This provides a simple way to drastically change the Verilog that is generated, by changing how often a construct is chosen or by not generating a construct at all. ### Property section -Changes properties of the generated Verilog code, such as the size of the -output, maximum statement or module depth and sampling method of Verilog -programs. This section also allows a seed to be specified, which would mean that -only that particular seed will be used in the fuzz run. This is extremely useful -when wanting to replay a specific failure and the output is missing. +Changes properties of the generated Verilog code, such as the size of the output, maximum statement or module depth and sampling method of Verilog programs. This section also allows a seed to be specified, which would mean that only that particular seed will be used in the fuzz run. This is extremely useful when wanting to replay a specific failure and the output is missing. ### Synthesiser section -Accepts a list of synthesisers which will be fuzzed. These have to first be -defined in the code and implement the required interface. They can then be -configured by having a name assigned to them and the name of the output Verilog -file. By each having a different name, multiple instances of the same -synthesiser can be included in a fuzz run. The instances might differ in the -optimisations that are performed, or in the version of the synthesiser. +Accepts a list of synthesisers which will be fuzzed. These have to first be defined in the code and implement the required interface. They can then be configured by having a name assigned to them and the name of the output Verilog file. By each having a different name, multiple instances of the same synthesiser can be included in a fuzz run. The instances might differ in the optimisations that are performed, or in the version of the synthesiser. ## Benchmark Results @@ -197,11 +158,6 @@ variance introduced by outliers: 73% (severely inflated) ## Acknowledgement -Clifford Wolf's [VlogHammer](http://www.clifford.at/yosys/vloghammer.html) is an -existing Verilog fuzzer that generates random Verilog to test how expressions -are handled in synthesis tools and simulators. It was the inspiration for the -general structure of this fuzzer, which extends the fuzzing to the behavioural -parts of Verilog. +Clifford Wolf's [VlogHammer](http://www.clifford.at/yosys/vloghammer.html) is an existing Verilog fuzzer that generates random Verilog to test how expressions are handled in synthesis tools and simulators. It was the inspiration for thegeneral structure of this fuzzer, which extends the fuzzing to the behavioural parts of Verilog. -Tom Hawkins' Verilog parser was used to write the lexer, the parser was then -rewritten using [Parsec](https://hackage.haskell.org/package/parsec). +Tom Hawkins' Verilog parser was used to write the lexer, the parser was then rewritten using [Parsec](https://hackage.haskell.org/package/parsec). -- cgit From e57b16651684e0f9e9d0a3cd6f81fccd5b8c7cb6 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 19:37:57 +0100 Subject: Update the version string for future release --- verismith.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/verismith.cabal b/verismith.cabal index 7afb640..b734b29 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -1,5 +1,5 @@ name: verismith -version: 0.4.0.0 +version: 0.4.0.1 synopsis: Random verilog generation and simulator testing. description: Verismith provides random verilog generation modules -- cgit From 779833f8e1253c150a31541799195a57958adfef Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Fri, 25 Oct 2019 19:40:16 +0100 Subject: Update config --- examples/config.toml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/examples/config.toml b/examples/config.toml index 7f030d7..a887bcb 100644 --- a/examples/config.toml +++ b/examples/config.toml @@ -1,7 +1,7 @@ [info] - commit = "d32f4cc45bc8c0670fb788b1fcd4c2f2b15fa094" - version = "0.3.0.0" + commit = "e57b16651684e0f9e9d0a3cd6f81fccd5b8c7cb6" + version = "0.4.0.1" [probability] expr.binary = 5 @@ -24,8 +24,10 @@ statement.nonblocking = 3 [property] + determinism = 1 module.depth = 2 module.max = 5 + nondeterminism = 0 output.combine = false sample.method = "random" sample.size = 10 -- cgit From cbb08507aea00fd95eaf065a26a8902eb8e412c3 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 27 Oct 2019 20:05:08 +0000 Subject: Add OptParser to separate option parsing --- src/Verismith.hs | 249 +----------------------------------------- src/Verismith/OptParser.hs | 266 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 270 insertions(+), 245 deletions(-) create mode 100644 src/Verismith/OptParser.hs diff --git a/src/Verismith.hs b/src/Verismith.hs index a3d3d03..bde3e2a 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -62,6 +62,7 @@ import Verismith.Circuit import Verismith.Config import Verismith.Fuzz import Verismith.Generate +import Verismith.OptParser import Verismith.Reduce import Verismith.Report import Verismith.Result @@ -70,254 +71,12 @@ import Verismith.Tool.Internal import Verismith.Verilog import Verismith.Verilog.Parser (parseSourceInfoFile) -data OptTool = TYosys - | TXST - | TIcarus - -instance Show OptTool where - show TYosys = "yosys" - show TXST = "xst" - show TIcarus = "icarus" - -data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text - , configFile :: !(Maybe FilePath) - , forced :: !Bool - , keepAll :: !Bool - , num :: {-# UNPACK #-} !Int - } - | Generate { mFileName :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - } - | Parse { fileName :: {-# UNPACK #-} !FilePath - } - | Reduce { fileName :: {-# UNPACK #-} !FilePath - , top :: {-# UNPACK #-} !Text - , reduceScript :: !(Maybe FilePath) - , synthesiserDesc :: ![SynthDescription] - , rerun :: Bool - } - | ConfigOpt { writeConfig :: !(Maybe FilePath) - , configFile :: !(Maybe FilePath) - , doRandomise :: !Bool - } - myForkIO :: IO () -> IO (MVar ()) myForkIO io = do mvar <- newEmptyMVar _ <- forkFinally io (\_ -> putMVar mvar ()) return mvar -textOption :: Mod OptionFields String -> Parser Text -textOption = fmap T.pack . strOption - -optReader :: (String -> Maybe a) -> ReadM a -optReader f = eitherReader $ \arg -> case f arg of - 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 - -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 - -parseSim :: String -> Maybe OptTool -parseSim val | val == "icarus" = Just TIcarus - | otherwise = Nothing - -fuzzOpts :: Parser Opts -fuzzOpts = - Fuzz - <$> textOption - ( long "output" - <> short 'o' - <> metavar "DIR" - <> help "Output directory that the fuzz run takes place in." - <> showDefault - <> value "output" - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> (switch $ long "force" <> short 'f' <> help - "Overwrite the specified directory." - ) - <*> (switch $ long "keep" <> short 'k' <> help - "Keep all the directories." - ) - <*> ( option auto - $ long "num" - <> short 'n' - <> help "The number of fuzz runs that should be performed." - <> showDefault - <> value 1 - <> metavar "INT" - ) - -genOpts :: Parser Opts -genOpts = - Generate - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a verilog file instead." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the generation run." - ) - -parseOpts :: Parser Opts -parseOpts = Parse . fromText . T.pack <$> strArgument - (metavar "FILE" <> help "Verilog input file.") - -reduceOpts :: Parser Opts -reduceOpts = - Reduce - . fromText - . T.pack - <$> strArgument (metavar "FILE" <> help "Verilog input file.") - <*> textOption - ( short 't' - <> long "top" - <> metavar "TOP" - <> help "Name of top level module." - <> showDefault - <> value "top" - ) - <*> ( optional - . strOption - $ long "script" - <> metavar "SCRIPT" - <> help - "Script that determines if the current file is interesting, which is determined by the script returning 0." - ) - <*> ( many - . option (optReader parseSynthDesc) - $ short 's' - <> long "synth" - <> metavar "SYNTH" - <> help "Specify synthesiser to use." - ) - <*> ( switch - $ short 'r' - <> long "rerun" - <> help - "Only rerun the current synthesis file with all the synthesisers." - ) - -configOpts :: Parser Opts -configOpts = - ConfigOpt - <$> ( optional - . strOption - $ long "output" - <> short 'o' - <> metavar "FILE" - <> help "Output to a TOML Config file." - ) - <*> ( optional - . strOption - $ long "config" - <> short 'c' - <> metavar "FILE" - <> help "Config file for the current fuzz run." - ) - <*> ( switch - $ long "randomise" - <> short 'r' - <> help - "Randomise the given default config, or the default config by randomly switchin on and off options." - ) - -argparse :: Parser Opts -argparse = - hsubparser - ( command - "fuzz" - (info - fuzzOpts - (progDesc - "Run fuzzing on the specified simulators and synthesisers." - ) - ) - <> metavar "fuzz" - ) - <|> hsubparser - ( command - "generate" - (info - genOpts - (progDesc "Generate a random Verilog program.") - ) - <> metavar "generate" - ) - <|> hsubparser - ( command - "parse" - (info - parseOpts - (progDesc - "Parse a verilog file and output a pretty printed version." - ) - ) - <> metavar "parse" - ) - <|> hsubparser - ( command - "reduce" - (info - reduceOpts - (progDesc - "Reduce a Verilog file by rerunning the fuzzer on the file." - ) - ) - <> metavar "reduce" - ) - <|> hsubparser - ( command - "config" - (info - configOpts - (progDesc - "Print the current configuration of the fuzzer." - ) - ) - <> metavar "config" - ) - -version :: Parser (a -> a) -version = infoOption versionInfo $ mconcat - [long "version", short 'v', help "Show version information.", hidden] - -opts :: ParserInfo Opts -opts = info - (argparse <**> helper <**> version) - ( fullDesc - <> progDesc "Fuzz different simulators and synthesisers." - <> header - "Verismith - A hardware simulator and synthesiser Verilog fuzzer." - ) - getConfig :: Maybe FilePath -> IO Config getConfig s = maybe (return defaultConfig) parseConfigFile $ T.unpack . toTextIgnore <$> s @@ -363,12 +122,12 @@ randomise config@(Config a _ c d e) = do ce = config ^. configProbability . probExpr handleOpts :: Opts -> IO () -handleOpts (Fuzz o configF _ k n) = do +handleOpts (Fuzz o configF f k n nosim noequiv) = do config <- getConfig configF _ <- runFuzz - config + (FuzzOpts (Just $ fromText o) f k n nosim noequiv config) defaultYosys - (fuzzMultiple n k (Just $ fromText o) (proceduralSrc "top" config)) + (fuzzMultiple (proceduralSrc "top" config)) return () handleOpts (Generate f c) = do config <- getConfig c diff --git a/src/Verismith/OptParser.hs b/src/Verismith/OptParser.hs new file mode 100644 index 0000000..1db0d52 --- /dev/null +++ b/src/Verismith/OptParser.hs @@ -0,0 +1,266 @@ +module Verismith.OptParser + ( 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 qualified Options.Applicative as Opt +import Prelude hiding (FilePath (..)) +import Shelly (FilePath (..), fromText) +import Verismith.Config (SynthDescription (..), versionInfo) + +data OptTool = TYosys + | TXST + | TIcarus + +instance Show OptTool where + show TYosys = "yosys" + show TXST = "xst" + show TIcarus = "icarus" + +data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text + , fuzzConfigFile :: !(Maybe FilePath) + , fuzzForced :: !Bool + , fuzzKeepAll :: !Bool + , fuzzNum :: {-# UNPACK #-} !Int + , fuzzNoSim :: !Bool + , fuzzNoEquiv :: !Bool + } + | Generate { generateFilename :: !(Maybe FilePath) + , generateConfigFile :: !(Maybe FilePath) + } + | Parse { parseFilename :: {-# UNPACK #-} !FilePath + } + | Reduce { reduceFilename :: {-# UNPACK #-} !FilePath + , reduceTop :: {-# UNPACK #-} !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 + +parseSynth :: String -> Maybe OptTool +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 + +parseSim :: String -> Maybe OptTool +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." + ) + +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." + ) + +parseOpts :: Parser Opts +parseOpts = Parse . fromText . T.pack <$> Opt.strArgument + (Opt.metavar "FILE" <> Opt.help "Verilog input file.") + +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." + ) + +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." + ) + +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 + "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] + +opts :: ParserInfo Opts +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." + ) -- cgit From c144ad106079190941206cac0750c4eed7c02f91 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 27 Oct 2019 20:05:18 +0000 Subject: Add mtl dependency to enable easier use of transformers --- src/Verismith/Fuzz.hs | 244 ++++++++++++++++++++++++++-------------------- src/Verismith/Generate.hs | 70 ++++++------- verismith.cabal | 60 ++++++------ 3 files changed, 202 insertions(+), 172 deletions(-) diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index a4b74b1..4f09b36 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -15,7 +15,8 @@ Environment to run the simulator and synthesisers in a matrix. {-# LANGUAGE TemplateHaskell #-} module Verismith.Fuzz - ( Fuzz + ( Fuzz (..) + , FuzzOpts (..) , fuzz , fuzzInDir , fuzzMultiple @@ -27,33 +28,31 @@ module Verismith.Fuzz ) where -import Control.DeepSeq (force) -import Control.Exception.Lifted (finally) -import Control.Lens hiding ((<.>)) -import Control.Monad (forM, replicateM) +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.Trans.Class (lift) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Maybe (runMaybeT) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import qualified Crypto.Random.DRBG as C -import Data.ByteString (ByteString) -import Data.List (nubBy, sort) -import Data.Maybe (isNothing) -import Data.Text (Text) -import qualified Data.Text as T +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Crypto.Random.DRBG as C +import Data.ByteString (ByteString) +import Data.List (nubBy, sort) +import Data.Maybe (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) -import Shelly.Lifted (MonadSh, liftSh) -import System.FilePath.Posix (takeBaseName) +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) +import Shelly.Lifted (MonadSh, liftSh) +import System.FilePath.Posix (takeBaseName) import Verismith.Config import Verismith.Internal import Verismith.Reduce @@ -65,12 +64,37 @@ import Verismith.Tool.Yosys import Verismith.Verilog.AST import Verismith.Verilog.CodeGen -data FuzzEnv = FuzzEnv { getSynthesisers :: ![SynthTool] - , getSimulators :: ![SimTool] - , yosysInstance :: {-# UNPACK #-} !Yosys +data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath) + , _fuzzOptsForced :: !Bool + , _fuzzOptsKeepAll :: !Bool + , _fuzzOptsIterations :: {-# UNPACK #-} !Int + , _fuzzOptsNoSim :: !Bool + , _fuzzOptsNoEquiv :: !Bool + , _fuzzOptsConfig :: {-# UNPACK #-} !Config + } + deriving (Show, Eq) + +$(makeLenses ''FuzzOpts) + +defaultFuzzOpts :: FuzzOpts +defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing + , _fuzzOptsForced = False + , _fuzzOptsKeepAll = False + , _fuzzOptsIterations = 1 + , _fuzzOptsNoSim = False + , _fuzzOptsNoEquiv = False + , _fuzzOptsConfig = defaultConfig + } + +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] @@ -87,23 +111,74 @@ type Fuzz m = StateT FuzzState (ReaderT FuzzEnv m) type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) -runFuzz :: MonadIO m => Config -> Yosys -> (Config -> Fuzz Sh a) -> m a -runFuzz conf yos m = shelly $ runFuzz' conf yos m - -runFuzz' :: Monad m => Config -> Yosys -> (Config -> Fuzz m b) -> m b -runFuzz' conf yos m = runReaderT - (evalStateT (m conf) (FuzzState [] [] [])) - (FuzzEnv - ( force - $ defaultIdentitySynth - : (descriptionToSynth <$> conf ^. configSynthesisers) - ) - (force $ descriptionToSim <$> conf ^. configSimulators) - yos +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 + (evalStateT m (FuzzState [] [] [])) + (FuzzEnv { _getSynthesisers = ( force + $ defaultIdentitySynth + : (descriptionToSynth <$> conf ^. configSynthesisers) + ) + , _getSimulators = (force $ descriptionToSim <$> conf ^. configSimulators) + , _yosysInstance = yos + , _fuzzEnvOpts = fo + } ) + where + conf = _fuzzOptsConfig fo + +askConfig :: Monad m => Fuzz m Config +askConfig = asks (_fuzzOptsConfig . _fuzzEnvOpts) + +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 + 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 + +filterSynth :: SynthResult -> Bool +filterSynth (SynthResult _ _ (Pass _) _) = True +filterSynth _ = False + +filterSim :: SimResult -> Bool +filterSim (SimResult _ _ (Pass _) _) = True +filterSim _ = False + +filterSynthStat :: SynthStatus -> Bool +filterSynthStat (SynthStatus _ (Pass _) _) = True +filterSynthStat _ = False + +passedFuzz :: FuzzReport -> Bool +passedFuzz (FuzzReport _ synth sim synthstat _ _ _ _) = + (passedSynth + passedSim + passedSynthStat) == 0 + where + passedSynth = length $ filter (not . filterSynth) synth + passedSim = length $ filter (not . filterSim) sim + passedSynthStat = length $ filter (not . filterSynthStat) synthstat synthesisers :: Monad m => Fuzz m [SynthTool] -synthesisers = lift $ asks getSynthesisers +synthesisers = lift $ asks _getSynthesisers --simulators :: (Monad m) => Fuzz () m [SimTool] --simulators = lift $ asks getSimulators @@ -346,9 +421,11 @@ medianFreqs l = zip hat (return <$> l) hat = set_ <$> [1 .. length l] set_ n = if n == h then 1 else 0 -fuzz :: MonadFuzz m => Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzz gen conf = do - (seed', src) <- generateSample genMethod +fuzz :: MonadFuzz m => Gen SourceInfo -> Fuzz m FuzzReport +fuzz gen = do + conf <- askConfig + let seed = conf ^. configProperty . propSeed + (seed', src) <- generateSample $ genMethod conf seed gen let size = length . lines . T.unpack $ genSource src liftSh . writefile "config.toml" @@ -378,70 +455,28 @@ fuzz gen conf = do tequiv (getTime redResult) return report - where - seed = conf ^. configProperty . propSeed - genMethod = 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 - 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 - -filterSynth :: SynthResult -> Bool -filterSynth (SynthResult _ _ (Pass _) _) = True -filterSynth _ = False - -filterSim :: SimResult -> Bool -filterSim (SimResult _ _ (Pass _) _) = True -filterSim _ = False - -filterSynthStat :: SynthStatus -> Bool -filterSynthStat (SynthStatus _ (Pass _) _) = True -filterSynthStat _ = False - -passedFuzz :: FuzzReport -> Bool -passedFuzz (FuzzReport _ synth sim synthstat _ _ _ _) = - (passedSynth + passedSim + passedSynthStat) == 0 - where - passedSynth = length $ filter (not . filterSynth) synth - passedSim = length $ filter (not . filterSim) sim - passedSynthStat = length $ filter (not . filterSynthStat) synthstat -fuzzInDir - :: MonadFuzz m => Bool -> FilePath -> Gen SourceInfo -> Config -> Fuzz m FuzzReport -fuzzInDir k fp src conf = do +fuzzInDir :: MonadFuzz m => Gen SourceInfo -> Fuzz m FuzzReport +fuzzInDir src = do + fuzzOpts <- askOpts + let fp = fromMaybe "fuzz" $ _fuzzOptsOutput fuzzOpts make fp - res <- pop fp $ fuzz src conf + res <- pop fp $ fuzz src liftSh $ do writefile (fp <.> "html") $ printResultReport (bname fp) res - when (passedFuzz res && not k) $ rm_rf fp + when (passedFuzz res && not (_fuzzOptsKeepAll fuzzOpts)) $ rm_rf fp relativeFuzzReport res where bname = T.pack . takeBaseName . T.unpack . toTextIgnore fuzzMultiple :: MonadFuzz m - => Int - -> Bool - -> Maybe FilePath - -> Gen SourceInfo - -> Config + => Gen SourceInfo -> Fuzz m [FuzzReport] -fuzzMultiple n k fp src conf = do - x <- case fp of +fuzzMultiple src = do + fuzzOpts <- askOpts + let seed = (_fuzzOptsConfig fuzzOpts) ^. configProperty . propSeed + x <- case _fuzzOptsOutput fuzzOpts of Nothing -> do ct <- liftIO getZonedTime return @@ -453,21 +488,22 @@ fuzzMultiple n k fp src conf = do make x pop x $ do results <- if isNothing seed - then forM [1 .. n] fuzzDir' + then forM [1 .. (_fuzzOptsIterations fuzzOpts)] fuzzDir' else (: []) <$> fuzzDir' (1 :: Int) liftSh . writefile (fromText "index" <.> "html") $ printSummary "Fuzz Summary" results return results where - fuzzDir' n' = fuzzInDir k (fromText $ "fuzz_" <> showT n') src conf - seed = conf ^. configProperty . propSeed + fuzzDir' :: (Show a, MonadFuzz m) => a -> Fuzz m FuzzReport + 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 + $ let loop n = if n <= 0 then error "Hedgehog.Gen.sample: too many discards, could not generate a sample" diff --git a/src/Verismith/Generate.hs b/src/Verismith/Generate.hs index 9bf7c58..ff20f05 100644 --- a/src/Verismith/Generate.hs +++ b/src/Verismith/Generate.hs @@ -10,7 +10,8 @@ Portability : POSIX Various useful generators. -} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-imports #-} module Verismith.Generate @@ -60,19 +61,18 @@ module Verismith.Generate ) where -import Control.Lens hiding (Context) -import Control.Monad (replicateM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader hiding (local) -import Control.Monad.Trans.State.Strict -import Data.Foldable (fold) -import Data.Functor.Foldable (cata) -import Data.List (foldl', partition) -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 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 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 @@ -149,12 +149,6 @@ probability c = c ^. configProbability askProbability :: StateGen Probability askProbability = asks probability -rask :: StateGen Config -rask = ask - -lget :: StateGen Context -lget = lift . lift $ get - -- | Generates a random large number, which can also be negative. largeNum :: (MonadGen m) => m Int largeNum = Hog.int $ Hog.linear (-100) 100 @@ -314,7 +308,7 @@ someI m f = do -- is then increased so that the label is unique. makeIdentifier :: T.Text -> StateGen Identifier makeIdentifier prefix = do - context <- lget + context <- get let ident = Identifier $ prefix <> showT (context ^. nameCounter) nameCounter += 1 return ident @@ -332,7 +326,7 @@ getPort' pt i c = case filter portId c of -- the generation is currently in the other branch of an if-statement. nextPort :: PortType -> StateGen Port nextPort pt = do - context <- lget + context <- get ident <- makeIdentifier . T.toLower $ showT pt getPort' pt ident (_variables context) @@ -347,7 +341,7 @@ newPort ident pt = do -- | Generates an expression from variables that are currently in scope. scopedExpr :: StateGen Expr scopedExpr = do - context <- lget + context <- get prob <- askProbability Hog.sized . exprWithContext (_probExpr prob) (_parameters context) @@ -383,12 +377,12 @@ seqBlock = do conditional :: StateGen Statement conditional = do expr <- scopedExpr - nc <- _nameCounter <$> lget + nc <- _nameCounter <$> get tstat <- seqBlock - nc' <- _nameCounter <$> lget + nc' <- _nameCounter <$> get nameCounter .= nc fstat <- seqBlock - nc'' <- _nameCounter <$> lget + nc'' <- _nameCounter <$> get nameCounter .= max nc' nc'' return $ CondStmnt expr (Just tstat) (Just fstat) @@ -408,7 +402,7 @@ forLoop = do statement :: StateGen Statement statement = do prob <- askProbability - cont <- lget + cont <- get let defProb i = prob ^. probStmnt . i Hog.frequency [ (defProb probStmntBlock , BlockAssign <$> assignment) @@ -442,13 +436,13 @@ resizePort ps i ra = foldl' func [] -- representation for the clock. instantiate :: ModDecl -> StateGen ModItem instantiate (ModDecl i outP inP _ _) = do - context <- lget + context <- get outs <- replicateM (length outP) (nextPort 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 <$> lget + vs <- view variables <$> get Hog.choice [ return . ModInst i ident $ ModConn <$> (toE (outs <> clkPort <> ins) <> insLit) , ModInst i ident <$> Hog.shuffle @@ -462,7 +456,7 @@ instantiate (ModDecl i outP inP _ _) = do | n == "clk" = False | otherwise = True process p r = do - params <- view parameters <$> lget + params <- view parameters <$> get variables %= resizePort params p r -- | Generates a module instance by also generating a new module if there are @@ -486,8 +480,8 @@ instantiate (ModDecl i outP inP _ _) = do -- a module from a context or generating a new one. modInst :: StateGen ModItem modInst = do - prob <- rask - context <- lget + prob <- ask + context <- get let maxMods = prob ^. configProperty . propMaxModules if length (context ^. modules) < maxMods then do @@ -499,7 +493,7 @@ modInst = do parameters .= [] modDepth -= 1 chosenMod <- moduleDef Nothing - ncont <- lget + ncont <- get let genMods = ncont ^. modules modDepth += 1 parameters .= params @@ -511,9 +505,9 @@ modInst = do -- | Generate a random module item. modItem :: StateGen ModItem modItem = do - conf <- rask + conf <- ask let prob = conf ^. configProbability - context <- lget + context <- get let defProb i = prob ^. probModItem . i det <- Hog.frequency [ (conf ^. configProperty . propDeterminism, return True) , (conf ^. configProperty . propNonDeterminism, return False) ] @@ -535,7 +529,7 @@ moduleName Nothing = makeIdentifier "module" constExpr :: StateGen ConstExpr constExpr = do prob <- askProbability - context <- lget + context <- get Hog.sized $ constExprWithContext (context ^. parameters) (prob ^. probExpr) @@ -576,8 +570,8 @@ moduleDef top = do portList <- Hog.list (Hog.linear 4 10) $ nextPort Wire mi <- Hog.list (Hog.linear 4 100) modItem ps <- Hog.list (Hog.linear 0 10) parameter - context <- lget - config <- rask + context <- get + config <- ask let (newPorts, local) = partition (`identElem` portList) $ _variables context let size = diff --git a/verismith.cabal b/verismith.cabal index b734b29..389ca16 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -50,6 +50,7 @@ library , Verismith.Fuzz , Verismith.Generate , Verismith.Internal + , Verismith.OptParser , Verismith.Reduce , Verismith.Report , Verismith.Result @@ -74,42 +75,41 @@ library , Verismith.Verilog.Preprocess , Verismith.Verilog.Quote , Verismith.Verilog.Token - build-depends: base >=4.7 && <5 - -- Cannot upgrade to 1.0 because of missing MonadGen instance for - -- StateT. - , hedgehog >=1.0 && <1.2 + build-depends: DRBG >=0.5 && <0.6 + , array >=0.5 && <0.6 + , base >=4.7 && <5 + , binary >= 0.8.5.1 && <0.9 + , blaze-html >=0.9.0.1 && <0.10 + , bytestring >=0.10 && <0.11 + , cryptonite >=0.25 && <0.26 + , deepseq >= 1.4.3.0 && <1.5 + , exceptions >=0.10.0 && <0.11 , fgl >=5.6 && <5.8 , fgl-visualize >=0.1 && <0.2 + , filepath >=1.4.2 && <1.5 + , gitrev >= 1.3.1 && <1.4 + , hedgehog >=1.0 && <1.2 , lens >=4.16.1 && <4.18 + , lifted-base >=0.2.3 && <0.3 + , memory >=0.14 && <0.15 + , monad-control >=1.0.2 && <1.1 + , mtl >=2.2.2 && <2.3 + , optparse-applicative >=0.14 && <0.15 + , parsec >=3.1 && <3.2 + , prettyprinter >=1.2.0.1 && <1.3 , random >=1.1 && <1.2 + , recursion-schemes >=5.0.2 && <5.2 , shakespeare >=2 && <2.1 , shelly >=1.8.0 && <1.9 + , statistics >=0.14.0.2 && <0.16 + , template-haskell >=2.13.0 && <2.15 , text >=1.2 && <1.3 - , bytestring >=0.10 && <0.11 - , filepath >=1.4.2 && <1.5 - , binary >= 0.8.5.1 && <0.9 - , cryptonite >=0.25 && <0.26 - , memory >=0.14 && <0.15 - , DRBG >=0.5 && <0.6 - , parsec >=3.1 && <3.2 + , time >= 1.8.0.2 && <1.9 + , tomland >=1.0 && <1.2 , transformers >=0.5 && <0.6 , transformers-base >=0.4.5 && <0.5 - , tomland >=1.0 && <1.2 - , prettyprinter >=1.2.0.1 && <1.3 - , array >=0.5 && <0.6 - , recursion-schemes >=5.0.2 && <5.2 - , time >= 1.8.0.2 && <1.9 - , lifted-base >=0.2.3 && <0.3 - , monad-control >=1.0.2 && <1.1 - , gitrev >= 1.3.1 && <1.4 - , deepseq >= 1.4.3.0 && <1.5 - , template-haskell >=2.13.0 && <2.15 - , optparse-applicative >=0.14 && <0.15 - , exceptions >=0.10.0 && <0.11 - , blaze-html >=0.9.0.1 && <0.10 - , statistics >=0.14.0.2 && <0.16 - , vector >=0.12.0.1 && <0.13 , unordered-containers >=0.2.10 && <0.3 + , vector >=0.12.0.1 && <0.13 default-extensions: OverloadedStrings executable verismith @@ -144,14 +144,14 @@ test-suite test build-depends: base >=4 && <5 , verismith , fgl >=5.6 && <5.8 - , tasty >=1.0.1.1 && <1.3 - , tasty-hunit >=0.10 && <0.11 - , tasty-hedgehog >=1.0 && <1.1 , hedgehog >=1.0 && <1.2 , lens >=4.16.1 && <4.18 + , parsec >= 3.1 && < 3.2 , shakespeare >=2 && <2.1 + , tasty >=1.0.1.1 && <1.3 + , tasty-hedgehog >=1.0 && <1.1 + , tasty-hunit >=0.10 && <0.11 , text >=1.2 && <1.3 - , parsec >= 3.1 && < 3.2 default-extensions: OverloadedStrings --test-suite doctest -- cgit From 44a250b5d5828146f13fecdb5bfdfcb2d5ecca78 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 28 Oct 2019 10:59:12 +0000 Subject: Add --no-reduction --- src/Verismith.hs | 5 +++-- src/Verismith/OptParser.hs | 38 +++++++++++++++++--------------------- 2 files changed, 20 insertions(+), 23 deletions(-) diff --git a/src/Verismith.hs b/src/Verismith.hs index bde3e2a..6a2bc72 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -122,10 +122,11 @@ randomise config@(Config a _ c d e) = do ce = config ^. configProbability . probExpr handleOpts :: Opts -> IO () -handleOpts (Fuzz o configF f k n nosim noequiv) = do +handleOpts (Fuzz o configF f k n nosim noequiv noreduction) = do config <- getConfig configF _ <- runFuzz - (FuzzOpts (Just $ fromText o) f k n nosim noequiv config) + (FuzzOpts (Just $ fromText o) + f k n nosim noequiv noreduction config) defaultYosys (fuzzMultiple (proceduralSrc "top" config)) return () diff --git a/src/Verismith/OptParser.hs b/src/Verismith/OptParser.hs index 1db0d52..a475e9a 100644 --- a/src/Verismith/OptParser.hs +++ b/src/Verismith/OptParser.hs @@ -24,13 +24,14 @@ instance Show OptTool where show TXST = "xst" show TIcarus = "icarus" -data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text - , fuzzConfigFile :: !(Maybe FilePath) - , fuzzForced :: !Bool - , fuzzKeepAll :: !Bool - , fuzzNum :: {-# UNPACK #-} !Int - , fuzzNoSim :: !Bool - , fuzzNoEquiv :: !Bool +data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text + , fuzzConfigFile :: !(Maybe FilePath) + , fuzzForced :: !Bool + , fuzzKeepAll :: !Bool + , fuzzNum :: {-# UNPACK #-} !Int + , fuzzNoSim :: !Bool + , fuzzNoEquiv :: !Bool + , fuzzNoReduction :: !Bool } | Generate { generateFilename :: !(Maybe FilePath) , generateConfigFile :: !(Maybe FilePath) @@ -85,35 +86,30 @@ fuzzOpts = <> Opt.metavar "DIR" <> Opt.help "Output directory that the fuzz run takes place in." <> Opt.showDefault - <> Opt.value "output" - ) + <> 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.help "Config file for the current fuzz run.") <*> (Opt.switch $ Opt.long "force" <> Opt.short 'f' <> Opt.help - "Overwrite the specified directory." - ) + "Overwrite the specified directory.") <*> (Opt.switch $ Opt.long "keep" <> Opt.short 'k' <> Opt.help - "Keep all the directories." - ) + "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.metavar "INT") <*> (Opt.switch $ Opt.long "no-sim" <> Opt.help - "Do not run simulation on the output netlist." - ) + "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." - ) + "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.") genOpts :: Parser Opts genOpts = -- cgit From 5e398e2adbe02e6f617d134b014135e0a6af0072 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 28 Oct 2019 10:59:18 +0000 Subject: Run simulation on all tools passing synthesis --- src/Verismith/Fuzz.hs | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index 4f09b36..eeafaa6 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -64,26 +64,28 @@ import Verismith.Tool.Yosys import Verismith.Verilog.AST import Verismith.Verilog.CodeGen -data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath) - , _fuzzOptsForced :: !Bool - , _fuzzOptsKeepAll :: !Bool - , _fuzzOptsIterations :: {-# UNPACK #-} !Int - , _fuzzOptsNoSim :: !Bool - , _fuzzOptsNoEquiv :: !Bool - , _fuzzOptsConfig :: {-# UNPACK #-} !Config +data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath) + , _fuzzOptsForced :: !Bool + , _fuzzOptsKeepAll :: !Bool + , _fuzzOptsIterations :: {-# UNPACK #-} !Int + , _fuzzOptsNoSim :: !Bool + , _fuzzOptsNoEquiv :: !Bool + , _fuzzOptsNoReduction :: !Bool + , _fuzzOptsConfig :: {-# UNPACK #-} !Config } deriving (Show, Eq) $(makeLenses ''FuzzOpts) defaultFuzzOpts :: FuzzOpts -defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing - , _fuzzOptsForced = False - , _fuzzOptsKeepAll = False - , _fuzzOptsIterations = 1 - , _fuzzOptsNoSim = False - , _fuzzOptsNoEquiv = False - , _fuzzOptsConfig = defaultConfig +defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing + , _fuzzOptsForced = False + , _fuzzOptsKeepAll = False + , _fuzzOptsIterations = 1 + , _fuzzOptsNoSim = False + , _fuzzOptsNoEquiv = False + , _fuzzOptsNoReduction = False + , _fuzzOptsConfig = defaultConfig } data FuzzEnv = FuzzEnv { _getSynthesisers :: ![SynthTool] @@ -286,16 +288,15 @@ equivalence src = do simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () simulation src = do - synth <- passEquiv + synth <- passedSynthesis vals <- liftIO $ generateByteString 20 ident <- liftSh $ equiv vals defaultIdentitySynth - resTimes <- liftSh $ mapM (equiv vals) $ conv <$> synth + resTimes <- liftSh $ mapM (equiv vals) synth liftSh . inspect $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) <$> (ident : resTimes) where - conv (SynthResult _ a _ _) = a equiv b a = toolRun ("simulation for " <> toText a) . runResultT $ do make dir pop dir $ do @@ -424,6 +425,7 @@ medianFreqs l = zip hat (return <$> l) fuzz :: MonadFuzz m => Gen SourceInfo -> 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 @@ -435,12 +437,17 @@ fuzz gen = do . propSeed ?~ seed' (tsynth, _) <- titleRun "Synthesis" $ synthesis src - (tequiv, _) <- titleRun "Equivalence Check" $ equivalence src - (_ , _) <- titleRun "Simulation" $ simulation 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 synthFails <- failedSynthesis redResult <- - whenMaybe (not $ null fails && null synthFails) + whenMaybe (not (null fails && null synthFails) + && not (_fuzzOptsNoReduction opts)) . titleRun "Reduction" $ reduction src state_ <- get -- cgit From 633522fc459439e6dff58509c7706ef831199fee Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Mon, 28 Oct 2019 19:40:35 +0000 Subject: Revert .envrc code --- .envrc | 83 ------------------------------------------------------------------ 1 file changed, 83 deletions(-) diff --git a/.envrc b/.envrc index af2d402..4a4726a 100644 --- a/.envrc +++ b/.envrc @@ -1,84 +1 @@ -#################################### -# Environment setup for Nix shells # -#################################### - -# From https://github.com/direnv/direnv/wiki/Nix#persistent-cached-shell -# -# Usage: use_nix [...] -# -# Load environment variables from `nix-shell`. -# If you have a `default.nix` or `shell.nix` one of these will be used and -# the derived environment will be stored at ./.direnv/env- -# and symlink to it will be created at ./.direnv/default. -# Dependencies are added to the GC roots, such that the environment remains persistent. -# -# Packages can also be specified directly via e.g `use nix -p ocaml`, -# however those will not be added to the GC roots. -# -# The resulting environment is cached for better performance. -# -# To trigger switch to a different environment: -# `rm -f .direnv/default` -# -# To derive a new environment: -# `rm -rf .direnv/env-$(md5sum {shell,default}.nix 2> /dev/null | cut -c -32)` -# -# To remove cache: -# `rm -f .direnv/dump-*` -# -# To remove all environments: -# `rm -rf .direnv/env-*` -# -# To remove only old environments: -# `find .direnv -name 'env-*' -and -not -name `readlink .direnv/default` -exec rm -rf {} +` -# -use_nix() { - set -e - - local shell="shell.nix" - if [[ ! -f "${shell}" ]]; then - shell="default.nix" - fi - - if [[ ! -f "${shell}" ]]; then - fail "use nix: shell.nix or default.nix not found in the folder" - fi - - local dir="${PWD}"/.direnv - local default="${dir}/default" - if [[ ! -L "${default}" ]] || [[ ! -d `readlink "${default}"` ]]; then - local wd="${dir}/env-`md5sum "${shell}" | cut -c -32`" # TODO: Hash also the nixpkgs version? - mkdir -p "${wd}" - - local drv="${wd}/env.drv" - if [[ ! -f "${drv}" ]]; then - log_status "use nix: deriving new environment" - IN_NIX_SHELL=1 nix-instantiate --add-root "${drv}" --indirect "${shell}" > /dev/null - nix-store -r `nix-store --query --references "${drv}"` --add-root "${wd}/dep" --indirect > /dev/null - fi - - rm -f "${default}" - ln -s `basename "${wd}"` "${default}" - fi - - local drv=`readlink -f "${default}/env.drv"` - local dump="${dir}/dump-`md5sum ".envrc" | cut -c -32`-`md5sum ${drv} | cut -c -32`" - - if [[ ! -f "${dump}" ]] || [[ "${XDG_CONFIG_DIR}/direnv/direnvrc" -nt "${dump}" ]]; then - log_status "use nix: updating cache" - - old=`find ${dir} -name 'dump-*'` - nix-shell "${drv}" --show-trace "$@" --run 'direnv dump' > "${dump}" - rm -f ${old} - fi - - direnv_load cat "${dump}" - - watch_file "${default}" - watch_file shell.nix - if [[ ${shell} == "default.nix" ]]; then - watch_file default.nix - fi -} - use_nix -- cgit From 01c2ab3f6a58d416528efce3057e2cf2f1604489 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Tue, 29 Oct 2019 11:53:43 +0000 Subject: Add data-file installation path This removes the need to recursively copy the data directory which will also save on space. --- src/Verismith.hs | 19 ++++++++++++++----- src/Verismith/Fuzz.hs | 29 ++++++++++++++++------------- src/Verismith/Reduce.hs | 7 ++++--- src/Verismith/Tool/Icarus.hs | 11 +++++++---- src/Verismith/Tool/Template.hs | 22 ++++++++++++---------- src/Verismith/Tool/Yosys.hs | 6 +++--- verismith.cabal | 4 ++-- 7 files changed, 58 insertions(+), 40 deletions(-) diff --git a/src/Verismith.hs b/src/Verismith.hs index 6a2bc72..41d845d 100644 --- a/src/Verismith.hs +++ b/src/Verismith.hs @@ -54,6 +54,7 @@ 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) @@ -71,6 +72,9 @@ import Verismith.Tool.Internal import Verismith.Verilog import Verismith.Verilog.Parser (parseSourceInfoFile) +toFP :: String -> FilePath +toFP = fromText . T.pack + myForkIO :: IO () -> IO (MVar ()) myForkIO io = do mvar <- newEmptyMVar @@ -124,9 +128,10 @@ randomise config@(Config a _ c d e) = do handleOpts :: Opts -> IO () handleOpts (Fuzz o configF f k n nosim noequiv noreduction) = do config <- getConfig configF + datadir <- getDataDir _ <- runFuzz (FuzzOpts (Just $ fromText o) - f k n nosim noequiv noreduction config) + f k n nosim noequiv noreduction config (toFP datadir)) defaultYosys (fuzzMultiple (proceduralSrc "top" config)) return () @@ -145,13 +150,14 @@ handleOpts (Parse f) = do where file = T.unpack . toTextIgnore $ f 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 a b src + src' <- reduceSynth (toFP datadir) a b src writefile (fromText ".." dir <.> "v") $ genSource src' a : _ -> do putStrLn "Reduce with synthesis failure" @@ -166,6 +172,7 @@ handleOpts (Reduce f t _ ls' False) = do where dir = fromText "reduce" handleOpts (Reduce f t _ ls' True) = do src <- parseSourceInfoFile t (toTextIgnore f) + datadir <- getDataDir case descriptionToSynth <$> ls' of a : b : _ -> do putStrLn "Starting equivalence check" @@ -174,7 +181,7 @@ handleOpts (Reduce f t _ ls' True) = do pop dir $ do runSynth a src runSynth b src - runEquiv a b src + runEquiv (toFP datadir) a b src case res of Pass _ -> putStrLn "Equivalence check passed" Fail EquivFail -> putStrLn "Equivalence check failed" @@ -264,10 +271,11 @@ checkEquivalence :: SourceInfo -> 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 defaultYosys defaultVivado src) >> return True) + ((runResultT $ runEquiv (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 @@ -284,6 +292,7 @@ runEquivalence seed gm t d k i = do (_, m) <- shelly $ sampleSeed seed gm let srcInfo = SourceInfo "top" m rand <- generateByteString 20 + datadir <- getDataDir shellyFailDir $ do mkdir_p (fromText d fromText n) curr <- toTextIgnore <$> pwd @@ -292,7 +301,7 @@ runEquivalence seed gm t d k i = do _ <- catch_sh ( runResultT - $ runEquiv defaultYosys defaultVivado srcInfo + $ runEquiv (toFP datadir) defaultYosys defaultVivado srcInfo >> liftSh (logger "Test OK") ) $ onFailure n diff --git a/src/Verismith/Fuzz.hs b/src/Verismith/Fuzz.hs index eeafaa6..d14e74b 100644 --- a/src/Verismith/Fuzz.hs +++ b/src/Verismith/Fuzz.hs @@ -72,6 +72,7 @@ data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath) , _fuzzOptsNoEquiv :: !Bool , _fuzzOptsNoReduction :: !Bool , _fuzzOptsConfig :: {-# UNPACK #-} !Config + , _fuzzDataDir :: {-# UNPACK #-} !FilePath } deriving (Show, Eq) @@ -86,6 +87,7 @@ defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing , _fuzzOptsNoEquiv = False , _fuzzOptsNoReduction = False , _fuzzOptsConfig = defaultConfig + , _fuzzDataDir = fromText "." } data FuzzEnv = FuzzEnv { _getSynthesisers :: ![SynthTool] @@ -225,9 +227,7 @@ failedSynthesis = fmap toSynth . filter failed . _fuzzSynthStatus <$> get toSynth (SynthStatus s _ _) = s make :: MonadSh m => FilePath -> m () -make f = liftSh $ do - mkdir_p f - cp_r "data" $ f fromText "data" +make f = liftSh $ mkdir_p f pop :: (MonadBaseControl IO m, MonadSh m) => FilePath -> m a -> m a pop f a = do @@ -255,6 +255,7 @@ toolRun t m = do equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m () equivalence src = do + datadir <- fmap _fuzzDataDir askOpts synth <- passedSynthesis -- let synthComb = -- nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth @@ -263,12 +264,12 @@ equivalence src = do . filter (uncurry (/=)) $ (,) defaultIdentitySynth <$> synth - resTimes <- liftSh $ mapM (uncurry equiv) synthComb + resTimes <- liftSh $ mapM (uncurry (equiv datadir)) synthComb fuzzSynthResults .= toSynthResult synthComb resTimes liftSh $ inspect resTimes where tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') - equiv a b = + equiv datadir a b = toolRun ("equivalence check for " <> toText a <> " and " <> toText b) . runResultT $ do make dir @@ -283,28 +284,29 @@ equivalence src = do synthOutput b ) $ synthOutput b writefile "rtl.v" $ genSource src - runEquiv a b src + runEquiv datadir a b src where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m () simulation src = do + datadir <- fmap _fuzzDataDir askOpts synth <- passedSynthesis vals <- liftIO $ generateByteString 20 - ident <- liftSh $ equiv vals defaultIdentitySynth - resTimes <- liftSh $ mapM (equiv vals) synth + ident <- liftSh $ equiv datadir vals defaultIdentitySynth + resTimes <- liftSh $ mapM (equiv datadir vals) synth liftSh . inspect $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r) <$> (ident : resTimes) where - equiv b a = toolRun ("simulation for " <> toText a) . runResultT $ do + equiv datadir b 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 defaultIcarus a src b + runSimIc datadir defaultIcarus a src b where dir = fromText $ "simulation_" <> toText a -- | Generate a specific number of random bytestrings of size 256. @@ -336,16 +338,17 @@ passEquiv = filter withIdentity . _fuzzSynthResults <$> get -- | Always reduces with respect to 'Identity'. reduction :: (MonadSh m) => SourceInfo -> Fuzz m () reduction src = do + datadir <- fmap _fuzzDataDir askOpts fails <- failEquivWithIdentity synthFails <- failedSynthesis - _ <- liftSh $ mapM red fails + _ <- liftSh $ mapM (red datadir) fails _ <- liftSh $ mapM redSynth synthFails return () where - red (SynthResult a b _ _) = do + red datadir (SynthResult a b _ _) = do make dir pop dir $ do - s <- reduceSynth a b src + s <- reduceSynth datadir a b src writefile (fromText ".." dir <.> "v") $ genSource s return s where dir = fromText $ "reduce_" <> toText a <> "_" <> toText b diff --git a/src/Verismith/Reduce.hs b/src/Verismith/Reduce.hs index 88f0b42..a7ec3f8 100644 --- a/src/Verismith/Reduce.hs +++ b/src/Verismith/Reduce.hs @@ -582,17 +582,18 @@ reduceWithScript top script file = do -- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it. reduceSynth :: (Synthesiser a, Synthesiser b, MonadSh m) - => a + => Shelly.FilePath + -> a -> b -> SourceInfo -> m SourceInfo -reduceSynth a b = reduce synth +reduceSynth datadir a b = reduce synth where synth src' = liftSh $ do r <- runResultT $ do runSynth a src' runSynth b src' - runEquiv a b src' + runEquiv datadir a b src' return $ case r of Fail EquivFail -> True Fail _ -> False diff --git a/src/Verismith/Tool/Icarus.hs b/src/Verismith/Tool/Icarus.hs index b783033..9d4281f 100644 --- a/src/Verismith/Tool/Icarus.hs +++ b/src/Verismith/Tool/Icarus.hs @@ -133,15 +133,16 @@ fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b runSimIc :: (Synthesiser b) - => Icarus + => FilePath + -> Icarus -> b -> SourceInfo -> [ByteString] -> ResultSh ByteString -runSimIc sim1 synth1 srcInfo bss = do +runSimIc datadir sim1 synth1 srcInfo bss = do dir <- liftSh pwd let top = srcInfo ^. mainModule - let inConcat = (RegConcat (Id . fromPort <$> (top ^. modInPorts))) + let inConcat = (RegConcat . filter filterClk $ (Id . fromPort <$> (top ^. modInPorts))) let tb = instantiateMod top $ ModDecl "testbench" @@ -170,7 +171,7 @@ runSimIc sim1 synth1 srcInfo bss = do ] [] - liftSh . writefile "testbench.v" $ icarusTestbench (Verilog [tb]) synth1 + liftSh . writefile "testbench.v" $ icarusTestbench datadir (Verilog [tb]) synth1 liftSh $ exe dir "icarus" "iverilog" ["-o", "main", "testbench.v"] liftSh $ B.take 8 @@ -186,3 +187,5 @@ runSimIc sim1 synth1 srcInfo bss = do ) where exe dir name e = void . errExit False . logCommand dir name . timeout e + filterClk (Id "clk") = False + filterClk (Id _) = True diff --git a/src/Verismith/Tool/Template.hs b/src/Verismith/Tool/Template.hs index c0cbfe1..d02daf8 100644 --- a/src/Verismith/Tool/Template.hs +++ b/src/Verismith/Tool/Template.hs @@ -89,8 +89,8 @@ write_verilog -force #{outf} |] -- brittany-disable-next-binding -sbyConfig :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> Text -sbyConfig sim1 sim2 (SourceInfo top _) = [st|[options] +sbyConfig :: (Synthesiser a, Synthesiser b) => FilePath -> a -> b -> SourceInfo -> Text +sbyConfig datadir sim1 sim2 (SourceInfo top _) = [st|[options] multiclock on mode prove @@ -115,19 +115,21 @@ top.v depList = T.intercalate "\n" $ toTextIgnore - . (fromText "data" ) + . (datadir fromText "data" ) . fromText <$> deps readL = T.intercalate "\n" $ mappend "read -formal " <$> deps -icarusTestbench :: (Synthesiser a) => Verilog -> a -> Text -icarusTestbench t synth1 = [st| -`include "data/cells_cmos.v" -`include "data/cells_cyclone_v.v" -`include "data/cells_verific.v" -`include "data/cells_xilinx_7.v" -`include "data/cells_yosys.v" +icarusTestbench :: (Synthesiser a) => FilePath -> Verilog -> a -> Text +icarusTestbench datadir t synth1 = [st| +`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/Yosys.hs b/src/Verismith/Tool/Yosys.hs index 9c0a864..afbffe9 100644 --- a/src/Verismith/Tool/Yosys.hs +++ b/src/Verismith/Tool/Yosys.hs @@ -102,8 +102,8 @@ runEquivYosys yosys sim1 sim2 srcInfo = do where checkFile = fromText [st|test.#{toText sim1}.#{toText sim2}.ys|] runEquiv - :: (Synthesiser a, Synthesiser b) => a -> b -> SourceInfo -> ResultSh () -runEquiv sim1 sim2 srcInfo = do + :: (Synthesiser a, Synthesiser b) => FilePath -> a -> b -> SourceInfo -> ResultSh () +runEquiv datadir sim1 sim2 srcInfo = do dir <- liftSh pwd liftSh $ do writefile "top.v" @@ -114,7 +114,7 @@ runEquiv sim1 sim2 srcInfo = do ^. mainModule replaceMods (synthOutput sim1) "_1" srcInfo replaceMods (synthOutput sim2) "_2" srcInfo - writefile "proof.sby" $ sbyConfig sim1 sim2 srcInfo + writefile "proof.sby" $ sbyConfig datadir sim1 sim2 srcInfo e <- liftSh $ do exe dir "symbiyosys" "sby" ["-f", "proof.sby"] lastExitCode diff --git a/verismith.cabal b/verismith.cabal index 389ca16..61fd087 100644 --- a/verismith.cabal +++ b/verismith.cabal @@ -14,11 +14,11 @@ category: Hardware build-type: Custom cabal-version: >=1.10 extra-source-files: README.md - , data/*.v , examples/*.v , examples/config.toml , scripts/*.py , scripts/*.sh +data-files: data/*.v source-repository head type: git @@ -27,7 +27,7 @@ source-repository head source-repository this type: git location: https://github.com/ymherklotz/verismith - tag: v0.4.0.0 + tag: v0.4.0.1 custom-setup setup-depends: -- cgit