verismith 1.0.0.2 → 1.1.0
raw patch · 66 files changed
+18102/−5740 lines, 66 filesdep +containersdep +mwc-probabilitydep +primitivedep −DRBGdep −shakespearedep −statisticsdep ~bytestringdep ~criteriondep ~cryptonitesetup-changed
Dependencies added: containers, mwc-probability, primitive
Dependencies removed: DRBG, shakespeare, statistics
Dependency ranges changed: bytestring, criterion, cryptonite, deepseq, fgl, hedgehog, lens, memory, mtl, optparse-applicative, prettyprinter, random, recursion-schemes, shelly, tasty, tasty-hedgehog, template-haskell, text, time, tomland, transformers, unordered-containers, vector
Files
- LICENSE +3/−15
- README.md +49/−7
- Setup.hs +1/−1
- app/Main.hs +1/−1
- examples/config.toml +569/−2
- scripts/build.sh +10/−0
- src/Verismith.hs +398/−260
- src/Verismith/Circuit.hs +37/−39
- src/Verismith/Circuit/Base.hs +25/−26
- src/Verismith/Circuit/Gen.hs +33/−35
- src/Verismith/Circuit/Internal.hs +25/−27
- src/Verismith/Circuit/Random.hs +41/−37
- src/Verismith/Config.hs +1501/−533
- src/Verismith/CounterEg.hs +52/−50
- src/Verismith/EMI.hs +244/−0
- src/Verismith/Fuzz.hs +486/−386
- src/Verismith/Generate.hs +555/−390
- src/Verismith/Internal.hs +0/−49
- src/Verismith/OptParser.hs +565/−257
- src/Verismith/Reduce.hs +500/−387
- src/Verismith/Report.hs +295/−274
- src/Verismith/Result.hs +114/−105
- src/Verismith/Shuffle.hs +153/−0
- src/Verismith/Tool.hs +49/−41
- src/Verismith/Tool/Icarus.hs +260/−155
- src/Verismith/Tool/Identity.hs +33/−34
- src/Verismith/Tool/Internal.hs +156/−141
- src/Verismith/Tool/Quartus.hs +58/−56
- src/Verismith/Tool/QuartusLight.hs +58/−56
- src/Verismith/Tool/Template.hs +156/−147
- src/Verismith/Tool/Vivado.hs +56/−54
- src/Verismith/Tool/XST.hs +62/−62
- src/Verismith/Tool/Yosys.hs +111/−100
- src/Verismith/Utils.hs +89/−0
- src/Verismith/Verilog.hs +99/−88
- src/Verismith/Verilog/AST.hs +819/−620
- src/Verismith/Verilog/BitVec.hs +76/−73
- src/Verismith/Verilog/CodeGen.hs +205/−176
- src/Verismith/Verilog/Distance.hs +182/−0
- src/Verismith/Verilog/Eval.hs +83/−75
- src/Verismith/Verilog/Internal.hs +52/−50
- src/Verismith/Verilog/Lex.x +1/−1
- src/Verismith/Verilog/Mutate.hs +208/−193
- src/Verismith/Verilog/Parser.hs +361/−286
- src/Verismith/Verilog/Preprocess.hs +84/−83
- src/Verismith/Verilog/Quote.hs +32/−32
- src/Verismith/Verilog/Token.hs +17/−19
- src/Verismith/Verilog2005.hs +24/−0
- src/Verismith/Verilog2005/AST.hs +1721/−0
- src/Verismith/Verilog2005/Generator.hs +1036/−0
- src/Verismith/Verilog2005/Lexer.x +851/−0
- src/Verismith/Verilog2005/LibPretty.hs +415/−0
- src/Verismith/Verilog2005/Parser.hs +1899/−0
- src/Verismith/Verilog2005/PrettyPrinter.hs +1369/−0
- src/Verismith/Verilog2005/Randomness.hs +209/−0
- src/Verismith/Verilog2005/Token.hs +583/−0
- src/Verismith/Verilog2005/Utils.hs +452/−0
- test/Benchmark.hs +18/−9
- test/Config.hs +44/−0
- test/Distance.hs +32/−0
- test/Parser.hs +88/−80
- test/Property.hs +35/−33
- test/Reduce.hs +233/−92
- test/Test.hs +3/−3
- test/Unit.hs +73/−63
- verismith.cabal +53/−37
LICENSE view
@@ -1,15 +1,3 @@-Verismith can be used under two licenses, either the GPLv3 license or a-commercial license from Imperial College London.--For commercial use you need a Software Usage Agreement from Imperial-College London. Otherwise the software is released under the GPLv3-license shown below.--For more information about the commercial version of Verismith, please-contact James Nightingale <j.nightingale15 [at] imperial.ac.uk>.--------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 @@ -643,8 +631,8 @@ state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. - Verismith: Verilog fuzzer for logic synthesis tools.- Copyright (C) 2018-2020 Yann Herklotz <yann@yannherklotz.com>+ Verismith: Verilog hardware synthesis tool fuzzer+ Copyright (C) 2018-2021 Yann Herklotz <yann@yannherklotz.com> This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by@@ -664,7 +652,7 @@ If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: - Verismith Copyright (C) 2018-2020 Yann Herklotz+ Verismith Copyright (C) 2018-2021 Yann Herklotz <yann@yannherklotz.com> This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details.
README.md view
@@ -1,5 +1,10 @@-# Verismith [](https://travis-ci.com/ymherklotz/verismith)+# Verismith +[](https://github.com/ymherklotz/verismith/actions)+[](https://doi.org/10.1145/3373087.3375310)+[](https://doi.org/10.5281/zenodo.3598790)+[](http://hackage.haskell.org/package/verismith)+ Verilog Fuzzer to test the major verilog compilers by generating random, valid and deterministic Verilog. It currently supports the following synthesis tools:@@ -88,7 +93,7 @@ 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: -**Note**: Only **GHC 8.6.5** is currently supported, work is going on to support newer versions of GHC.+**Note**: A recent version of GHC is recommended, such as GHC 9.6.4. ``` shell cabal install verismith@@ -117,6 +122,7 @@ 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 update # needed if cabal is used for the first time cabal configure cabal build ```@@ -131,19 +137,19 @@ 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 +### 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. -### Probability section +### 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. -### Property section +### 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. -### Synthesiser section +### 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. @@ -204,9 +210,45 @@ } ``` +## Contributing++### Running the [ormolu formatter](https://github.com/tweag/ormolu).++It can be installed using the following:++```shell+cabal install ormolu+```++Then, it can be run on all the files in this repository using (in bash):++```shell+ormolu --mode inplace $(find src test app -name '*.hs')+```+ ## License -Verismith is not free software. This non-commercial release can only be used for evaluation, research, educational and personal purposes. A commercial version of Verismith, without this restriction and with professional support, can be purchased from Imperial College London. See the file [LICENSE](/LICENSE) for more information.+This open source version of Verismith is licensed under the GPLv3 license, which can be seen in the [LICENSE](/LICENSE) file.++A **closed source** version of Verismith is also available without the restrictions of the GPLv3 license following a software with a software usage agreement from Imperial College London.++``` text+Verismith: Verilog hardware synthesis tool fuzzer+Copyright (C) 2019-2020 Yann Herklotz <yann@yannherklotz.com>++This program is free software: you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation, either version 3 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program. If not, see <https://www.gnu.org/licenses/>.+``` ## Acknowledgement
Setup.hs view
@@ -1,4 +1,4 @@-import Distribution.Simple+import Distribution.Simple main :: IO () main = defaultMain
app/Main.hs view
@@ -1,6 +1,6 @@ module Main where -import Verismith+import Verismith main :: IO () main = defaultMain
examples/config.toml view
@@ -1,8 +1,573 @@ +[emi]+ generate_prob = 2+ nogenerate_prob = 8+ [info]- commit = "e57b16651684e0f9e9d0a3cd6f81fccd5b8c7cb6"- version = "0.4.0.1"+ commit = "866707b03e4c2346d25b77c423fbf03d29c4e26c"+ version = "1.0.0.2" +[invalid_generator]+ attribute_optional_value = 0.5+ lvalue_optional = 0.5+ parameter_mintypmax_or_single = 0.5++ [invalid_generator.attribute_items]+ [[invalid_generator.attribute_items.LinearCombination]]+ weight = 2.0++ [[invalid_generator.attribute_items.LinearCombination.Discrete]]+ value = 0+ weight = 1.0++ [[invalid_generator.attribute_items.LinearCombination]]+ weight = 1.0++ [invalid_generator.attribute_items.LinearCombination.NegativeBinomial]+ failureRate = 0.75+ numberOfFailures = 1+ offset = 0++ [invalid_generator.config]+ cell_or_inst = 0.5+ config = 0.5+ liblist_or_use = 0.5+ libraryScope = 0.5++ [invalid_generator.config.blocks]+ [invalid_generator.config.blocks.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.config.designs]+ [invalid_generator.config.designs.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.config.items]+ [invalid_generator.config.items.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.delay_base]+ [invalid_generator.delay_base.BiasedUniform]+ weight = 1.0++ [invalid_generator.delay_items]+ Discrete = [1.0, 1.0, 2.0, 4.0]++ [invalid_generator.driveStrength]+ [invalid_generator.driveStrength.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr]+ X_or_Z = 0.5+ attenuation = 0.7+ dimRange = 0.5+ fixed_or_float = 0.5+ literal_signed = 0.5+ minTypMax = 0.5+ range_offset_pos_or_neg = 0.5++ [invalid_generator.expr.binary_digit]+ [invalid_generator.expr.binary_digit.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.binary_digits]+ [invalid_generator.expr.binary_digits.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.expr.concatenations]+ [invalid_generator.expr.concatenations.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.expr.decimal_digit]+ [invalid_generator.expr.decimal_digit.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.decimal_digits]+ [invalid_generator.expr.decimal_digits.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.expr.exponentSign]+ [invalid_generator.expr.exponentSign.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.hex_digit]+ [invalid_generator.expr.hex_digit.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.hex_digits]+ [invalid_generator.expr.hex_digits.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.expr.item]+ Discrete = [2.0, 2.0, 2.0, 1.0]++ [invalid_generator.expr.literal_width]+ [invalid_generator.expr.literal_width.BiasedUniform]+ weight = 1.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 1+ weight = 1024.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 8+ weight = 512.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 16+ weight = 256.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 32+ weight = 128.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 64+ weight = 64.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 128+ weight = 32.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 256+ weight = 16.0++ [[invalid_generator.expr.literal_width.BiasedUniform.biases]]+ value = 512+ weight = 8.0++ [invalid_generator.expr.octal_digit]+ [invalid_generator.expr.octal_digit.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.octal_digits]+ [invalid_generator.expr.octal_digits.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.expr.op_binary]+ [invalid_generator.expr.op_binary.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.op_unary]+ [invalid_generator.expr.op_unary.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.primary]+ Discrete = [2.0, 4.0, 4.0, 4.0, 4.0, 4.0, 2.0, 4.0, 1.0, 1.0, 1.0, 1.0, 1.0]++ [invalid_generator.expr.range_kind]+ [invalid_generator.expr.range_kind.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.string_character]+ [invalid_generator.expr.string_character.BiasedUniform]+ weight = 1.0++ [invalid_generator.expr.string_characters]+ [invalid_generator.expr.string_characters.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.expr.sysFunArgs]+ [invalid_generator.expr.sysFunArgs.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.generate]+ attenuation = 0.7+ declaration_dim_or_init = 0.5+ funReturnType = 0.5+ gate_optional_name = 0.5+ instance_optional_delay = 0.5+ instance_optional_range = 0.5+ net_range = 0.5+ optionalBlock = 0.5+ primitive_optional_name = 0.5+ taskFun_automatic = 0.5+ taskFun_register = 0.5++ [invalid_generator.generate.case_branches]+ [invalid_generator.generate.case_branches.NegativeBinomial]+ failureRate = 0.75+ numberOfFailures = 2+ offset = 0++ [invalid_generator.generate.case_patterns]+ [invalid_generator.generate.case_patterns.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.generate.chargeStrength]+ [invalid_generator.generate.chargeStrength.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.declaration]+ [invalid_generator.generate.declaration.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.gate]+ [invalid_generator.generate.gate.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.gate_ninput]+ [invalid_generator.generate.gate_ninput.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.gate_ninputs]+ [invalid_generator.generate.gate_ninputs.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.generate.gate_noutputs]+ [invalid_generator.generate.gate_noutputs.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.generate.item]+ [invalid_generator.generate.item.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.items]+ [invalid_generator.generate.items.Poisson]+ lambda = 3.0+ offset = 0++ [invalid_generator.generate.nested_condition]+ [invalid_generator.generate.nested_condition.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.net_type]+ [invalid_generator.generate.net_type.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.net_vectoring]+ [invalid_generator.generate.net_vectoring.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.taskFun_declaration]+ [invalid_generator.generate.taskFun_declaration.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.taskFun_portType]+ [invalid_generator.generate.taskFun_portType.BiasedUniform]+ weight = 1.0++ [invalid_generator.generate.taskFun_ports]+ [invalid_generator.generate.taskFun_ports.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.generate.taskPortDir]+ [invalid_generator.generate.taskPortDir.BiasedUniform]+ weight = 1.0++ [invalid_generator.identifier]+ escaped_or_simple = 0.5++ [invalid_generator.identifier.escaped_length]+ [invalid_generator.identifier.escaped_length.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.identifier.escaped_letter]+ [invalid_generator.identifier.escaped_letter.BiasedUniform]+ weight = 1.0++ [invalid_generator.identifier.simple_length]+ [invalid_generator.identifier.simple_length.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.identifier.simple_letter]+ [invalid_generator.identifier.simple_letter.BiasedUniform]+ weight = 1.0++ [invalid_generator.identifier.system_first_letter]+ [invalid_generator.identifier.system_first_letter.BiasedUniform]+ weight = 1.0++ [invalid_generator.identifier.system_length]+ [invalid_generator.identifier.system_length.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 3+ offset = 0++ [invalid_generator.lvalue_items]+ [invalid_generator.lvalue_items.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 1+ offset = 0++ [invalid_generator.module]+ cell = 0.5+ instance_named_or_positional = 0.5+ instance_optparam = 0.5+ nonAsciiHeader = true+ port_optional = 0.5+ port_range = 0.5+ timescale_optional = 0.5++ [invalid_generator.module.blocks]+ [invalid_generator.module.blocks.Poisson]+ lambda = 2.0+ offset = 1++ [invalid_generator.module.defaultNetType]+ [invalid_generator.module.defaultNetType.BiasedUniform]+ weight = 1.0++ [invalid_generator.module.instance_parameters]+ [invalid_generator.module.instance_parameters.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.module.item]+ Discrete = [6.0, 2.0, 2.0, 3.0, 2.0, 1.0, 1.0, 1.0]++ [invalid_generator.module.items]+ [invalid_generator.module.items.Poisson]+ lambda = 3.0+ offset = 0++ [invalid_generator.module.port_count]+ [invalid_generator.module.port_count.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.module.port_dir]+ [invalid_generator.module.port_dir.BiasedUniform]+ weight = 1.0++ [invalid_generator.module.port_lvalues]+ [invalid_generator.module.port_lvalues.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.module.timescale_magnitude]+ [invalid_generator.module.timescale_magnitude.BiasedUniform]+ weight = 1.0++ [invalid_generator.module.unconnectedDrive]+ [invalid_generator.module.unconnectedDrive.BiasedUniform]+ weight = 1.0++ [invalid_generator.path_depth]+ [invalid_generator.path_depth.NegativeBinomial]+ failureRate = 0.75+ numberOfFailures = 1+ offset = 0++ [invalid_generator.primitive]+ edgeSensitive = 0.5+ outputNoChange = 0.5+ regInitNoSem = 0.5+ seq_or_comb = 0.5++ [invalid_generator.primitive.blocks]+ [invalid_generator.primitive.blocks.Poisson]+ lambda = 2.0+ offset = 0++ [invalid_generator.primitive.combInit]+ [invalid_generator.primitive.combInit.BiasedUniform]+ weight = 1.0++ [invalid_generator.primitive.edgeSimplePosNeg]+ [invalid_generator.primitive.edgeSimplePosNeg.BiasedUniform]+ weight = 1.0++ [invalid_generator.primitive.inLevel]+ [invalid_generator.primitive.inLevel.BiasedUniform]+ weight = 1.0++ [invalid_generator.primitive.outLevel]+ [invalid_generator.primitive.outLevel.BiasedUniform]+ weight = 1.0++ [invalid_generator.primitive.portType]+ [invalid_generator.primitive.portType.BiasedUniform]+ weight = 1.0++ [invalid_generator.primitive.ports]+ [invalid_generator.primitive.ports.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.primitive.tableRows]+ [invalid_generator.primitive.tableRows.Poisson]+ lambda = 4.0+ offset = 0++ [invalid_generator.specify]+ parameter_range = 0.5+ pathpulse_escaped_or_simple = 0.5+ pathpulse_term_range = 0.5+ termRange = 0.5++ [invalid_generator.specify.item]+ [invalid_generator.specify.item.BiasedUniform]+ weight = 1.0++ [invalid_generator.specify.items]+ [invalid_generator.specify.items.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.specify.path]+ edgeSensitive = 0.5+ full_or_parallel = 0.5++ [invalid_generator.specify.path.condition]+ [invalid_generator.specify.path.condition.BiasedUniform]+ weight = 1.0++ [invalid_generator.specify.path.delayKind]+ [invalid_generator.specify.path.delayKind.BiasedUniform]+ weight = 1.0++ [invalid_generator.specify.path.edgeSensitivity]+ [invalid_generator.specify.path.edgeSensitivity.BiasedUniform]+ weight = 1.0++ [invalid_generator.specify.path.full_destinations]+ [invalid_generator.specify.path.full_destinations.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.specify.path.full_sources]+ [invalid_generator.specify.path.full_sources.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.specify.path.polarity]+ [invalid_generator.specify.path.polarity.BiasedUniform]+ weight = 1.0++ [invalid_generator.specify.timingCheck]+ condition_neg_or_pos = 0.5+ condition_optional = 0.5+ delayedMinTypMax = 0.5+ event_edge = 0.25+ event_optional = 0.5+ optarg = 0.5++ [invalid_generator.statement]+ assignmentBlocking = 0.5+ attenuation = 0.7+ block_header = 0.5+ block_par_or_seq = 0.5+ optional = 0.5+ optionalDelayEventControl = 0.5+ procContAss_var_or_net = 0.5+ sysTask_optionalPort = 0.5++ [invalid_generator.statement.block_declaration]+ [invalid_generator.statement.block_declaration.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.block_declarations]+ [invalid_generator.statement.block_declarations.Poisson]+ lambda = 1.0+ offset = 0++ [invalid_generator.statement.case_branches]+ [invalid_generator.statement.case_branches.NegativeBinomial]+ failureRate = 0.75+ numberOfFailures = 2+ offset = 0++ [invalid_generator.statement.case_kind]+ [invalid_generator.statement.case_kind.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.case_patterns]+ [invalid_generator.statement.case_patterns.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.statement.delayEventRepeat]+ [invalid_generator.statement.delayEventRepeat.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.event]+ [invalid_generator.statement.event.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.event_exprs]+ [invalid_generator.statement.event_exprs.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 1+ offset = 0++ [invalid_generator.statement.event_prefix]+ [invalid_generator.statement.event_prefix.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.item]+ [invalid_generator.statement.item.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.items]+ [invalid_generator.statement.items.Poisson]+ lambda = 3.0+ offset = 0++ [invalid_generator.statement.loop]+ [invalid_generator.statement.loop.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.procContAss_assDeassForceRel]+ [invalid_generator.statement.procContAss_assDeassForceRel.BiasedUniform]+ weight = 1.0++ [invalid_generator.statement.sysTask_ports]+ [invalid_generator.statement.sysTask_ports.NegativeBinomial]+ failureRate = 0.4+ numberOfFailures = 1+ offset = 0++ [invalid_generator.type]+ abstract_or_concrete = 0.5+ concrete_bitRange = 0.5+ concrete_signedness = 0.5++ [invalid_generator.type.abstract]+ [invalid_generator.type.abstract.BiasedUniform]+ weight = 1.0++ [invalid_generator.type.dimensions]+ [invalid_generator.type.dimensions.NegativeBinomial]+ failureRate = 0.5+ numberOfFailures = 1+ offset = 0+ [probability] expr.binary = 5 expr.concatenation = 3@@ -18,6 +583,8 @@ moditem.combinational = 1 moditem.instantiation = 1 moditem.sequential = 1+ module.drop_output = 0+ module.keep_output = 1 statement.blocking = 0 statement.conditional = 1 statement.forloop = 0
+ scripts/build.sh view
@@ -0,0 +1,10 @@+#!/bin/bash++if ! [[ -z $NIX ]]; then+ if [[ $NIX -eq 0 ]]; then+ cabal update+ cabal build+ else+ nix-build+ fi+fi
src/Verismith.hs view
@@ -1,247 +1,380 @@-{-|-Module : Verismith-Description : Verismith-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--}- {-# OPTIONS_GHC -Wno-unused-top-binds #-} +-- |+-- Module : Verismith+-- Description : Verismith+-- Copyright : (c) 2018-2022, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX module Verismith- ( defaultMain+ ( defaultMain,+ -- * Types- , Opts(..)- , SourceInfo(..)+ Opts (..),+ SourceInfo (..),+ -- * Run functions- , runEquivalence- , runSimulation- , runReduce- , draw+ runEquivalence,+ runSimulation,+ runReduce,+ draw,+ -- * Verilog generation functions- , procedural- , proceduralIO- , proceduralSrc- , proceduralSrcIO- , randomMod+ procedural,+ proceduralIO,+ proceduralSrc,+ proceduralSrcIO,+ randomMod,+ -- * Extra modules- , module Verismith.Verilog- , module Verismith.Config- , module Verismith.Circuit- , module Verismith.Tool- , module Verismith.Fuzz- , module Verismith.Report- )+ module Verismith.Verilog,+ module Verismith.Config,+ module Verismith.Circuit,+ module Verismith.Tool,+ module Verismith.Fuzz,+ module Verismith.Report,+ ) where -import Control.Concurrent-import Control.Lens hiding ((<.>))-import Control.Monad.IO.Class (liftIO)-import 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 Control.Concurrent+import Control.Lens hiding ((<.>))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (runReaderT)+import Data.ByteString (ByteString)+import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import Data.ByteString.Internal (unpackChars)+import qualified Data.ByteString.Lazy as L+import qualified Data.Graph.Inductive as G import qualified Data.Graph.Inductive.Dot as G-import Data.Maybe (isNothing)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)-import qualified Data.Text.IO as T-import Hedgehog (Gen)-import qualified Hedgehog.Gen as Hog-import Hedgehog.Internal.Seed (Seed)-import Options.Applicative-import Paths_verismith (getDataDir)-import Prelude hiding (FilePath)-import Shelly hiding (command)-import Shelly.Lifted (liftSh)-import System.Random (randomIO)-import Verismith.Circuit-import Verismith.Config-import Verismith.Fuzz-import Verismith.Generate-import Verismith.OptParser-import Verismith.Reduce-import Verismith.Report-import Verismith.Result-import Verismith.Tool-import Verismith.Tool.Internal-import Verismith.Verilog-import Verismith.Verilog.Parser (parseSourceInfoFile)---- | 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 []+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 qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as LT+import Data.Time+import Hedgehog (Gen)+import qualified Hedgehog.Gen as Hog+import Hedgehog.Internal.Seed (Seed)+import Options.Applicative+import Paths_verismith (getDataDir)+import Shelly hiding (command)+import Shelly.Lifted (liftSh)+import System.Exit (exitFailure, exitSuccess)+import System.IO+import System.Random (randomIO)+import Verismith.Circuit+import Verismith.Config+import Verismith.EMI+import Verismith.Fuzz+import Verismith.Generate+import Verismith.OptParser+import Verismith.Reduce+import Verismith.Report+import Verismith.Result+import Verismith.Shuffle+import Verismith.Tool+import Verismith.Tool.Internal+import Verismith.Utils (generateByteString)+import Verismith.Verilog+import Verismith.Verilog.Distance+import Verismith.Verilog.Parser (parseSourceInfoFile)+import qualified Verismith.Verilog2005 as V2+import Prelude hiding (FilePath) toFP :: String -> FilePath toFP = fromText . T.pack myForkIO :: IO () -> IO (MVar ()) myForkIO io = do- mvar <- newEmptyMVar- _ <- forkFinally io (\_ -> putMVar mvar ())- return mvar+ mvar <- newEmptyMVar+ _ <- forkFinally io (\_ -> putMVar mvar ())+ return mvar -getConfig :: Maybe FilePath -> IO Config-getConfig s =- maybe (return defaultConfig) parseConfigFile $ T.unpack . toTextIgnore <$> s+logMsg :: Text -> Text -> IO ()+logMsg level msg = do+ currentTime <- getZonedTime+ T.putStrLn $+ "["+ <> level+ <> "] "+ <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime)+ <> msg -getGenerator :: Config -> Text -> Maybe FilePath -> IO (Gen SourceInfo)+logInfo :: Text -> IO ()+logInfo = logMsg "INFO"++logWarn :: Text -> IO ()+logWarn = logMsg "WARN"++logFatal :: Text -> IO ()+logFatal = logMsg "FATAL"++getConfig' :: Bool -> Maybe FilePath -> IO Config+getConfig' strict s = do+ config <- maybe def (parseConfigFile . T.unpack . toTextIgnore) s+ case config of+ Left errFst -> do+ when strict $ mapM_ logFatal (T.lines errFst) >> exitFailure+ relaxedConfig <- maybe def (parseConfigFileRelaxed . T.unpack . toTextIgnore) s+ case relaxedConfig of+ Left errSnd -> do+ mapM_ logFatal $ T.lines errSnd+ exitFailure+ Right x -> do+ mapM_ logWarn (T.lines errFst)+ logWarn "Ignoring additional fields"+ return x+ Right x -> return x+ where+ def = return (Right defaultConfig)++getConfig = getConfig' True++getGenerator :: Config -> Text -> Maybe FilePath -> IO (Gen (SourceInfo ())) getGenerator config top s =- maybe (return $ proceduralSrc top config) (fmap return . parseSourceInfoFile top)- $ toTextIgnore <$> s+ maybe (return $ proceduralSrc top config) (fmap return . parseSourceInfoFile top) $+ toTextIgnore <$> s -- | Randomly remove an option by setting it to 0. randDelete :: Int -> IO Int randDelete i = do- r <- randomIO- return $ if r then i else 0+ r <- randomIO+ return $ if r then i else 0 randomise :: Config -> IO Config-randomise config@(Config a _ c d e) = do- mia <- return $ cm ^. probModItemAssign- misa <- return $ cm ^. probModItemSeqAlways- mica <- return $ cm ^. probModItemCombAlways- mii <- return $ cm ^. probModItemInst- ssb <- return $ cs ^. probStmntBlock- ssnb <- return $ cs ^. probStmntNonBlock- ssc <- return $ cs ^. probStmntCond- ssf <- return $ cs ^. probStmntFor- en <- return $ ce ^. probExprNum- 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+randomise config@(Config emi a _ c d e f) = do+ mia <- return $ cm ^. probModItemAssign+ misa <- return $ cm ^. probModItemSeqAlways+ mica <- return $ cm ^. probModItemCombAlways+ mii <- return $ cm ^. probModItemInst+ ssb <- return $ cs ^. probStmntBlock+ ssnb <- return $ cs ^. probStmntNonBlock+ ssc <- return $ cs ^. probStmntCond+ ssf <- return $ cs ^. probStmntFor+ en <- return $ ce ^. probExprNum+ keep_out <- return $ cmo ^. probModDropOutput+ drop_out <- randDelete $ cmo ^. probModDropOutput+ ei <- randDelete $ ce ^. probExprId+ ers <- randDelete $ ce ^. probExprRangeSelect+ euo <- randDelete $ ce ^. probExprUnOp+ ebo <- randDelete $ ce ^. probExprBinOp+ ec <- randDelete $ ce ^. probExprCond+ eco <- randDelete $ ce ^. probExprConcat+ estr <- randDelete $ ce ^. probExprStr+ esgn <- randDelete $ ce ^. probExprSigned+ eus <- randDelete $ ce ^. probExprUnsigned+ return $+ Config+ emi+ a+ ( Probability+ (ProbModItem mia misa mica mii)+ (ProbStatement ssb ssnb ssc ssf)+ (ProbExpr en ei ers euo ebo ec eco estr esgn eus)+ (ProbMod drop_out keep_out)+ )+ c+ d+ e+ f where cm = config ^. configProbability . probModItem cs = config ^. configProbability . probStmnt ce = config ^. configProbability . probExpr+ cmo = config ^. configProbability . probMod handleOpts :: Opts -> IO () handleOpts (Fuzz o configF f k n nosim noequiv noreduction file top cc checker) = do- config <- getConfig configF- gen <- getGenerator config top file- datadir <- getDataDir- _ <- runFuzz- (FuzzOpts (Just $ fromText o)- f k n nosim noequiv noreduction config (toFP datadir) cc checker)- defaultYosys- (fuzzMultiple gen)- return ()-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 t o rc) = do- verilogSrc <- T.readFile file- case parseVerilog (T.pack file) verilogSrc of- Left l -> print l- Right v ->- case (o, GenVerilog- . mapply rc (takeReplace . removeConstInConcat)- $ SourceInfo t v) of- (Nothing, a) -> print a- (Just o', a) -> writeFile (T.unpack $ toTextIgnore o') $ show a+ config <- getConfig configF+ gen <- getGenerator config top file+ datadir <- getDataDir+ _ <-+ runFuzz+ ( FuzzOpts+ (Just $ fromText o)+ f+ k+ n+ nosim+ noequiv+ noreduction+ config+ (toFP datadir)+ cc+ checker+ )+ defaultYosys+ (fuzzMultiple gen)+ return ()+handleOpts (EMIOpts o configF f k n nosim noequiv noreduction top file) = do+ config <- getConfig configF+ datadir <- getDataDir+ src <- parseSourceInfoFile top (T.pack file) :: IO (SourceInfo ())+ let gen = proceduralEMI src config+ _ <-+ runFuzz+ ( FuzzOpts+ (Just $ fromText o)+ f+ k+ n+ nosim+ noequiv+ noreduction+ config+ (toFP datadir)+ False+ Nothing+ )+ defaultYosys+ (fuzzMultipleEMI gen)+ return ()+handleOpts (Generate f c sf popts) = do+ config <- getConfig c+ if sf+ then do+ source <- V2.runGarbageGeneration config+ maybe L.putStr L.writeFile f $ V2.genSource (Just 80) popts source+ else do+ source <- proceduralIO "top" config :: IO (Verilog ())+ maybe T.putStrLn T.writeFile (T.unpack . toTextIgnore <$> f) $ genSource source+handleOpts (Parse f o s popts) = do+ (ast, warns) <- V2.parseVerilog2005 (T.unpack (toTextIgnore f))+ mapM_ (hPutStrLn stderr) warns+ if null warns || not s+ then pure ()+ else error "Input file does not comply strictly with the Verilog 2005 standard"+ maybe L.putStr L.writeFile o $ V2.genSource (Just 80) popts ast+handleOpts (ShuffleOpt f t o nshuffle nrename noequiv equivdir checker) = do+ datadir <- getDataDir+ verilogSrc <- T.readFile file+ case parseVerilog (T.pack file) verilogSrc of+ Left l -> print l+ Right v -> do+ let sv = SourceInfo t v+ sv' <- runShuffle nshuffle nrename sv+ let gv = GenVerilog sv' :: GenVerilog (SourceInfo ())+ if noequiv+ then return ()+ else do+ shelly $ do+ mkdir equivdir+ cp file (equivdir </> fn1)+ writeFile (equivdir </> fn2) $ show gv+ res <- shelly . runResultT $+ pop equivdir $ do+ runEquiv checker (toFP datadir) (mkid fn1) (mkid fn2) sv'+ 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"+ case o of+ Nothing -> print gv+ Just o' -> writeFile (T.unpack $ toTextIgnore o') $ show gv where file = T.unpack . toTextIgnore $ f- mapply i f = if i then f else id+ fn1 = "rtl1.v"+ fn2 = "rtl2.v"+ mkid f = Verismith.Tool.Identity "" (fromText 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 Nothing (toFP datadir) 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"+ src <- parseSourceInfoFile t (toTextIgnore f)+ datadir <- getDataDir+ case descriptionToSynth <$> ls' of+ a : b : _ -> do+ putStrLn "Reduce with equivalence check"+ shelly $ do+ make dir+ pop dir $ do+ src' <- reduceSynth Nothing (toFP datadir) a b src :: Sh (SourceInfo ())+ writefile (fromText ".." </> dir <.> "v") $ genSource src'+ a : _ -> do+ putStrLn "Reduce with synthesis failure"+ shelly $ do+ make dir+ pop dir $ do+ src' <- reduceSynthesis a src+ writefile (fromText ".." </> dir <.> "v") $ genSource src'+ _ -> do+ putStrLn "Not reducing because no synthesiser was specified"+ return ()+ where+ dir = fromText "reduce" handleOpts (Reduce f t _ ls' True) = do- src <- parseSourceInfoFile t (toTextIgnore f)- datadir <- getDataDir- case descriptionToSynth <$> ls' of- a : b : _ -> do- putStrLn "Starting equivalence check"- res <- shelly . runResultT $ do- make dir- pop dir $ do- runSynth a src- runSynth b src- runEquiv Nothing (toFP datadir) a b src- case res of- Pass _ -> putStrLn "Equivalence check passed"- Fail (EquivFail _) -> putStrLn "Equivalence check failed"- Fail TimeoutError -> putStrLn "Equivalence check timed out"- Fail _ -> putStrLn "Equivalence check error"- return ()- as -> do- putStrLn "Synthesis check"- _ <- shelly . runResultT $ mapM (flip runSynth src) as- return ()- where dir = fromText "equiv"+ src <- parseSourceInfoFile t (toTextIgnore f) :: IO (SourceInfo ())+ datadir <- getDataDir+ case descriptionToSynth <$> ls' of+ a : b : _ -> do+ putStrLn "Starting equivalence check"+ res <- shelly . runResultT $ do+ make dir+ pop dir $ do+ runSynth a src+ runSynth b src+ runEquiv Nothing (toFP datadir) a b src+ case res of+ Pass _ -> putStrLn "Equivalence check passed"+ Fail (EquivFail _) -> putStrLn "Equivalence check failed"+ Fail TimeoutError -> putStrLn "Equivalence check timed out"+ Fail _ -> putStrLn "Equivalence check error"+ return ()+ as -> do+ putStrLn "Synthesis check"+ _ <- shelly . runResultT $ mapM (flip runSynth src) as+ return ()+ where+ dir = fromText "equiv" handleOpts (ConfigOpt c conf r) = do- config <- if r then getConfig conf >>= randomise else getConfig conf- maybe (T.putStrLn . encodeConfig $ config) (`encodeConfigFile` config)- $ T.unpack- . toTextIgnore- <$> c+ config <- if r then getConfig conf >>= randomise else getConfig conf+ maybe (T.putStrLn . encodeConfig $ config) (`encodeConfigFile` config) $+ T.unpack+ . toTextIgnore+ <$> c+handleOpts (DistanceOpt v1 v2) = do+ src1 <- parseSourceInfoFile (T.pack v1) (toTextIgnore v1)+ src2 <- parseSourceInfoFile (T.pack v2) (toTextIgnore v2)+ let d = distance src1 src2+ putStrLn ("Distance: " <> show d)+handleOpts (Equiv o v1 v2 top checker) = do+ datadir <- getDataDir+ src <- parseSourceInfoFile top (toTextIgnore v1) :: IO (SourceInfo ())+ shelly $ do+ mkdir o+ cp v1 (o </> fn1)+ cp v2 (o </> fn2)+ res <- shelly . runResultT $+ pop o $ do+ runEquiv checker (toFP datadir) (mkid fn1) (mkid fn2) 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"+ where+ fn1 = "rtl1.v"+ fn2 = "rtl2.v"+ mkid f = Verismith.Tool.Identity "" (fromText f) defaultMain :: IO () defaultMain = do- optsparsed <- execParser opts- handleOpts optsparsed+ optsparsed <- execParser opts+ handleOpts optsparsed -makeSrcInfo :: ModDecl -> SourceInfo+makeSrcInfo :: (ModDecl ann) -> (SourceInfo ann) 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"]+ 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@@ -256,80 +389,85 @@ -- 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"-+ rand <- generateByteString Nothing 32 20+ rand2 <- Hog.sample (randomMod 10 100) :: IO (ModDecl ())+ val <- shelly . runResultT $ runSim defaultIcarus (makeSrcInfo rand2) rand+ case val of+ Pass a -> T.putStrLn $ showBS a+ _ -> T.putStrLn "Test failed" -- | Code to be executed on a failure. Also checks if the failure was a timeout, -- as the timeout command will return the 124 error code if that was the -- case. In that case, the error will be moved to a different directory. onFailure :: Text -> RunFailed -> Sh (Result Failed ()) onFailure t _ = do- ex <- lastExitCode- case ex of- 124 -> do- logger "Test TIMEOUT"- chdir ".." $ cp_r (fromText t) $ fromText (t <> "_timeout")- return $ Fail EmptyFail- _ -> do- logger "Test FAIL"- chdir ".." $ cp_r (fromText t) $ fromText (t <> "_failed")- return $ Fail EmptyFail+ ex <- lastExitCode+ case ex of+ 124 -> do+ logger "Test TIMEOUT"+ chdir ".." $ cp_r (fromText t) $ fromText (t <> "_timeout")+ return $ Fail EmptyFail+ _ -> do+ logger "Test FAIL"+ chdir ".." $ cp_r (fromText t) $ fromText (t <> "_failed")+ return $ Fail EmptyFail -checkEquivalence :: SourceInfo -> Text -> IO Bool+checkEquivalence :: (Show ann) => SourceInfo ann -> Text -> IO Bool checkEquivalence src dir = shellyFailDir $ do- mkdir_p (fromText dir)- curr <- toTextIgnore <$> pwd- datadir <- liftIO getDataDir- setenv "VERISMITH_ROOT" curr- cd (fromText dir)- catch_sh- ((runResultT $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado src) >> return True)- ((\_ -> return False) :: RunFailed -> Sh Bool)+ mkdir_p (fromText dir)+ curr <- toTextIgnore <$> pwd+ datadir <- liftIO getDataDir+ setenv "VERISMITH_ROOT" curr+ cd (fromText dir)+ catch_sh+ ((runResultT $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado src) >> return True)+ ((\_ -> return False) :: RunFailed -> Sh Bool) -- | Run a fuzz run and check if all of the simulators passed by checking if the -- generated Verilog files are equivalent.-runEquivalence- :: Maybe Seed- -> Gen Verilog -- ^ Generator for the Verilog file.- -> Text -- ^ Name of the folder on each thread.- -> Text -- ^ Name of the general folder being used.- -> Bool -- ^ Keep flag.- -> Int -- ^ Used to track the recursion.- -> IO ()+runEquivalence ::+ Maybe Seed ->+ -- | Generator for the Verilog file.+ Gen (Verilog ()) ->+ -- | Name of the folder on each thread.+ Text ->+ -- | Name of the general folder being used.+ Text ->+ -- | Keep flag.+ Bool ->+ -- | Used to track the recursion.+ Int ->+ IO () runEquivalence seed gm t d k i = do- (_, m) <- shelly $ sampleSeed seed gm- let srcInfo = SourceInfo "top" m- rand <- generateByteString 20- datadir <- getDataDir- shellyFailDir $ do- mkdir_p (fromText d </> fromText n)- curr <- toTextIgnore <$> pwd- setenv "VERISMITH_ROOT" curr- cd (fromText "output" </> fromText n)- _ <-- catch_sh- ( runResultT- $ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado srcInfo- >> liftSh (logger "Test OK")- )- $ onFailure n- _ <-- catch_sh- ( runResultT- $ runSim (Icarus "iverilog" "vvp") srcInfo rand- >>= (\b -> liftSh $ logger ("RTL Sim: " <> showBS b))- )- $ onFailure n- cd ".."- unless k . rm_rf $ fromText n- when (i < 5 && isNothing seed) (runEquivalence seed gm t d k $ i + 1)- where n = t <> "_" <> T.pack (show i)+ (_, m) <- shelly $ sampleSeed seed gm+ let srcInfo = SourceInfo "top" m+ rand <- generateByteString Nothing 32 20+ datadir <- getDataDir+ shellyFailDir $ do+ mkdir_p (fromText d </> fromText n)+ curr <- toTextIgnore <$> pwd+ setenv "VERISMITH_ROOT" curr+ cd (fromText "output" </> fromText n)+ _ <-+ catch_sh+ ( runResultT $+ runEquiv Nothing (toFP datadir) defaultYosys defaultVivado srcInfo+ >> liftSh (logger "Test OK")+ )+ $ onFailure n+ _ <-+ catch_sh+ ( runResultT $+ runSim (Icarus "iverilog" "vvp") srcInfo rand+ >>= (\b -> liftSh $ logger ("RTL Sim: " <> showBS b))+ )+ $ onFailure n+ cd ".."+ unless k . rm_rf $ fromText n+ when (i < 5 && isNothing seed) (runEquivalence seed gm t d k $ i + 1)+ where+ n = t <> "_" <> T.pack (show i) -runReduce :: SourceInfo -> IO SourceInfo+runReduce :: (SourceInfo ()) -> IO (SourceInfo ()) runReduce s =- shelly $ reduce "reduce.v" (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s+ shelly $ reduce "reduce.v" (\s' -> not <$> liftIO (checkEquivalence s' "reduce")) s
src/Verismith/Circuit.hs view
@@ -1,45 +1,43 @@-{-|-Module : Verismith.Circuit-Description : Definition of the circuit graph.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Definition of the circuit graph.--}-+-- |+-- Module : Verismith.Circuit+-- Description : Definition of the circuit graph.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Definition of the circuit graph. module Verismith.Circuit- ( -- * Circuit- Gate(..)- , Circuit(..)- , CNode(..)- , CEdge(..)- , fromGraph- , generateAST- , rDups- , rDupsCirc- , randomDAG- , genRandomDAG- )+ ( -- * Circuit+ Gate (..),+ Circuit (..),+ CNode (..),+ CEdge (..),+ fromGraph,+ generateAST,+ rDups,+ rDupsCirc,+ randomDAG,+ genRandomDAG,+ ) where -import Control.Lens-import Hedgehog (Gen)-import qualified Hedgehog.Gen as Hog-import Verismith.Circuit.Base-import Verismith.Circuit.Gen-import Verismith.Circuit.Random-import Verismith.Verilog.AST-import Verismith.Verilog.Mutate+import Control.Lens+import Hedgehog (Gen)+import qualified Hedgehog.Gen as Hog+import Verismith.Circuit.Base+import Verismith.Circuit.Gen+import Verismith.Circuit.Random+import Verismith.Verilog.AST+import Verismith.Verilog.Mutate -fromGraph :: Gen ModDecl+fromGraph :: Gen (ModDecl ann) fromGraph = do- gr <- rDupsCirc <$> Hog.resize 100 randomDAG- return- $ initMod- . head- $ nestUpTo 5 (generateAST gr)+ gr <- rDupsCirc <$> Hog.resize 100 randomDAG+ return $+ initMod+ . head+ $ nestUpTo 5 (generateAST gr) ^.. _Wrapped- . traverse+ . traverse
src/Verismith/Circuit/Base.hs view
@@ -1,40 +1,39 @@-{-|-Module : Verismith.Circuit.Base-Description : Base types for the circuit module.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Base types for the circuit module.--}-+-- |+-- Module : Verismith.Circuit.Base+-- Description : Base types for the circuit module.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Base types for the circuit module. module Verismith.Circuit.Base- ( Gate(..)- , Circuit(..)- , CNode(..)- , CEdge(..)- )+ ( Gate (..),+ Circuit (..),+ CNode (..),+ CEdge (..),+ ) where -import Data.Graph.Inductive (Gr, LEdge, LNode)-import System.Random+import Data.Graph.Inductive (Gr, LEdge, LNode)+import System.Random -- | The types for all the gates.-data Gate = And- | Or- | Xor- deriving (Show, Eq, Enum, Bounded, Ord)+data Gate+ = And+ | Or+ | Xor+ deriving (Show, Eq, Enum, Bounded, Ord) -- | Newtype for the Circuit which implements a Graph from fgl.-newtype Circuit = Circuit { getCircuit :: Gr Gate () }+newtype Circuit = Circuit {getCircuit :: Gr Gate ()} -- | Newtype for a node in the circuit, which is an 'LNode Gate'.-newtype CNode = CNode { getCNode :: LNode Gate }+newtype CNode = CNode {getCNode :: LNode Gate} -- | Newtype for a named edge which is empty, as it does not need a label.-newtype CEdge = CEdge { getCEdge :: LEdge () }+newtype CEdge = CEdge {getCEdge :: LEdge ()} instance Random Gate where randomR (a, b) g =
src/Verismith/Circuit/Gen.hs view
@@ -1,27 +1,25 @@-{-|-Module : Verilog.Circuit.Gen-Description : Generate verilog from circuit.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Generate verilog from circuit.--}-+-- |+-- Module : Verilog.Circuit.Gen+-- Description : Generate verilog from circuit.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Generate verilog from circuit. module Verismith.Circuit.Gen- ( generateAST- )+ ( generateAST,+ ) where -import Data.Graph.Inductive (LNode, Node)-import qualified Data.Graph.Inductive as G-import Data.Maybe (catMaybes)-import Verismith.Circuit.Base-import Verismith.Circuit.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.Mutate+import Data.Graph.Inductive (LNode, Node)+import qualified Data.Graph.Inductive as G+import Data.Maybe (catMaybes)+import Verismith.Circuit.Base+import Verismith.Circuit.Internal+import Verismith.Verilog.AST+import Verismith.Verilog.Mutate -- | Converts a 'CNode' to an 'Identifier'. frNode :: Node -> Identifier@@ -31,7 +29,7 @@ -- mapping. fromGate :: Gate -> BinaryOperator fromGate And = BinAnd-fromGate Or = BinOr+fromGate Or = BinOr fromGate Xor = BinXor inputsC :: Circuit -> [Node]@@ -43,8 +41,8 @@ -- | Generates the nested expression AST, so that it can then generate the -- assignment expressions. genAssignExpr :: Gate -> [Node] -> Maybe Expr-genAssignExpr _ [] = Nothing-genAssignExpr _ [n ] = Just . Id $ frNode n+genAssignExpr _ [] = Nothing+genAssignExpr _ [n] = Just . Id $ frNode n genAssignExpr g (n : ns) = BinOp wire oper <$> genAssignExpr g ns where wire = Id $ frNode n@@ -53,27 +51,27 @@ -- | 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 :: Circuit -> LNode Gate -> Maybe (ModItem ann) genContAssignAST c (n, g) = ModCA . ContAssign name <$> genAssignExpr g nodes where- gr = getCircuit c+ gr = getCircuit c nodes = G.pre gr n- name = frNode n+ name = frNode n -genAssignAST :: Circuit -> [ModItem]+genAssignAST :: Circuit -> [ModItem ann] genAssignAST c = catMaybes $ genContAssignAST c <$> nodes where- gr = getCircuit c+ gr = getCircuit c nodes = G.labNodes gr -genModuleDeclAST :: Circuit -> ModDecl+genModuleDeclAST :: Circuit -> (ModDecl ann) genModuleDeclAST c = ModDecl i output ports (combineAssigns yPort a) [] where- i = Identifier "gen_module"- ports = genPortsAST inputsC c+ i = Identifier "gen_module"+ ports = genPortsAST inputsC c output = []- a = genAssignAST c- yPort = Port Wire False 90 "y"+ a = genAssignAST c+ yPort = Port Wire False 90 "y" -generateAST :: Circuit -> Verilog+generateAST :: Circuit -> (Verilog ann) generateAST c = Verilog [genModuleDeclAST c]
src/Verismith/Circuit/Internal.hs view
@@ -1,27 +1,25 @@-{-|-Module : Verismith.Circuit.Internal-Description : Internal helpers for generation.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Internal helpers for generation.--}-+-- |+-- Module : Verismith.Circuit.Internal+-- Description : Internal helpers for generation.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Internal helpers for generation. module Verismith.Circuit.Internal- ( fromNode- , filterGr- , only- , inputs- , outputs- )+ ( fromNode,+ filterGr,+ only,+ inputs,+ outputs,+ ) where -import Data.Graph.Inductive (Graph, Node)+import Data.Graph.Inductive (Graph, Node) import qualified Data.Graph.Inductive as G-import qualified Data.Text as T+import qualified Data.Text as T -- | Convert an integer into a label. --@@ -36,13 +34,13 @@ -- | Takes two functions that return an 'Int', and compares there results to 0 -- and not 0 respectively. This result is returned.-only- :: (Graph gr)- => gr n e- -> (gr n e -> Node -> Int)- -> (gr n e -> Node -> Int)- -> Node- -> Bool+only ::+ (Graph gr) =>+ gr n e ->+ (gr n e -> Node -> Int) ->+ (gr n e -> Node -> Int) ->+ Node ->+ Bool only graph fun1 fun2 n = fun1 graph n == 0 && fun2 graph n /= 0 -- | Returns all the input nodes to a graph, which means nodes that do not have
src/Verismith/Circuit/Random.hs view
@@ -1,35 +1,34 @@-{-|-Module : Verismith.Circuit.Random-Description : Random generation for DAG-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Define the random generation for the directed acyclic graph.--}-+-- |+-- Module : Verismith.Circuit.Random+-- Description : Random generation for DAG+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Define the random generation for the directed acyclic graph. module Verismith.Circuit.Random- ( rDups- , rDupsCirc- , randomDAG- , genRandomDAG- )+ ( rDups,+ rDupsCirc,+ randomDAG,+ genRandomDAG,+ ) where -import Data.Graph.Inductive (Context)-import qualified Data.Graph.Inductive as G-import Data.Graph.Inductive.PatriciaTree (Gr)-import Data.List (nub)-import Hedgehog (Gen)-import qualified Hedgehog.Gen as Hog-import qualified Hedgehog.Range as Hog-import Verismith.Circuit.Base+import Data.Graph.Inductive (Context)+import qualified Data.Graph.Inductive as G+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.List (nub)+import Hedgehog (Gen)+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as Hog+import Verismith.Circuit.Base dupFolder :: (Eq a, Eq b) => Context a b -> [Context a b] -> [Context a b] dupFolder cont ns = unique cont : ns- where unique (a, b, c, d) = (nub a, b, c, nub d)+ where+ unique (a, b, c, d) = (nub a, b, c, nub d) -- | Remove duplicates. rDups :: (Eq a, Eq b) => Gr a b -> Gr a b@@ -43,21 +42,26 @@ -- `n` that is passed to it. arbitraryEdge :: Hog.Size -> Gen CEdge arbitraryEdge n = do- x <- with $ \a -> a < n && a > 0 && a /= n - 1- y <- with $ \a -> x < a && a < n && a > 0- return $ CEdge (fromIntegral x, fromIntegral y, ())+ x <- with $ \a -> a < n && a > 0 && a /= n - 1+ y <- with $ \a -> x < a && a < n && a > 0+ return $ CEdge (fromIntegral x, fromIntegral y, ()) where- with = flip Hog.filter $ fromIntegral <$> Hog.resize- n- (Hog.int (Hog.linear 0 100))+ with =+ flip Hog.filter $+ fromIntegral+ <$> Hog.resize+ n+ (Hog.int (Hog.linear 0 100)) -- | Gen instance for a random acyclic DAG.-randomDAG :: Gen Circuit -- ^ The generated graph. It uses Arbitrary to generate- -- random instances of each node+randomDAG ::+ -- | The generated graph. It uses Arbitrary to generate+ -- random instances of each node+ Gen Circuit randomDAG = do- list <- Hog.list (Hog.linear 1 100) $ Hog.enum minBound maxBound- l <- Hog.list (Hog.linear 10 1000) aE- return . Circuit $ G.mkGraph (nodes list) l+ list <- Hog.list (Hog.linear 1 100) $ Hog.enum minBound maxBound+ l <- Hog.list (Hog.linear 10 1000) aE+ return . Circuit $ G.mkGraph (nodes list) l where nodes l = zip [0 .. length l - 1] l aE = getCEdge <$> Hog.sized arbitraryEdge
src/Verismith/Config.hs view
@@ -1,533 +1,1501 @@-{-|-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- , fromQuartusLight- , 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- , propDefaultYosys- , parseConfigFile- , parseConfig- , encodeConfig- , encodeConfigFile- , versionInfo- )-where--import Control.Applicative (Alternative)-import Control.Lens hiding ((.=))-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-import qualified Data.Text.IO as T-import Data.Version (showVersion)-import Development.GitRev-import Hedgehog.Internal.Seed (Seed)-import Paths_verismith (version)-import Shelly (toTextIgnore)-import Toml (TomlCodec, (.=))-import qualified Toml-import Verismith.Tool.Quartus-import Verismith.Tool.QuartusLight-import Verismith.Tool.Vivado-import Verismith.Tool.XST-import Verismith.Tool.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--- <http://iverilog.icarus.com/ Icarus Verilog>.------ [@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:------ - <https://www.intel.com/content/www/us/en/programmable/downloads/download-center.html Quartus>--- - <https://www.xilinx.com/products/design-tools/ise-design-suite.html ISE Design Suite>--- - <https://www.xilinx.com/products/design-tools/ise-design-suite.html Vivado Design Suite>--- - <http://www.clifford.at/yosys/ Yosys Open SYnthesis Suite>---- | Probability of different expressions nodes.-data ProbExpr = ProbExpr { _probExprNum :: {-# UNPACK #-} !Int- -- ^ @expr.number@: probability of generation a number like- -- @4'ha@. This should never be set to 0, as it is used- -- as a fallback in case there are no viable- -- identifiers, such as none being in scope.- , _probExprId :: {-# UNPACK #-} !Int- -- ^ @expr.variable@: probability of generating an identifier that is in- -- scope and of the right type.- , _probExprRangeSelect :: {-# UNPACK #-} !Int- -- ^ @expr.rangeselect@: probability of generating a range- -- selection from a port (@reg1[2:0]@).- , _probExprUnOp :: {-# UNPACK #-} !Int- -- ^ @expr.unary@: probability of generating a unary operator.- , _probExprBinOp :: {-# UNPACK #-} !Int- -- ^ @expr.binary@: probability of generation a binary operator.- , _probExprCond :: {-# UNPACK #-} !Int- -- ^ @expr.ternary@: probability of generating a conditional ternary- -- operator.- , _probExprConcat :: {-# UNPACK #-} !Int- -- ^ @expr.concatenation@: probability of generating a concatenation.- , _probExprStr :: {-# UNPACK #-} !Int- -- ^ @expr.string@: probability of generating a string. This is not- -- fully supported therefore currently cannot be set.- , _probExprSigned :: {-# UNPACK #-} !Int- -- ^ @expr.signed@: probability of generating a signed function- -- @$signed(...)@.- , _probExprUnsigned :: {-# UNPACK #-} !Int- -- ^ @expr.unsigned@: probability of generating an unsigned function- -- @$unsigned(...)@.- }- deriving (Eq, Show)---- | Probability of generating different nodes inside a module declaration.-data ProbModItem = ProbModItem { _probModItemAssign :: {-# UNPACK #-} !Int- -- ^ @moditem.assign@: probability of generating an @assign@.- , _probModItemSeqAlways :: {-# UNPACK #-} !Int- -- ^ @moditem.sequential@: probability of generating a sequential @always@ block.- , _probModItemCombAlways :: {-# UNPACK #-} !Int- -- ^ @moditem.combinational@: probability of generating an combinational @always@- -- block. This is currently not implemented.- , _probModItemInst :: {-# UNPACK #-} !Int- -- ^ @moditem.instantiation@: probability of generating a module- -- instantiation.- }- deriving (Eq, Show)---- | Probability of generating different statements.-data ProbStatement = ProbStatement { _probStmntBlock :: {-# UNPACK #-} !Int- -- ^ @statement.blocking@: probability of generating blocking assignments.- , _probStmntNonBlock :: {-# UNPACK #-} !Int- -- ^ @statement.nonblocking@: probability of generating nonblocking assignments.- , _probStmntCond :: {-# UNPACK #-} !Int- -- ^ @statement.conditional@: probability of generating conditional- -- statements (@if@ statements).- , _probStmntFor :: {-# UNPACK #-} !Int- -- ^ @statement.forloop@: probability of generating for loops.- }- deriving (Eq, Show)---- | @[probability]@: combined probabilities.-data Probability = Probability { _probModItem :: {-# UNPACK #-} !ProbModItem- -- ^ Probabilities for module items.- , _probStmnt :: {-# UNPACK #-} !ProbStatement- -- ^ Probabilities for statements.- , _probExpr :: {-# UNPACK #-} !ProbExpr- -- ^ Probaiblities for expressions.- }- deriving (Eq, Show)---- | @[property]@: properties for the generated Verilog file.-data ConfProperty = ConfProperty { _propSize :: {-# UNPACK #-} !Int- -- ^ @size@: the size of the generated Verilog.- , _propSeed :: !(Maybe Seed)- -- ^ @seed@: a possible seed that could be used to- -- generate the same Verilog.- , _propStmntDepth :: {-# UNPACK #-} !Int- -- ^ @statement.depth@: the maximum statement depth that should be- -- reached.- , _propModDepth :: {-# UNPACK #-} !Int- -- ^ @module.depth@: the maximium module depth that should be- -- reached.- , _propMaxModules :: {-# UNPACK #-} !Int- -- ^ @module.max@: the maximum number of modules that are- -- allowed to be created at each level.- , _propSampleMethod :: !Text- -- ^ @sample.method@: the sampling method that should be used to- -- generate specific distributions of random- -- programs.- , _propSampleSize :: {-# UNPACK #-} !Int- -- ^ @sample.size@: the number of samples to take for the- -- sampling method.- , _propCombine :: !Bool- -- ^ @output.combine@: if the output should be combined into one- -- bit or not.- , _propNonDeterminism :: {-# UNPACK #-} !Int- -- ^ @nondeterminism@: the frequency at which nondeterminism- -- should be generated (currently a work in progress).- , _propDeterminism :: {-# UNPACK #-} !Int- -- ^ @determinism@: the frequency at which determinism should- -- be generated (currently modules are always deterministic).- , _propDefaultYosys :: !(Maybe Text)- -- ^ @default.yosys@: Default location for Yosys, which will be used for- -- equivalence checking.- }- deriving (Eq, Show)--data Info = Info { _infoCommit :: !Text- -- ^ @commit@: the hash of the commit that was compiled.- , _infoVersion :: !Text- -- ^ @version@: the version of Verismith that was compiled.- }- deriving (Eq, Show)---- | Description of the simulator-data SimDescription = SimDescription { simName :: {-# UNPACK #-} !Text }- deriving (Eq, Show)---- | @[[synthesiser]]@: description of the synthesis tool. There can be multiple of these sections in a config--- file.-data SynthDescription = SynthDescription { synthName :: {-# UNPACK #-} !Text- -- ^ @name@: type of the synthesis tool. Can either be @yosys@, @quartus@,- -- @quartuslight@, @vivado@, @xst@.- , synthBin :: Maybe Text- -- ^ @bin@: location of the synthesis tool binary.- , synthDesc :: Maybe Text- -- ^ @description@: description that should be used for the synthesis tool.- , synthOut :: Maybe Text- -- ^ @output@: name of the output Verilog file.- }- deriving (Eq, Show)--data Config = Config { _configInfo :: Info- , _configProbability :: {-# UNPACK #-} !Probability- , _configProperty :: {-# UNPACK #-} !ConfProperty- , _configSimulators :: [SimDescription]- , _configSynthesisers :: [SynthDescription]- }- deriving (Eq, Show)--$(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)--fromQuartusLight :: QuartusLight -> SynthDescription-fromQuartusLight (QuartusLight a b c) = SynthDescription "quartuslight"- (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 Nothing)- []- [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- <*> Toml.dioptional (Toml.text (twoKey "default" "yosys"))- .= _propDefaultYosys- 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)- <> ")"+-- Module : Verismith.Config+-- Description : TOML Configuration file format and parser.+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX++{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TemplateHaskell #-}++module Verismith.Config+ ( -- * TOML Configuration+ -- $conf+ Config (..),+ defaultConfig,++ -- ** Probabilities+ Probability (..),++ -- *** Expression+ ProbExpr (..),++ -- *** Module Item+ ProbModItem (..),++ -- *** Statement+ ProbStatement (..),++ -- *** Module+ ProbMod (..),++ -- ** EMI Configuration+ ConfEMI (..),++ -- ** ConfProperty+ ConfProperty (..),++ -- ** ConfGarbage+ NumberProbability (..),+ CategoricalProbability (..),+ uniformCP,+ GarbageOpts (..),+ GarbageConfigOpts (..),+ GarbagePrimitiveOpts (..),+ GarbageModuleOpts (..),+ GarbageSpecifyOpts (..),+ GarbageSpecifyPathOpts (..),+ GarbageSpecifyTimingCheckOpts (..),+ GarbageGenerateOpts (..),+ GarbageTypeOpts (..),+ GarbageAttenuationOpts (..),+ GarbageStatementOpts (..),+ GarbageExprOpts (..),+ GarbageIdentifierOpts (..),+ defGarbageOpts,++ -- ** Simulator Description+ SimDescription (..),++ -- ** Synthesiser Description+ SynthDescription (..),++ -- * Useful Lenses+ fromXST,+ fromYosys,+ fromVivado,+ fromQuartus,+ fromQuartusLight,+ configEMI,+ configProbability,+ configGarbageGenerator,+ configProperty,+ configSimulators,+ configSynthesisers,+ confEMIGenerateProb,+ confEMINoGenerateProb,+ probModItem,+ probMod,+ probModDropOutput,+ probModKeepOutput,+ probStmnt,+ probExpr,+ probExprNum,+ probExprId,+ probExprRangeSelect,+ probExprUnOp,+ probExprBinOp,+ probExprCond,+ probExprConcat,+ probExprStr,+ probExprSigned,+ probExprUnsigned,+ probModItemAssign,+ probModItemSeqAlways,+ probModItemCombAlways,+ probModItemInst,+ probStmntBlock,+ probStmntNonBlock,+ probStmntCond,+ probStmntFor,+ propSampleSize,+ propSampleMethod,+ propSize,+ propSeed,+ propStmntDepth,+ propModDepth,+ propMaxModules,+ propCombine,+ propDeterminism,+ propNonDeterminism,+ propDefaultYosys,+ goSeed,+ gaoCurrent,+ goGenerate,+ goStatement,+ goExpr,+ ggoAttenuation,+ geoAttenuation,+ gstoAttenuation,+ parseConfigFile,+ parseConfig,+ parseConfigFileRelaxed,+ parseConfigRelaxed,+ encodeConfig,+ encodeConfigFile,+ versionInfo,+ )+where++import Control.Applicative (Alternative, liftA2, liftA3, (<|>))+import Control.Lens hiding ((.=))+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import qualified Data.Text.IO as T+import qualified Data.Vector.Unboxed as VU+import Data.Version (showVersion)+import Data.Word (Word32)+import Development.GitRev+import Hedgehog.Internal.Seed (Seed)+import Paths_verismith (version)+import Shelly (toTextIgnore)+import Toml (TomlCodec, (.=))+import qualified Toml+import Verismith.Tool.Quartus+import Verismith.Tool.QuartusLight+import Verismith.Tool.Vivado+import Verismith.Tool.XST+import Verismith.Tool.Yosys+import Verismith.Utils (uncurry3)++-- $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+-- <http://iverilog.icarus.com/ Icarus Verilog>.+--+-- [@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:+--+-- - <https://www.intel.com/content/www/us/en/programmable/downloads/download-center.html Quartus>+-- - <https://www.xilinx.com/products/design-tools/ise-design-suite.html ISE Design Suite>+-- - <https://www.xilinx.com/products/design-tools/ise-design-suite.html Vivado Design Suite>+-- - <http://www.clifford.at/yosys/ Yosys Open SYnthesis Suite>++-- | Probability of different expressions nodes.+data ProbExpr = ProbExpr+ { -- | @expr.number@: probability of generation a number like+ -- @4'ha@. This should never be set to 0, as it is used+ -- as a fallback in case there are no viable+ -- identifiers, such as none being in scope.+ _probExprNum :: {-# UNPACK #-} !Int,+ -- | @expr.variable@: probability of generating an identifier that is in+ -- scope and of the right type.+ _probExprId :: {-# UNPACK #-} !Int,+ -- | @expr.rangeselect@: probability of generating a range+ -- selection from a port (@reg1[2:0]@).+ _probExprRangeSelect :: {-# UNPACK #-} !Int,+ -- | @expr.unary@: probability of generating a unary operator.+ _probExprUnOp :: {-# UNPACK #-} !Int,+ -- | @expr.binary@: probability of generation a binary operator.+ _probExprBinOp :: {-# UNPACK #-} !Int,+ -- | @expr.ternary@: probability of generating a conditional ternary+ -- operator.+ _probExprCond :: {-# UNPACK #-} !Int,+ -- | @expr.concatenation@: probability of generating a concatenation.+ _probExprConcat :: {-# UNPACK #-} !Int,+ -- | @expr.string@: probability of generating a string. This is not+ -- fully supported therefore currently cannot be set.+ _probExprStr :: {-# UNPACK #-} !Int,+ -- | @expr.signed@: probability of generating a signed function+ -- @$signed(...)@.+ _probExprSigned :: {-# UNPACK #-} !Int,+ -- | @expr.unsigned@: probability of generating an unsigned function+ -- @$unsigned(...)@.+ _probExprUnsigned :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++-- | Probability of generating different nodes inside a module declaration.+data ProbModItem = ProbModItem+ { -- | @moditem.assign@: probability of generating an @assign@.+ _probModItemAssign :: {-# UNPACK #-} !Int,+ -- | @moditem.sequential@: probability of generating a sequential @always@ block.+ _probModItemSeqAlways :: {-# UNPACK #-} !Int,+ -- | @moditem.combinational@: probability of generating an combinational @always@+ -- block. This is currently not implemented.+ _probModItemCombAlways :: {-# UNPACK #-} !Int,+ -- | @moditem.instantiation@: probability of generating a module+ -- instantiation.+ _probModItemInst :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++-- | Probability of generating different statements.+data ProbStatement = ProbStatement+ { -- | @statement.blocking@: probability of generating blocking assignments.+ _probStmntBlock :: {-# UNPACK #-} !Int,+ -- | @statement.nonblocking@: probability of generating nonblocking assignments.+ _probStmntNonBlock :: {-# UNPACK #-} !Int,+ -- | @statement.conditional@: probability of generating conditional+ -- statements (@if@ statements).+ _probStmntCond :: {-# UNPACK #-} !Int,+ -- | @statement.forloop@: probability of generating for loops.+ _probStmntFor :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++-- | Probability of generating various properties of a module.+data ProbMod = ProbMod+ { -- | "@module.drop_output@: frequency of a wire or register being dropped from the output."+ _probModDropOutput :: {-# UNPACK #-} !Int,+ -- | "@module.keep_output@: frequency of a wire or register being kept in the output."+ _probModKeepOutput :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++-- | @[probability]@: combined probabilities.+data Probability = Probability+ { -- | Probabilities for module items.+ _probModItem :: {-# UNPACK #-} !ProbModItem,+ -- | Probabilities for statements.+ _probStmnt :: {-# UNPACK #-} !ProbStatement,+ -- | Probaiblities for expressions.+ _probExpr :: {-# UNPACK #-} !ProbExpr,+ _probMod :: {-# UNPACK #-} !ProbMod+ }+ deriving (Eq, Show)++data ConfEMI = ConfEMI+ { -- | Probability of generating a new EMI statement with a new EMI entry.+ _confEMIGenerateProb :: {-# UNPACK #-} !Int,+ _confEMINoGenerateProb :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++-- | @[property]@: properties for the generated Verilog file.+data ConfProperty = ConfProperty+ { -- | @size@: the size of the generated Verilog.+ _propSize :: {-# UNPACK #-} !Int,+ -- | @seed@: a possible seed that could be used to+ -- generate the same Verilog.+ _propSeed :: !(Maybe Seed),+ -- | @statement.depth@: the maximum statement depth that should be+ -- reached.+ _propStmntDepth :: {-# UNPACK #-} !Int,+ -- | @module.depth@: the maximium module depth that should be+ -- reached.+ _propModDepth :: {-# UNPACK #-} !Int,+ -- | @module.max@: the maximum number of modules that are+ -- allowed to be created at each level.+ _propMaxModules :: {-# UNPACK #-} !Int,+ -- | @sample.method@: the sampling method that should be used to+ -- generate specific distributions of random+ -- programs.+ _propSampleMethod :: !Text,+ -- | @sample.size@: the number of samples to take for the+ -- sampling method.+ _propSampleSize :: {-# UNPACK #-} !Int,+ -- | @output.combine@: if the output should be combined into one+ -- bit or not.+ _propCombine :: !Bool,+ -- | @nondeterminism@: the frequency at which nondeterminism+ -- should be generated (currently a work in progress).+ _propNonDeterminism :: {-# UNPACK #-} !Int,+ -- | @determinism@: the frequency at which determinism should+ -- be generated (currently modules are always deterministic).+ _propDeterminism :: {-# UNPACK #-} !Int,+ -- | @default.yosys@: Default location for Yosys, which will be used for+ -- equivalence checking.+ _propDefaultYosys :: !(Maybe Text)+ }+ deriving (Eq, Show)++data NumberProbability+ = NPUniform+ { _NPULow :: !Int,+ _NPUHigh :: !Int+ }+ | NPBinomial+ { _NPBOffset :: !Int,+ _NPBTrials :: !Int,+ _NPBSuccess :: !Double+ }+ | NPNegativeBinomial -- Geometric is negative binomial with 1 failure+ { _NPNBOffset :: !Int,+ _NPNBFailRate :: !Double,+ _NPNBFailure :: !Int+ }+ | NPPoisson+ { _NPPOffset :: !Int,+ _NPPParam :: !Double+ }+ | NPDiscrete !(NonEmpty (Double, Int)) -- Weight, outcome index+ | NPLinearComb !(NonEmpty (Double, NumberProbability))+ deriving (Eq, Show)++data CategoricalProbability+ = CPDiscrete !(NonEmpty Double)+ | CPBiasedUniform+ { _CPBUBiases :: ![(Double, Int)],+ _CPBUUniformWeight :: Double+ }+ deriving (Eq, Show)++uniformCP :: CategoricalProbability+uniformCP = CPBiasedUniform [] 1++data GarbageOpts = GarbageOpts+ { _goSeed :: !(Maybe (VU.Vector Word32)),+ _goConfig :: !GarbageConfigOpts,+ _goPrimitive :: !GarbagePrimitiveOpts,+ _goModule :: !GarbageModuleOpts,+ _goSpecify :: !GarbageSpecifyOpts,+ _goGenerate :: !GarbageGenerateOpts,+ _goType :: !GarbageTypeOpts,+ _goStatement :: !GarbageStatementOpts,+ _goExpr :: !GarbageExprOpts,+ _goIdentifier :: !GarbageIdentifierOpts,+ _goDriveStrength :: !CategoricalProbability,+ _goLValues :: !NumberProbability,+ _goOptionalLValue :: !Double,+ _goAttributes :: !NumberProbability,+ _goAttributeOptionalValue :: !Double,+ _goDelay :: !CategoricalProbability,+ _goIntRealIdent :: !CategoricalProbability,+ _goPathDepth :: !NumberProbability,+ _goBareMinTypMax :: !Double+ }+ deriving (Eq, Show)++data GarbageConfigOpts = GarbageConfigOpts+ { _gcoBlocks :: !NumberProbability,+ _gcoDesigns :: !NumberProbability,+ _gcoItems :: !NumberProbability,+ _gcoLibraries :: !NumberProbability,+ _gcoCell_Inst :: !Double,+ _gcoLiblist_Use :: !Double,+ _gcoConfig :: !Double,+ _gcoLibraryScope :: !Double+ }+ deriving (Eq, Show)++data GarbagePrimitiveOpts = GarbagePrimitiveOpts+ { _gpoBlocks :: !NumberProbability,+ _gpoPorts :: !NumberProbability,+ _gpoPortType :: !CategoricalProbability,+ _gpoSeq_Comb :: !Double,+ _gpoRegInit :: !Double,+ _gpoCombInit :: !CategoricalProbability,+ _gpoTableRows :: !NumberProbability,+ _gpoInLevel :: !CategoricalProbability,+ _gpoOutLevel :: !CategoricalProbability,+ _gpoEdgeSensitive :: !Double,+ _gpoEdgeSimplePosNeg :: !CategoricalProbability,+ _gpoOutputNoChange :: !Double+ }+ deriving (Eq, Show)++data GarbageModuleOpts = GarbageModuleOpts+ { _gmoBlocks :: !NumberProbability,+ _gmoNamed_Positional :: !Double,+ _gmoParameters :: !NumberProbability,+ _gmoOptionalParameter :: !Double,+ _gmoPorts :: !NumberProbability,+ _gmoPortLValues :: !NumberProbability,+ _gmoPortRange :: !Double,+ _gmoPortDir :: !CategoricalProbability,+ _gmoOptionalPort :: !Double,+ _gmoItems :: !NumberProbability,+ _gmoItem :: !CategoricalProbability,+ _gmoTimeScale :: !Double,+ _gmoTimeMagnitude :: !CategoricalProbability,+ _gmoCell :: !Double,+ _gmoUnconnectedDrive :: !CategoricalProbability,+ _gmoDefaultNetType :: !CategoricalProbability,+ _gmoNonAsciiHeader :: !Bool+ }+ deriving (Eq, Show)++data GarbageSpecifyOpts = GarbageSpecifyOpts+ { _gsyoPath :: !GarbageSpecifyPathOpts,+ _gsyoTimingCheck :: !GarbageSpecifyTimingCheckOpts,+ _gsyoItems :: !NumberProbability,+ _gsyoItem :: !CategoricalProbability,+ _gsyoTermRange :: !Double,+ _gsyoParamRange :: !Double,+ _gsyoPathPulseEscaped_Simple :: !Double,+ _gsyoPathPulseRange :: !Double+ }+ deriving (Eq, Show)++data GarbageSpecifyPathOpts = GarbageSpecifyPathOpts+ { _gspoCondition :: !CategoricalProbability,+ _gspoFull_Parallel :: !Double,+ _gspoEdgeSensitive :: !Double,+ _gspoFullSources :: !NumberProbability,+ _gspoFullDestinations :: !NumberProbability,+ _gspoPolarity :: !CategoricalProbability,+ _gspoEdgeSensitivity :: !CategoricalProbability,+ _gspoDelayKind :: !CategoricalProbability+ }+ deriving (Eq, Show)++data GarbageSpecifyTimingCheckOpts = GarbageSpecifyTimingCheckOpts+ { _gstcoOptionalArg :: !Double,+ _gstcoEvent :: !Double,+ _gstcoEventEdge :: !Double,+ _gstcoCondition :: !Double,+ _gstcoCondNeg_Pos :: !Double,+ _gstcoDelayedMinTypMax :: !Double+ }+ deriving (Eq, Show)++data GarbageGenerateOpts = GarbageGenerateOpts+ { _ggoAttenuation :: !GarbageAttenuationOpts,+ _ggoItems :: !NumberProbability,+ _ggoItem :: !CategoricalProbability,+ _ggoOptionalBlock :: !Double,+ _ggoInstOptionalDelay :: !Double,+ _ggoInstOptionalRange :: !Double,+ _ggoPrimitiveOptIdent :: !Double,+ _ggoCondBlock :: !CategoricalProbability,+ _ggoNetType :: !CategoricalProbability,+ _ggoNetRange :: !Double,+ _ggoNetVectoring :: !CategoricalProbability,+ _ggoDeclItem :: !CategoricalProbability,+ _ggoDeclDim_Init :: !Double,+ _ggoChargeStrength :: !CategoricalProbability,+ _ggoTaskFunAutomatic :: !Double,+ _ggoTaskFunDecl :: !CategoricalProbability,+ _ggoTaskFunRegister :: !Double,+ _ggoTaskFunPorts :: !NumberProbability,+ _ggoTaskFunPortType :: !CategoricalProbability,+ _ggoTaskPortDirection :: !CategoricalProbability,+ _ggoFunRetType :: !Double,+ _ggoGateInst :: !CategoricalProbability,+ _ggoGateOptIdent :: !Double,+ _ggoGateNInputType :: !CategoricalProbability,+ _ggoGateInputs :: !NumberProbability,+ _ggoGateOutputs :: !NumberProbability,+ _ggoCaseBranches :: !NumberProbability,+ _ggoCaseBranchPatterns :: !NumberProbability+ }+ deriving (Eq, Show)++data GarbageTypeOpts = GarbageTypeOpts+ { _gtoAbstract_Concrete :: !Double,+ _gtoAbstract :: !CategoricalProbability,+ _gtoConcreteSignedness :: !Double,+ _gtoConcreteBitRange :: !Double,+ _gtoDimensions :: !NumberProbability+ }+ deriving (Eq, Show)++data GarbageAttenuationOpts = GarbageAttenuationOpts+ { _gaoCurrent :: !Double,+ _gaoDecrease :: !Double+ }+ deriving (Eq, Show)++data GarbageStatementOpts = GarbageStatementOpts+ { _gstoAttenuation :: !GarbageAttenuationOpts,+ _gstoOptional :: !Double,+ _gstoItem :: !CategoricalProbability,+ _gstoItems :: !NumberProbability,+ _gstoOptionalDelEvCtl :: !Double,+ _gstoAssignmentBlocking :: !Double,+ _gstoCase :: !CategoricalProbability,+ _gstoCaseBranches :: !NumberProbability,+ _gstoCaseBranchPatterns :: !NumberProbability,+ _gstoLoop :: !CategoricalProbability,+ _gstoBlockPar_Seq :: !Double,+ _gstoBlockHeader :: !Double,+ _gstoBlockDecls :: !NumberProbability,+ _gstoBlockDecl :: !CategoricalProbability,+ _gstoProcContAssign :: !CategoricalProbability,+ _gstoPCAVar_Net :: !Double,+ _gstoDelayEventRepeat :: !CategoricalProbability,+ _gstoEvent :: !CategoricalProbability,+ _gstoEvents :: !NumberProbability,+ _gstoEventPrefix :: !CategoricalProbability,+ _gstoSysTaskPorts :: !NumberProbability,+ _gstoSysTaskOptionalPort :: !Double+ }+ deriving (Eq, Show)++data GarbageExprOpts = GarbageExprOpts+ { _geoAttenuation :: !GarbageAttenuationOpts,+ _geoItem :: !CategoricalProbability,+ _geoPrimary :: !CategoricalProbability,+ _geoUnary :: !CategoricalProbability,+ _geoBinary :: !CategoricalProbability,+ _geoMinTypMax :: !Double,+ _geoDimRange :: !Double,+ _geoRange :: !CategoricalProbability,+ _geoRangeOffsetPos_Neg :: !Double,+ _geoConcatenations :: !NumberProbability,+ _geoSysFunArgs :: !NumberProbability,+ _geoLiteralWidth :: !CategoricalProbability,+ _geoLiteralSigned :: !Double,+ _geoStringCharacters :: !NumberProbability,+ _geoStringCharacter :: !CategoricalProbability,+ _geoFixed_Floating :: !Double,+ _geoExponentSign :: !CategoricalProbability,+ _geoX_Z :: !Double,+ _geoBinarySymbols :: !NumberProbability,+ _geoBinarySymbol :: !CategoricalProbability,+ _geoOctalSymbols :: !NumberProbability,+ _geoOctalSymbol :: !CategoricalProbability,+ _geoDecimalSymbols :: !NumberProbability,+ _geoDecimalSymbol :: !CategoricalProbability,+ _geoHexadecimalSymbols :: !NumberProbability,+ _geoHexadecimalSymbol :: !CategoricalProbability+ }+ deriving (Eq, Show)++data GarbageIdentifierOpts = GarbageIdentifierOpts+ { _gioEscaped_Simple :: !Double,+ _gioSimpleLetters :: !NumberProbability,+ _gioSimpleLetter :: !CategoricalProbability,+ _gioEscapedLetters :: !NumberProbability,+ _gioEscapedLetter :: !CategoricalProbability,+ _gioSystemLetters :: !NumberProbability,+ _gioSystemFirstLetter :: !CategoricalProbability+ }+ deriving (Eq, Show)++defAttenuationOpts :: GarbageAttenuationOpts+defAttenuationOpts = GarbageAttenuationOpts 1.0 0.7++defGarbageOpts :: GarbageOpts+defGarbageOpts =+ GarbageOpts+ { _goSeed = Nothing,+ _goConfig = GarbageConfigOpts+ { _gcoBlocks = NPPoisson 0 1,+ _gcoDesigns = NPPoisson 0 1,+ _gcoItems = NPPoisson 0 1,+ _gcoLibraries = NPPoisson 0 1,+ _gcoCell_Inst = 0.5,+ _gcoLiblist_Use = 0.5,+ _gcoConfig = 0.5,+ _gcoLibraryScope = 0.5+ },+ _goPrimitive = GarbagePrimitiveOpts+ { _gpoBlocks = NPPoisson 0 2,+ _gpoPorts = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gpoPortType = uniformCP,+ _gpoSeq_Comb = 0.5,+ _gpoRegInit = 0.5,+ _gpoCombInit = uniformCP,+ _gpoTableRows = NPPoisson 0 4,+ _gpoInLevel = uniformCP,+ _gpoOutLevel = uniformCP,+ _gpoEdgeSensitive = 0.5,+ _gpoEdgeSimplePosNeg = uniformCP,+ _gpoOutputNoChange = 0.5+ },+ _goModule = GarbageModuleOpts+ { _gmoBlocks = NPPoisson 1 2,+ _gmoNamed_Positional = 0.5,+ _gmoParameters = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gmoOptionalParameter = 0.5,+ _gmoPorts = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gmoPortLValues = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gmoPortRange = 0.5,+ _gmoPortDir = uniformCP,+ _gmoOptionalPort = 0.5,+ _gmoItems = NPPoisson 0 3,+ _gmoItem = CPDiscrete [6, 2, 2, 3, 2, 1, 1, 1],+ _gmoTimeScale = 0.5,+ _gmoTimeMagnitude = uniformCP,+ _gmoCell = 0.5,+ _gmoUnconnectedDrive = uniformCP,+ _gmoDefaultNetType = uniformCP,+ _gmoNonAsciiHeader = True+ },+ _goSpecify = GarbageSpecifyOpts+ { _gsyoPath = GarbageSpecifyPathOpts+ { _gspoCondition = uniformCP,+ _gspoFull_Parallel = 0.5,+ _gspoEdgeSensitive = 0.5,+ _gspoFullSources = NPPoisson 0 1,+ _gspoFullDestinations = NPPoisson 0 1,+ _gspoPolarity = uniformCP,+ _gspoEdgeSensitivity = uniformCP,+ _gspoDelayKind = uniformCP+ },+ _gsyoTimingCheck = GarbageSpecifyTimingCheckOpts+ { _gstcoOptionalArg = 0.5,+ _gstcoEvent = 0.5,+ _gstcoEventEdge = 0.25,+ _gstcoCondition = 0.5,+ _gstcoCondNeg_Pos = 0.5,+ _gstcoDelayedMinTypMax = 0.5+ },+ _gsyoItems = NPPoisson 0 1,+ _gsyoItem = uniformCP,+ _gsyoTermRange = 0.5,+ _gsyoParamRange = 0.5,+ _gsyoPathPulseEscaped_Simple = 0.5,+ _gsyoPathPulseRange = 0.5+ },+ _goGenerate = GarbageGenerateOpts+ { _ggoAttenuation = defAttenuationOpts,+ _ggoItems = NPPoisson 0 3,+ _ggoItem = uniformCP,+ _ggoOptionalBlock = 0.5,+ _ggoInstOptionalDelay = 0.5,+ _ggoInstOptionalRange = 0.5,+ _ggoPrimitiveOptIdent = 0.5,+ _ggoCondBlock = uniformCP,+ _ggoNetType = uniformCP,+ _ggoNetRange = 0.5,+ _ggoNetVectoring = uniformCP,+ _ggoDeclItem = uniformCP,+ _ggoDeclDim_Init = 0.5,+ _ggoChargeStrength = uniformCP,+ _ggoTaskFunAutomatic = 0.5,+ _ggoTaskFunDecl = uniformCP,+ _ggoTaskFunRegister = 0.5,+ _ggoTaskFunPorts = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _ggoTaskFunPortType = uniformCP,+ _ggoTaskPortDirection = uniformCP,+ _ggoFunRetType = 0.5,+ _ggoGateInst = uniformCP,+ _ggoGateOptIdent = 0.5,+ _ggoGateNInputType = uniformCP,+ _ggoGateInputs = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _ggoGateOutputs = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _ggoCaseBranches = NPNegativeBinomial 0 0.75 2,+ _ggoCaseBranchPatterns = NPNegativeBinomial 0 (2.0 / 5.0) 1+ },+ _goType = GarbageTypeOpts+ { _gtoAbstract_Concrete = 0.5,+ _gtoAbstract = uniformCP,+ _gtoConcreteSignedness = 0.5,+ _gtoConcreteBitRange = 0.5,+ _gtoDimensions = NPNegativeBinomial 0 0.5 1+ },+ _goStatement = GarbageStatementOpts+ { _gstoAttenuation = defAttenuationOpts,+ _gstoOptional = 0.5,+ _gstoItems = NPPoisson 0 3,+ _gstoItem = uniformCP,+ _gstoOptionalDelEvCtl = 0.5,+ _gstoAssignmentBlocking = 0.5,+ _gstoCase = uniformCP,+ _gstoCaseBranches = NPNegativeBinomial 0 0.75 2,+ _gstoCaseBranchPatterns = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gstoLoop = uniformCP,+ _gstoBlockPar_Seq = 0.5,+ _gstoBlockHeader = 0.5,+ _gstoBlockDecls = NPPoisson 0 1,+ _gstoBlockDecl = uniformCP,+ _gstoProcContAssign = uniformCP,+ _gstoPCAVar_Net = 0.5,+ _gstoDelayEventRepeat = uniformCP,+ _gstoEvent = uniformCP,+ _gstoEvents = NPNegativeBinomial 0 0.5 1,+ _gstoEventPrefix = uniformCP,+ _gstoSysTaskPorts = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _gstoSysTaskOptionalPort = 0.5+ },+ _goExpr = GarbageExprOpts+ { _geoAttenuation = defAttenuationOpts,+ _geoItem = CPDiscrete [2, 2, 2, 1],+ _geoPrimary = CPDiscrete [2, 4, 4, 4, 4, 4, 2, 4, 1, 1, 1, 1, 1],+ _geoUnary = uniformCP,+ _geoBinary = uniformCP,+ _geoMinTypMax = 0.5,+ _geoDimRange = 0.5,+ _geoRange = uniformCP,+ _geoRangeOffsetPos_Neg = 0.5,+ _geoConcatenations = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _geoSysFunArgs = NPNegativeBinomial 0 (2.0 / 5.0) 1,+ _geoLiteralWidth =+ CPBiasedUniform+ [(1024, 1), (512, 8), (256, 16), (128, 32), (64, 64), (32, 128), (16, 256), (8, 512)]+ 1,+ _geoLiteralSigned = 0.5,+ _geoStringCharacters = NPNegativeBinomial 0 0.5 3,+ _geoStringCharacter = uniformCP,+ _geoFixed_Floating = 0.5,+ _geoExponentSign = uniformCP,+ _geoX_Z = 0.5,+ _geoBinarySymbols = NPNegativeBinomial 0 0.5 3,+ _geoBinarySymbol = uniformCP,+ _geoOctalSymbols = NPNegativeBinomial 0 0.5 3,+ _geoOctalSymbol = uniformCP,+ _geoDecimalSymbols = NPNegativeBinomial 0 0.5 3,+ _geoDecimalSymbol = uniformCP,+ _geoHexadecimalSymbols = NPNegativeBinomial 0 0.5 3,+ _geoHexadecimalSymbol = uniformCP+ },+ _goIdentifier = GarbageIdentifierOpts+ { _gioEscaped_Simple = 0.5,+ _gioSimpleLetters = NPNegativeBinomial 0 0.5 3,+ _gioSimpleLetter = uniformCP,+ _gioEscapedLetters = NPNegativeBinomial 0 0.5 3,+ _gioEscapedLetter = uniformCP,+ _gioSystemLetters = NPNegativeBinomial 0 0.5 3,+ _gioSystemFirstLetter = uniformCP+ },+ _goDriveStrength = uniformCP,+ _goLValues = NPNegativeBinomial 0 0.5 1,+ _goOptionalLValue = 0.5,+ _goAttributes = NPLinearComb [(2, NPDiscrete [(1, 0)]), (1, NPNegativeBinomial 0 0.75 1)],+ _goAttributeOptionalValue = 0.5,+ _goDelay = CPDiscrete [1, 1, 2, 4],+ _goIntRealIdent = uniformCP,+ _goPathDepth = NPNegativeBinomial 0 0.75 1,+ _goBareMinTypMax = 0.5+ }++data Info = Info+ { -- | @commit@: the hash of the commit that was compiled.+ _infoCommit :: !Text,+ -- | @version@: the version of Verismith that was compiled.+ _infoVersion :: !Text+ }+ deriving (Eq, Show)++-- | Description of the simulator+data SimDescription = SimDescription {simName :: {-# UNPACK #-} !Text}+ deriving (Eq, Show)++-- | @[[synthesiser]]@: description of the synthesis tool. There can be multiple of these sections in a config+-- file.+data SynthDescription = SynthDescription+ { -- | @name@: type of the synthesis tool. Can either be @yosys@, @quartus@,+ -- @quartuslight@, @vivado@, @xst@.+ synthName :: {-# UNPACK #-} !Text,+ -- | @bin@: location of the synthesis tool binary.+ synthBin :: Maybe Text,+ -- | @description@: description that should be used for the synthesis tool.+ synthDesc :: Maybe Text,+ -- | @output@: name of the output Verilog file.+ synthOut :: Maybe Text+ }+ deriving (Eq, Show)++data Config = Config+ { _configEMI :: {-# UNPACK #-} !ConfEMI,+ _configInfo :: {-# UNPACK #-} !Info,+ _configProbability :: {-# UNPACK #-} !Probability,+ _configProperty :: {-# UNPACK #-} !ConfProperty,+ _configGarbageGenerator :: {-# UNPACK #-} !GarbageOpts,+ _configSimulators :: [SimDescription],+ _configSynthesisers :: [SynthDescription]+ }+ deriving (Eq, Show)++$(makeLenses ''ProbExpr)++$(makeLenses ''ProbModItem)++$(makeLenses ''ProbStatement)++$(makeLenses ''ProbMod)++$(makeLenses ''Probability)++$(makeLenses ''ConfEMI)++$(makeLenses ''ConfProperty)++$(makeLenses ''GarbageOpts)+$(makeLenses ''GarbageConfigOpts)+$(makeLenses ''GarbagePrimitiveOpts)+$(makeLenses ''GarbageModuleOpts)+$(makeLenses ''GarbageSpecifyOpts)+$(makeLenses ''GarbageSpecifyPathOpts)+$(makeLenses ''GarbageSpecifyTimingCheckOpts)+$(makeLenses ''GarbageGenerateOpts)+$(makeLenses ''GarbageTypeOpts)+$(makeLenses ''GarbageAttenuationOpts)+$(makeLenses ''GarbageStatementOpts)+$(makeLenses ''GarbageExprOpts)+$(makeLenses ''GarbageIdentifierOpts)++$(makeLenses ''Info)++$(makeLenses ''Config)++$(makePrisms ''CategoricalProbability)++$(makePrisms ''NumberProbability)++defaultValue :: a -> TomlCodec a -> TomlCodec a+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)++fromQuartusLight :: QuartusLight -> SynthDescription+fromQuartusLight (QuartusLight a b c) =+ SynthDescription+ "quartuslight"+ (toTextIgnore <$> a)+ (Just b)+ (Just $ toTextIgnore c)++defaultConfig :: Config+defaultConfig =+ Config+ (ConfEMI 2 8)+ (Info (pack $(gitHash)) (pack $ showVersion version))+ (Probability defModItem defStmnt defExpr defMod)+ (ConfProperty 20 Nothing 3 2 5 "random" 10 False 0 1 Nothing)+ defGarbageOpts+ []+ [fromYosys defaultYosys, fromVivado defaultVivado]+ where+ defMod =+ ProbMod+ 0 -- Drop Output+ 1 -- Keep Output+ 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++catProbCodec :: TomlCodec CategoricalProbability+catProbCodec =+ Toml.dimatch (firstOf _CPDiscrete) CPDiscrete (Toml.arrayNonEmptyOf Toml._Double "Discrete")+ <|> Toml.table+ ( liftA2+ CPBiasedUniform+ ( defaultValue [] (Toml.list (Toml.pair (Toml.double "weight") (Toml.int "value")) "biases")+ .= _CPBUBiases+ )+ (Toml.double "weight" .= _CPBUUniformWeight)+ )+ "BiasedUniform"++numProbCodec :: TomlCodec NumberProbability+numProbCodec =+ Toml.dimatch+ (firstOf _NPUniform)+ (uncurry NPUniform)+ (Toml.table (Toml.pair (defaultValue 0 $ Toml.int "low") (Toml.int "high")) "Uniform")+ <|> Toml.dimatch+ (firstOf _NPBinomial)+ (uncurry3 NPBinomial)+ ( Toml.table+ ( Toml.triple+ (defaultValue 0 (Toml.int "offset"))+ (Toml.int "trials")+ (Toml.double "succesRate")+ )+ "Binomial"+ )+ <|> Toml.dimatch+ (firstOf _NPNegativeBinomial)+ (uncurry3 NPNegativeBinomial)+ ( Toml.table+ ( Toml.triple+ (defaultValue 0 (Toml.int "offset"))+ (Toml.double "failureRate")+ (Toml.int "numberOfFailures")+ )+ "NegativeBinomial"+ )+ <|> Toml.dimatch+ (firstOf _NPNegativeBinomial)+ (uncurry3 NPNegativeBinomial)+ ( Toml.table+ ( Toml.triple+ (defaultValue 0 (Toml.int "offset"))+ (Toml.double "failureRate")+ (pure 1)+ )+ "Geometric"+ )+ <|> Toml.dimatch+ (firstOf _NPPoisson)+ (uncurry NPPoisson)+ (Toml.table (Toml.pair (defaultValue 0 (Toml.int "offset")) (Toml.double "lambda")) "Poisson")+ <|> Toml.dimatch+ (firstOf _NPDiscrete)+ NPDiscrete+ (Toml.nonEmpty (Toml.pair (Toml.double "weight") (Toml.int "value")) "Discrete")+ <|> Toml.dimatch+ (firstOf _NPLinearComb)+ NPLinearComb+ (Toml.nonEmpty (Toml.pair (Toml.double "weight") numProbCodec) "LinearCombination")++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"++modCodec :: TomlCodec ProbMod+modCodec =+ ProbMod+ <$> defaultValue (defProb probModDropOutput) (intM "drop_output")+ .= _probModDropOutput+ <*> defaultValue (defProb probModKeepOutput) (intM "keep_output")+ .= _probModKeepOutput+ where+ defProb i = defaultConfig ^. configProbability . probMod . i+ intM = int "module"++probCodec :: TomlCodec Probability+probCodec =+ Probability+ <$> defaultValue (defProb probModItem) modItemCodec+ .= _probModItem+ <*> defaultValue (defProb probStmnt) stmntCodec+ .= _probStmnt+ <*> defaultValue (defProb probExpr) exprCodec+ .= _probExpr+ <*> defaultValue (defProb probMod) modCodec+ .= _probMod+ where+ defProb i = defaultConfig ^. configProbability . i++propCodec :: TomlCodec ConfProperty+propCodec =+ ConfProperty+ <$> defaultValue (defProp propSize) (Toml.int "size")+ .= _propSize+ <*> Toml.dioptional (Toml.read "seed")+ .= _propSeed+ <*> defaultValue (defProp propStmntDepth) (int "statement" "depth")+ .= _propStmntDepth+ <*> defaultValue (defProp propModDepth) (int "module" "depth")+ .= _propModDepth+ <*> defaultValue (defProp propMaxModules) (int "module" "max")+ .= _propMaxModules+ <*> defaultValue+ (defProp propSampleMethod)+ (Toml.text (twoKey "sample" "method"))+ .= _propSampleMethod+ <*> defaultValue (defProp propSampleSize) (int "sample" "size")+ .= _propSampleSize+ <*> defaultValue+ (defProp propCombine)+ (Toml.bool (twoKey "output" "combine"))+ .= _propCombine+ <*> defaultValue (defProp propNonDeterminism) (Toml.int "nondeterminism")+ .= _propNonDeterminism+ <*> defaultValue (defProp propDeterminism) (Toml.int "determinism")+ .= _propDeterminism+ <*> Toml.dioptional (Toml.text (twoKey "default" "yosys"))+ .= _propDefaultYosys+ where+ defProp i = defaultConfig ^. configProperty . i++garbageAttenuationCodec :: Toml.Key -> TomlCodec GarbageAttenuationOpts+garbageAttenuationCodec =+ Toml.dimap _gaoDecrease (GarbageAttenuationOpts 1.0)+ . defaultValue (_gaoDecrease defAttenuationOpts)+ . Toml.double++garbageConfigCodec :: TomlCodec GarbageConfigOpts+garbageConfigCodec =+ GarbageConfigOpts+ <$> tfield _gcoBlocks "blocks" numProbCodec+ <*> tfield _gcoDesigns "designs" numProbCodec+ <*> tfield _gcoItems "items" numProbCodec+ <*> tfield _gcoLibraries "items" numProbCodec+ <*> dfield _gcoCell_Inst "cell_or_inst"+ <*> dfield _gcoLiblist_Use "liblist_or_use"+ <*> dfield _gcoConfig "config"+ <*> dfield _gcoLibraryScope "libraryScope"+ where+ tfield p n c =+ defaultValue (p $ _goConfig $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goConfig $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbagePrimitiveCodec :: TomlCodec GarbagePrimitiveOpts+garbagePrimitiveCodec =+ GarbagePrimitiveOpts+ <$> tfield _gpoBlocks "blocks" numProbCodec+ <*> tfield _gpoPorts "ports" numProbCodec+ <*> tfield _gpoPortType "portType" catProbCodec+ <*> dfield _gpoSeq_Comb "seq_or_comb"+ <*> dfield _gpoRegInit "regInitNoSem"+ <*> tfield _gpoCombInit "combInit" catProbCodec+ <*> tfield _gpoTableRows "tableRows" numProbCodec+ <*> tfield _gpoInLevel "inLevel" catProbCodec+ <*> tfield _gpoOutLevel "outLevel" catProbCodec+ <*> dfield _gpoEdgeSensitive "edgeSensitive"+ <*> tfield _gpoEdgeSimplePosNeg "edgeSimplePosNeg" catProbCodec+ <*> dfield _gpoOutputNoChange "outputNoChange"+ where+ tfield p n c =+ defaultValue (p $ _goPrimitive $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goPrimitive $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageModuleCodec :: TomlCodec GarbageModuleOpts+garbageModuleCodec =+ GarbageModuleOpts+ <$> tfield _gmoBlocks "blocks" numProbCodec+ <*> dfield _gmoNamed_Positional "instance_named_or_positional"+ <*> tfield _gmoParameters "instance_parameters" numProbCodec+ <*> dfield _gmoOptionalParameter "instance_optparam"+ <*> tfield _gmoPorts "port_count" numProbCodec+ <*> tfield _gmoPortLValues "port_lvalues" numProbCodec+ <*> dfield _gmoPortRange "port_range"+ <*> tfield _gmoPortDir "port_dir" catProbCodec+ <*> dfield _gmoOptionalPort "port_optional"+ <*> tfield _gmoItems "items" numProbCodec+ <*> tfield _gmoItem "item" catProbCodec+ <*> dfield _gmoTimeScale "timescale_optional"+ <*> tfield _gmoTimeMagnitude "timescale_magnitude" catProbCodec+ <*> dfield _gmoCell "cell"+ <*> tfield _gmoUnconnectedDrive "unconnectedDrive" catProbCodec+ <*> tfield _gmoDefaultNetType "defaultNetType" catProbCodec+ <*> bfield _gmoNonAsciiHeader "nonAsciiHeader"+ where+ tfield p n c =+ defaultValue (p $ _goModule $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goModule $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p+ bfield p n =+ defaultValue (p $ _goModule $ _configGarbageGenerator defaultConfig) (Toml.bool n) .= p++garbageSpecifyPathCodec :: TomlCodec GarbageSpecifyPathOpts+garbageSpecifyPathCodec =+ GarbageSpecifyPathOpts+ <$> tfield _gspoCondition "condition" catProbCodec+ <*> dfield _gspoFull_Parallel "full_or_parallel"+ <*> dfield _gspoEdgeSensitive "edgeSensitive"+ <*> tfield _gspoFullSources "full_sources" numProbCodec+ <*> tfield _gspoFullDestinations "full_destinations" numProbCodec+ <*> tfield _gspoPolarity "polarity" catProbCodec+ <*> tfield _gspoEdgeSensitivity "edgeSensitivity" catProbCodec+ <*> tfield _gspoDelayKind "delayKind" catProbCodec+ where+ tfield p n c =+ defaultValue+ (p $ _gsyoPath $ _goSpecify $ _configGarbageGenerator defaultConfig)+ (Toml.table c n)+ .= p+ dfield p n =+ defaultValue+ (p $ _gsyoPath $ _goSpecify $ _configGarbageGenerator defaultConfig)+ (Toml.double n)+ .= p++garbageSpecifyTimingCheckCodec :: TomlCodec GarbageSpecifyTimingCheckOpts+garbageSpecifyTimingCheckCodec =+ GarbageSpecifyTimingCheckOpts+ <$> dfield _gstcoOptionalArg "optarg"+ <*> dfield _gstcoEvent "event_optional"+ <*> dfield _gstcoEventEdge "event_edge"+ <*> dfield _gstcoCondition "condition_optional"+ <*> dfield _gstcoCondNeg_Pos "condition_neg_or_pos"+ <*> dfield _gstcoDelayedMinTypMax "delayedMinTypMax"+ where+ dfield p n =+ defaultValue+ (p $ _gsyoTimingCheck $ _goSpecify $ _configGarbageGenerator defaultConfig)+ (Toml.double n)+ .= p++garbageSpecifyCodec :: TomlCodec GarbageSpecifyOpts+garbageSpecifyCodec =+ GarbageSpecifyOpts+ <$> tfield _gsyoPath "path" garbageSpecifyPathCodec+ <*> tfield _gsyoTimingCheck "timingCheck" garbageSpecifyTimingCheckCodec+ <*> tfield _gsyoItems "items" numProbCodec+ <*> tfield _gsyoItem "item" catProbCodec+ <*> dfield _gsyoTermRange "termRange"+ <*> dfield _gsyoParamRange "parameter_range"+ <*> dfield _gsyoPathPulseEscaped_Simple "pathpulse_escaped_or_simple"+ <*> dfield _gsyoPathPulseRange "pathpulse_term_range"+ where+ tfield p n c =+ defaultValue (p $ _goSpecify $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goSpecify $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageGenerateCodec :: TomlCodec GarbageGenerateOpts+garbageGenerateCodec =+ GarbageGenerateOpts+ <$> garbageAttenuationCodec "attenuation" .= _ggoAttenuation+ <*> tfield _ggoItems "items" numProbCodec+ <*> tfield _ggoItem "item" catProbCodec+ <*> dfield _ggoOptionalBlock "optionalBlock"+ <*> dfield _ggoInstOptionalDelay "instance_optional_delay"+ <*> dfield _ggoInstOptionalRange "instance_optional_range"+ <*> dfield _ggoPrimitiveOptIdent "primitive_optional_name"+ <*> tfield _ggoCondBlock "nested_condition" catProbCodec+ <*> tfield _ggoNetType "net_type" catProbCodec+ <*> dfield _ggoNetRange "net_range"+ <*> tfield _ggoNetVectoring "net_vectoring" catProbCodec+ <*> tfield _ggoDeclItem "declaration" catProbCodec+ <*> dfield _ggoDeclDim_Init "declaration_dim_or_init"+ <*> tfield _ggoChargeStrength "chargeStrength" catProbCodec+ <*> dfield _ggoTaskFunAutomatic "taskFun_automatic"+ <*> tfield _ggoTaskFunDecl "taskFun_declaration" catProbCodec+ <*> dfield _ggoTaskFunRegister "taskFun_register"+ <*> tfield _ggoTaskFunPorts "taskFun_ports" numProbCodec+ <*> tfield _ggoTaskFunPortType "taskFun_portType" catProbCodec+ <*> tfield _ggoTaskPortDirection "taskPortDir" catProbCodec+ <*> dfield _ggoFunRetType "funReturnType"+ <*> tfield _ggoGateInst "gate" catProbCodec+ <*> dfield _ggoGateOptIdent "gate_optional_name"+ <*> tfield _ggoGateNInputType "gate_ninput" catProbCodec+ <*> tfield _ggoGateInputs "gate_ninputs" numProbCodec+ <*> tfield _ggoGateOutputs "gate_noutputs" numProbCodec+ <*> tfield _ggoCaseBranches "case_branches" numProbCodec+ <*> tfield _ggoCaseBranchPatterns "case_patterns" numProbCodec+ where+ tfield p n c =+ defaultValue (p $ _goGenerate $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goGenerate $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageTypeCodec :: TomlCodec GarbageTypeOpts+garbageTypeCodec =+ GarbageTypeOpts+ <$> dfield _gtoAbstract_Concrete "abstract_or_concrete"+ <*> tfield _gtoAbstract "abstract" catProbCodec+ <*> dfield _gtoConcreteSignedness "concrete_signedness"+ <*> dfield _gtoConcreteBitRange "concrete_bitRange"+ <*> tfield _gtoDimensions "dimensions" numProbCodec+ where+ tfield p n c =+ defaultValue (p $ _goType $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goType $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageStatementCodec :: TomlCodec GarbageStatementOpts+garbageStatementCodec =+ GarbageStatementOpts+ <$> garbageAttenuationCodec "attenuation" .= _gstoAttenuation+ <*> dfield _gstoOptional "optional"+ <*> tfield _gstoItem "item" catProbCodec+ <*> tfield _gstoItems "items" numProbCodec+ <*> dfield _gstoOptionalDelEvCtl "optionalDelayEventControl"+ <*> dfield _gstoAssignmentBlocking "assignmentBlocking"+ <*> tfield _gstoCase "case_kind" catProbCodec+ <*> tfield _gstoCaseBranches "case_branches" numProbCodec+ <*> tfield _gstoCaseBranchPatterns "case_patterns" numProbCodec+ <*> tfield _gstoLoop "loop" catProbCodec+ <*> dfield _gstoBlockPar_Seq "block_par_or_seq"+ <*> dfield _gstoBlockHeader "block_header"+ <*> tfield _gstoBlockDecls "block_declarations" numProbCodec+ <*> tfield _gstoBlockDecl "block_declaration" catProbCodec+ <*> tfield _gstoProcContAssign "procContAss_assDeassForceRel" catProbCodec+ <*> dfield _gstoPCAVar_Net "procContAss_var_or_net"+ <*> tfield _gstoDelayEventRepeat "delayEventRepeat" catProbCodec+ <*> tfield _gstoEvent "event" catProbCodec+ <*> tfield _gstoEvents "event_exprs" numProbCodec+ <*> tfield _gstoEventPrefix "event_prefix" catProbCodec+ <*> tfield _gstoSysTaskPorts "sysTask_ports" numProbCodec+ <*> dfield _gstoSysTaskOptionalPort "sysTask_optionalPort"+ where+ tfield p n c =+ defaultValue (p $ _goStatement $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goStatement $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageExprCodec :: TomlCodec GarbageExprOpts+garbageExprCodec =+ GarbageExprOpts+ <$> garbageAttenuationCodec "attenuation" .= _geoAttenuation+ <*> tfield _geoItem "item" catProbCodec+ <*> tfield _geoPrimary "primary" catProbCodec+ <*> tfield _geoUnary "op_unary" catProbCodec+ <*> tfield _geoBinary "op_binary" catProbCodec+ <*> dfield _geoMinTypMax "minTypMax"+ <*> dfield _geoDimRange "dimRange"+ <*> tfield _geoRange "range_kind" catProbCodec+ <*> dfield _geoRangeOffsetPos_Neg "range_offset_pos_or_neg"+ <*> tfield _geoConcatenations "concatenations" numProbCodec+ <*> tfield _geoSysFunArgs "sysFunArgs" numProbCodec+ <*> tfield _geoLiteralWidth "literal_width" catProbCodec+ <*> dfield _geoLiteralSigned "literal_signed"+ <*> tfield _geoStringCharacters "string_characters" numProbCodec+ <*> tfield _geoStringCharacter "string_character" catProbCodec+ <*> dfield _geoFixed_Floating "fixed_or_float"+ <*> tfield _geoExponentSign "exponentSign" catProbCodec+ <*> dfield _geoX_Z "X_or_Z"+ <*> tfield _geoBinarySymbols "binary_digits" numProbCodec+ <*> tfield _geoBinarySymbol "binary_digit" catProbCodec+ <*> tfield _geoOctalSymbols "octal_digits" numProbCodec+ <*> tfield _geoOctalSymbol "octal_digit" catProbCodec+ <*> tfield _geoDecimalSymbols "decimal_digits" numProbCodec+ <*> tfield _geoDecimalSymbol "decimal_digit" catProbCodec+ <*> tfield _geoHexadecimalSymbols "hex_digits" numProbCodec+ <*> tfield _geoHexadecimalSymbol "hex_digit" catProbCodec+ where+ tfield p n c =+ defaultValue (p $ _goExpr $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goExpr $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageIdentifierCodec :: TomlCodec GarbageIdentifierOpts+garbageIdentifierCodec =+ GarbageIdentifierOpts+ <$> dfield _gioEscaped_Simple "escaped_or_simple"+ <*> tfield _gioSimpleLetters "simple_length" numProbCodec+ <*> tfield _gioSimpleLetter "simple_letter" catProbCodec+ <*> tfield _gioEscapedLetters "escaped_length" numProbCodec+ <*> tfield _gioEscapedLetter "escaped_letter" catProbCodec+ <*> tfield _gioSystemLetters "system_length" numProbCodec+ <*> tfield _gioSystemFirstLetter "system_first_letter" catProbCodec+ where+ tfield p n c =+ defaultValue (p $ _goIdentifier $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n =+ defaultValue (p $ _goIdentifier $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++garbageCodec :: TomlCodec GarbageOpts+garbageCodec =+ GarbageOpts+ <$> Toml.dioptional (Toml.read "seed") .= _goSeed+ <*> tfield _goConfig "config" garbageConfigCodec+ <*> tfield _goPrimitive "primitive" garbagePrimitiveCodec+ <*> tfield _goModule "module" garbageModuleCodec+ <*> tfield _goSpecify "specify" garbageSpecifyCodec+ <*> tfield _goGenerate "generate" garbageGenerateCodec+ <*> tfield _goType "type" garbageTypeCodec+ <*> tfield _goStatement "statement" garbageStatementCodec+ <*> tfield _goExpr "expr" garbageExprCodec+ <*> tfield _goIdentifier "identifier" garbageIdentifierCodec+ <*> tfield _goDriveStrength "driveStrength" catProbCodec+ <*> tfield _goLValues "lvalue_items" numProbCodec+ <*> dfield _goOptionalLValue "lvalue_optional"+ <*> tfield _goAttributes "attribute_items" numProbCodec+ <*> dfield _goAttributeOptionalValue "attribute_optional_value"+ <*> tfield _goDelay "delay_items" catProbCodec+ <*> tfield _goIntRealIdent "delay_base" catProbCodec+ <*> tfield _goPathDepth "path_depth" numProbCodec+ <*> dfield _goBareMinTypMax "parameter_mintypmax_or_single"+ where+ tfield p n c = defaultValue (p $ _configGarbageGenerator defaultConfig) (Toml.table c n) .= p+ dfield p n = defaultValue (p $ _configGarbageGenerator defaultConfig) (Toml.double n) .= p++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++emiCodec :: TomlCodec ConfEMI+emiCodec =+ ConfEMI+ <$> defaultValue+ (defaultConfig ^. configEMI . confEMIGenerateProb)+ (Toml.int "generate_prob")+ .= _confEMIGenerateProb+ <*> defaultValue+ (defaultConfig ^. configEMI . confEMINoGenerateProb)+ (Toml.int "nogenerate_prob")+ .= _confEMINoGenerateProb++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 ^. configEMI)+ (Toml.table emiCodec "emi")+ .= _configEMI+ <*> 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 ^. configGarbageGenerator)+ (Toml.table garbageCodec "invalid_generator")+ .= _configGarbageGenerator+ <*> defaultValue+ (defaultConfig ^. configSimulators)+ (Toml.list simulator "simulator")+ .= _configSimulators+ <*> defaultValue+ (defaultConfig ^. configSynthesisers)+ (Toml.list synthesiser "synthesiser")+ .= _configSynthesisers++parseConfigFile :: FilePath -> IO (Either Text Config)+parseConfigFile fp = do+ decoded <- Toml.decodeFileExact configCodec fp+ case decoded of+ Right c -> return $ Right c+ Left e -> return . Left $ Toml.prettyTomlDecodeErrors e++parseConfig :: Text -> Either Text Config+parseConfig t = case Toml.decodeExact configCodec t of+ Right c -> Right c+ Left e -> Left $ Toml.prettyTomlDecodeErrors e++parseConfigFileRelaxed :: FilePath -> IO (Either Text Config)+parseConfigFileRelaxed fp = do+ decoded <- Toml.decodeFileEither configCodec fp+ case decoded of+ Right c -> return $ Right c+ Left e -> return . Left $ Toml.prettyTomlDecodeErrors e++parseConfigRelaxed :: Text -> Either Text Config+parseConfigRelaxed t = case Toml.decode configCodec t of+ Right c -> Right c+ Left e -> Left $ Toml.prettyTomlDecodeErrors e++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)+ <> ")"
src/Verismith/CounterEg.hs view
@@ -1,44 +1,43 @@-{-|-Module : Verismith.CounterEg-Description : Counter example parser to load the counter example-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--}-+-- |+-- Module : Verismith.CounterEg+-- Description : Counter example parser to load the counter example+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX module Verismith.CounterEg- ( CounterEg(..)- , parseCounterEg- )+ ( CounterEg (..),+ parseCounterEg,+ ) where -import Control.Applicative ((<|>))-import Data.Bifunctor (bimap)-import Data.Binary (encode)-import Data.Bits (shiftL, (.|.))-import Data.ByteString (ByteString)-import qualified Data.ByteString as B+import Control.Applicative ((<|>))+import Data.Bifunctor (bimap)+import Data.Binary (encode)+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Char (digitToInt)-import Data.Functor (($>))-import Data.Maybe (listToMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Numeric (readInt)-import qualified Text.Parsec as P+import Data.Char (digitToInt)+import Data.Functor (($>))+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Numeric (readInt)+import qualified Text.Parsec as P -data CounterEg = CounterEg { _counterEgInitial :: ![(Text, Text)]- , _counterEgStates :: ![[(Text, Text)]]- }- deriving (Eq, Show)+data CounterEg = CounterEg+ { _counterEgInitial :: ![(Text, Text)],+ _counterEgStates :: ![[(Text, Text)]]+ }+ deriving (Eq, Show) instance Semigroup CounterEg where- CounterEg a b <> CounterEg c d = CounterEg (a <> c) (b <> d)+ CounterEg a b <> CounterEg c d = CounterEg (a <> c) (b <> d) instance Monoid CounterEg where- mempty = CounterEg mempty mempty+ mempty = CounterEg mempty mempty type Parser = P.Parsec String () @@ -57,11 +56,12 @@ -- convertBinary = fromBytes . convert lexme :: Parser a -> Parser a-lexme f = do { a <- f; _ <- P.spaces; return a }+lexme f = do a <- f; _ <- P.spaces; return a nameChar :: Parser Char-nameChar = P.alphaNum- <|> P.oneOf "$.:_"+nameChar =+ P.alphaNum+ <|> P.oneOf "$.:_" parens :: Parser a -> Parser a parens = lexme . P.between (P.char '(') (P.char ')')@@ -74,39 +74,41 @@ assumeBody :: Parser (String, String) assumeBody = lexme $ do- name <- P.char '=' *> P.spaces *> brackets (P.many1 nameChar)- num <- P.spaces *> ((P.string "#b" *> P.many1 P.digit) <|> trueOrFalse)- return (name, num)+ name <- P.char '=' *> P.spaces *> brackets (P.many1 nameChar)+ num <- P.spaces *> ((P.string "#b" *> P.many1 P.digit) <|> trueOrFalse)+ return (name, num) parseAssume :: Parser (String, String) parseAssume = lexme $ P.string "assume" *> P.spaces *> parens assumeBody parseInitial :: Parser [(String, String)] parseInitial = lexme $ do- _ <- lexme $ P.string "initial"- P.many parseAssume+ _ <- lexme $ P.string "initial"+ P.many parseAssume parseState :: Parser (String, [(String, String)]) parseState = lexme $ do- n <- lexme $ P.string "state" *> P.spaces *> P.many1 P.digit- assumes <- P.many parseAssume- return (n, assumes)+ n <- lexme $ P.string "state" *> P.spaces *> P.many1 P.digit+ assumes <- P.many parseAssume+ return (n, assumes) parseCE :: Parser [[(String, String)]] parseCE = lexme $ do- i <- parseInitial- other <- fmap snd <$> P.many parseState- return (i : other)+ i <- parseInitial+ other <- fmap snd <$> P.many parseState+ return (i : other) cEtoCounterEg :: [[(String, String)]] -> CounterEg cEtoCounterEg [] = mempty-cEtoCounterEg (i : is) = CounterEg (bimap T.pack T.pack <$> i)- (fmap (bimap T.pack T.pack) <$> is)+cEtoCounterEg (i : is) =+ CounterEg+ (bimap T.pack T.pack <$> i)+ (fmap (bimap T.pack T.pack) <$> is) parseCounterEg' :: Parser CounterEg parseCounterEg' = lexme $ do- _ <- P.spaces- cEtoCounterEg <$> parseCE+ _ <- P.spaces+ cEtoCounterEg <$> parseCE parseCounterEg :: Text -> Either String CounterEg parseCounterEg = bimap show id . P.parse parseCounterEg' "" . T.unpack
+ src/Verismith/EMI.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module : Verismith.EMI+-- Description : Definition of the circuit graph.+-- Copyright : (c) 2021, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Equivalence modulo inputs (EMI) testing. This file should get an existing design, and spit out a+-- modified design that is equivalent under some specific values of the extra inputs.+module Verismith.EMI where++import Control.Lens hiding (Context)+import Control.Monad (replicateM)+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Hedgehog (Gen, GenT, MonadGen)+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as HogR+import Verismith.Config+import Verismith.Generate+import Verismith.Utils+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Eval+import Verismith.Verilog.Internal+import Verismith.Verilog.Mutate+import Verismith.Verilog.Quote++data EMIInputs a+ = EMIInputs [Identifier]+ | EMIOrig a+ deriving (Eq, Ord)++instance (Show a) => Show (EMIInputs a) where+ show (EMIInputs i) = "EMI: " <> intercalate ", " (T.unpack . getIdentifier <$> i)+ show (EMIOrig a) = show a++newPort' :: Identifier -> StateGen a Port+newPort' ident = do+ hex <- Identifier . T.toLower . T.pack <$> Hog.list (HogR.constant 10 10) Hog.hexit+ let p = Port Wire False (Range 0 0) (ident <> hex)+ emiContext . _Just . emiNewInputs %= (p :)+ return p++nstatementEMI :: StateGen a (Maybe (Statement a))+nstatementEMI = do+ config <- ask+ Hog.frequency+ [ ( config ^. configEMI . confEMIGenerateProb,+ do+ s' <- statement+ n <- newPort' "emi_"+ return (Just (CondStmnt (Id (n ^. portName)) (Just s') Nothing))+ ),+ (config ^. configEMI . confEMINoGenerateProb, return Nothing)+ ]++statementEMI :: Statement a -> StateGen a (Statement a)+statementEMI (SeqBlock s) = do+ s'' <- nstatementEMI+ return $ SeqBlock ((s'' ^.. _Just) ++ s)+statementEMI s = return s++moditemEMI :: ModItem a -> StateGen a (ModItem a)+moditemEMI (Always s) = Always <$> transformM statementEMI s+moditemEMI m = return m++moddeclEMI :: ModDecl a -> StateGen a (ModDecl (EMIInputs a))+moddeclEMI m = do+ emiContext . _Just . emiNewInputs .= []+ blocking .= []+ nonblocking .= []+ wires .= []+ m' <- traverseOf (modItems . traverse) moditemEMI m+ c <- use (emiContext . _Just . emiNewInputs)+ b <- use blocking+ nb <- use nonblocking+ w <- use wires+ let m'' = m' & modInPorts %~ (c ++) & initNewRegs c & initNewInnerRegs (b <> nb <> w)+ return (ModDeclAnn (EMIInputs (c ^.. traverse . portName)) (fmap (\x -> EMIOrig x) m''))++sourceEMI :: (SourceInfo a) -> StateGen a (SourceInfo (EMIInputs a))+sourceEMI s =+ traverseOf (infoSrc . _Wrapped . traverse) moddeclEMI s++initNewRegs :: [Port] -> ModDecl a -> ModDecl a+initNewRegs ps m = m & modItems %~ (++ (Decl (Just PortIn) <$> ps <*> pure Nothing))++initNewInnerRegs :: [Port] -> ModDecl a -> ModDecl a+initNewInnerRegs ps m = m & modItems %~ (++ (Decl Nothing <$> ps <*> pure Nothing))++-- | Procedural generation method for random Verilog. Uses internal 'Reader' and+-- 'State' to keep track of the current Verilog code structure.+proceduralEMI :: SourceInfo a -> Config -> Gen (SourceInfo (EMIInputs a))+proceduralEMI src config = do+ (mainMod, st) <-+ Hog.resize num $+ runStateT+ (Hog.distributeT (runReaderT (sourceEMI src) config))+ context+ return mainMod+ where+ context =+ Context+ []+ []+ []+ []+ []+ []+ 100000+ (confProp propStmntDepth)+ (confProp propModDepth)+ True+ (Just (EMIContext []))+ num = fromIntegral $ confProp propSize+ confProp i = config ^. configProperty . i++proceduralEMIIO :: SourceInfo a -> Config -> IO (SourceInfo (EMIInputs a))+proceduralEMIIO t = Hog.sample . proceduralEMI t++-- | Make top level module for equivalence verification. Also takes in how many+-- modules to instantiate.+makeTopEMI :: Int -> ModDecl (EMIInputs ann) -> (ModDecl (EMIInputs ann), [Identifier])+makeTopEMI i m' = (ModDecl (m ^. modId) ys nports modIt [], anns)+ where+ ys = yPort . flip makeIdFrom "y" <$> [1 .. i]+ modIt = instantiateModSpec_ True "_" . modN <$> [1 .. i]+ modN n =+ m & modId %~ makeIdFrom n & modOutPorts .~ [yPort (makeIdFrom n "y")]+ anns =+ concatMap+ ( \x -> case x of+ EMIInputs x -> x+ _ -> []+ )+ (collectAnn m')+ m = removeAnn m'+ nports = filter (\x -> (x ^. portName) `notElem` anns) (m ^. modInPorts)++createProperty :: Identifier -> ModItem a+createProperty i =+ Property (i <> "_emi_prop") (EPosEdge "clk") Nothing (BinOp (Id i) BinEq 0)++createAssignment :: Identifier -> Statement a+createAssignment i = BlockAssign (Assign (RegId i) Nothing 0)++addAssumesEMI ::+ (ModDecl a, [Identifier]) ->+ (ModDecl a, [Identifier])+addAssumesEMI (m, i) = (m & modItems %~ (++ mods), i)+ where+ mods = fmap createProperty i++addAssignmentsEMI ::+ (ModDecl a, [Identifier]) ->+ (ModDecl a, [Identifier])+addAssignmentsEMI (m, i) = (m & modItems %~ (mods :), i)+ where+ mods = Initial (SeqBlock (createAssignment <$> i))++-- | 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.+makeTopAssertEMI :: Bool -> ModDecl (EMIInputs ann) -> (ModDecl (EMIInputs ann), [Identifier])+makeTopAssertEMI b =+ bimap (modItems %~ (assert :)) id+ . (if b then addAssumesEMI else addAssignmentsEMI)+ . makeTopEMI 2+ where+ assert =+ Always . EventCtrl e . Just $+ SeqBlock+ [TaskEnable $ Task "assert" [BinOp (Id "y_1") BinEq (Id "y_2")]]+ e = EPosEdge "clk"++initModEMI :: (ModDecl ann, [Identifier]) -> (ModDecl ann)+initModEMI (m, i) = m & modItems %~ ((out ++ inp ++ other) ++)+ where+ out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing+ inp = Decl (Just PortIn) <$> (m ^. modInPorts) <*> pure Nothing+ other = Decl Nothing <$> map (\i' -> Port Reg False (Range 0 0) i') i <*> pure Nothing++getTopEMIIdent :: SourceInfo (EMIInputs a) -> [Identifier]+getTopEMIIdent s =+ concatMap+ ( \x -> case x of+ EMIInputs x -> x+ _ -> []+ )+ (collectAnn (s ^. mainModule))++-- Test code++m :: SourceInfo ()+m =+ SourceInfo+ "m"+ [verilog|+module m;+ always @(posedge clk) begin+ if (z == 2) begin+ ry = 2;+ end+ x <= y;+ y <= z;+ end+endmodule++module m2;+ always @(posedge clk) begin+ if (z == 2) begin+ ry = 2;+ end+ x <= y;+ y <= z;+ end+endmodule+|]++p :: (Show a) => ModDecl a -> IO ()+p = T.putStrLn . genSource++p2 :: (Show a) => SourceInfo a -> IO ()+p2 = T.putStrLn . genSource++customConfig =+ defaultConfig+ & (configEMI . confEMIGenerateProb .~ 1)+ . (configEMI . confEMINoGenerateProb .~ 0)++top = ((initModEMI . makeTopAssertEMI True . (\s -> s ^. mainModule)) <$> proceduralEMIIO m customConfig) >>= p++top2 = proceduralEMIIO m customConfig >>= p2
src/Verismith/Fuzz.hs view
@@ -1,114 +1,119 @@-{-|-Module : Verismith.Fuzz-Description : Environment to run the simulator and synthesisers in a matrix.-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Environment to run the simulator and synthesisers in a matrix.--}--{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} +-- |+-- Module : Verismith.Fuzz+-- Description : Environment to run the simulator and synthesisers in a matrix.+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Environment to run the simulator and synthesisers in a matrix. module Verismith.Fuzz- ( Fuzz (..)- , FuzzOpts (..)- , fuzz- , fuzzInDir- , fuzzMultiple- , runFuzz- , sampleSeed+ ( Fuzz (..),+ FuzzOpts (..),+ fuzz,+ fuzzInDir,+ fuzzMultiple,+ fuzzMultipleEMI,+ runFuzz,+ sampleSeed,+ -- * Helpers- , make- , pop- )+ make,+ pop,+ ) where -import Control.DeepSeq (force)-import Control.Exception.Lifted (finally)-import Control.Lens hiding ((<.>))-import Control.Monad (forM, replicateM)-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State.Strict-import Control.Monad.Trans.Control (MonadBaseControl)-import qualified Crypto.Random.DRBG as C-import Data.ByteString (ByteString)-import Data.List (nubBy, sort)-import Data.Maybe (catMaybes, fromMaybe, isNothing)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time-import Data.Tuple (swap)-import Hedgehog (Gen)-import qualified Hedgehog.Internal.Gen as Hog-import Hedgehog.Internal.Seed (Seed)-import qualified Hedgehog.Internal.Seed as Hog-import qualified Hedgehog.Internal.Tree as Hog-import Prelude hiding (FilePath)-import Shelly hiding (get, sub)-import Shelly.Lifted (MonadSh, liftSh, sub)-import System.FilePath.Posix (takeBaseName)-import Verismith.Config-import Verismith.CounterEg (CounterEg (..))-import Verismith.Internal-import Verismith.Reduce-import Verismith.Report-import Verismith.Result-import Verismith.Tool.Icarus-import Verismith.Tool.Internal-import Verismith.Tool.Yosys-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (force)+import Control.Exception.Lifted (finally)+import Control.Lens hiding ((<.>))+import Control.Monad (forM, replicateM)+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.ByteString (ByteString)+import Data.List (nubBy, sort)+import Data.Maybe (catMaybes, fromMaybe, isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Data.Tuple (swap)+import Hedgehog (Gen)+import qualified Hedgehog.Internal.Gen as Hog+import Hedgehog.Internal.Seed (Seed)+import qualified Hedgehog.Internal.Seed as Hog+import qualified Hedgehog.Internal.Tree as Hog+import Shelly hiding (get, sub)+import Shelly.Lifted (MonadSh, liftSh, sub)+import System.FilePath.Posix (takeBaseName)+import Verismith.Config+import Verismith.CounterEg (CounterEg (..))+import Verismith.EMI+import Verismith.Reduce+import Verismith.Report+import Verismith.Result+import Verismith.Tool.Icarus+import Verismith.Tool.Internal+import Verismith.Tool.Yosys+import Verismith.Utils+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data FuzzOpts = FuzzOpts { _fuzzOptsOutput :: !(Maybe FilePath)- , _fuzzOptsForced :: !Bool- , _fuzzOptsKeepAll :: !Bool- , _fuzzOptsIterations :: {-# UNPACK #-} !Int- , _fuzzOptsNoSim :: !Bool- , _fuzzOptsNoEquiv :: !Bool- , _fuzzOptsNoReduction :: !Bool- , _fuzzOptsConfig :: {-# UNPACK #-} !Config- , _fuzzDataDir :: {-# UNPACK #-} !FilePath- , _fuzzOptsCrossCheck :: !Bool- , _fuzzOptsChecker :: !(Maybe Text)- }- deriving (Show, Eq)+data FuzzOpts = FuzzOpts+ { _fuzzOptsOutput :: !(Maybe FilePath),+ _fuzzOptsForced :: !Bool,+ _fuzzOptsKeepAll :: !Bool,+ _fuzzOptsIterations :: {-# UNPACK #-} !Int,+ _fuzzOptsNoSim :: !Bool,+ _fuzzOptsNoEquiv :: !Bool,+ _fuzzOptsNoReduction :: !Bool,+ _fuzzOptsConfig :: {-# UNPACK #-} !Config,+ _fuzzDataDir :: !FilePath,+ _fuzzOptsCrossCheck :: !Bool,+ _fuzzOptsChecker :: !(Maybe Text)+ }+ deriving (Show, Eq) $(makeLenses ''FuzzOpts) defaultFuzzOpts :: FuzzOpts-defaultFuzzOpts = FuzzOpts { _fuzzOptsOutput = Nothing- , _fuzzOptsForced = False- , _fuzzOptsKeepAll = False- , _fuzzOptsIterations = 1- , _fuzzOptsNoSim = False- , _fuzzOptsNoEquiv = False- , _fuzzOptsNoReduction = False- , _fuzzOptsConfig = defaultConfig- , _fuzzDataDir = fromText "."- , _fuzzOptsCrossCheck = False- , _fuzzOptsChecker = Nothing- }+defaultFuzzOpts =+ FuzzOpts+ { _fuzzOptsOutput = Nothing,+ _fuzzOptsForced = False,+ _fuzzOptsKeepAll = False,+ _fuzzOptsIterations = 1,+ _fuzzOptsNoSim = False,+ _fuzzOptsNoEquiv = False,+ _fuzzOptsNoReduction = False,+ _fuzzOptsConfig = defaultConfig,+ _fuzzDataDir = fromText ".",+ _fuzzOptsCrossCheck = False,+ _fuzzOptsChecker = Nothing+ } -data FuzzEnv = FuzzEnv { _getSynthesisers :: ![SynthTool]- , _getSimulators :: ![SimTool]- , _yosysInstance :: {-# UNPACK #-} !Yosys- , _fuzzEnvOpts :: {-# UNPACK #-} !FuzzOpts- }- deriving (Eq, Show)+data FuzzEnv = FuzzEnv+ { _getSynthesisers :: ![SynthTool],+ _getSimulators :: ![SimTool],+ _yosysInstance :: {-# UNPACK #-} !Yosys,+ _fuzzEnvOpts :: {-# UNPACK #-} !FuzzOpts+ }+ deriving (Eq, Show) $(makeLenses ''FuzzEnv) -data FuzzState = FuzzState { _fuzzSynthResults :: ![SynthResult]- , _fuzzSimResults :: ![SimResult]- , _fuzzSynthStatus :: ![SynthStatus]- }- deriving (Eq, Show)+data FuzzState = FuzzState+ { _fuzzSynthResults :: ![SynthResult],+ _fuzzSimResults :: ![SimResult],+ _fuzzSynthStatus :: ![SynthStatus]+ }+ deriving (Eq, Show) $(makeLenses ''FuzzState) @@ -120,124 +125,127 @@ type MonadFuzz m = (MonadBaseControl IO m, MonadIO m, MonadSh m) -runFuzz :: MonadIO m => FuzzOpts -> Yosys -> Fuzz Sh a -> m a+runFuzz :: (MonadIO m) => FuzzOpts -> Yosys -> Fuzz Sh a -> m a runFuzz fo yos m = shelly $ runFuzz' fo yos m -runFuzz' :: Monad m => FuzzOpts -> Yosys -> Fuzz m b -> m b-runFuzz' fo yos m = runReaderT+runFuzz' :: (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- }+ ( 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 :: (Monad m) => Fuzz m Config askConfig = asks (_fuzzOptsConfig . _fuzzEnvOpts) -askOpts :: Monad m => Fuzz m FuzzOpts+askOpts :: (Monad m) => Fuzz m FuzzOpts askOpts = asks _fuzzEnvOpts genMethod conf seed gen =- case T.toLower $ conf ^. configProperty . propSampleMethod of- "hat" -> do- logT "Using the hat function"- sv hatFreqs- "mean" -> do- logT "Using the mean function"- sv meanFreqs- "median" -> do- logT "Using the median function"- sv medianFreqs- _ -> do- logT "Using first seed"- sampleSeed seed gen+ case T.toLower $ conf ^. configProperty . propSampleMethod of+ "hat" -> do+ logT "Using the hat function"+ sv hatFreqs+ "mean" -> do+ logT "Using the mean function"+ sv meanFreqs+ "median" -> do+ logT "Using the median function"+ sv medianFreqs+ _ -> do+ logT "Using first seed"+ sampleSeed seed gen where sv a = sampleVerilog a (conf ^. configProperty . propSampleSize) seed gen relativeFuzzReport :: (MonadSh m) => FuzzReport -> m FuzzReport relativeFuzzReport fr@(FuzzReport dir _ _ _ _ _ _ _) = liftSh $ do- newPath <- relPath dir- return $ (fuzzDir .~ newPath) fr+ newPath <- relPath dir+ return $ (fuzzDir .~ newPath) fr filterSynth :: SynthResult -> Bool filterSynth (SynthResult _ _ (Pass _) _) = True-filterSynth _ = False+filterSynth _ = False filterSim :: SimResult -> Bool filterSim (SimResult _ _ _ (Pass _) _) = True-filterSim _ = False+filterSim _ = False filterSynthStat :: SynthStatus -> Bool filterSynthStat (SynthStatus _ (Pass _) _) = True-filterSynthStat _ = False+filterSynthStat _ = False passedFuzz :: FuzzReport -> Bool passedFuzz (FuzzReport _ synth sim synthstat _ _ _ _) =- (passedSynth + passedSim + passedSynthStat) == 0+ (passedSynth + passedSim + passedSynthStat) == 0 where passedSynth = length $ filter (not . filterSynth) synth passedSim = length $ filter (not . filterSim) sim passedSynthStat = length $ filter (not . filterSynthStat) synthstat -synthesisers :: Monad m => Fuzz m [SynthTool]+synthesisers :: (Monad m) => Fuzz m [SynthTool] synthesisers = lift $ asks _getSynthesisers ---simulators :: (Monad m) => Fuzz () m [SimTool]---simulators = lift $ asks getSimulators+-- simulators :: (Monad m) => Fuzz () m [SimTool]+-- simulators = lift $ asks getSimulators combinations :: [a] -> [b] -> [(a, b)]-combinations l1 l2 = [ (x, y) | x <- l1, y <- l2 ]+combinations l1 l2 = [(x, y) | x <- l1, y <- l2] -logT :: MonadSh m => Text -> m ()+logT :: (MonadSh m) => Text -> m () logT = liftSh . logger timeit :: (MonadIO m, MonadSh m) => m a -> m (NominalDiffTime, a) timeit a = do- start <- liftIO getCurrentTime- result <- a- end <- liftIO getCurrentTime- return (diffUTCTime end start, result)+ start <- liftIO getCurrentTime+ result <- a+ end <- liftIO getCurrentTime+ return (diffUTCTime end start, result) -synthesis :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m ()+synthesis :: (MonadBaseControl IO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () synthesis src = do- synth <- synthesisers- resTimes <- liftSh $ mapM exec synth- fuzzSynthStatus- .= applyList (uncurry . SynthStatus <$> synth) (fmap swap resTimes)- liftSh $ inspect resTimes+ synth <- synthesisers+ resTimes <- liftSh $ mapM exec synth+ fuzzSynthStatus+ .= applyList (uncurry . SynthStatus <$> synth) (fmap swap resTimes)+ liftSh $ inspect resTimes where exec a = toolRun ("synthesis with " <> toText a) . runResultT $ do- liftSh . mkdir_p . fromText $ toText a- pop (fromText $ toText a) $ runSynth a src+ liftSh . mkdir_p . fromText $ toText a+ pop (fromText $ toText a) $ runSynth a src -passedSynthesis :: MonadSh m => Fuzz m [SynthTool]+passedSynthesis :: (MonadSh m) => Fuzz m [SynthTool] passedSynthesis = fmap toSynth . filter passed . _fuzzSynthStatus <$> get where passed (SynthStatus _ (Pass _) _) = True- passed _ = False+ passed _ = False toSynth (SynthStatus s _ _) = s -failedSynthesis :: MonadSh m => Fuzz m [SynthTool]+failedSynthesis :: (MonadSh m) => Fuzz m [SynthTool] failedSynthesis = fmap toSynth . filter failed . _fuzzSynthStatus <$> get where failed (SynthStatus _ (Fail SynthFail) _) = True- failed _ = False+ failed _ = False toSynth (SynthStatus s _ _) = s -make :: MonadSh m => FilePath -> m ()+make :: (MonadSh m) => FilePath -> m () make f = liftSh $ mkdir_p f pop :: (MonadBaseControl IO m, MonadSh m) => FilePath -> m a -> m a pop f a = do- dir <- liftSh pwd- finally (liftSh (cd f) >> a) . liftSh $ cd dir+ dir <- liftSh pwd+ finally (liftSh (cd f) >> a) . liftSh $ cd dir applyList :: [a -> b] -> [a] -> [b] applyList a b = apply' <$> zip a b where apply' (a', b') = a' b'@@ -245,324 +253,416 @@ applyLots :: (a -> b -> c -> d -> e) -> [(a, b)] -> [(c, d)] -> [e] applyLots func a b = applyList (uncurry . uncurry func <$> a) b -toSynthResult :: [(SynthTool, SynthTool)]- -> [(NominalDiffTime, Result Failed ())]- -> [SynthResult]+toSynthResult ::+ [(SynthTool, SynthTool)] ->+ [(NominalDiffTime, Result Failed ())] ->+ [SynthResult] toSynthResult a b = applyLots SynthResult a $ fmap swap b -toSimResult :: SimTool- -> [ByteString]- -> [SynthTool]- -> [(NominalDiffTime, Result Failed ByteString)]- -> [SimResult]+toSimResult ::+ SimTool ->+ [ByteString] ->+ [SynthTool] ->+ [(NominalDiffTime, Result Failed ByteString)] ->+ [SimResult] toSimResult sima bs as b =- applyList (applyList (repeat uncurry)- (applyList (applyList (SimResult <$> as) (repeat sima)) (repeat bs)))+ applyList+ ( applyList+ (repeat uncurry)+ (applyList (applyList (SimResult <$> as) (repeat sima)) (repeat bs))+ ) $ fmap swap b toolRun :: (MonadIO m, MonadSh m, Show a) => Text -> m a -> m (NominalDiffTime, a) toolRun t m = do- logT $ "Running " <> t- s <- timeit m- logT $ "Finished " <> t <> " " <> showT s- return s+ logT $ "Running " <> t+ s <- timeit m+ logT $ "Finished " <> t <> " " <> showT s+ return s -equivalence :: (MonadBaseControl IO m, MonadSh m) => SourceInfo -> Fuzz m ()+equivalence :: (MonadBaseControl IO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () equivalence src = do- doCrossCheck <- fmap _fuzzOptsCrossCheck askOpts- datadir <- fmap _fuzzDataDir askOpts- checker <- fmap _fuzzOptsChecker askOpts- synth <- passedSynthesis- conf <- fmap _fuzzOptsConfig askOpts- let synthComb =- if doCrossCheck- then nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth- else nubBy tupEq . filter (uncurry (/=)) $ (,) defaultIdentitySynth <$> synth- resTimes <- liftSh $ mapM (uncurry (equiv (conf ^. configProperty . propDefaultYosys) checker datadir)) synthComb- fuzzSynthResults .= toSynthResult synthComb resTimes- liftSh $ inspect resTimes+ doCrossCheck <- fmap _fuzzOptsCrossCheck askOpts+ datadir <- fmap _fuzzDataDir askOpts+ checker <- fmap _fuzzOptsChecker askOpts+ synth <- passedSynthesis+ conf <- fmap _fuzzOptsConfig askOpts+ let synthComb =+ if doCrossCheck+ then nubBy tupEq . filter (uncurry (/=)) $ combinations synth synth+ else nubBy tupEq . filter (uncurry (/=)) $ (,) defaultIdentitySynth <$> synth+ resTimes <- liftSh $ mapM (uncurry (equiv (conf ^. configProperty . propDefaultYosys) checker datadir)) synthComb+ fuzzSynthResults .= toSynthResult synthComb resTimes+ liftSh $ inspect resTimes where tupEq (a, b) (a', b') = (a == a' && b == b') || (a == b' && b == a') equiv yosysloc checker datadir a b =- toolRun ("equivalence check for " <> toText a <> " and " <> toText b)- . runResultT- $ do make dir- pop dir $ do- liftSh $ do- cp ( fromText ".."- </> fromText (toText a)- </> synthOutput a- ) $ synthOutput a- cp ( fromText ".."- </> fromText (toText b)- </> synthOutput b- ) $ synthOutput b- writefile "rtl.v" $ genSource src- sub $ do- maybe (return ()) (liftSh . prependToPath . fromText) yosysloc- runEquiv checker datadir a b src- where dir = fromText $ "equiv_" <> toText a <> "_" <> toText b+ toolRun ("equivalence check for " <> toText a <> " and " <> toText b)+ . runResultT+ $ do+ make dir+ pop dir $ do+ liftSh $ do+ cp+ ( fromText ".."+ </> fromText (toText a)+ </> synthOutput a+ )+ $ synthOutput a+ cp+ ( fromText ".."+ </> fromText (toText b)+ </> synthOutput b+ )+ $ synthOutput b+ writefile "rtl.v" $ genSource src+ sub $ do+ maybe (return ()) (liftSh . prependToPath . fromText) yosysloc+ runEquiv checker datadir a b src+ where+ dir = fromText $ "equiv_" <> toText a <> "_" <> toText b -simulation :: (MonadIO m, MonadSh m) => SourceInfo -> Fuzz m ()+simulation :: (MonadIO m, MonadSh m, Show ann) => (SourceInfo ann) -> Fuzz m () simulation src = do- datadir <- fmap _fuzzDataDir askOpts- synth <- passedSynthesis- counterEgs <- failEquivWithIdentityCE- vals <- liftIO $ generateByteString 20- ident <- liftSh $ sim datadir vals Nothing defaultIdentitySynth- resTimes <- liftSh $ mapM (sim datadir vals (justPass $ snd ident)) synth- resTimes2 <- liftSh $ mapM (simCounterEg datadir) counterEgs- fuzzSimResults .= toSimResult defaultIcarusSim vals synth resTimes- liftSh- . inspect- $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r)- <$> (ident : resTimes)+ datadir <- fmap _fuzzDataDir askOpts+ synth <- passedSynthesis+ counterEgs <- failEquivWithIdentityCE+ vals <- liftIO $ generateByteString Nothing 32 20+ ident <- liftSh $ sim datadir vals Nothing defaultIdentitySynth+ resTimes <- liftSh $ mapM (sim datadir vals (justPass $ snd ident)) synth+ resTimes2 <- liftSh $ mapM (simCounterEg datadir) counterEgs+ fuzzSimResults .= toSimResult defaultIcarusSim vals synth resTimes+ liftSh+ . inspect+ $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r)+ <$> (ident : resTimes) where sim datadir b i a = toolRun ("simulation for " <> toText a) . runResultT $ do- make dir- pop dir $ do- liftSh $ do- cp (fromText ".." </> fromText (toText a) </> synthOutput a)- $ synthOutput a- writefile "rtl.v" $ genSource src- runSimIc datadir defaultIcarus a src b i- where dir = fromText $ "simulation_" <> toText a+ make dir+ pop dir $ do+ liftSh $ do+ cp (fromText ".." </> fromText (toText a) </> synthOutput a) $+ synthOutput a+ writefile "rtl.v" $ genSource src+ runSimIc datadir defaultIcarus a src b i+ where+ dir = fromText $ "simulation_" <> toText a simCounterEg datadir (a, Nothing) = toolRun ("counter-example simulation for " <> toText a) . return $ Fail EmptyFail simCounterEg datadir (a, Just b) = toolRun ("counter-example simulation for " <> toText a) . runResultT $ do- make dir- pop dir $ do- liftSh $ do- cp (fromText ".." </> fromText (toText a) </> synthOutput a) $ synthOutput a- writefile "syn_identity.v" $ genSource src- ident <- runSimIcEC datadir defaultIcarus defaultIdentitySynth src b Nothing- runSimIcEC datadir defaultIcarus a src b (Just ident)- where dir = fromText $ "countereg_sim_" <> toText a---- | 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+ make dir+ pop dir $ do+ liftSh $ do+ cp (fromText ".." </> fromText (toText a) </> synthOutput a) $ synthOutput a+ writefile "syn_identity.v" $ genSource src+ ident <- runSimIcEC datadir defaultIcarus defaultIdentitySynth src b Nothing+ runSimIcEC datadir defaultIcarus a src b (Just ident)+ where+ dir = fromText $ "countereg_sim_" <> toText a --- | 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 []+simulationEMI :: (MonadIO m, MonadSh m, Show ann) => (SourceInfo (EMIInputs ann)) -> Fuzz m ()+simulationEMI src = do+ datadir <- fmap _fuzzDataDir askOpts+ synth <- passedSynthesis+ counterEgs <- failEquivWithIdentityCE+ vals <- liftIO $ generateByteString Nothing 32 100+ ident <- liftSh $ sim datadir vals Nothing defaultIdentitySynth+ resTimes <- liftSh $ mapM (sim datadir vals (justPass $ snd ident)) synth+ fuzzSimResults .= toSimResult defaultIcarusSim vals synth resTimes+ liftSh+ . inspect+ $ (\(_, r) -> bimap show (T.unpack . T.take 10 . showBS) r)+ <$> (ident : resTimes)+ where+ sim datadir b i a = toolRun ("simulation for " <> toText a) . runResultT $ do+ make dir+ pop dir $ do+ liftSh $ do+ cp (fromText ".." </> fromText (toText a) </> synthOutput a) $+ synthOutput a+ writefile "rtl.v" $ genSource src+ runSimIcEMI (getTopEMIIdent src) datadir defaultIcarus a (clearAnn src) b i+ where+ dir = fromText $ "emi_sim_" <> toText a failEquivWithIdentity :: (MonadSh m) => Fuzz m [SynthResult] failEquivWithIdentity = filter withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult (IdentitySynth _) _ (Fail (EquivFail _)) _) = True withIdentity (SynthResult _ (IdentitySynth _) (Fail (EquivFail _)) _) = True- withIdentity _ = False+ withIdentity _ = False failEquivWithIdentityCE :: (MonadSh m) => Fuzz m [(SynthTool, Maybe CounterEg)] failEquivWithIdentityCE = catMaybes . fmap withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult (IdentitySynth _) s (Fail (EquivFail c)) _) = Just (s, c) withIdentity (SynthResult s (IdentitySynth _) (Fail (EquivFail c)) _) = Just (s, c)- withIdentity _ = Nothing+ withIdentity _ = Nothing failedSimulations :: (MonadSh m) => Fuzz m [SimResult] failedSimulations = filter failedSim . _fuzzSimResults <$> get where failedSim (SimResult _ _ _ (Fail (SimFail _)) _) = True- failedSim _ = False+ failedSim _ = False passEquiv :: (MonadSh m) => Fuzz m [SynthResult] passEquiv = filter withIdentity . _fuzzSynthResults <$> get where withIdentity (SynthResult _ _ (Pass _) _) = True- withIdentity _ = False+ withIdentity _ = False -- | Always reduces with respect to 'Identity'.-reduction :: (MonadSh m) => SourceInfo -> Fuzz m ()-reduction src = do- datadir <- fmap _fuzzDataDir askOpts- checker <- fmap _fuzzOptsChecker askOpts- fails <- failEquivWithIdentity- synthFails <- failedSynthesis- simFails <- failedSimulations- _ <- liftSh $ mapM (red checker datadir) fails- _ <- liftSh $ mapM redSynth synthFails- _ <- liftSh $ mapM (redSim datadir) simFails- return ()+reduction :: (MonadSh m) => SourceInfo ann -> Fuzz m ()+reduction rsrc = do+ datadir <- fmap _fuzzDataDir askOpts+ checker <- fmap _fuzzOptsChecker askOpts+ fails <- failEquivWithIdentity+ synthFails <- failedSynthesis+ simFails <- failedSimulations+ _ <- liftSh $ mapM (red checker datadir) fails+ _ <- liftSh $ mapM redSynth synthFails+ _ <- liftSh $ mapM (redSim datadir) simFails+ return () where red checker datadir (SynthResult a b _ _) = do- r <- reduceSynth checker datadir a b src- writefile (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") $ genSource r+ r <- reduceSynth checker datadir a b src+ writefile (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") $ genSource r redSynth a = do- r <- reduceSynthesis a src- writefile (fromText $ "reduce_" <> toText a <> ".v") $ genSource r+ r <- reduceSynthesis a src+ writefile (fromText $ "reduce_" <> toText a <> ".v") $ genSource r redSim datadir (SimResult t _ bs _ _) = do- r <- reduceSimIc datadir bs t src- writefile (fromText $ "reduce_sim_" <> toText t <> ".v") $ genSource r+ r <- reduceSimIc datadir bs t src+ writefile (fromText $ "reduce_sim_" <> toText t <> ".v") $ genSource r+ src = clearAnn rsrc -titleRun- :: (MonadIO m, MonadSh m) => Text -> Fuzz m a -> Fuzz m (NominalDiffTime, a)+titleRun ::+ (MonadIO m, MonadSh m) => Text -> Fuzz m a -> Fuzz m (NominalDiffTime, a) titleRun t f = do- logT $ "### Starting " <> t <> " ###"- (diff, res) <- timeit f- logT $ "### Finished " <> t <> " (" <> showT diff <> ") ###"- return (diff, res)+ logT $ "### Starting " <> t <> " ###"+ (diff, res) <- timeit f+ logT $ "### Finished " <> t <> " (" <> showT diff <> ") ###"+ return (diff, res) -whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a)+whenMaybe :: (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 ::+ (MonadIO m, MonadSh m, Show ann) =>+ Fuzz m (Seed, (SourceInfo ann)) ->+ Fuzz m (Seed, (SourceInfo ann)) generateSample f = do- logT "Sampling Verilog from generator"- (t, v@(s, _)) <- timeit f- logT $ "Chose " <> showT s- logT $ "Generated Verilog (" <> showT t <> ")"- return v+ logT "Sampling Verilog from generator"+ (t, v@(s, _)) <- timeit f+ logT $ "Chose " <> showT s+ logT $ "Generated Verilog (" <> showT t <> ")"+ return v verilogSize :: (Source a) => a -> Int verilogSize = length . lines . T.unpack . genSource -sampleVerilog- :: (MonadSh m, MonadIO m, Source a, Ord a)- => Frequency a- -> Int- -> Maybe Seed- -> Gen a- -> m (Seed, a)-sampleVerilog _ _ seed@(Just _) gen = sampleSeed seed gen-sampleVerilog freq n Nothing gen = do- res <- replicateM n $ sampleSeed Nothing gen- let sizes = fmap getSize res- let samples = fmap snd . sort $ zip sizes res- liftIO $ Hog.sample . Hog.frequency $ freq samples- where getSize (_, s) = verilogSize s+sampleVerilog ::+ (MonadSh m, MonadIO m, Source a, Ord a) =>+ Frequency a ->+ Int ->+ Maybe Seed ->+ Gen a ->+ m (Seed, a)+sampleVerilog _ _ seed@(Just _) gen = sampleSeed seed gen+sampleVerilog freq n Nothing gen = do+ res <- replicateM n $ sampleSeed Nothing gen+ let sizes = fmap getSize res+ let samples = fmap snd . sort $ zip sizes res+ liftIO $ Hog.sample . Hog.frequency $ freq samples+ where+ getSize (_, s) = verilogSize s hatFreqs :: Frequency a hatFreqs l = zip hat (return <$> l) where- h = length l `div` 2+ h = length l `div` 2 hat = (+ h) . negate . abs . (h -) <$> [1 .. length l] -meanFreqs :: Source a => Frequency a+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+ mean = sum sizes `div` length l+ min_ = minimum $ abs . (mean -) <$> sizes sizes = verilogSize . snd <$> l medianFreqs :: Frequency a medianFreqs l = zip hat (return <$> l) where- h = length l `div` 2+ h = length l `div` 2 hat = set_ <$> [1 .. length l] set_ n = if n == h then 1 else 0 -fuzz :: MonadFuzz m => Gen SourceInfo -> Fuzz m FuzzReport+fuzz :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo ann) -> Fuzz m FuzzReport fuzz gen = do- conf <- askConfig- opts <- askOpts- let seed = conf ^. configProperty . propSeed- (seed', src) <- generateSample $ genMethod conf seed gen- let size = length . lines . T.unpack $ genSource src- liftSh- . writefile "config.toml"- . encodeConfig- $ conf- & configProperty- . propSeed+ conf <- askConfig+ opts <- askOpts+ let seed = conf ^. configProperty . propSeed+ (seed', src) <- generateSample $ genMethod conf seed gen+ let size = length . lines . T.unpack $ genSource src+ liftSh+ . writefile "config.toml"+ . encodeConfig+ $ conf+ & configProperty+ . propSeed ?~ seed'- (tsynth, _) <- titleRun "Synthesis" $ synthesis src- (tequiv, _) <- if (_fuzzOptsNoEquiv opts)- then return (0, mempty)- else titleRun "Equivalence Check" $ equivalence src- (_ , _) <- if (_fuzzOptsNoSim opts)- then return (0, mempty)- else titleRun "Simulation" $ simulation src- fails <- failEquivWithIdentity- failedSim <- failedSimulations- synthFails <- failedSynthesis- redResult <-- whenMaybe (not (null failedSim && null fails && null synthFails)- && not (_fuzzOptsNoReduction opts))- . titleRun "Reduction"- $ reduction src- state_ <- get- currdir <- liftSh pwd- let vi = flip view state_- let report = FuzzReport currdir- (vi fuzzSynthResults)- (vi fuzzSimResults)- (vi fuzzSynthStatus)- size- tsynth- tequiv- (getTime redResult)- return report+ (tsynth, _) <- titleRun "Synthesis" $ synthesis src+ (tequiv, _) <-+ if (_fuzzOptsNoEquiv opts)+ then return (0, mempty)+ else titleRun "Equivalence Check" $ equivalence src+ (_, _) <-+ if (_fuzzOptsNoSim opts)+ then return (0, mempty)+ else titleRun "Simulation" $ simulation src+ fails <- failEquivWithIdentity+ failedSim <- failedSimulations+ synthFails <- failedSynthesis+ redResult <-+ whenMaybe+ ( not (null failedSim && null fails && null synthFails)+ && not (_fuzzOptsNoReduction opts)+ )+ . titleRun "Reduction"+ $ reduction src+ state_ <- get+ currdir <- liftSh pwd+ let vi = flip view state_+ let report =+ FuzzReport+ currdir+ (vi fuzzSynthResults)+ (vi fuzzSimResults)+ (vi fuzzSynthStatus)+ size+ tsynth+ tequiv+ (getTime redResult)+ return report -fuzzInDir :: MonadFuzz m => Gen SourceInfo -> Fuzz m FuzzReport-fuzzInDir src = do- fuzzOpts <- askOpts- let fp = fromMaybe "fuzz" $ _fuzzOptsOutput fuzzOpts- make fp- res <- pop fp $ fuzz src- liftSh $ do- writefile (fp <.> "html") $ printResultReport (bname fp) res- when (passedFuzz res && not (_fuzzOptsKeepAll fuzzOpts)) $ rm_rf fp- relativeFuzzReport res+fuzzInDirG ::+ (MonadFuzz m, Ord ann, Show ann) =>+ (Gen (SourceInfo ann) -> Fuzz m FuzzReport) ->+ Gen (SourceInfo ann) ->+ Fuzz m FuzzReport+fuzzInDirG f src = do+ fuzzOpts <- askOpts+ let fp = fromMaybe "fuzz" $ _fuzzOptsOutput fuzzOpts+ make fp+ res <- pop fp $ f src+ liftSh $ do+ writefile (fp <.> "html") $ printResultReport (bname fp) res+ when (passedFuzz res && not (_fuzzOptsKeepAll fuzzOpts)) $ rm_rf fp+ relativeFuzzReport res where bname = T.pack . takeBaseName . T.unpack . toTextIgnore -fuzzMultiple- :: MonadFuzz m- => Gen SourceInfo- -> Fuzz m [FuzzReport]-fuzzMultiple src = do- fuzzOpts <- askOpts- let seed = (_fuzzOptsConfig fuzzOpts) ^. configProperty . propSeed- x <- case _fuzzOptsOutput fuzzOpts of- Nothing -> do- ct <- liftIO getZonedTime- return- . fromText- . T.pack- $ "output_"- <> formatTime defaultTimeLocale "%Y-%m-%d_%H-%M-%S" ct- Just f -> return f- make x- pop x $ do- results <- if isNothing seed- then forM [1 .. (_fuzzOptsIterations fuzzOpts)] fuzzDir'- else (: []) <$> fuzzDir' (1 :: Int)- liftSh . writefile (fromText "index" <.> "html") $ printSummary- "Fuzz Summary"- results- return results+fuzzMultipleG ::+ (MonadFuzz m, Ord ann, Show ann) =>+ (Gen (SourceInfo ann) -> Fuzz m FuzzReport) ->+ Gen (SourceInfo ann) ->+ Fuzz m [FuzzReport]+fuzzMultipleG f src = do+ fuzzOpts <- askOpts+ let seed = (_fuzzOptsConfig fuzzOpts) ^. configProperty . propSeed+ x <- case _fuzzOptsOutput fuzzOpts of+ Nothing -> do+ ct <- liftIO getZonedTime+ return+ . fromText+ . T.pack+ $ "output_"+ <> formatTime defaultTimeLocale "%Y-%m-%d_%H-%M-%S" ct+ Just f -> return f+ make x+ pop x $ do+ results <-+ if isNothing seed+ then forM [1 .. (_fuzzOptsIterations fuzzOpts)] fuzzDir'+ else (: []) <$> fuzzDir' (1 :: Int)+ liftSh . writefile (fromText "index" <.> "html") $+ printSummary+ "Fuzz Summary"+ results+ return results where- fuzzDir' :: (Show a, MonadFuzz m) => a -> Fuzz m FuzzReport- fuzzDir' n' = local (fuzzEnvOpts . fuzzOptsOutput .~- (Just . fromText $ "fuzz_" <> showT n'))- $ fuzzInDir src+ fuzzDir' n' =+ local+ ( fuzzEnvOpts . fuzzOptsOutput+ .~ (Just . fromText $ "fuzz_" <> showT n')+ )+ $ fuzzInDirG f src -sampleSeed :: MonadSh m => Maybe Seed -> Gen a -> m (Seed, a)+sampleSeed :: (MonadSh m) => Maybe Seed -> Gen a -> m (Seed, a) sampleSeed s gen =- liftSh- $ let loop n = if n <= 0- then- error- "Hedgehog.Gen.sample: too many discards, could not generate a sample"- else do- seed <- maybe Hog.random return s- case Hog.evalGen 30 seed gen of- Nothing ->- loop (n - 1)- Just x ->- pure (seed, Hog.treeValue x)- in loop (100 :: Int)+ liftSh $+ let loop n =+ if n <= 0+ then+ error+ "Hedgehog.Gen.sample: too many discards, could not generate a sample"+ else do+ seed <- maybe Hog.random return s+ case Hog.evalGen 30 seed gen of+ Nothing ->+ loop (n - 1)+ Just x ->+ pure (seed, Hog.treeValue x)+ in loop (100 :: Int)++fuzzEMI :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo (EMIInputs ann)) -> Fuzz m FuzzReport+fuzzEMI gen = do+ conf <- askConfig+ opts <- askOpts+ let seed = conf ^. configProperty . propSeed+ (seed', src) <- generateSample $ genMethod conf seed gen+ let size = length . lines . T.unpack $ genSource src+ liftSh+ . writefile "config.toml"+ . encodeConfig+ $ conf+ & configProperty+ . propSeed+ ?~ seed'+ (tsynth, _) <- titleRun "Synthesis" $ synthesis src+ (_, _) <-+ if (_fuzzOptsNoSim opts)+ then return (0, mempty)+ else titleRun "Simulation" $ simulationEMI src+ fails <- failEquivWithIdentity+ failedSim <- failedSimulations+ synthFails <- failedSynthesis+ state_ <- get+ currdir <- liftSh pwd+ let vi = flip view state_+ let report =+ FuzzReport+ currdir+ (vi fuzzSynthResults)+ (vi fuzzSimResults)+ (vi fuzzSynthStatus)+ size+ tsynth+ 0+ 0+ return report++fuzzInDir :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo ann) -> Fuzz m FuzzReport+fuzzInDir = fuzzInDirG fuzz++fuzzInDirEMI :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo (EMIInputs ann)) -> Fuzz m FuzzReport+fuzzInDirEMI = fuzzInDirG fuzzEMI++fuzzMultiple :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo ann) -> Fuzz m [FuzzReport]+fuzzMultiple = fuzzMultipleG fuzz++fuzzMultipleEMI :: (MonadFuzz m, Ord ann, Show ann) => Gen (SourceInfo (EMIInputs ann)) -> Fuzz m [FuzzReport]+fuzzMultipleEMI = fuzzMultipleG fuzzEMI
src/Verismith/Generate.hs view
@@ -1,141 +1,175 @@-{-|-Module : Verismith.Generate-Description : Various useful generators.-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Various useful generators.--}- {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unused-imports #-} +-- |+-- Module : Verismith.Generate+-- Description : Various useful generators.+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Various useful generators. module Verismith.Generate- ( -- * Generation methods- procedural- , proceduralIO- , proceduralSrc- , proceduralSrcIO- , randomMod+ ( -- * Generation methods+ procedural,+ proceduralIO,+ proceduralSrc,+ proceduralSrcIO,+ randomMod,++ -- ** Data types+ EMIContext (..),+ emiNewInputs,+ Context (..),+ wires,+ nonblocking,+ blocking,+ outofscope,+ parameters,+ modules,+ nameCounter,+ stmntDepth,+ modDepth,+ determinism,+ emiContext,+ StateGen (..),+ -- ** Generate Functions- , largeNum- , wireSize- , range- , genBitVec- , binOp- , unOp- , constExprWithContext- , exprSafeList- , exprRecList- , exprWithContext- , makeIdentifier- , nextPort- , newPort- , scopedExpr- , contAssign- , lvalFromPort- , assignment- , seqBlock- , conditional- , forLoop- , statement- , alwaysSeq- , instantiate- , modInst- , modItem- , constExpr- , parameter- , moduleDef+ largeNum,+ wireSize,+ range,+ genBitVec,+ binOp,+ unOp,+ constExprWithContext,+ exprSafeList,+ exprRecList,+ exprWithContext,+ makeIdentifier,+ nextWirePort,+ nextNBPort,+ nextBPort,+ newWirePort,+ newNBPort,+ newBPort,+ scopedExpr,+ contAssign,+ lvalFromPort,+ assignment,+ seqBlock,+ conditional,+ forLoop,+ statement,+ alwaysSeq,+ instantiate,+ modInst,+ modItem,+ constExpr,+ parameter,+ moduleDef,+ -- ** Helpers- , someI- , probability- , askProbability- , resizePort- , moduleName- , evalRange- , calcRange- )+ someI,+ probability,+ askProbability,+ resizePort,+ moduleName,+ evalRange,+ calcRange,+ ) where -import Control.Lens hiding (Context)-import Control.Monad (replicateM)-import Control.Monad.Reader-import Control.Monad.State.Strict-import Data.Foldable (fold)-import Data.Functor.Foldable (cata)-import Data.List (foldl', partition)-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Hedgehog (Gen, GenT, MonadGen)-import qualified Hedgehog as Hog-import qualified Hedgehog.Gen as Hog-import qualified Hedgehog.Range as Hog-import Verismith.Config-import Verismith.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec-import Verismith.Verilog.Eval-import Verismith.Verilog.Internal-import Verismith.Verilog.Mutate+import Control.Lens hiding (Context)+import Control.Monad (replicateM)+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Foldable (fold)+import Data.Functor.Foldable (cata)+import Data.List (foldl', partition)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Hedgehog (Gen, GenT, MonadGen)+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as Hog+import Verismith.Config+import Verismith.Utils+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- }+data EMIContext = EMIContext+ { _emiNewInputs :: [Port]+ } +makeLenses ''EMIContext++data Context a = Context+ { _wires :: [Port],+ _nonblocking :: [Port],+ _blocking :: [Port],+ _outofscope :: [Port],+ _parameters :: [Parameter],+ _modules :: [ModDecl a],+ _nameCounter :: {-# UNPACK #-} !Int,+ _stmntDepth :: {-# UNPACK #-} !Int,+ _modDepth :: {-# UNPACK #-} !Int,+ _determinism :: !Bool,+ _emiContext :: !(Maybe EMIContext)+ }+ makeLenses ''Context -type StateGen = ReaderT Config (GenT (State Context))+type StateGen a = ReaderT Config (GenT (State (Context a))) toId :: Int -> Identifier toId = Identifier . ("w" <>) . T.pack . show toPort :: (MonadGen m) => Identifier -> m Port toPort ident = do- i <- range- return $ wire i ident+ i <- range+ return $ wire i ident sumSize :: [Port] -> Range sumSize ps = sum $ ps ^.. traverse . portSize -random :: (MonadGen m) => [Port] -> (Expr -> ContAssign) -> m ModItem+random :: (MonadGen m) => [Port] -> (Expr -> ContAssign) -> m (ModItem ann) random ctx fun = do- expr <- Hog.sized (exprWithContext (ProbExpr 1 1 0 1 1 1 1 0 1 1) [] ctx)- return . ModCA $ fun expr+ expr <- Hog.sized (exprWithContext (ProbExpr 1 1 0 1 1 1 1 0 1 1) [] ctx)+ return . ModCA $ fun expr ---randomAssigns :: [Identifier] -> [Gen ModItem]---randomAssigns ids = random ids . ContAssign <$> ids+-- randomAssigns :: [Identifier] -> [Gen ModItem]+-- randomAssigns ids = random ids . ContAssign <$> ids -randomOrdAssigns :: (MonadGen m) => [Port] -> [Port] -> [m ModItem]+randomOrdAssigns :: (MonadGen m) => [Port] -> [Port] -> [m (ModItem ann)] randomOrdAssigns inp ids = snd $ foldr generate (inp, []) ids where generate cid (i, o) = (cid : i, random i (ContAssign (_portName cid)) : o) -randomMod :: (MonadGen m) => Int -> Int -> m ModDecl+randomMod :: (MonadGen m) => Int -> Int -> m (ModDecl ann) randomMod inps total = do- ident <- sequence $ toPort <$> ids- x <- sequence $ randomOrdAssigns (start ident) (end ident)- let inputs_ = take inps ident- let other = drop inps ident- let y = ModCA . ContAssign "y" . fold $ Id <$> drop inps ids- let yport = [wire (sumSize other) "y"]- return . declareMod other $ ModDecl "test_module"- yport- inputs_- (x ++ [y])- []+ ident <- sequence $ toPort <$> ids+ x <- sequence $ randomOrdAssigns (start ident) (end ident)+ let inputs_ = take inps ident+ let other = drop inps ident+ let y = ModCA . ContAssign "y" . fold $ Id <$> drop inps ids+ let yport = [wire (sumSize other) "y"]+ return . declareMod other $+ ModDecl+ "test_module"+ yport+ inputs_+ (x ++ [y])+ [] where- ids = toId <$> [1 .. total]- end = drop inps+ ids = toId <$> [1 .. total]+ end = drop inps start = take inps -- | Converts a 'Port' to an 'LVal' by only keeping the 'Identifier' of the@@ -148,7 +182,7 @@ probability c = c ^. configProbability -- | Gets the current probabilities from the 'State'.-askProbability :: StateGen Probability+askProbability :: StateGen ann Probability askProbability = asks probability -- | Generates a random large number, which can also be negative.@@ -174,77 +208,82 @@ -- because it can only be used in conjunction with base powers of 2 which is -- currently not enforced. binOp :: (MonadGen m) => m BinaryOperator-binOp = Hog.element- [ BinPlus- , BinMinus- , BinTimes- -- , BinDiv- -- , BinMod- , BinEq- , BinNEq- -- , BinCEq- -- , BinCNEq- , BinLAnd- , BinLOr- , BinLT- , BinLEq- , BinGT- , BinGEq- , BinAnd- , BinOr- , BinXor- , BinXNor- , BinXNorInv- -- , BinPower- , BinLSL- , BinLSR- , BinASL- , BinASR+binOp =+ Hog.element+ [ BinPlus,+ BinMinus,+ BinTimes,+ -- , BinDiv+ -- , BinMod+ BinEq,+ BinNEq,+ -- , BinCEq+ -- , BinCNEq+ BinLAnd,+ BinLOr,+ BinLT,+ BinLEq,+ BinGT,+ BinGEq,+ BinAnd,+ BinOr,+ BinXor,+ BinXNor,+ BinXNorInv,+ -- , BinPower+ BinLSL,+ BinLSR,+ BinASL,+ BinASR ] -- | Generate a random 'UnaryOperator'. unOp :: (MonadGen m) => m UnaryOperator-unOp = Hog.element- [ UnPlus- , UnMinus- , UnNot- , UnLNot- , UnAnd- , UnNand- , UnOr- , UnNor- , UnXor- , UnNxor- , UnNxorInv+unOp =+ Hog.element+ [ UnPlus,+ UnMinus,+ UnNot,+ UnLNot,+ UnAnd,+ UnNand,+ UnOr,+ UnNor,+ UnXor,+ UnNxor,+ UnNxorInv ] -- | Generate a random 'ConstExpr' by using the current context of 'Parameter'. constExprWithContext :: (MonadGen m) => [Parameter] -> ProbExpr -> Hog.Size -> m ConstExpr constExprWithContext ps prob size- | size == 0 = Hog.frequency- [ (prob ^. probExprNum, ConstNum <$> genBitVec)- , ( if null ps then 0 else prob ^. probExprId- , ParamId . view paramIdent <$> Hog.element ps- )- ]- | size > 0 = Hog.frequency- [ (prob ^. probExprNum, ConstNum <$> genBitVec)- , ( if null ps then 0 else prob ^. probExprId- , ParamId . view paramIdent <$> Hog.element ps- )- , (prob ^. probExprUnOp, ConstUnOp <$> unOp <*> subexpr 2)- , ( prob ^. probExprBinOp- , ConstBinOp <$> subexpr 2 <*> binOp <*> subexpr 2- )- , ( prob ^. probExprCond- , ConstCond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2- )- , ( prob ^. probExprConcat- , ConstConcat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2)- )- ]- | otherwise = constExprWithContext ps prob 0- where subexpr y = constExprWithContext ps prob $ size `div` y+ | size == 0 =+ Hog.frequency+ [ (prob ^. probExprNum, ConstNum <$> genBitVec),+ ( if null ps then 0 else prob ^. probExprId,+ ParamId . view paramIdent <$> Hog.element ps+ )+ ]+ | size > 0 =+ Hog.frequency+ [ (prob ^. probExprNum, ConstNum <$> genBitVec),+ ( if null ps then 0 else prob ^. probExprId,+ ParamId . view paramIdent <$> Hog.element ps+ ),+ (prob ^. probExprUnOp, ConstUnOp <$> unOp <*> subexpr 2),+ ( prob ^. probExprBinOp,+ ConstBinOp <$> subexpr 2 <*> binOp <*> subexpr 2+ ),+ ( prob ^. probExprCond,+ ConstCond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2+ ),+ ( prob ^. probExprConcat,+ ConstConcat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2)+ )+ ]+ | otherwise = constExprWithContext ps prob 0+ where+ subexpr y = constExprWithContext ps prob $ size `div` y -- | The list of safe 'Expr', meaning that these will not recurse and will end -- the 'Expr' generation.@@ -255,179 +294,254 @@ -- used when the expression grows too large. exprRecList :: (MonadGen m) => ProbExpr -> (Hog.Size -> m Expr) -> [(Int, m Expr)] exprRecList prob subexpr =- [ (prob ^. probExprNum, Number <$> genBitVec)- , ( prob ^. probExprConcat- , Concat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2)- )- , (prob ^. probExprUnOp , UnOp <$> unOp <*> subexpr 2)- , (prob ^. probExprStr, Str <$> Hog.text (Hog.linear 0 100) Hog.alphaNum)- , (prob ^. probExprBinOp , BinOp <$> subexpr 2 <*> binOp <*> subexpr 2)- , (prob ^. probExprCond , Cond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2)- , (prob ^. probExprSigned , Appl <$> pure "$signed" <*> subexpr 2)- , (prob ^. probExprUnsigned, Appl <$> pure "$unsigned" <*> subexpr 2)- ]+ [ (prob ^. probExprNum, Number <$> genBitVec),+ ( prob ^. probExprConcat,+ Concat <$> Hog.nonEmpty (Hog.linear 0 10) (subexpr 2)+ ),+ (prob ^. probExprUnOp, UnOp <$> unOp <*> subexpr 2),+ (prob ^. probExprStr, Str <$> Hog.text (Hog.linear 0 100) Hog.alphaNum),+ (prob ^. probExprBinOp, BinOp <$> subexpr 2 <*> binOp <*> subexpr 2),+ (prob ^. probExprCond, Cond <$> subexpr 2 <*> subexpr 2 <*> subexpr 2),+ (prob ^. probExprSigned, Appl <$> pure "$signed" <*> subexpr 2),+ (prob ^. probExprUnsigned, Appl <$> pure "$unsigned" <*> subexpr 2)+ ] -- | Select a random port from a list of ports and generate a safe bit selection -- for that port. rangeSelect :: (MonadGen m) => [Parameter] -> [Port] -> m Expr rangeSelect ps ports = do- p <- Hog.element ports- let s = calcRange ps (Just 32) $ _portSize p- msb <- Hog.int (Hog.constantFrom (s `div` 2) 0 (s - 1))- lsb <- Hog.int (Hog.constantFrom (msb `div` 2) 0 msb)- return . RangeSelect (_portName p) $ Range (fromIntegral msb)- (fromIntegral lsb)+ p <- Hog.element ports+ let s = calcRange ps (Just 32) $ _portSize p+ msb <- Hog.int (Hog.constantFrom (s `div` 2) 0 (s - 1))+ lsb <- Hog.int (Hog.constantFrom (msb `div` 2) 0 msb)+ return . RangeSelect (_portName p) $+ Range+ (fromIntegral msb)+ (fromIntegral lsb) -- | Generate a random expression from the 'Context' with a guarantee that it -- will terminate using the list of safe 'Expr'. exprWithContext :: (MonadGen m) => ProbExpr -> [Parameter] -> [Port] -> Hog.Size -> m Expr-exprWithContext prob ps [] n | n == 0 = Hog.frequency $ exprSafeList prob- | n > 0 = Hog.frequency $ exprRecList prob subexpr- | otherwise = exprWithContext prob ps [] 0- where subexpr y = exprWithContext prob ps [] $ n `div` y+exprWithContext prob ps [] n+ | n == 0 = Hog.frequency $ exprSafeList prob+ | n > 0 = Hog.frequency $ exprRecList prob subexpr+ | otherwise = exprWithContext prob ps [] 0+ where+ subexpr y = exprWithContext prob ps [] $ n `div` y exprWithContext prob ps l n- | n == 0- = Hog.frequency- $ (prob ^. probExprId, Id . fromPort <$> Hog.element l)- : 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+ | 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 :: Int -> StateGen ann a -> StateGen ann [a] someI m f = do- amount <- Hog.int (Hog.linear 1 m)- replicateM amount f+ amount <- Hog.int (Hog.linear 1 m)+ replicateM amount f -- | Make a new name with a prefix and the current nameCounter. The nameCounter -- is then increased so that the label is unique.-makeIdentifier :: Text -> StateGen Identifier+makeIdentifier :: Text -> StateGen ann Identifier makeIdentifier prefix = do- context <- get- let ident = Identifier $ prefix <> showT (context ^. nameCounter)- nameCounter += 1- return ident+ context <- get+ let ident = Identifier $ prefix <> showT (context ^. nameCounter)+ nameCounter += 1+ return ident -getPort' :: PortType -> Identifier -> [Port] -> StateGen 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'+newPort_ :: Bool -> PortType -> Identifier -> StateGen ann Port+newPort_ blk pt ident = do+ p <- Port pt <$> Hog.bool <*> range <*> pure ident+ case pt of+ Reg -> if blk then blocking %= (p :) else nonblocking %= (p :)+ Wire -> wires %= (p :)+ return p +-- | Creates a new port based on the current name counter and adds it to the+-- current context. It will be added to the '_wires' list.+newWirePort :: Identifier -> StateGen ann Port+newWirePort = newPort_ False Wire++-- | Creates a new port based on the current name counter and adds it to the+-- current context. It will be added to the '_nonblocking' list.+newNBPort :: Identifier -> StateGen ann Port+newNBPort = newPort_ False Reg++-- | Creates a new port based on the current name counter and adds it to the+-- current context. It will be added to the '_blocking' list.+newBPort :: Identifier -> StateGen ann Port+newBPort = newPort_ True Reg++getPort' :: Bool -> PortType -> Identifier -> StateGen ann (Maybe Port)+getPort' blk pt i = do+ cont <- get+ let b = _blocking cont+ let nb = _nonblocking cont+ let w = _wires cont+ let (c, nc) =+ case pt of+ Reg -> if blk then (b, nb <> w) else (nb, b <> w)+ Wire -> (w, b <> nb)+ case (filter portId c, filter portId nc) of+ (_, x : _) -> return Nothing+ (x : _, []) -> return $ Just x+ ([], []) ->+ fmap+ Just+ ( case pt of+ Reg -> if blk then newBPort i else newNBPort i+ Wire -> newWirePort i+ )+ where+ portId (Port pt' _ _ i') = i == i' && pt == pt'++try :: StateGen ann (Maybe a) -> StateGen ann a+try a = do+ r <- a+ case r of+ Nothing -> try a+ Just res -> return res+ -- | 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 :: Maybe Text -> PortType -> StateGen Port-nextPort i pt = do- context <- get- ident <- makeIdentifier $ fromMaybe (T.toLower $ showT pt) i- getPort' pt ident (_variables context)+nextWirePort :: Maybe Text -> StateGen ann Port+nextWirePort i = try $ do+ ident <- makeIdentifier $ fromMaybe (T.toLower $ showT Wire) i+ getPort' False Wire ident --- | 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 <- Port pt <$> Hog.bool <*> range <*> pure ident- variables %= (p :)- return p+nextNBPort :: Maybe Text -> StateGen ann Port+nextNBPort i = try $ do+ ident <- makeIdentifier $ fromMaybe (T.toLower $ showT Reg) i+ getPort' False Reg ident +nextBPort :: Maybe Text -> StateGen ann Port+nextBPort i = try $ do+ ident <- makeIdentifier $ fromMaybe (T.toLower $ showT Reg) i+ getPort' True Reg ident++allVariables :: StateGen ann [Port]+allVariables =+ fmap (\context -> _wires context <> _nonblocking context <> _blocking context) get++shareableVariables :: StateGen ann [Port]+shareableVariables =+ fmap (\context -> _wires context <> _nonblocking context) get+ -- | Generates an expression from variables that are currently in scope.-scopedExpr :: StateGen Expr-scopedExpr = do- context <- get- prob <- askProbability- Hog.sized- . exprWithContext (_probExpr prob) (_parameters context)- $ _variables context+scopedExpr_ :: [Port] -> StateGen ann Expr+scopedExpr_ vars = do+ context <- get+ prob <- askProbability+ Hog.sized+ . exprWithContext (_probExpr prob) (_parameters context)+ $ vars +scopedExprAll :: StateGen ann Expr+scopedExprAll = allVariables >>= scopedExpr_++scopedExpr :: StateGen ann Expr+scopedExpr = shareableVariables >>= scopedExpr_+ -- | Generates a random continuous assignment and assigns it to a random wire -- that is created.-contAssign :: StateGen ContAssign+contAssign :: StateGen ann ContAssign contAssign = do- expr <- scopedExpr- p <- nextPort Nothing Wire- return $ ContAssign (p ^. portName) expr+ expr <- scopedExpr+ p <- nextWirePort Nothing+ 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 Nothing Reg- return $ Assign lval Nothing expr+assignment :: Bool -> StateGen ann Assign+assignment blk = do+ expr <- scopedExprAll+ lval <- lvalFromPort <$> (if blk then nextBPort else nextNBPort) Nothing+ return $ Assign lval Nothing expr -- | Generate a random 'Statement' safely, by also increasing the depth counter.-seqBlock :: StateGen Statement+seqBlock :: StateGen ann (Statement ann) seqBlock = do- stmntDepth -= 1- tstat <- SeqBlock <$> someI 20 statement- stmntDepth += 1- return tstat+ stmntDepth -= 1+ tstat <- SeqBlock <$> someI 20 statement+ stmntDepth += 1+ return tstat -- | Generate a random conditional 'Statement'. The nameCounter is reset between -- branches so that port names can be reused. This is safe because if a 'Port' -- is not reused, it is left at 0, as all the 'Reg' are initialised to 0 at the -- start.-conditional :: StateGen Statement+conditional :: StateGen ann (Statement ann) conditional = do- expr <- scopedExpr- nc <- _nameCounter <$> get- tstat <- seqBlock- nc' <- _nameCounter <$> get- nameCounter .= nc- fstat <- seqBlock- nc'' <- _nameCounter <$> get- nameCounter .= max nc' nc''- return $ CondStmnt expr (Just tstat) (Just fstat)+ expr <- scopedExprAll+ 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 :: StateGen ann (Statement ann) forLoop = do- num <- Hog.int (Hog.linear 0 20)- var <- lvalFromPort <$> nextPort (Just "forvar") Reg- ForLoop (Assign var Nothing 0)- (BinOp (varId var) BinLT $ fromIntegral num)- (Assign var Nothing $ BinOp (varId var) BinPlus 1)- <$> seqBlock- where varId v = Id (v ^. regId)+ num <- Hog.int (Hog.linear 0 20)+ var <- lvalFromPort <$> nextBPort (Just "forvar")+ 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 :: StateGen ann (Statement ann) statement = do- prob <- askProbability- cont <- get- let defProb i = prob ^. probStmnt . i- Hog.frequency- [ (defProb probStmntBlock , BlockAssign <$> assignment)- , (defProb probStmntNonBlock , NonBlockAssign <$> assignment)- , (onDepth cont (defProb probStmntCond), conditional)- , (onDepth cont (defProb probStmntFor) , forLoop)- ]- where onDepth c n = if c ^. stmntDepth > 0 then n else 0+ prob <- askProbability+ cont <- get+ let defProb i = prob ^. probStmnt . i+ Hog.frequency+ [ (defProb probStmntBlock, BlockAssign <$> assignment True),+ (defProb probStmntNonBlock, NonBlockAssign <$> assignment False),+ (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+alwaysSeq :: StateGen ann (ModItem ann)+alwaysSeq = do+ always <- Always . EventCtrl (EPosEdge "clk") . Just <$> seqBlock+ blk <- fmap _blocking get+ outofscope %= mappend blk+ blocking .= []+ return always -- | 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+ 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.@@ -436,30 +550,41 @@ -- 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 ann) -> StateGen ann (ModItem ann) instantiate (ModDecl i outP inP _ _) = do- context <- get- outs <- replicateM (length outP) (nextPort Nothing Wire)- ins <- take (length inpFixed) <$> Hog.shuffle (context ^. variables)- insLit <- replicateM (length inpFixed - length ins) (Number <$> genBitVec)- mapM_ (uncurry process) . zip (ins ^.. traverse . portName) $ inpFixed ^.. traverse . portSize- ident <- makeIdentifier "modinst"- vs <- view variables <$> get- Hog.choice- [ return . ModInst i ident $ ModConn <$> (toE (outs <> clkPort <> ins) <> insLit)- , ModInst i ident <$> Hog.shuffle- (zipWith ModConnNamed (view portName <$> outP <> clkPort <> inpFixed)- (toE (outs <> clkPort <> ins) <> insLit))- ]- where- toE ins = Id . view portName <$> ins- (inpFixed, clkPort) = partition filterFunc inP- filterFunc (Port _ _ _ n)- | n == "clk" = False- | otherwise = True- process p r = do- params <- view parameters <$> get- variables %= resizePort params p r+ vars <- shareableVariables+ outs <- replicateM (length outP) $ nextWirePort Nothing+ ins <- take (length inpFixed) <$> Hog.shuffle vars+ insLit <- replicateM (length inpFixed - length ins) (Number <$> genBitVec)+ mapM_ (uncurry process)+ . zip+ ( zip+ (ins ^.. traverse . portName)+ (ins ^.. traverse . portType)+ )+ $ inpFixed ^.. traverse . portSize+ ident <- makeIdentifier "modinst"+ Hog.choice+ [ return . ModInst i [] ident $ ModConn <$> (toE (outs <> clkPort <> ins) <> insLit),+ ModInst i [] ident+ <$> Hog.shuffle+ ( zipWith+ ModConnNamed+ (view portName <$> outP <> clkPort <> inpFixed)+ (toE (outs <> clkPort <> ins) <> insLit)+ )+ ]+ where+ toE ins = Id . view portName <$> ins+ (inpFixed, clkPort) = partition filterFunc inP+ filterFunc (Port _ _ _ n)+ | n == "clk" = False+ | otherwise = True+ process (p, t) r = do+ params <- view parameters <$> get+ case t of+ Reg -> nonblocking %= resizePort params p r+ Wire -> wires %= 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@@ -480,76 +605,92 @@ -- -- 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 :: StateGen ann (ModItem ann) modInst = do- prob <- ask- context <- get- let maxMods = prob ^. configProperty . propMaxModules- if length (context ^. modules) < maxMods- then do- let currMods = context ^. modules- let params = context ^. parameters- let vars = context ^. variables- modules .= []- variables .= []- parameters .= []- modDepth -= 1- chosenMod <- moduleDef Nothing- ncont <- get- let genMods = ncont ^. modules- modDepth += 1- parameters .= params- variables .= vars- modules .= chosenMod : currMods <> genMods- instantiate chosenMod- else Hog.element (context ^. modules) >>= instantiate+ prob <- ask+ context <- get+ let maxMods = prob ^. configProperty . propMaxModules+ if length (context ^. modules) < maxMods+ then do+ let currMods = context ^. modules+ let params = context ^. parameters+ let w = _wires context+ let nb = _nonblocking context+ let b = _blocking context+ let oos = _outofscope context+ modules .= []+ wires .= []+ nonblocking .= []+ blocking .= []+ outofscope .= []+ parameters .= []+ modDepth -= 1+ chosenMod <- moduleDef Nothing+ ncont <- get+ let genMods = ncont ^. modules+ modDepth += 1+ parameters .= params+ wires .= w+ nonblocking .= nb+ blocking .= b+ outofscope .= oos+ modules .= chosenMod : currMods <> genMods+ instantiate chosenMod+ else Hog.element (context ^. modules) >>= instantiate -- | Generate a random module item.-modItem :: StateGen ModItem+modItem :: StateGen ann (ModItem ann) modItem = do- conf <- ask- let prob = conf ^. configProbability- context <- get- let defProb i = prob ^. probModItem . i- det <- Hog.frequency [ (conf ^. configProperty . propDeterminism, return True)- , (conf ^. configProperty . propNonDeterminism, return False) ]- determinism .= det+ conf <- ask+ let prob = conf ^. configProbability+ context <- get+ let defProb i = prob ^. probModItem . i+ det <- Hog.frequency- [ (defProb probModItemAssign , ModCA <$> contAssign)- , (defProb probModItemSeqAlways, alwaysSeq)- , ( if context ^. modDepth > 0 then defProb probModItemInst else 0- , modInst )- ]+ [ (conf ^. configProperty . propDeterminism, return True),+ (conf ^. configProperty . propNonDeterminism, return False)+ ]+ determinism .= det+ Hog.frequency+ [ (defProb probModItemAssign, ModCA <$> contAssign),+ (defProb probModItemSeqAlways, alwaysSeq),+ ( if context ^. modDepth > 0 then defProb probModItemInst else 0,+ modInst+ )+ ] -- | Either return the 'Identifier' that was passed to it, or generate a new -- 'Identifier' based on the current 'nameCounter'.-moduleName :: Maybe Identifier -> StateGen Identifier+moduleName :: Maybe Identifier -> StateGen ann Identifier moduleName (Just t) = return t-moduleName Nothing = makeIdentifier "module"+moduleName Nothing = makeIdentifier "module" -- | Generate a random 'ConstExpr' by using the current context of 'Parameters'.-constExpr :: StateGen ConstExpr+constExpr :: StateGen ann ConstExpr constExpr = do- prob <- askProbability- context <- get- Hog.sized $ constExprWithContext (context ^. parameters)- (prob ^. probExpr)+ prob <- askProbability+ context <- get+ Hog.sized $+ constExprWithContext+ (context ^. parameters)+ (prob ^. probExpr) -- | Generate a random 'Parameter' and assign it to a constant expression which -- it will be initialised to. The assumption is that this constant expression -- should always be able to be evaluated with the current context of parameters.-parameter :: StateGen Parameter+parameter :: StateGen ann Parameter parameter = do- ident <- makeIdentifier "param"- cexpr <- constExpr- let param = Parameter ident cexpr- parameters %= (param :)- return param+ ident <- makeIdentifier "param"+ cexpr <- constExpr+ let param = Parameter ident cexpr+ parameters %= (param :)+ return param -- | Evaluate a range to an integer, and cast it back to a range. evalRange :: [Parameter] -> Int -> Range -> Range evalRange ps n (Range l r) = Range (eval l) (eval r)- where eval = ConstNum . cata (evaluateConst ps) . resize n+ where+ eval = ConstNum . cata (evaluateConst ps) . resize n -- | Calculate a range to an int by maybe resizing the ranges to a value. calcRange :: [Parameter] -> Maybe Int -> Range -> Int@@ -562,61 +703,85 @@ identElem :: Port -> [Port] -> Bool identElem p = elem (p ^. portName) . toListOf (traverse . portName) +-- | Select items from a list with a specific frequency, returning the new list+-- that contains the selected items. If 0 is passed to both the select and+-- not-select parameter, the function will act like the idententy, returning the+-- original list inside the 'Gen' monad.+--+-- The reason for doing this at the output of a module reduces the number of+-- wires that are exposed at the output and therefore allows the synthesis tool+-- to perform more optimisations that it could otherwise not perform. The+-- synthesis tool is quite strict with optimisations if all the wires and+-- registers are exposed.+selectwfreq :: (MonadGen m) => Int -> Int -> [a] -> m [a]+selectwfreq _ _ [] = return []+selectwfreq s n a@(l : ls)+ | s > 0 && n > 0 =+ Hog.frequency+ [ (s, (l :) <$> selectwfreq s n ls),+ (n, selectwfreq s n ls)+ ]+ | otherwise = return a+ -- | 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 :: Maybe Identifier -> StateGen ann (ModDecl ann) moduleDef top = do- name <- moduleName top- portList <- Hog.list (Hog.linear 4 10) $ nextPort Nothing Wire- mi <- Hog.list (Hog.linear 4 100) modItem- ps <- Hog.list (Hog.linear 0 10) parameter- context <- get- config <- ask- let (newPorts, local) = partition (`identElem` portList) $ _variables context- let- size =- evalRange (_parameters context) 32- . sum- $ local- ^.. traverse- . portSize- let 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+ name <- moduleName top+ portList <- Hog.list (Hog.linear 4 10) $ nextWirePort Nothing+ mi <- Hog.list (Hog.linear 4 100) modItem+ ps <- Hog.list (Hog.linear 0 10) parameter+ context <- get+ vars <- shareableVariables+ config <- ask+ let (newPorts, local) = partition (`identElem` portList) $ vars <> _outofscope context+ let size =+ evalRange (_parameters context) 32+ . sum+ $ local+ ^.. traverse+ . portSize+ let (ProbMod n s) = config ^. configProbability . probMod+ newlocal <- selectwfreq s n local+ let clock = Port Wire False 1 "clk"+ let combine = config ^. configProperty . propCombine+ let yport =+ if combine then Port Wire False 1 "y" else Port Wire False size "y"+ let comb = combineAssigns_ combine yport newlocal+ return+ . declareMod local+ . ModDecl name [yport] (clock : newPorts) (comb : mi)+ $ ps -- | Procedural generation method for random Verilog. Uses internal 'Reader' and -- 'State' to keep track of the current Verilog code structure.-procedural :: Text -> Config -> Gen Verilog+procedural :: Text -> Config -> Gen (Verilog ann) procedural top config = do- (mainMod, st) <- Hog.resize num $ runStateT+ (mainMod, st) <-+ Hog.resize num $+ runStateT (Hog.distributeT (runReaderT (moduleDef (Just $ Identifier top)) config)) context- return . Verilog $ mainMod : st ^. modules+ return . Verilog $ mainMod : st ^. modules where context =- Context [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True+ Context [] [] [] [] [] [] 0 (confProp propStmntDepth) (confProp propModDepth) True Nothing num = fromIntegral $ confProp propSize confProp i = config ^. configProperty . i -- | Samples the 'Gen' directly to generate random 'Verilog' using the 'Text' as -- the name of the main module and the configuration 'Config' to influence the -- generation.-proceduralIO :: Text -> Config -> IO Verilog+proceduralIO :: Text -> Config -> IO (Verilog a) proceduralIO t = Hog.sample . procedural t --- | Given a 'Text' and a 'Config' will generate a 'SourceInfo' which has the+-- | Given a 'Text' and a 'Config' will generate a '(SourceInfo ann)' which has the -- top module set to the right name.-proceduralSrc :: Text -> Config -> Gen SourceInfo+proceduralSrc :: Text -> Config -> Gen (SourceInfo ann) proceduralSrc t c = SourceInfo t <$> procedural t c --- | Sampled and wrapped into a 'SourceInfo' with the given top module name.-proceduralSrcIO :: Text -> Config -> IO SourceInfo+-- | Sampled and wrapped into a '(SourceInfo ann)' with the given top module name.+proceduralSrcIO :: Text -> Config -> IO (SourceInfo ann) proceduralSrcIO t c = SourceInfo t <$> proceduralIO t c
− src/Verismith/Internal.hs
@@ -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 : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Shared high level code used in the other modules internally.--}--module Verismith.Internal- ( -- * Useful functions- safe- , showT- , showBS- , comma- , commaNL- )-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"
src/Verismith/OptParser.hs view
@@ -1,304 +1,612 @@ module Verismith.OptParser- ( OptTool (..)- , Opts (..)- , opts- )+ ( OptTool (..),+ Opts (..),+ opts,+ ) where -import Control.Applicative ((<|>))-import Data.Text (Text)-import qualified Data.Text as T-import Options.Applicative (Mod (..), OptionFields (..), Parser (..),- ParserInfo (..), ReadM (..), (<**>))+import Control.Applicative ((<|>))+import Data.Text (Text)+import qualified Data.Text as T+import Options.Applicative+ ( Mod (..),+ OptionFields (..),+ Parser (..),+ ParserInfo (..),+ ReadM (..),+ (<**>),+ ) import qualified Options.Applicative as Opt-import Prelude hiding (FilePath (..))-import Shelly (FilePath (..), fromText)-import Verismith.Config (SynthDescription (..), versionInfo)+import Shelly (FilePath (..), fromText)+import Verismith.Config (SynthDescription (..), versionInfo)+import Prelude hiding (FilePath (..))+import Verismith.Verilog2005 (PrintingOpts (..)) -data OptTool = TYosys- | TXST- | TIcarus+data OptTool+ = TYosys+ | TXST+ | TIcarus instance Show OptTool where- show TYosys = "yosys"- show TXST = "xst"+ show TYosys = "yosys"+ show TXST = "xst" show TIcarus = "icarus" -data Opts = Fuzz { fuzzOutput :: {-# UNPACK #-} !Text- , fuzzConfigFile :: !(Maybe FilePath)- , fuzzForced :: !Bool- , fuzzKeepAll :: !Bool- , fuzzNum :: {-# UNPACK #-} !Int- , fuzzNoSim :: !Bool- , fuzzNoEquiv :: !Bool- , fuzzNoReduction :: !Bool- , fuzzExistingFile :: !(Maybe FilePath)- , fuzzExistingFileTop :: !Text- , fuzzCrossCheck :: !Bool- , fuzzChecker :: !(Maybe Text)- }- | Generate { generateFilename :: !(Maybe FilePath)- , generateConfigFile :: !(Maybe FilePath)- }- | Parse { parseFilename :: {-# UNPACK #-} !FilePath- , parseTop :: {-# UNPACK #-} !Text- , parseOutput :: !(Maybe FilePath)- , parseRemoveConstInConcat :: !Bool- }- | Reduce { reduceFilename :: {-# UNPACK #-} !FilePath- , reduceTop :: {-# UNPACK #-} !Text- , reduceScript :: !(Maybe FilePath)- , reduceSynthesiserDesc :: ![SynthDescription]- , reduceRerun :: !Bool- }- | ConfigOpt { configOptWriteConfig :: !(Maybe FilePath)- , configOptConfigFile :: !(Maybe FilePath)- , configOptDoRandomise :: !Bool- }+data Opts+ = Fuzz+ { fuzzOutput :: Text,+ fuzzConfigFile :: !(Maybe FilePath),+ fuzzForced :: !Bool,+ fuzzKeepAll :: !Bool,+ fuzzNum :: {-# UNPACK #-} !Int,+ fuzzNoSim :: !Bool,+ fuzzNoEquiv :: !Bool,+ fuzzNoReduction :: !Bool,+ fuzzExistingFile :: !(Maybe FilePath),+ fuzzExistingFileTop :: !Text,+ fuzzCrossCheck :: !Bool,+ fuzzChecker :: !(Maybe Text)+ }+ | EMIOpts+ { emiOutput :: Text,+ emiConfigFile :: !(Maybe FilePath),+ emiForced :: !Bool,+ emiKeepAll :: !Bool,+ emiNum :: {-# UNPACK #-} !Int,+ emiNoSim :: !Bool,+ emiNoEquiv :: !Bool,+ emiNoReduction :: !Bool,+ emiTopModule :: Text,+ emiInputFile :: FilePath+ }+ | Generate+ { generateFilename :: !(Maybe FilePath),+ generateConfigFile :: !(Maybe FilePath),+ generateValidSyntax :: !Bool,+ generatePrinting :: !PrintingOpts+ }+ | Parse+ { parseFilename :: !FilePath,+ parseOutput :: !(Maybe FilePath),+ parseStrict :: !Bool,+ parsePrinting :: !PrintingOpts+ }+ | Reduce+ { reduceFilename :: !FilePath,+ reduceTop :: !Text,+ reduceScript :: !(Maybe FilePath),+ reduceSynthesiserDesc :: ![SynthDescription],+ reduceRerun :: !Bool+ }+ | ConfigOpt+ { configOptWriteConfig :: !(Maybe FilePath),+ configOptConfigFile :: !(Maybe FilePath),+ configOptDoRandomise :: !Bool+ }+ | DistanceOpt+ { distanceOptVerilogA :: !FilePath,+ distanceOptVerilogB :: !FilePath+ }+ | ShuffleOpt+ { shuffleOptFilename :: !FilePath,+ shuffleOptTop :: !Text,+ shuffleOptOutput :: !(Maybe FilePath),+ shuffleOptShuffleLines :: !Bool,+ shuffleOptRenameVars :: !Bool,+ shuffleOptEquiv :: !Bool,+ shuffleOptEquivFolder :: !FilePath,+ shuffleOptChecker :: !(Maybe Text)+ }+ | Equiv+ { equivOutput :: !FilePath,+ equivFilenameA :: !FilePath,+ equivFilenameB :: !FilePath,+ equivFileTop :: !Text,+ equivChecker :: !(Maybe Text)+ } textOption :: Mod OptionFields String -> Parser Text textOption = fmap T.pack . Opt.strOption optReader :: (String -> Maybe a) -> ReadM a optReader f = Opt.eitherReader $ \arg -> case f arg of- Just a -> Right a- Nothing -> Left $ "Cannot parse option: " <> arg+ Just a -> Right a+ Nothing -> Left $ "Cannot parse option: " <> arg parseSynth :: String -> Maybe OptTool-parseSynth val | val == "yosys" = Just TYosys- | val == "xst" = Just TXST- | otherwise = Nothing+parseSynth val+ | val == "yosys" = Just TYosys+ | val == "xst" = Just TXST+ | otherwise = Nothing parseSynthDesc :: String -> Maybe SynthDescription parseSynthDesc val- | val == "yosys" = Just $ SynthDescription "yosys" Nothing Nothing Nothing- | val == "vivado" = Just $ SynthDescription "vivado" Nothing Nothing Nothing- | val == "xst" = Just $ SynthDescription "xst" Nothing Nothing Nothing- | val == "quartus" = Just- $ SynthDescription "quartus" Nothing Nothing Nothing- | val == "identity" = Just- $ SynthDescription "identity" Nothing Nothing Nothing- | otherwise = Nothing+ | val == "yosys" = Just $ SynthDescription "yosys" Nothing Nothing Nothing+ | val == "vivado" = Just $ SynthDescription "vivado" Nothing Nothing Nothing+ | val == "xst" = Just $ SynthDescription "xst" Nothing Nothing Nothing+ | val == "quartus" =+ Just $+ SynthDescription "quartus" Nothing Nothing Nothing+ | val == "identity" =+ Just $+ SynthDescription "identity" Nothing Nothing Nothing+ | otherwise = Nothing parseSim :: String -> Maybe OptTool-parseSim val | val == "icarus" = Just TIcarus- | otherwise = Nothing+parseSim val+ | val == "icarus" = Just TIcarus+ | otherwise = Nothing fuzzOpts :: Parser Opts fuzzOpts =- Fuzz- <$> textOption- ( Opt.long "output"- <> Opt.short 'o'- <> Opt.metavar "DIR"- <> Opt.help "Output directory that the fuzz run takes place in."- <> Opt.showDefault- <> Opt.value "output")- <*> ( Opt.optional- . Opt.strOption- $ Opt.long "config"- <> Opt.short 'c'- <> Opt.metavar "FILE"- <> Opt.help "Config file for the current fuzz run.")- <*> (Opt.switch $ Opt.long "force" <> Opt.short 'f' <> Opt.help- "Overwrite the specified directory.")- <*> (Opt.switch $ Opt.long "keep" <> Opt.short 'k' <> Opt.help- "Keep all the directories.")- <*> ( Opt.option Opt.auto- $ Opt.long "num"- <> Opt.short 'n'- <> Opt.help "The number of fuzz runs that should be performed."- <> Opt.showDefault- <> Opt.value 1- <> Opt.metavar "INT")- <*> (Opt.switch $ Opt.long "no-sim" <> Opt.help- "Do not run simulation on the output netlist.")- <*> (Opt.switch $ Opt.long "no-equiv" <> Opt.help- "Do not run an equivalence check on the output netlist.")- <*> (Opt.switch $ Opt.long "no-reduction" <> Opt.help- "Do not run reduction on a failed testcase.")- <*> ( Opt.optional- . Opt.strOption- $ Opt.long "source"- <> Opt.short 's'- <> Opt.metavar "FILE"- <> Opt.help "Name of the top module.")- <*> textOption- ( Opt.long "source-top"- <> Opt.short 't'- <> Opt.metavar "TOP"- <> Opt.help "Define the top module for the source file."- <> Opt.showDefault- <> Opt.value "top")- <*> (Opt.switch $ Opt.long "crosscheck" <> Opt.help- "Do not only compare against the original design, but also against other netlists.")- <*> (Opt.optional . textOption $- Opt.long "checker"- <> Opt.metavar "CHECKER"- <> Opt.help "Define the checker to use.")+ Fuzz+ <$> textOption+ ( Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "DIR"+ <> Opt.help "Output directory that the fuzz run takes place in."+ <> Opt.showDefault+ <> Opt.value "output"+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "config"+ <> Opt.short 'c'+ <> Opt.metavar "FILE"+ <> Opt.help "Config file for the current fuzz run."+ )+ <*> ( Opt.switch $+ Opt.long "force"+ <> Opt.short 'f'+ <> Opt.help+ "Overwrite the specified directory."+ )+ <*> ( Opt.switch $+ Opt.long "keep"+ <> Opt.short 'k'+ <> Opt.help+ "Keep all the directories."+ )+ <*> ( Opt.option Opt.auto $+ Opt.long "num"+ <> Opt.short 'n'+ <> Opt.help "The number of fuzz runs that should be performed."+ <> Opt.showDefault+ <> Opt.value 1+ <> Opt.metavar "INT"+ )+ <*> ( Opt.switch $+ Opt.long "no-sim"+ <> Opt.help+ "Do not run simulation on the output netlist."+ )+ <*> ( Opt.switch $+ Opt.long "no-equiv"+ <> Opt.help+ "Do not run an equivalence check on the output netlist."+ )+ <*> ( Opt.switch $+ Opt.long "no-reduction"+ <> Opt.help+ "Do not run reduction on a failed testcase."+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "source"+ <> Opt.short 's'+ <> Opt.metavar "FILE"+ <> Opt.help "Name of the top module."+ )+ <*> textOption+ ( Opt.long "source-top"+ <> Opt.short 't'+ <> Opt.metavar "TOP"+ <> Opt.help "Define the top module for the source file."+ <> Opt.showDefault+ <> Opt.value "top"+ )+ <*> ( Opt.switch $+ Opt.long "crosscheck"+ <> Opt.help+ "Do not only compare against the original design, but also against other netlists."+ )+ <*> ( Opt.optional . textOption $+ Opt.long "checker"+ <> Opt.metavar "CHECKER"+ <> Opt.help "Define the checker to use."+ ) +emiOpts :: Parser Opts+emiOpts =+ EMIOpts+ <$> textOption+ ( Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "DIR"+ <> Opt.help "Output directory that the fuzz run takes place in."+ <> Opt.showDefault+ <> Opt.value "output"+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "config"+ <> Opt.short 'c'+ <> Opt.metavar "FILE"+ <> Opt.help "Config file for the current fuzz run."+ )+ <*> ( Opt.switch $+ Opt.long "force"+ <> Opt.short 'f'+ <> Opt.help+ "Overwrite the specified directory."+ )+ <*> ( Opt.switch $+ Opt.long "keep"+ <> Opt.short 'k'+ <> Opt.help+ "Keep all the directories."+ )+ <*> ( Opt.option Opt.auto $+ Opt.long "num"+ <> Opt.short 'n'+ <> Opt.help "The number of fuzz runs that should be performed."+ <> Opt.showDefault+ <> Opt.value 1+ <> Opt.metavar "INT"+ )+ <*> ( Opt.switch $+ Opt.long "no-sim"+ <> Opt.help+ "Do not run simulation on the output netlist."+ )+ <*> ( Opt.switch $+ Opt.long "no-equiv"+ <> Opt.help+ "Do not run an equivalence check on the output netlist."+ )+ <*> ( Opt.switch $+ Opt.long "no-reduction"+ <> Opt.help+ "Do not run reduction on a failed testcase."+ )+ <*> textOption+ ( Opt.long "top"+ <> Opt.short 't'+ <> Opt.metavar "MODULE"+ <> Opt.help "Top module for the Verilog module."+ <> Opt.showDefault+ <> Opt.value "top"+ )+ <*> Opt.strArgument (Opt.metavar "FILE" <> Opt.help "Verilog input file to pass to EMI.")++printOpts :: Parser PrintingOpts+printOpts =+ PrintingOpts+ <$> ( Opt.switch $+ Opt.long "space-after-escaped"+ <> Opt.help "Always print a space after an escaped identifier."+ )+ <*> ( Opt.switch $+ Opt.long "spaces-in-primitive"+ <> Opt.help "Always print spaces in primitives table between levels."+ )+ <*> ( Opt.switch $+ Opt.long "edge-control-z"+ <> Opt.help "Use z instead of x in edge-control specifiers."+ )+ genOpts :: Parser Opts genOpts =- Generate- <$> ( Opt.optional- . Opt.strOption- $ Opt.long "output"- <> Opt.short 'o'- <> Opt.metavar "FILE"- <> Opt.help "Output to a verilog file instead."- )- <*> ( Opt.optional- . Opt.strOption- $ Opt.long "config"- <> Opt.short 'c'- <> Opt.metavar "FILE"- <> Opt.help "Config file for the generation run."- )+ Generate+ <$> ( Opt.optional+ . Opt.strOption+ $ Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "FILE"+ <> Opt.help "Output to a verilog file instead."+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "config"+ <> Opt.short 'c'+ <> Opt.metavar "FILE"+ <> Opt.help "Config file for the generation run."+ )+ <*> ( Opt.switch $+ Opt.long "invalid"+ <> Opt.help+ "Generate invalid Verilog that is only syntactically allowed."+ )+ <*> printOpts parseOpts :: Parser Opts-parseOpts = Parse- <$> (fromText . T.pack <$> Opt.strArgument- (Opt.metavar "FILE" <> Opt.help "Verilog input file."))- <*> textOption ( Opt.short 't'- <> Opt.long "top"- <> Opt.metavar "TOP"- <> Opt.help "Name of top level module."- <> Opt.showDefault- <> Opt.value "top"- )+parseOpts =+ Parse+ <$> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILE" <> Opt.help "Verilog input file.")+ ) <*> ( Opt.optional- . Opt.strOption- $ Opt.long "output"- <> Opt.short 'o'- <> Opt.metavar "FILE"- <> Opt.help "Output file to write the parsed file to.")- <*> (Opt.switch $ Opt.long "remove-const-in-concat" <> Opt.help- "Remove constants in concatenation to simplify the Verilog.")+ . Opt.strOption+ $ Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "FILE"+ <> Opt.help "Output file to write the parsed file to."+ )+ <*> ( Opt.switch $+ Opt.long "strict"+ <> Opt.help+ "Makes the parser comply strictly to the Verilog 2005 standard."+ )+ <*> printOpts +shuffleOpts :: Parser Opts+shuffleOpts =+ ShuffleOpt+ <$> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILE" <> Opt.help "Verilog input file.")+ )+ <*> textOption+ ( Opt.short 't'+ <> Opt.long "top"+ <> Opt.metavar "TOP"+ <> Opt.help "Name of top level module."+ <> Opt.showDefault+ <> Opt.value "top"+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "FILE"+ <> Opt.help "Output file to write the parsed file to."+ )+ <*> ( Opt.switch $+ Opt.long "no-shuffle-lines"+ <> Opt.help+ "Shuffle the lines in a Verilog file."+ )+ <*> ( Opt.switch $+ Opt.long "no-rename-vars"+ <> Opt.help+ "Rename the variables in a Verilog file."+ )+ <*> ( Opt.switch $+ Opt.long "noequiv"+ <> Opt.help+ "Do not check equivalence between input and output (currently only verismith generated Verilog is likely to pass this equivalence check)."+ )+ <*> ( Opt.strOption $+ Opt.long "equiv-output"+ <> Opt.short 'e'+ <> Opt.metavar "FOLDER"+ <> Opt.help "Output folder to write the equivalence checking files in."+ <> Opt.showDefault+ <> Opt.value "equiv"+ )+ <*> ( Opt.optional . textOption $+ Opt.long "checker"+ <> Opt.metavar "CHECKER"+ <> Opt.help "Define the checker to use."+ )+ reduceOpts :: Parser Opts reduceOpts =- Reduce- . fromText- . T.pack- <$> Opt.strArgument (Opt.metavar "FILE" <> Opt.help "Verilog input file.")- <*> textOption- ( Opt.short 't'- <> Opt.long "top"- <> Opt.metavar "TOP"- <> Opt.help "Name of top level module."- <> Opt.showDefault- <> Opt.value "top"- )- <*> ( Opt.optional- . Opt.strOption- $ Opt.long "script"- <> Opt.metavar "SCRIPT"- <> Opt.help- "Script that determines if the current file is interesting, which is determined by the script returning 0."- )- <*> ( Opt.many- . Opt.option (optReader parseSynthDesc)- $ Opt.short 's'- <> Opt.long "synth"- <> Opt.metavar "SYNTH"- <> Opt.help "Specify synthesiser to use."- )- <*> ( Opt.switch- $ Opt.short 'r'- <> Opt.long "rerun"- <> Opt.help- "Only rerun the current synthesis file with all the synthesisers."- )+ Reduce+ . fromText+ . T.pack+ <$> Opt.strArgument (Opt.metavar "FILE" <> Opt.help "Verilog input file.")+ <*> textOption+ ( Opt.short 't'+ <> Opt.long "top"+ <> Opt.metavar "TOP"+ <> Opt.help "Name of top level module."+ <> Opt.showDefault+ <> Opt.value "top"+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "script"+ <> Opt.metavar "SCRIPT"+ <> Opt.help+ "Script that determines if the current file is interesting, which is determined by the script returning 0."+ )+ <*> ( Opt.many+ . Opt.option (optReader parseSynthDesc)+ $ Opt.short 's'+ <> Opt.long "synth"+ <> Opt.metavar "SYNTH"+ <> Opt.help "Specify synthesiser to use."+ )+ <*> ( Opt.switch $+ Opt.short 'r'+ <> Opt.long "rerun"+ <> Opt.help+ "Only rerun the current synthesis file with all the synthesisers."+ ) configOpts :: Parser Opts configOpts =- ConfigOpt- <$> ( Opt.optional- . Opt.strOption- $ Opt.long "output"- <> Opt.short 'o'- <> Opt.metavar "FILE"- <> Opt.help "Output to a TOML Config file."- )- <*> ( Opt.optional- . Opt.strOption- $ Opt.long "config"- <> Opt.short 'c'- <> Opt.metavar "FILE"- <> Opt.help "Config file for the current fuzz run."- )- <*> ( Opt.switch- $ Opt.long "randomise"- <> Opt.short 'r'- <> Opt.help- "Randomise the given default config, or the default config by randomly switchin on and off options."- )+ ConfigOpt+ <$> ( Opt.optional+ . Opt.strOption+ $ Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "FILE"+ <> Opt.help "Output to a TOML Config file."+ )+ <*> ( Opt.optional+ . Opt.strOption+ $ Opt.long "config"+ <> Opt.short 'c'+ <> Opt.metavar "FILE"+ <> Opt.help "Config file for the current fuzz run."+ )+ <*> ( Opt.switch $+ Opt.long "randomise"+ <> Opt.short 'r'+ <> Opt.help+ "Randomise the given default config, or the default config by randomly switchin on and off options."+ ) +distanceOpts :: Parser Opts+distanceOpts =+ DistanceOpt+ <$> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILE" <> Opt.help "First verilog file.")+ )+ <*> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILE" <> Opt.help "Second verilog file.")+ )++equivOpts :: Parser Opts+equivOpts =+ Equiv+ <$> Opt.strOption+ ( Opt.long "output"+ <> Opt.short 'o'+ <> Opt.metavar "DIR"+ <> Opt.help "Output directory that the equivalence run takes place in."+ <> Opt.showDefault+ <> Opt.value "output"+ )+ <*> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILEA" <> Opt.help "First verilog file.")+ )+ <*> ( fromText . T.pack+ <$> Opt.strArgument+ (Opt.metavar "FILEB" <> Opt.help "Second verilog file.")+ )+ <*> textOption+ ( Opt.long "source-top"+ <> Opt.short 't'+ <> Opt.metavar "TOP"+ <> Opt.help "Define the top module to compare between the source files."+ <> Opt.showDefault+ <> Opt.value "top"+ )+ <*> ( Opt.optional . textOption $+ Opt.long "checker"+ <> Opt.metavar "CHECKER"+ <> Opt.help "Define the checker to use."+ )+ argparse :: Parser Opts argparse =- Opt.hsubparser- ( Opt.command- "fuzz"- (Opt.info- fuzzOpts- (Opt.progDesc- "Run fuzzing on the specified simulators and synthesisers."- )- )- <> Opt.metavar "fuzz"+ Opt.hsubparser+ ( Opt.command+ "fuzz"+ ( Opt.info+ fuzzOpts+ ( Opt.progDesc+ "Run fuzzing on the specified simulators and synthesisers." )- <|> Opt.hsubparser- ( Opt.command- "generate"- (Opt.info- genOpts- (Opt.progDesc "Generate a random Verilog program.")- )- <> Opt.metavar "generate"- )- <|> Opt.hsubparser- ( Opt.command- "parse"- (Opt.info- parseOpts- (Opt.progDesc- "Parse a verilog file and output a pretty printed version."- )- )- <> Opt.metavar "parse"- )- <|> Opt.hsubparser- ( Opt.command- "reduce"- (Opt.info- reduceOpts- (Opt.progDesc- "Reduce a Verilog file by rerunning the fuzzer on the file."- )- )- <> Opt.metavar "reduce"- )- <|> Opt.hsubparser- ( Opt.command- "config"- (Opt.info- configOpts- (Opt.progDesc- "Print the current configuration of the fuzzer."- )- )- <> Opt.metavar "config"- )+ )+ <> Opt.metavar "fuzz"+ )+ <|> Opt.hsubparser+ ( Opt.command+ "emi"+ ( Opt.info+ emiOpts+ ( Opt.progDesc+ "EMI testing using generated inputs, or existing Verilog designs."+ )+ )+ <> Opt.metavar "emi"+ )+ <|> 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+ "shuffle"+ ( Opt.info+ shuffleOpts+ ( Opt.progDesc+ "Shuffle a Verilog file."+ )+ )+ <> Opt.metavar "shuffle"+ )+ <|> Opt.hsubparser+ ( Opt.command+ "config"+ ( Opt.info+ configOpts+ ( Opt.progDesc+ "Print the current configuration of the fuzzer."+ )+ )+ <> Opt.metavar "config"+ )+ <|> Opt.hsubparser+ ( Opt.command+ "distance"+ ( Opt.info+ distanceOpts+ ( Opt.progDesc+ "Calculate the distance between two different pieces of Verilog."+ )+ )+ <> Opt.metavar "distance"+ )+ <|> Opt.hsubparser+ ( Opt.command+ "equiv"+ ( Opt.info+ equivOpts+ ( Opt.progDesc+ "Check two different pieces of Verilog are equivalent."+ )+ )+ <> Opt.metavar "equiv"+ ) version :: Parser (a -> a)-version = Opt.infoOption versionInfo $ mconcat- [Opt.long "version", Opt.short 'v', Opt.help "Show version information.", Opt.hidden]+version =+ Opt.infoOption versionInfo $+ mconcat+ [Opt.long "version", Opt.short 'v', Opt.help "Show version information.", Opt.hidden] opts :: ParserInfo Opts-opts = Opt.info+opts =+ Opt.info (argparse <**> Opt.helper <**> version)- ( Opt.fullDesc- <> Opt.progDesc "Fuzz different simulators and synthesisers."- <> Opt.header- "Verismith - A hardware simulator and synthesiser Verilog fuzzer."+ ( Opt.fullDesc+ <> Opt.progDesc "Fuzz different simulators and synthesisers."+ <> Opt.header+ "Verismith - A hardware simulator and synthesiser Verilog fuzzer." )
src/Verismith/Reduce.hs view
@@ -1,67 +1,69 @@-{-|-Module : Verismith.Reduce-Description : Test case reducer implementation.-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Test case reducer implementation.--}--{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +-- |+-- Module : Verismith.Reduce+-- Description : Test case reducer implementation.+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Test case reducer implementation. module Verismith.Reduce- ( -- $strategy- reduceWithScript- , reduceSynth- , reduceSynthesis- , reduceSimIc- , reduce- , reduce_- , Replacement(..)- , halveModules- , halveModItems- , halveStatements- , halveExpr- , halveAssigns- , findActiveWires- , clean- , cleanSourceInfo- , cleanSourceInfoAll- , removeDecl- , removeConstInConcat- , takeReplace- , filterExpr- )+ ( -- $strategy+ reduceWithScript,+ reduceSynth,+ reduceSynthesis,+ reduceSimIc,+ reduce,+ reduce_,+ Replacement (..),+ halveModules,+ halveModItems,+ halveStatements,+ halveExpr,+ halveAssigns,+ findActiveWires,+ clean,+ cleanSourceInfo,+ cleanSourceInfoAll,+ removeDecl,+ removeConstInConcat,+ takeReplace,+ filterExpr,+ ReduceAnn (..),+ tagAlways,+ untagAlways,+ ) where -import Control.Lens hiding ((<.>))-import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.ByteString (ByteString)-import Data.Foldable (foldrM)-import Data.List (nub)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import Shelly (fromText, (<.>))+import Control.Lens hiding ((<.>))+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString (ByteString)+import Data.Foldable (foldrM)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (nub)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (mapMaybe)+import Data.Text (Text, unpack)+import Shelly (fromText, (<.>)) import qualified Shelly-import Shelly.Lifted (MonadSh, liftSh, rm_rf, writefile)-import Verismith.Internal-import Verismith.Result-import Verismith.Tool-import Verismith.Tool.Icarus-import Verismith.Tool.Identity-import Verismith.Tool.Internal-import Verismith.Verilog-import Verismith.Verilog.AST-import Verismith.Verilog.Mutate-import Verismith.Verilog.Parser-+import Shelly.Lifted (MonadSh, liftSh, rm_rf, writefile)+import Verismith.Result+import Verismith.Tool+import Verismith.Tool.Icarus+import Verismith.Tool.Identity+import Verismith.Tool.Internal+import Verismith.Utils+import Verismith.Verilog+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Mutate+import Verismith.Verilog.Parser -- $strategy -- The reduction strategy has multiple different steps. 'reduce' will run these@@ -86,77 +88,95 @@ -- | Replacement type that supports returning different kinds of reduced -- replacements that could be tried.-data Replacement a = Dual a a- | Single a- | None- deriving (Show, Eq)+data Replacement a+ = Dual a a+ | Single a+ | None+ deriving (Show, Eq) -type Replace a = a -> Replacement a+data ReduceAnn+ = Active+ | Reduced+ | Idle+ deriving (Show, Eq) +type Replace a = (a -> Replacement a)+ instance Functor Replacement where- fmap f (Dual a b) = Dual (f a) $ f b- fmap f (Single a) = Single $ f a- fmap _ None = None+ fmap f (Dual a b) = Dual (f a) $ f b+ fmap f (Single a) = Single $ f a+ fmap _ None = None instance Applicative Replacement where- pure = Single- (Dual a b) <*> (Dual c d) = Dual (a c) $ b d- (Dual a b) <*> (Single c) = Dual (a c) $ b c- (Single a) <*> (Dual b c) = Dual (a b) $ a c- (Single a) <*> (Single b) = Single $ a b- None <*> _ = None- _ <*> None = None+ pure = Single+ (Dual a b) <*> (Dual c d) = Dual (a c) $ b d+ (Dual a b) <*> (Single c) = Dual (a c) $ b c+ (Single a) <*> (Dual b c) = Dual (a b) $ a c+ (Single a) <*> (Single b) = Single $ a b+ None <*> _ = None+ _ <*> None = None instance Foldable Replacement where- foldMap _ None = mempty- foldMap f (Single a) = f a- foldMap f (Dual a b) = f a <> f b+ foldMap _ None = mempty+ foldMap f (Single a) = f a+ foldMap f (Dual a b) = f a <> f b instance Traversable Replacement where- traverse _ None = pure None- traverse f (Single a) = Single <$> f a- traverse f (Dual a b) = Dual <$> f a <*> f b+ traverse _ None = pure None+ traverse f (Single a) = Single <$> f a+ traverse f (Dual a b) = Dual <$> f a <*> f b -- | Split a list in two halves. halve :: Replace [a]-halve [] = Single []+halve [] = Single [] halve [_] = Single []-halve l = Dual a b where (a, b) = splitAt (length l `div` 2) l+halve l = Dual a b where (a, b) = splitAt (length l `div` 2) l +remove1 :: Replace [a]+remove1 [] = Single []+remove1 [_] = Single []+remove1 (a : b) = Dual [a] b+ halveNonEmpty :: Replace (NonEmpty a) halveNonEmpty l = case NonEmpty.splitAt (length l `div` 2) l of- ([] , [] ) -> None- ([] , a : b) -> Single $ a :| b- (a : b, [] ) -> Single $ a :| b- (a : b, c : d) -> Dual (a :| b) $ c :| d+ ([], []) -> None+ ([], a : b) -> Single $ a :| b+ (a : b, []) -> Single $ a :| b+ (a : b, c : d) -> Dual (a :| b) $ c :| d -- | When given a Lens and a function that works on a lower replacement, it will -- go down, apply the replacement, and return a replacement of the original -- module.-combine :: Lens' a b -> Replace b -> Replace a+combine :: (Monoid b) => Traversal' a b -> Replace b -> Replace a combine l f i = modify <$> f (i ^. l) where modify res = i & l .~ res +-- | 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.+combineL :: Lens' a b -> Replace b -> Replace a+combineL 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+ if i `elem` ids then VecSelect i e else Number 0 filterExpr ids (RangeSelect i r) =- if i `elem` ids then RangeSelect i r else Number 0+ if i `elem` ids then RangeSelect i r else Number 0 filterExpr _ e = e -- | Checks if a declaration is part of the current scope. If not, it returns -- 'False', otherwise 'True', as it should be kept.---filterDecl :: [Identifier] -> ModItem -> Bool---filterDecl ids (Decl Nothing (Port _ _ _ i) _) = i `elem` ids---filterDecl _ _ = True+-- filterDecl :: [Identifier] -> (ModItem ReduceAnn) -> Bool+-- filterDecl ids (Decl Nothing (Port _ _ _ i) _) = i `elem` ids+-- filterDecl _ _ = True -- | Checks if a continuous assignment is in the current scope, if not, it -- returns 'False'.-filterAssigns :: [Port] -> ModItem -> Bool+filterAssigns :: [Port] -> (ModItem ReduceAnn) -> Bool filterAssigns out (ModCA (ContAssign i _)) =- elem i $ out ^.. traverse . portName+ elem i $ out ^.. traverse . portName filterAssigns _ _ = True clean :: (Mutate a) => [Identifier] -> a -> a@@ -165,123 +185,104 @@ takeReplace :: (Monoid a) => Replacement a -> a takeReplace (Single a) = a takeReplace (Dual a _) = a-takeReplace None = mempty+takeReplace None = mempty -removeConstInConcat :: Replace SourceInfo+-- | Remove all the constants that are in the concatination.+removeConstInConcat :: Replace (SourceInfo ReduceAnn) removeConstInConcat = Single . mutExpr replace where replace :: Expr -> Expr- replace (Concat expr) = maybe (Number 0) Concat . NonEmpty.nonEmpty- $ NonEmpty.filter notConstant expr- replace e = e+ replace (Concat expr) =+ maybe (Number 0) Concat . NonEmpty.nonEmpty $+ NonEmpty.filter notConstant expr+ replace e = e notConstant (Number _) = False- notConstant _ = True+ notConstant _ = True -cleanUndefined :: [Identifier] -> [ModItem] -> [ModItem]+cleanUndefined :: [Identifier] -> [ModItem ReduceAnn] -> [ModItem ReduceAnn] cleanUndefined ids mis = clean usedWires mis where usedWires = mis ^.. traverse . modContAssign . contAssignNetLVal <> ids -halveModAssign :: Replace ModDecl+halveModAssign :: Replace (ModDecl ReduceAnn) 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 :: (ModDecl ReduceAnn) -> Replacement (ModDecl ReduceAnn) -> Replacement (ModDecl ReduceAnn) 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+ cleanUndefined (m ^.. modInPorts . traverse . portName)+ . combineAssigns (head $ m ^. modOutPorts)+ . (filter (not . filterAssigns []) mis <>)+ $ l+ ^. modItems halveIndExpr :: Replace Expr-halveIndExpr (Concat l ) = Concat <$> halveNonEmpty l-halveIndExpr (BinOp e1 _ e2) = Dual e1 e2-halveIndExpr (Cond _ e1 e2) = Dual e1 e2-halveIndExpr (UnOp _ e ) = Single e-halveIndExpr (Appl _ e ) = Single e-halveIndExpr e = Single e+halveIndExpr (Concat l) = Concat <$> halveNonEmpty l+halveIndExpr (BinOp e1 _ e2) = Dual e1 e2+halveIndExpr (Cond _ e1 e2) = Dual e1 e2+halveIndExpr (UnOp _ e) = Single e+halveIndExpr (Appl _ e) = Single e+halveIndExpr e = Single e -halveModExpr :: Replace ModItem+halveModExpr :: Replace (ModItem ReduceAnn) 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 :)+halveModExpr a = Single a -- | 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+halveAssigns :: Replace (SourceInfo ReduceAnn)+halveAssigns = combineL mainModule halveModAssign -- | Checks if a module item is needed in the module declaration.-relevantModItem :: ModDecl -> ModItem -> Bool+relevantModItem :: (ModDecl ReduceAnn) -> (ModItem ReduceAnn) -> Bool relevantModItem (ModDecl _ out _ _ _) (ModCA (ContAssign i _)) =- i `elem` fmap _portName out-relevantModItem _ Decl{} = True-relevantModItem _ _ = False+ i `elem` fmap _portName out+relevantModItem _ Decl {} = True+relevantModItem _ _ = False -isAssign :: Statement -> Bool-isAssign (BlockAssign _) = True+isAssign :: (Statement ReduceAnn) -> Bool+isAssign (BlockAssign _) = True isAssign (NonBlockAssign _) = True-isAssign _ = False+isAssign (ForLoop _ _ _ _) = True+isAssign _ = False lValName :: LVal -> [Identifier]-lValName (RegId i ) = [i]+lValName (RegId i) = [i] lValName (RegExpr i _) = [i] lValName (RegSize i _) = [i] lValName (RegConcat e) = mapMaybe getId . concat $ universe <$> e where getId (Id i) = Just i- getId _ = Nothing+ getId _ = Nothing -- | Pretending that expr is an LVal for the case that it is in a module -- instantiation. exprName :: Expr -> [Identifier]-exprName (Id i ) = [i]-exprName (VecSelect i _) = [i]+exprName (Id i) = [i]+exprName (VecSelect i _) = [i] exprName (RangeSelect i _) = [i]-exprName (Concat i ) = concat . NonEmpty.toList $ exprName <$> i-exprName _ = []+exprName (Concat i) = concat . NonEmpty.toList $ exprName <$> i+exprName _ = [] -- | Returns the only identifiers that are directly tied to an expression. This -- is useful if one does not have to recurse deeper into the expressions. exprId :: Expr -> Maybe Identifier-exprId (Id i ) = Just i-exprId (VecSelect i _) = Just i+exprId (Id i) = Just i+exprId (VecSelect i _) = Just i exprId (RangeSelect i _) = Just i-exprId _ = Nothing+exprId _ = Nothing eventId :: Event -> Maybe Identifier-eventId (EId i) = Just i+eventId (EId i) = Just i eventId (EPosEdge i) = Just i eventId (ENegEdge i) = Just i-eventId _ = Nothing+eventId _ = Nothing portToId :: Port -> Identifier portToId (Port _ _ _ i) = i@@ -289,73 +290,91 @@ paramToId :: Parameter -> Identifier paramToId (Parameter i _) = i -isModule :: Identifier -> ModDecl -> Bool+isModule :: Identifier -> (ModDecl ReduceAnn) -> 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 ..]+modInstActive :: [(ModDecl ReduceAnn)] -> (ModItem ReduceAnn) -> [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 _ _ _) (ModConn e, n')+ | n' < length o = exprName e+ | otherwise = [] calcActive (ModDecl _ o _ _ _) (ModConnNamed i' e, _)- | i' `elem` fmap _portName o = exprName e- | otherwise = []+ | i' `elem` fmap _portName o = exprName e+ | otherwise = [] modInstActive _ _ = [] -fixModInst :: SourceInfo -> 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 ..]+fixModInst :: (SourceInfo ReduceAnn) -> (ModItem ReduceAnn) -> (ModItem ReduceAnn)+fixModInst (SourceInfo _ (Verilog decl)) (ModInst n p g i) = case m of+ Nothing -> error "Moditem not found"+ Just m' -> ModInst n p g . mapMaybe (fixModInst' m') $ zip i [0 ..] where m = safe head $ filter (isModule n) decl fixModInst' (ModDecl _ o i' _ _) (ModConn e, n')- | n' < length o + length i' = Just $ ModConn e- | otherwise = Nothing+ | n' < length o + length i' = Just $ ModConn e+ | otherwise = Nothing fixModInst' (ModDecl _ o i'' _ _) (ModConnNamed i' e, _)- | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e- | otherwise = Nothing+ | i' `elem` fmap _portName (o <> i'') = Just $ ModConnNamed i' e+ | otherwise = Nothing fixModInst _ a = a -findActiveWires :: Identifier -> SourceInfo -> [Identifier]+eventIdent :: Event -> [Identifier]+eventIdent (EId i) = [i]+eventIdent (EExpr e) =+ case exprId e of+ Nothing -> []+ Just eid -> [eid]+eventIdent EAll = []+eventIdent (EPosEdge i) = [i]+eventIdent (ENegEdge i) = [i]+eventIdent (EOr e1 e2) = eventIdent e1 <> eventIdent e2+eventIdent (EComb e1 e2) = eventIdent e1 <> eventIdent e2++findActiveWires :: Identifier -> (SourceInfo ReduceAnn) -> [Identifier] findActiveWires t src =- nub- $ assignWires- <> assignStat- <> fmap portToId i- <> fmap portToId o- <> fmap paramToId p- <> modinstwires+ nub $+ assignWires+ <> assignStat+ <> fmap portToId i+ <> fmap portToId o+ <> fmap paramToId p+ <> modinstwires+ <> events where assignWires = m ^.. modItems . traverse . modContAssign . contAssignNetLVal assignStat =- concatMap lValName- $ (allStat ^.. traverse . stmntBA . assignReg)- <> (allStat ^.. traverse . stmntNBA . assignReg)+ concatMap lValName $+ (allStat ^.. traverse . stmntBA . assignReg)+ <> (allStat ^.. traverse . stmntNBA . assignReg)+ <> (allStat ^.. traverse . forAssign . assignReg)+ <> (allStat ^.. traverse . forIncr . assignReg)+ events = concatMap eventIdent $ (allStat ^.. traverse . statEvent) allStat = filter isAssign . concat $ fmap universe stat stat =- (m ^.. modItems . traverse . _Initial)- <> (m ^.. modItems . traverse . _Always)+ (m ^.. modItems . traverse . _Initial)+ <> (m ^.. modItems . traverse . _Always) modinstwires =- concat $ modInstActive (src ^. infoSrc . _Wrapped) <$> m ^. modItems+ concat $ modInstActive (src ^. infoSrc . _Wrapped) <$> m ^. modItems m@(ModDecl _ o i _ p) = src ^. aModule t -- | Clean a specific module. Have to be carful that the module is in the--- 'SourceInfo', otherwise it will crash.-cleanSourceInfo :: Identifier -> SourceInfo -> SourceInfo+-- '(SourceInfo ReduceAnn)', otherwise it will crash.+cleanSourceInfo :: Identifier -> (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn) cleanSourceInfo t src = src & aModule t %~ clean (findActiveWires t src) -cleanSourceInfoAll :: SourceInfo -> SourceInfo+cleanSourceInfoAll :: (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn) cleanSourceInfoAll src = foldr cleanSourceInfo src allMods- where allMods = src ^.. infoSrc . _Wrapped . traverse . modId+ where+ allMods = src ^.. infoSrc . _Wrapped . traverse . modId -- | Returns true if the text matches the name of a module.-matchesModName :: Identifier -> ModDecl -> Bool+matchesModName :: Identifier -> (ModDecl ReduceAnn) -> Bool matchesModName top (ModDecl i _ _ _ _) = top == i -halveStatement :: Replace Statement+halveStatement :: Replace (Statement ReduceAnn) halveStatement (SeqBlock [s]) = halveStatement s halveStatement (SeqBlock s) = SeqBlock <$> halve s halveStatement (CondStmnt _ (Just s1) (Just s2)) = Dual s1 s2@@ -365,60 +384,81 @@ 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+halveAlways :: Replace (ModItem ReduceAnn)+halveAlways (ModItemAnn Active (Always s)) = ModItemAnn Active . Always <$> halveStatement s+halveAlways r@(ModItemAnn Reduced (Always s)) = Single r+halveAlways a = Single a +-- | Check if a mod instance is in the current context.+validModInst :: [Identifier] -> (ModItem ReduceAnn) -> Bool+validModInst ids (ModInst i _ _ _) = i `elem` ids+validModInst _ _ = True++-- | Clean all the undefined module instances in a specific module using a+-- context.+cleanModInst' :: [Identifier] -> (ModDecl ReduceAnn) -> (ModDecl ReduceAnn)+cleanModInst' ids m = m & modItems .~ newModItem+ where+ newModItem = filter (validModInst ids) $ m ^.. modItems . traverse++-- | Remove all the undefined mod instances.+cleanModInst :: (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn)+cleanModInst srcInfo = srcInfo & infoSrc . _Wrapped .~ cleaned+ where+ validInst = srcInfo ^.. infoSrc . _Wrapped . traverse . modId+ cleaned = cleanModInst' validInst <$> srcInfo ^. infoSrc . _Wrapped++-- | Adds a '(ModDecl ReduceAnn)' to a '(SourceInfo ReduceAnn)'.+addMod :: (ModDecl ReduceAnn) -> (SourceInfo ReduceAnn) -> (SourceInfo ReduceAnn)+addMod m srcInfo = srcInfo & infoSrc . _Wrapped %~ (m :)+ -- | 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 :: Replace (SourceInfo ReduceAnn) halveModules srcInfo@(SourceInfo top _) =- cleanSourceInfoAll- . cleanModInst- . addMod main- <$> combine (infoSrc . _Wrapped) repl srcInfo+ cleanSourceInfoAll+ . cleanModInst+ . addMod main+ <$> combine (infoSrc . _Wrapped) repl srcInfo where repl = halve . filter (not . matchesModName (Identifier top)) main = srcInfo ^. mainModule -moduleBot :: SourceInfo -> Bool-moduleBot (SourceInfo _ (Verilog [] )) = True+moduleBot :: (SourceInfo ReduceAnn) -> Bool+moduleBot (SourceInfo _ (Verilog [])) = True moduleBot (SourceInfo _ (Verilog [_])) = True-moduleBot (SourceInfo _ (Verilog _ )) = False+moduleBot (SourceInfo _ (Verilog _)) = False -- | Reducer for module items. It does a binary search on all the module items, -- except assignments to outputs and input-output declarations.-halveModItems :: Identifier -> Replace SourceInfo+halveModItems :: Identifier -> Replace (SourceInfo ReduceAnn) halveModItems t srcInfo = cleanSourceInfo t . addRelevant <$> src where- repl = halve . filter (not . relevantModItem main)- relevant = filter (relevantModItem main) $ main ^. modItems- main = srcInfo ^. aModule t- src = combine (aModule t . modItems) repl srcInfo+ repl = halve . filter (not . relevantModItem main)+ relevant = filter (relevantModItem main) $ main ^. modItems+ main = srcInfo ^. aModule t+ src = combine (aModule t . modItems) repl srcInfo addRelevant = aModule t . modItems %~ (relevant ++) -modItemBot :: Identifier -> SourceInfo -> Bool-modItemBot t srcInfo | length modItemsNoDecl > 2 = False- | otherwise = True+modItemBot :: Identifier -> (SourceInfo ReduceAnn) -> Bool+modItemBot t srcInfo+ | length modItemsNoDecl > 2 = False+ | otherwise = True where modItemsNoDecl =- filter noDecl $ srcInfo ^.. aModule t . modItems . traverse- noDecl Decl{} = False- noDecl _ = True+ filter noDecl $ srcInfo ^.. aModule t . modItems . traverse+ noDecl Decl {} = False+ noDecl _ = True -halveStatements :: Identifier -> Replace SourceInfo+halveStatements :: Identifier -> Replace (SourceInfo ReduceAnn) halveStatements t m =- cleanSourceInfo t <$> combine (aModule t . modItems) halves m- where halves = traverse halveAlways+ cleanSourceInfo t <$> combine (aModule t . modItems) (traverse halveAlways) m -- | 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+halveExpr :: Identifier -> Replace (SourceInfo ReduceAnn)+halveExpr t = combine (aModule t . modItems) $ traverse halveModExpr toIds :: [Expr] -> [Identifier] toIds = nub . mapMaybe exprId . concatMap universe@@ -429,66 +469,66 @@ toIdsEvent :: [Event] -> [Identifier] toIdsEvent = nub . mapMaybe eventId . concatMap universe -allStatIds' :: Statement -> [Identifier]+allStatIds' :: (Statement ReduceAnn) -> [Identifier] allStatIds' s = nub $ assignIds <> otherExpr <> eventProcessedIds where assignIds =- toIds- $ (s ^.. stmntBA . assignExpr)- <> (s ^.. stmntNBA . assignExpr)- <> (s ^.. forAssign . assignExpr)- <> (s ^.. forIncr . assignExpr)- otherExpr = toIds $ (s ^.. forExpr) <> (s ^.. stmntCondExpr)+ toIds $+ (s ^.. stmntBA . assignExpr)+ <> (s ^.. stmntNBA . assignExpr)+ <> (s ^.. forAssign . assignExpr)+ <> (s ^.. forIncr . assignExpr)+ otherExpr = toIds $ (s ^.. forExpr) <> (s ^.. stmntCondExpr) eventProcessedIds = toIdsEvent $ s ^.. statEvent -allStatIds :: Statement -> [Identifier]+allStatIds :: (Statement ReduceAnn) -> [Identifier] allStatIds s = nub . concat $ allStatIds' <$> universe s fromRange :: Range -> [ConstExpr] fromRange r = [rangeMSB r, rangeLSB r] -allExprIds :: ModDecl -> [Identifier]+allExprIds :: (ModDecl ReduceAnn) -> [Identifier] allExprIds m =- nub- $ contAssignIds- <> modInstIds- <> modInitialIds- <> modAlwaysIds- <> modPortIds- <> modDeclIds- <> paramIds+ nub $+ contAssignIds+ <> modInstIds+ <> modInitialIds+ <> modAlwaysIds+ <> modPortIds+ <> modDeclIds+ <> paramIds where contAssignIds =- toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr+ toIds $ m ^.. modItems . traverse . modContAssign . contAssignExpr modInstIds =- toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr+ toIds $ m ^.. modItems . traverse . modInstConns . traverse . modExpr modInitialIds =- nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial+ nub . concatMap allStatIds $ m ^.. modItems . traverse . _Initial modAlwaysIds =- nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always+ nub . concatMap allStatIds $ m ^.. modItems . traverse . _Always modPortIds =- nub- . concatMap (toIdsConst . fromRange)- $ m- ^.. modItems- . traverse- . declPort- . portSize+ nub+ . concatMap (toIdsConst . fromRange)+ $ m+ ^.. modItems+ . traverse+ . declPort+ . portSize modDeclIds = toIdsConst $ m ^.. modItems . traverse . declVal . _Just paramIds =- toIdsConst- $ (m ^.. modItems . traverse . paramDecl . traverse . paramValue)- <> ( m- ^.. modItems- . traverse- . localParamDecl- . traverse- . localParamValue- )+ toIdsConst $+ (m ^.. modItems . traverse . paramDecl . traverse . paramValue)+ <> ( m+ ^.. modItems+ . traverse+ . localParamDecl+ . traverse+ . localParamValue+ ) -isUsedDecl :: [Identifier] -> ModItem -> Bool+isUsedDecl :: [Identifier] -> (ModItem ReduceAnn) -> Bool isUsedDecl ids (Decl _ (Port _ _ _ i) _) = i `elem` ids-isUsedDecl _ _ = True+isUsedDecl _ _ = True isUsedParam :: [Identifier] -> Parameter -> Bool isUsedParam ids (Parameter i _) = i `elem` ids@@ -496,161 +536,234 @@ isUsedPort :: [Identifier] -> Port -> Bool isUsedPort ids (Port _ _ _ i) = i `elem` ids -removeDecl :: SourceInfo -> SourceInfo+-- | Should return true if there is any active tag present.+checkActiveTag :: ModDecl ReduceAnn -> Bool+checkActiveTag m = (/= []) . filter hasActiveTag $ _modItems m+ where+ hasActiveTag (ModItemAnn Active (Always _)) = True+ hasActiveTag _ = False++tagAlwaysBlockMis :: [ModItem ReduceAnn] -> [ModItem ReduceAnn]+tagAlwaysBlockMis [] = []+tagAlwaysBlockMis (mi@(Always _) : mis) = ModItemAnn Active mi : mis+tagAlwaysBlockMis (mi : mis) = mi : tagAlwaysBlockMis mis++-- | Tag an always block to be reduced if there are no active ones.+tagAlwaysBlock :: ModDecl ReduceAnn -> ModDecl ReduceAnn+tagAlwaysBlock m+ | checkActiveTag m = m+ | otherwise = m {_modItems = tagAlwaysBlockMis (_modItems m)}++tagAlwaysBlockReducedMis :: [ModItem ReduceAnn] -> [ModItem ReduceAnn]+tagAlwaysBlockReducedMis [] = []+tagAlwaysBlockReducedMis ((ModItemAnn Active mi) : mis) =+ ModItemAnn Reduced mi : tagAlwaysBlockReducedMis mis+tagAlwaysBlockReducedMis (mi : mis) = mi : tagAlwaysBlockReducedMis mis++-- | Tag an always block to be reduced if there are no active ones.+tagAlwaysBlockReduced :: ModDecl ReduceAnn -> ModDecl ReduceAnn+tagAlwaysBlockReduced m = m {_modItems = tagAlwaysBlockReducedMis (_modItems m)}++tAlways ::+ (ModDecl ReduceAnn -> ModDecl ReduceAnn) ->+ Identifier ->+ SourceInfo ReduceAnn ->+ SourceInfo ReduceAnn+tAlways f t m =+ m & aModule t %~ f++tagAlways, untagAlways, idTag :: Identifier -> SourceInfo ReduceAnn -> SourceInfo ReduceAnn+tagAlways = tAlways tagAlwaysBlock+untagAlways = tAlways tagAlwaysBlockReduced+idTag = const id++removeDecl :: SourceInfo ReduceAnn -> SourceInfo ReduceAnn 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)+ 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 :: (SourceInfo ReduceAnn) -> Bool defaultBot = const False -- | Reduction using custom reduction strategies.-reduce_- :: MonadSh m- => Shelly.FilePath- -> Text- -> Replace SourceInfo- -> (SourceInfo -> Bool)- -> (SourceInfo -> m Bool)- -> SourceInfo- -> m SourceInfo-reduce_ out title repl bot eval src = do- writefile out $ genSource src- liftSh- . Shelly.echo- $ "Reducing "- <> title- <> " (Modules: "- <> showT (length . getVerilog $ _infoSrc src)- <> ", Module items: "- <> showT- (length- (src ^.. infoSrc . _Wrapped . traverse . modItems . traverse)- )- <> ")"- if bot src- then return 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+reduce_ ::+ (MonadSh m) =>+ Shelly.FilePath ->+ (SourceInfo ReduceAnn -> m Bool) ->+ Text ->+ (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) ->+ (SourceInfo ReduceAnn -> SourceInfo ReduceAnn) ->+ Replace (SourceInfo ReduceAnn) ->+ (SourceInfo ReduceAnn -> Bool) ->+ SourceInfo ReduceAnn ->+ m (SourceInfo ReduceAnn)+reduce_ out eval title tag untag repl bot usrc = do+ writefile out $ genSource src+ liftSh+ . Shelly.echo+ $ "Reducing "+ <> title+ <> " (modules: "+ <> showT (length . getVerilog $ _infoSrc src)+ <> ", module items: "+ <> showT (length (src ^.. infoSrc . _Wrapped . traverse . modItems . traverse))+ <> ", loc: "+ <> showT (length . lines . unpack $ genSource usrc)+ <> ")"+ if bot src+ then return $ untag src+ else case repl src of+ Single s -> do+ red <- eval s+ if red+ then if s /= src then recReduction s else return $ untag src+ else return $ untag src+ Dual l r -> do+ red <- eval l+ if red+ then if l /= src then recReduction l else return $ untag src+ else do+ red' <- eval r+ if red'+ then if r /= src then recReduction r else return $ untag src+ else return $ untag src+ None -> return $ untag src where- cond s = s /= src- recReduction = reduce_ out title repl bot eval+ src = tag usrc+ recReduction = reduce_ out eval title tag untag repl bot -- | Reduce an input to a minimal representation. It follows the reduction -- strategy mentioned above.-reduce- :: MonadSh m- => Shelly.FilePath -- ^ Filepath for temporary file.- -> (SourceInfo -> m Bool) -- ^ Failed or not.- -> SourceInfo -- ^ Input verilog source to be reduced.- -> m SourceInfo -- ^ Reduced output.-reduce fp eval src =- fmap removeDecl- $ red "Modules" moduleBot halveModules src- >>= redAll "Module items" modItemBot halveModItems- >>= redAll "Statements" (const defaultBot) halveStatements- -- >>= redAll "Expressions" (const defaultBot) halveExpr- >>= red "Remove constants in concat" defaultBot removeConstInConcat- >>= red "Cleaning" defaultBot (pure . removeDecl)+reduce ::+ (MonadSh m) =>+ -- | Filepath for temporary file.+ Shelly.FilePath ->+ -- | Failed or not.+ (SourceInfo ReduceAnn -> m Bool) ->+ -- | Input verilog source to be reduced.+ SourceInfo () ->+ -- | Reduced output.+ m (SourceInfo ())+reduce fp eval rsrc =+ fmap clearAnn $+ red "Modules" id id halveModules moduleBot src+ >>= redAll "Module items" idTag idTag halveModItems modItemBot+ >>= redAll "Statements" tagAlways untagAlways halveStatements (const defaultBot)+ -- >>= redAll "Expressions" halveExpr (const defaultBot)+ >>= red "Remove constants in concat" id id removeConstInConcat defaultBot+ >>= red "Cleaning" id id (pure . removeDecl) defaultBot where- red s bot a = reduce_ fp s a bot eval- red' s bot a t = reduce_ fp s (a t) (bot t) eval- redAll s bot halve' src' = foldrM- (\t -> red' (s <> " (" <> getIdentifier t <> ")") bot halve' t)+ red = reduce_ fp eval+ redAll s tag untag halve' bot src' =+ foldrM+ (\t -> red (s <> " (" <> getIdentifier t <> ")") (tag t) (untag t) (halve' t) (bot t)) src' (src' ^.. infoSrc . _Wrapped . traverse . modId)+ src = fmap (\_ -> Idle) rsrc -runScript- :: MonadSh m => Shelly.FilePath -> Shelly.FilePath -> SourceInfo -> m Bool+runScript ::+ (MonadSh m, Show ann) =>+ Shelly.FilePath ->+ Shelly.FilePath ->+ (SourceInfo ann) ->+ m Bool runScript fp file src = do- e <- liftSh $ do- Shelly.writefile file $ genSource src- noPrint . Shelly.errExit False $ Shelly.run_ fp []- Shelly.lastExitCode- return $ e == 0+ e <- liftSh $ do+ Shelly.writefile file $ genSource src+ noPrint . Shelly.errExit False $ Shelly.run_ fp []+ Shelly.lastExitCode+ return $ e == 0 -- | Reduce using a script that is passed to it-reduceWithScript- :: (MonadSh m, MonadIO m)- => Text- -> Shelly.FilePath- -> Shelly.FilePath- -> m ()+reduceWithScript ::+ (MonadSh m, MonadIO m) =>+ Text ->+ Shelly.FilePath ->+ Shelly.FilePath ->+ m () reduceWithScript top script file = do- liftSh . Shelly.cp file $ file <.> "original"- srcInfo <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file- void $ reduce (fromText "reduce_script.v") (runScript script file) srcInfo+ liftSh . Shelly.cp file $ file <.> "original"+ (srcInfo :: SourceInfo ()) <- liftIO . parseSourceInfoFile top $ Shelly.toTextIgnore file+ void $ reduce (fromText "reduce_script.v") (runScript script file) srcInfo --- | Reduce a 'SourceInfo' using two 'Synthesiser' that are passed to it.-reduceSynth- :: (Synthesiser a, Synthesiser b, MonadSh m)- => Maybe Text- -> Shelly.FilePath- -> a- -> b- -> SourceInfo- -> m SourceInfo-reduceSynth mt datadir a b = reduce (fromText $ "reduce_" <> toText a <> "_" <> toText b <> ".v") synth+-- | Reduce a '(SourceInfo ReduceAnn)' using two 'Synthesiser' that are passed to it.+reduceSynth ::+ (Synthesiser a, Synthesiser b, MonadSh m) =>+ Maybe Text ->+ Shelly.FilePath ->+ a ->+ b ->+ SourceInfo () ->+ m (SourceInfo ())+reduceSynth mt datadir a b src = do+ counter <- liftSh . liftIO $ newIORef (0 :: Int)+ reduce (fromText $ prefix <> ".v") (synth counter) src where- synth src' = liftSh $ do- r <- runResultT $ do- runSynth a src'- runSynth b src'- runEquiv mt datadir a b src'- return $ case r of- Fail (EquivFail _) -> True- _ -> False+ synth counter src' = liftSh $ do+ count <- liftIO $ readIORef counter+ liftIO $ writeIORef counter (count + 1)+ Shelly.mkdir (fromText $ prefix <> "_" <> showT count)+ current_dir <- Shelly.pwd+ Shelly.cd (fromText $ prefix <> "_" <> showT count)+ r <- runResultT $ do+ runSynth a src'+ runSynth b src'+ runEquiv mt datadir a b src'+ Shelly.cd current_dir+ return $ case r of+ Fail (EquivFail _) -> True+ _ -> False+ prefix = "reduce_" <> toText a <> "_" <> toText b -reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo -> m SourceInfo+reduceSynthesis :: (Synthesiser a, MonadSh m) => a -> SourceInfo () -> m (SourceInfo ()) reduceSynthesis a = reduce (fromText $ "reduce_" <> toText a <> ".v") synth where synth src = liftSh $ do- r <- runResultT $ runSynth a src- return $ case r of- Fail SynthFail -> True- _ -> False+ r <- runResultT $ runSynth a src+ return $ case r of+ Fail SynthFail -> True+ _ -> False runInTmp :: Shelly.Sh a -> Shelly.Sh a-runInTmp a = Shelly.withTmpDir $ (\f -> do- dir <- Shelly.pwd- Shelly.cd f- r <- a- Shelly.cd dir- return r)+runInTmp a =+ Shelly.withTmpDir $+ ( \f -> do+ dir <- Shelly.pwd+ Shelly.cd f+ r <- a+ Shelly.cd dir+ return r+ ) -reduceSimIc :: (Synthesiser a, MonadSh m) => Shelly.FilePath -> [ByteString] -> a -> SourceInfo -> m SourceInfo+reduceSimIc ::+ (Synthesiser a, MonadSh m) =>+ Shelly.FilePath ->+ [ByteString] ->+ a ->+ SourceInfo () ->+ m (SourceInfo ()) reduceSimIc fp bs a = reduce (fromText $ "reduce_sim_" <> toText a <> ".v") synth where synth src = liftSh . runInTmp $ do- r <- runResultT $ do- runSynth a src- runSynth defaultIdentity src- i <- runSimIc fp defaultIcarus defaultIdentity src bs Nothing- runSimIc fp defaultIcarus a src bs $ Just i- return $ case r of- Fail (SimFail _) -> True- _ -> False+ r <- runResultT $ do+ runSynth a src+ runSynth defaultIdentity src+ i <- runSimIc fp defaultIcarus defaultIdentity src bs Nothing+ runSimIc fp defaultIcarus a src bs $ Just i+ return $ case r of+ Fail (SimFail _) -> True+ _ -> False
src/Verismith/Report.hs view
@@ -1,71 +1,72 @@-{-# LANGUAGE RankNTypes #-}-{-|-Module : Verismith.Report-Description : Generate a report from a fuzz run.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Generate a report from a fuzz run.--}-+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- |+-- Module : Verismith.Report+-- Description : Generate a report from a fuzz run.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Generate a report from a fuzz run. module Verismith.Report- ( SynthTool(..)- , SynthStatus(..)- , SynthResult(..)- , SimResult(..)- , SimTool(..)- , FuzzReport(..)- , printResultReport- , printSummary- , synthResults- , simResults- , synthStatus- , equivTime- , fuzzDir- , fileLines- , reducTime- , synthTime- , defaultIcarusSim- , defaultVivadoSynth- , defaultYosysSynth- , defaultXSTSynth- , defaultQuartusSynth- , defaultQuartusLightSynth- , defaultIdentitySynth- , descriptionToSim- , descriptionToSynth- )+ ( SynthTool (..),+ SynthStatus (..),+ SynthResult (..),+ SimResult (..),+ SimTool (..),+ FuzzReport (..),+ printResultReport,+ printSummary,+ synthResults,+ simResults,+ synthStatus,+ equivTime,+ fuzzDir,+ fileLines,+ reducTime,+ synthTime,+ defaultIcarusSim,+ defaultVivadoSynth,+ defaultYosysSynth,+ defaultXSTSynth,+ defaultQuartusSynth,+ defaultQuartusLightSynth,+ defaultIdentitySynth,+ descriptionToSim,+ descriptionToSynth,+ ) where -import Control.DeepSeq (NFData, rnf)-import Control.Lens hiding (Identity, (<.>))-import Data.Bifunctor (bimap)-import Data.ByteString (ByteString)-import Data.Maybe (fromMaybe)-import Data.Monoid (Endo)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Lazy (toStrict)-import Data.Time-import 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.Tool-import Verismith.Tool.Internal+import Control.DeepSeq (NFData, rnf)+import Control.Lens hiding (Identity, (<.>))+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Data.Monoid (Endo)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (toStrict)+import Data.Time+import Shelly+ ( FilePath,+ fromText,+ toTextIgnore,+ (<.>),+ (</>),+ )+import Text.Blaze.Html (Html, (!))+import Text.Blaze.Html.Renderer.Text (renderHtml)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Verismith.Config+import Verismith.Result+import Verismith.Tool+import Verismith.Tool.Internal+import Verismith.Utils+import Prelude hiding (FilePath) -- | Common type alias for synthesis results type UResult = Result Failed ()@@ -73,59 +74,60 @@ -- | Commont type alias for simulation results type BResult = Result Failed ByteString -data SynthTool = XSTSynth {-# UNPACK #-} !XST- | VivadoSynth {-# UNPACK #-} !Vivado- | YosysSynth {-# UNPACK #-} !Yosys- | QuartusSynth {-# UNPACK #-} !Quartus- | QuartusLightSynth {-# UNPACK #-} !QuartusLight- | IdentitySynth {-# UNPACK #-} !Identity- deriving (Eq)+data SynthTool+ = XSTSynth {-# UNPACK #-} !XST+ | VivadoSynth {-# UNPACK #-} !Vivado+ | YosysSynth {-# UNPACK #-} !Yosys+ | QuartusSynth {-# UNPACK #-} !Quartus+ | QuartusLightSynth {-# UNPACK #-} !QuartusLight+ | IdentitySynth {-# UNPACK #-} !Identity+ deriving (Eq) instance NFData SynthTool where- rnf (XSTSynth a) = rnf a- rnf (VivadoSynth a) = rnf a- rnf (YosysSynth a) = rnf a- rnf (QuartusSynth a) = rnf a- rnf (QuartusLightSynth a) = rnf a- rnf (IdentitySynth a) = rnf a+ rnf (XSTSynth a) = rnf a+ rnf (VivadoSynth a) = rnf a+ rnf (YosysSynth a) = rnf a+ rnf (QuartusSynth a) = rnf a+ rnf (QuartusLightSynth a) = rnf a+ rnf (IdentitySynth a) = rnf a instance Show SynthTool where- show (XSTSynth xst) = show xst- show (VivadoSynth vivado) = show vivado- show (YosysSynth yosys) = show yosys- show (QuartusSynth quartus) = show quartus- show (QuartusLightSynth quartus) = show quartus- show (IdentitySynth identity) = show identity+ show (XSTSynth xst) = show xst+ show (VivadoSynth vivado) = show vivado+ show (YosysSynth yosys) = show yosys+ show (QuartusSynth quartus) = show quartus+ show (QuartusLightSynth quartus) = show quartus+ show (IdentitySynth identity) = show identity instance Tool SynthTool where- toText (XSTSynth xst) = toText xst- toText (VivadoSynth vivado) = toText vivado- toText (YosysSynth yosys) = toText yosys- toText (QuartusSynth quartus) = toText quartus- toText (QuartusLightSynth quartus) = toText quartus- toText (IdentitySynth identity) = toText identity+ toText (XSTSynth xst) = toText xst+ toText (VivadoSynth vivado) = toText vivado+ toText (YosysSynth yosys) = toText yosys+ toText (QuartusSynth quartus) = toText quartus+ toText (QuartusLightSynth quartus) = toText quartus+ toText (IdentitySynth identity) = toText identity instance Synthesiser SynthTool where- runSynth (XSTSynth xst) = runSynth xst- runSynth (VivadoSynth vivado) = runSynth vivado- runSynth (YosysSynth yosys) = runSynth yosys- runSynth (QuartusSynth quartus) = runSynth quartus- runSynth (QuartusLightSynth quartus) = runSynth quartus- runSynth (IdentitySynth identity) = runSynth identity+ runSynth (XSTSynth xst) = runSynth xst+ runSynth (VivadoSynth vivado) = runSynth vivado+ runSynth (YosysSynth yosys) = runSynth yosys+ runSynth (QuartusSynth quartus) = runSynth quartus+ runSynth (QuartusLightSynth quartus) = runSynth quartus+ runSynth (IdentitySynth identity) = runSynth identity - synthOutput (XSTSynth xst) = synthOutput xst- synthOutput (VivadoSynth vivado) = synthOutput vivado- synthOutput (YosysSynth yosys) = synthOutput yosys- synthOutput (QuartusSynth quartus) = synthOutput quartus- synthOutput (QuartusLightSynth quartus) = synthOutput quartus- synthOutput (IdentitySynth identity) = synthOutput identity+ synthOutput (XSTSynth xst) = synthOutput xst+ synthOutput (VivadoSynth vivado) = synthOutput vivado+ synthOutput (YosysSynth yosys) = synthOutput yosys+ synthOutput (QuartusSynth quartus) = synthOutput quartus+ synthOutput (QuartusLightSynth quartus) = synthOutput quartus+ synthOutput (IdentitySynth identity) = synthOutput identity - setSynthOutput (YosysSynth yosys) = YosysSynth . setSynthOutput yosys- setSynthOutput (XSTSynth xst) = XSTSynth . setSynthOutput xst- setSynthOutput (VivadoSynth vivado) = VivadoSynth . setSynthOutput vivado- setSynthOutput (QuartusSynth quartus) = QuartusSynth . setSynthOutput quartus- setSynthOutput (QuartusLightSynth quartus) = QuartusLightSynth . setSynthOutput quartus- setSynthOutput (IdentitySynth identity) = IdentitySynth . setSynthOutput identity+ setSynthOutput (YosysSynth yosys) = YosysSynth . setSynthOutput yosys+ setSynthOutput (XSTSynth xst) = XSTSynth . setSynthOutput xst+ setSynthOutput (VivadoSynth vivado) = VivadoSynth . setSynthOutput vivado+ setSynthOutput (QuartusSynth quartus) = QuartusSynth . setSynthOutput quartus+ setSynthOutput (QuartusLightSynth quartus) = QuartusLightSynth . setSynthOutput quartus+ setSynthOutput (IdentitySynth identity) = IdentitySynth . setSynthOutput identity defaultYosysSynth :: SynthTool defaultYosysSynth = YosysSynth defaultYosys@@ -146,20 +148,20 @@ defaultIdentitySynth = IdentitySynth defaultIdentity newtype SimTool = IcarusSim Icarus- deriving (Eq)+ deriving (Eq) instance NFData SimTool where- rnf (IcarusSim a) = rnf a+ rnf (IcarusSim a) = rnf a instance Tool SimTool where- toText (IcarusSim icarus) = toText icarus+ toText (IcarusSim icarus) = toText icarus instance Simulator SimTool where- runSim (IcarusSim icarus) = runSim icarus- runSimWithFile (IcarusSim icarus) = runSimWithFile icarus+ runSim (IcarusSim icarus) = runSim icarus+ runSimWithFile (IcarusSim icarus) = runSimWithFile icarus instance Show SimTool where- show (IcarusSim icarus) = show icarus+ show (IcarusSim icarus) = show icarus defaultIcarusSim :: SimTool defaultIcarusSim = IcarusSim defaultIcarus@@ -167,10 +169,10 @@ -- | The results from running a tool through a simulator. It can either fail or -- return a result, which is most likely a 'ByteString'. data SimResult = SimResult !SynthTool !SimTool ![ByteString] !BResult !NominalDiffTime- deriving (Eq)+ deriving (Eq) instance Show SimResult where- show (SimResult synth sim _ r d) = show synth <> ", " <> show sim <> ": " <> show (bimap show (T.unpack . showBS) r) <> " (" <> show d <> ")"+ show (SimResult synth sim _ r d) = show synth <> ", " <> show sim <> ": " <> show (bimap show (T.unpack . showBS) r) <> " (" <> show d <> ")" getSimResult :: SimResult -> UResult getSimResult (SimResult _ _ _ (Pass _) _) = Pass ()@@ -180,10 +182,10 @@ -- formal equivalence checker. This will either return a failure or an output -- which is most likely '()'. data SynthResult = SynthResult !SynthTool !SynthTool !UResult !NominalDiffTime- deriving (Eq)+ deriving (Eq) instance Show SynthResult where- show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")"+ show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")" getSynthResult :: SynthResult -> UResult getSynthResult (SynthResult _ _ a _) = a@@ -192,220 +194,239 @@ -- attempting to run the equivalence checks on the simulator, as that would be -- unnecessary otherwise. data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime- deriving (Eq)+ deriving (Eq) getSynthStatus :: SynthStatus -> UResult getSynthStatus (SynthStatus _ a _) = a instance Show SynthStatus where- show (SynthStatus synth r d) = "synthesis " <> show synth <> ": " <> show r <> " (" <> show d <> ")"+ show (SynthStatus synth r d) = "synthesis " <> show synth <> ": " <> show r <> " (" <> show d <> ")" -- | The complete state that will be used during fuzzing, which contains the -- results from all the operations.-data FuzzReport = FuzzReport { _fuzzDir :: !FilePath- , _synthResults :: ![SynthResult] -- ^ Results of the equivalence check.- , _simResults :: ![SimResult] -- ^ Results of the simulation.- , _synthStatus :: ![SynthStatus] -- ^ Results of the synthesis step.- , _fileLines :: {-# UNPACK #-} !Int- , _synthTime :: !NominalDiffTime- , _equivTime :: !NominalDiffTime- , _reducTime :: !NominalDiffTime- }- deriving (Eq, Show)+data FuzzReport = FuzzReport+ { _fuzzDir :: !FilePath,+ -- | Results of the equivalence check.+ _synthResults :: ![SynthResult],+ -- | Results of the simulation.+ _simResults :: ![SimResult],+ -- | Results of the synthesis step.+ _synthStatus :: ![SynthStatus],+ _fileLines :: {-# UNPACK #-} !Int,+ _synthTime :: !NominalDiffTime,+ _equivTime :: !NominalDiffTime,+ _reducTime :: !NominalDiffTime+ }+ deriving (Eq, Show) $(makeLenses ''FuzzReport) descriptionToSim :: SimDescription -> SimTool descriptionToSim (SimDescription "icarus") = defaultIcarusSim descriptionToSim s =- error $ "Could not find implementation for simulator '" <> show s <> "'"+ error $ "Could not find implementation for simulator '" <> show s <> "'" -- | Convert a description to a synthesiser. descriptionToSynth :: SynthDescription -> SynthTool descriptionToSynth (SynthDescription "yosys" bin desc out) =- YosysSynth- . Yosys (fromText <$> bin) (fromMaybe (yosysDesc defaultYosys) desc)- $ maybe (yosysOutput defaultYosys) fromText out+ YosysSynth+ . Yosys (fromText <$> bin) (fromMaybe (yosysDesc defaultYosys) desc)+ $ maybe (yosysOutput defaultYosys) fromText out descriptionToSynth (SynthDescription "vivado" bin desc out) =- VivadoSynth- . Vivado (fromText <$> bin) (fromMaybe (vivadoDesc defaultVivado) desc)- $ maybe (vivadoOutput defaultVivado) fromText out+ VivadoSynth+ . Vivado (fromText <$> bin) (fromMaybe (vivadoDesc defaultVivado) desc)+ $ maybe (vivadoOutput defaultVivado) fromText out descriptionToSynth (SynthDescription "xst" bin desc out) =- XSTSynth- . XST (fromText <$> bin) (fromMaybe (xstDesc defaultXST) desc)- $ maybe (xstOutput defaultXST) fromText out+ XSTSynth+ . XST (fromText <$> bin) (fromMaybe (xstDesc defaultXST) desc)+ $ maybe (xstOutput defaultXST) fromText out descriptionToSynth (SynthDescription "quartus" bin desc out) =- QuartusSynth- . Quartus (fromText <$> bin)- (fromMaybe (quartusDesc defaultQuartus) desc)- $ maybe (quartusOutput defaultQuartus) fromText out+ QuartusSynth+ . Quartus+ (fromText <$> bin)+ (fromMaybe (quartusDesc defaultQuartus) desc)+ $ maybe (quartusOutput defaultQuartus) fromText out descriptionToSynth (SynthDescription "quartuslight" bin desc out) =- QuartusLightSynth- . QuartusLight (fromText <$> bin)- (fromMaybe (quartusDesc defaultQuartus) desc)- $ maybe (quartusOutput defaultQuartus) fromText out+ QuartusLightSynth+ . QuartusLight+ (fromText <$> bin)+ (fromMaybe (quartusDesc defaultQuartus) desc)+ $ maybe (quartusOutput defaultQuartus) fromText out descriptionToSynth (SynthDescription "identity" _ desc out) =- IdentitySynth- . Identity (fromMaybe (identityDesc defaultIdentity) desc)- $ maybe (identityOutput defaultIdentity) fromText out+ IdentitySynth+ . Identity (fromMaybe (identityDesc defaultIdentity) desc)+ $ maybe (identityOutput defaultIdentity) fromText out descriptionToSynth s =- error $ "Could not find implementation for synthesiser '" <> show s <> "'"+ error $ "Could not find implementation for synthesiser '" <> show s <> "'" status :: Result Failed () -> Html-status (Pass _ ) = H.td ! A.class_ "is-success" $ "Passed"-status (Fail EmptyFail ) = H.td ! A.class_ "is-danger" $ "Failed"+status (Pass _) = H.td ! A.class_ "is-success" $ "Passed"+status (Fail EmptyFail) = H.td ! A.class_ "is-danger" $ "Failed" status (Fail (EquivFail _)) = H.td ! A.class_ "is-danger" $ "Equivalence failed"-status (Fail (SimFail _)) = H.td ! A.class_ "is-danger" $ "Simulation failed"-status (Fail SynthFail ) = H.td ! A.class_ "is-danger" $ "Synthesis failed"-status (Fail EquivError ) = H.td ! A.class_ "is-danger" $ "Equivalence error"-status (Fail TimeoutError) = H.td ! A.class_ "is-warning" $ "Time out"+status (Fail (SimFail _)) = H.td ! A.class_ "is-danger" $ "Simulation failed"+status (Fail SynthFail) = H.td ! A.class_ "is-danger" $ "Synthesis failed"+status (Fail EquivError) = H.td ! A.class_ "is-danger" $ "Equivalence error"+status (Fail TimeoutError) = H.td ! A.class_ "is-warning" $ "Time out" synthStatusHtml :: SynthStatus -> Html synthStatusHtml (SynthStatus synth res diff) = H.tr $ do- H.td . H.toHtml $ toText synth- status res- H.td . H.toHtml $ showT diff+ H.td . H.toHtml $ toText synth+ status res+ H.td . H.toHtml $ showT diff synthResultHtml :: SynthResult -> Html synthResultHtml (SynthResult synth1 synth2 res diff) = H.tr $ do- H.td . H.toHtml $ toText synth1- H.td . H.toHtml $ toText synth2- status res- H.td . H.toHtml $ showT diff+ H.td . H.toHtml $ toText synth1+ H.td . H.toHtml $ toText synth2+ status res+ H.td . H.toHtml $ showT diff resultHead :: Text -> Html resultHead name = H.head $ do- H.title $ "Fuzz Report - " <> H.toHtml name- H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"- H.meta ! A.charset "utf8"- H.link- ! A.rel "stylesheet"- ! A.href- "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.4/css/bulma.min.css"+ H.title $ "Fuzz Report - " <> H.toHtml name+ H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"+ H.meta ! A.charset "utf8"+ H.link+ ! A.rel "stylesheet"+ ! A.href+ "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.4/css/bulma.min.css" resultReport :: Text -> FuzzReport -> Html resultReport name (FuzzReport _ synth _ stat _ _ _ _) = H.docTypeHtml $ do- resultHead name- H.body- . (H.section ! A.class_ "section")- . (H.div ! A.class_ "container")- $ do- H.h1 ! A.class_ "title is-1" $ "Fuzz Report - " <> H.toHtml name- H.h2 ! A.class_ "title is-2" $ "Synthesis"- H.table ! A.class_ "table" $ do- H.thead- . H.toHtml- $ ( H.tr- . H.toHtml- $ [H.th "Tool", H.th "Status", H.th "Run time"]- )- H.tbody . H.toHtml $ fmap synthStatusHtml stat- H.h2 ! A.class_ "title is-2" $ "Equivalence Check"- H.table ! A.class_ "table" $ do- H.thead- . H.toHtml- $ ( H.tr- . H.toHtml- $ [ H.th "First tool"- , H.th "Second tool"- , H.th "Status"- , H.th "Run time"- ]- )- H.tbody . H.toHtml $ fmap synthResultHtml synth+ resultHead name+ H.body+ . (H.section ! A.class_ "section")+ . (H.div ! A.class_ "container")+ $ do+ H.h1 ! A.class_ "title is-1" $ "Fuzz Report - " <> H.toHtml name+ H.h2 ! A.class_ "title is-2" $ "Synthesis"+ H.table ! A.class_ "table" $ do+ H.thead+ . H.toHtml+ $ ( H.tr+ . H.toHtml+ $ [H.th "Tool", H.th "Status", H.th "Run time"]+ )+ H.tbody . H.toHtml $ fmap synthStatusHtml stat+ H.h2 ! A.class_ "title is-2" $ "Equivalence Check"+ H.table ! A.class_ "table" $ do+ H.thead+ . H.toHtml+ $ ( H.tr+ . H.toHtml+ $ [ H.th "First tool",+ H.th "Second tool",+ H.th "Status",+ H.th "Run time"+ ]+ )+ H.tbody . H.toHtml $ fmap synthResultHtml synth resultStatus :: Result a b -> Html resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed" 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)+meanVariance :: [Double] -> (Double, Double)+meanVariance l = (mean, variance)+ where+ mean = sum l / len+ variance = sum (squ . subtract mean <$> l) / (len - 1.0)+ squ x = x * x+ len = fromIntegral $ length l++fuzzStats ::+ (Real a1, Traversable t) =>+ ((a1 -> Const (Endo [a1]) a1) -> a2 -> Const (Endo [a1]) a2) ->+ t a2 ->+ (Double, Double) fuzzStats sel fr = meanVariance converted- where converted = fromList . fmap realToFrac $ fr ^.. traverse . sel+ where+ converted = fmap realToFrac $ fr ^.. traverse . sel fuzzStatus :: Text -> FuzzReport -> Html fuzzStatus name (FuzzReport dir s1 s2 s3 sz t1 t2 t3) = H.tr $ do- H.td- . ( H.a+ H.td+ . ( H.a ! A.href- ( H.textValue- $ toTextIgnore (dir <.> "html")- )- )- $ H.toHtml name- resultStatus- $ mconcat (fmap getSynthResult s1)- <> mconcat (fmap getSimResult s2)- <> mconcat (fmap getSynthStatus s3)- H.td . H.string $ show sz- H.td . H.string $ show t1- H.td . H.string $ show t2- H.td . H.string $ show t3+ ( H.textValue $+ toTextIgnore (dir <.> "html")+ )+ )+ $ H.toHtml name+ resultStatus $+ mconcat (fmap getSynthResult s1)+ <> mconcat (fmap getSimResult s2)+ <> mconcat (fmap getSynthStatus s3)+ H.td . H.string $ show sz+ H.td . H.string $ show t1+ H.td . H.string $ show t2+ H.td . H.string $ show t3 summary :: Text -> [FuzzReport] -> Html summary name fuzz = H.docTypeHtml $ do- resultHead name- H.body- . (H.section ! A.class_ "section")- . (H.div ! A.class_ "container")- $ do- H.h1 ! A.class_ "title is-1" $ "FuzzReport - " <> H.toHtml name- H.table ! A.class_ "table" $ do- H.thead . H.tr $ H.toHtml- [ H.th "Name"- , H.th "Status"- , H.th "Size (loc)"- , H.th "Synthesis time"- , H.th "Equivalence check time"- , H.th "Reduction time"- ]- H.tbody- . H.toHtml- . fmap- (\(i, r) ->- fuzzStatus ("Fuzz " <> showT (i :: Int)) r- )- $ zip [1 ..] fuzz- H.tfoot . H.toHtml $ do- H.tr $ H.toHtml- [ H.td $ H.strong "Total"- , H.td mempty- , H.td- . H.string- . show- . sum- $ fuzz- ^.. traverse- . fileLines- , sumUp synthTime- , sumUp equivTime- , sumUp reducTime- ]- H.tr $ H.toHtml- [ H.td $ H.strong "Mean"- , H.td mempty- , fst $ bimap d2I d2I $ fuzzStats fileLines fuzz- , fst $ meanVar synthTime- , fst $ meanVar equivTime- , fst $ meanVar reducTime- ]- H.tr $ H.toHtml- [ H.td $ H.strong "Variance"- , H.td mempty- , snd $ bimap d2I d2I $ fuzzStats fileLines fuzz- , snd $ meanVar synthTime- , snd $ meanVar equivTime- , snd $ meanVar reducTime- ]+ resultHead name+ H.body+ . (H.section ! A.class_ "section")+ . (H.div ! A.class_ "container")+ $ do+ H.h1 ! A.class_ "title is-1" $ "FuzzReport - " <> H.toHtml name+ H.table ! A.class_ "table" $ do+ H.thead . H.tr $+ H.toHtml+ [ H.th "Name",+ H.th "Status",+ H.th "Size (loc)",+ H.th "Synthesis time",+ H.th "Equivalence check time",+ H.th "Reduction time"+ ]+ H.tbody+ . H.toHtml+ . fmap+ ( \(i, r) ->+ fuzzStatus ("Fuzz " <> showT (i :: Int)) r+ )+ $ zip [1 ..] fuzz+ H.tfoot . H.toHtml $ do+ H.tr $+ H.toHtml+ [ H.td $ H.strong "Total",+ H.td mempty,+ H.td+ . H.string+ . show+ . sum+ $ fuzz+ ^.. traverse+ . fileLines,+ sumUp synthTime,+ sumUp equivTime,+ sumUp reducTime+ ]+ H.tr $+ H.toHtml+ [ H.td $ H.strong "Mean",+ H.td mempty,+ fst $ bimap d2I d2I $ fuzzStats fileLines fuzz,+ fst $ meanVar synthTime,+ fst $ meanVar equivTime,+ fst $ meanVar reducTime+ ]+ H.tr $+ H.toHtml+ [ H.td $ H.strong "Variance",+ H.td mempty,+ snd $ bimap d2I d2I $ fuzzStats fileLines fuzz,+ snd $ meanVar synthTime,+ snd $ meanVar equivTime,+ snd $ meanVar reducTime+ ] where sumUp s = showHtml . sum $ fuzz ^.. traverse . s meanVar s = bimap d2T d2T $ fuzzStats s fuzz showHtml = H.td . H.string . show- d2T = showHtml . (realToFrac :: Double -> NominalDiffTime)- d2I = H.td . H.string . show+ d2T = showHtml . (realToFrac :: Double -> NominalDiffTime)+ d2I = H.td . H.string . show printResultReport :: Text -> FuzzReport -> Text printResultReport t f = toStrict . renderHtml $ resultReport t f
src/Verismith/Result.hs view
@@ -1,50 +1,55 @@-{-|-Module : Verismith.Result-Description : Result monadic type.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Result monadic type. This is nearly equivalent to the transformers 'Error' type,-but to have more control this is reimplemented with the instances that are-needed in "Verismith".--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +-- |+-- Module : Verismith.Result+-- Description : Result monadic type.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Result monadic type. This is nearly equivalent to the transformers 'Error' type,+-- but to have more control this is reimplemented with the instances that are+-- needed in "Verismith". module Verismith.Result- ( Result(..)- , ResultT(..)- , justPass- , justFail- , (<?>)- , annotate- )+ ( Result (..),+ ResultT (..),+ justPass,+ justFail,+ (<?>),+ annotate,+ ) where -import Control.Monad (liftM)-import Control.Monad.Base-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Control-import Data.Bifunctor (Bifunctor (..))-import Shelly (RunFailed (..), Sh, catch_sh)-import Shelly.Lifted (MonadSh, MonadShControl, ShM,- liftSh, liftShWith, restoreSh)+import Control.Monad (liftM)+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Data.Bifunctor (Bifunctor (..))+import Shelly (RunFailed (..), Sh, catch_sh)+import Shelly.Lifted+ ( MonadSh,+ MonadShControl,+ ShM,+ liftSh,+ liftShWith,+ restoreSh,+ ) -- | Result type which is equivalent to 'Either' or 'Error'. This is -- reimplemented so that there is full control over the 'Monad' definition and -- definition of a 'Monad' transformer 'ResultT'.-data Result a b = Fail a- | Pass b- deriving (Eq, Show)+data Result a b+ = Fail a+ | Pass b+ deriving (Eq, Show) justPass :: Result a b -> Maybe b justPass (Fail _) = Nothing@@ -55,105 +60,109 @@ justFail (Fail a) = Just a instance Semigroup (Result a b) where- Pass _ <> a = a- a <> _ = a+ Pass _ <> a = a+ a <> _ = a instance (Monoid b) => Monoid (Result a b) where- mempty = Pass mempty+ mempty = Pass mempty instance Functor (Result a) where- fmap f (Pass a) = Pass $ f a- fmap _ (Fail b) = Fail b+ fmap f (Pass a) = Pass $ f a+ fmap _ (Fail b) = Fail b instance Applicative (Result a) where- pure = Pass- Fail e <*> _ = Fail e- Pass f <*> r = fmap f r+ pure = Pass+ Fail e <*> _ = Fail e+ Pass f <*> r = fmap f r instance Monad (Result a) where- Pass a >>= f = f a- Fail b >>= _ = Fail b+ Pass a >>= f = f a+ Fail b >>= _ = Fail b instance MonadBase (Result a) (Result a) where- liftBase = id+ liftBase = id instance Bifunctor Result where- bimap a _ (Fail c) = Fail $ a c- bimap _ b (Pass c) = Pass $ b c+ bimap a _ (Fail c) = Fail $ a c+ bimap _ b (Pass c) = Pass $ b c -- | The transformer for the 'Result' type. This-newtype ResultT a m b = ResultT { runResultT :: m (Result a b) }+newtype ResultT a m b = ResultT {runResultT :: m (Result a b)} -instance Functor f => Functor (ResultT a f) where- fmap f = ResultT . fmap (fmap f) . runResultT+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) => 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 (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))+ 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 (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 (MonadBase b m) => MonadBase b (ResultT a m) where+ liftBase = liftBaseDefault instance MonadTrans (ResultT e) where- lift m = ResultT $ Pass <$> m+ lift m = ResultT $ Pass <$> m instance MonadTransControl (ResultT a) where- type StT (ResultT a) b = Result a b- liftWith f = ResultT $ return <$> f runResultT- restoreT = ResultT- {-# INLINABLE liftWith #-}- {-# INLINABLE restoreT #-}+ type StT (ResultT a) b = Result a b+ liftWith f = ResultT $ return <$> f runResultT+ restoreT = ResultT+ {-# INLINEABLE liftWith #-}+ {-# INLINEABLE restoreT #-} -instance MonadBaseControl IO m => MonadBaseControl IO (ResultT a m) where- type StM (ResultT a m) b = ComposeSt (ResultT a) m b- liftBaseWith = defaultLiftBaseWith- restoreM = defaultRestoreM- {-# INLINABLE liftBaseWith #-}- {-# INLINABLE restoreM #-}+instance (MonadBaseControl IO m) => MonadBaseControl IO (ResultT a m) where+ type StM (ResultT a m) b = ComposeSt (ResultT a) m b+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+ {-# INLINEABLE liftBaseWith #-}+ {-# INLINEABLE restoreM #-} -instance (MonadShControl m)- => MonadShControl (ResultT a m) where- newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b))- liftShWith f =- ResultT $ liftM return $ liftShWith $ \runInSh -> f $ \k ->- liftM ResultTShM $ runInSh $ runResultT k- restoreSh (ResultTShM m) = ResultT . restoreSh $ m- {-# INLINE liftShWith #-}- {-# INLINE restoreSh #-}+instance+ (MonadShControl m) =>+ MonadShControl (ResultT a m)+ where+ newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b))+ liftShWith f =+ ResultT $+ liftM return $+ liftShWith $ \runInSh -> f $ \k ->+ liftM ResultTShM $ runInSh $ runResultT k+ restoreSh (ResultTShM m) = ResultT . restoreSh $ m+ {-# INLINE liftShWith #-}+ {-# INLINE restoreSh #-} infix 0 <?> (<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b m <?> b = ResultT $ do- a <- runResultT m- case a of- Pass a' -> return $ Pass a'- Fail a' -> return . Fail $ a' <> b+ a <- runResultT m+ case a of+ Pass a' -> return $ Pass a'+ Fail a' -> return . Fail $ a' <> b annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b annotate = flip (<?>)
+ src/Verismith/Shuffle.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE QuasiQuotes #-}++-- |+-- Module : Verismith.Shuffle+-- Description : Shuffle Verilog around.+-- Copyright : (c) 2021, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Shuffles the Verilog file around a bit.+module Verismith.Shuffle where++import Control.Lens hiding (Context)+import Control.Monad (replicateM)+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Containers.ListUtils (nubOrd)+import Data.List (intercalate, partition)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Hedgehog (Gen, GenT, MonadGen)+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as HogR+import Verismith.Config+import Verismith.Generate+import Verismith.Utils+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Eval+import Verismith.Verilog.Internal+import Verismith.Verilog.Mutate+import Verismith.Verilog.Quote++-- | Shuffles assign statements and always blocks in a Verilog file.+shuffleLinesModule :: (MonadGen m) => ModDecl a -> m (ModDecl a)+shuffleLinesModule m = do+ shuf' <- Hog.shuffle shuf+ return (m & modItems .~ (stat <> shuf'))+ where+ (shuf, stat) =+ partition+ ( \x -> case x of+ Always _ -> True+ ModCA _ -> True+ _ -> False+ )+ (m ^. modItems)++renameIdent :: Map.Map Text Text -> Identifier -> Identifier+renameIdent map (Identifier e) = Identifier $ Map.findWithDefault e e map++renameExpr :: Map.Map Text Text -> Expr -> Expr+renameExpr map (Id e) = Id (renameIdent map e)+renameExpr map (VecSelect e a) = VecSelect (renameIdent map e) a+renameExpr map (RangeSelect e r) = RangeSelect (renameIdent map e) r+renameExpr map (Appl e r) = Appl (renameIdent map e) r+renameExpr _ e = e++renameVariablesModule :: (MonadGen m) => ModDecl a -> m (ModDecl a)+renameVariablesModule m = do+ shuf' <- Hog.shuffle ids+ let map = Map.fromList $ zip ids shuf'+ return+ ( m+ & (modItems . traverse %~ (mutExpr (transform $ renameExpr map)))+ . (modOutPorts . traverse . portName %~ renameIdent map)+ . (modInPorts . traverse . portName %~ renameIdent map)+ . (modItems . traverse . declPort . portName %~ renameIdent map)+ . (transformOn (modItems . traverse . _Always) (stmntBA . assignReg . regId %~ renameIdent map))+ . (transformOn (modItems . traverse . _Always) (stmntNBA . assignReg . regId %~ renameIdent map))+ . (transformOn (modItems . traverse . _Initial) (stmntBA . assignReg . regId %~ renameIdent map))+ . (transformOn (modItems . traverse . _Initial) (stmntNBA . assignReg . regId %~ renameIdent map))+ . (modItems . traverse . modContAssign . contAssignNetLVal %~ renameIdent map)+ )+ where+ ids = nubOrd $ (concatMap universe $ allExprCA <> allExprStmnt) ^.. traverse . _Id . _Wrapped+ allExprCA = m ^.. modItems . traverse . modContAssign . contAssignExpr+ allExprStmnt =+ (allStat ^.. traverse . stmntCondExpr)+ <> (allStat ^.. traverse . stmntCaseExpr)+ <> (allStat ^.. traverse . forExpr)+ <> (allStat ^.. traverse . stmntBA . assignExpr)+ <> (allStat ^.. traverse . stmntNBA . assignExpr)+ allStat = concatMap universe stat+ stat =+ (m ^.. modItems . traverse . _Initial)+ <> (m ^.. modItems . traverse . _Always)++identModule :: (MonadGen m) => ModDecl a -> m (ModDecl a)+identModule = return++applyModules :: (MonadGen m) => (ModDecl a -> m (ModDecl a)) -> SourceInfo a -> m (SourceInfo a)+applyModules f s = do+ ms' <- sequence (f <$> ms)+ return (s & infoSrc . _Wrapped .~ ms')+ where+ ms = s ^. infoSrc . _Wrapped++shuffleLines, renameVariables, identityMod :: (SourceInfo a) -> Gen (SourceInfo a)+shuffleLines = applyModules shuffleLinesModule+renameVariables = applyModules renameVariablesModule+identityMod = applyModules identModule++shuffleLinesIO :: (SourceInfo a) -> IO (SourceInfo a)+shuffleLinesIO = Hog.sample . shuffleLines++renameVariablesIO :: (SourceInfo a) -> IO (SourceInfo a)+renameVariablesIO = Hog.sample . renameVariables++runShuffle :: Bool -> Bool -> SourceInfo a -> IO (SourceInfo a)+runShuffle nshuf nren sv = do+ sv' <- fopt nren renameVariablesIO sv+ fopt nshuf shuffleLinesIO sv'+ where+ fopt o f = if o then return else f++m' :: SourceInfo ()+m' =+ SourceInfo+ "m"+ [verilog|+module fir_kernel_4tap_arch_1 #(+ parameter BW = 32,+ parameter SW = 5+) (X1, X2, X3, X5, X4, S, result);+ input [BW-1:0] X1;+ input [BW-1:0] X2;+ input [BW-1:0] X3;+ input [BW-1:0] X5;+ input [BW-1:0] X4;+ input [SW-1:0] S;+ output [BW-1:0] result;+ reg [SW:0] two_shift;+ wire [BW-1:0] first_sum;+ wire [BW-1:0] second_sum;++ always @* two_shift = S<<1;+ assign first_sum = X1 ? X1[2:0] : X1;+ assign second_sum = X4 + (X5 << S);+ assign result = ((first_sum >> two_shift) + second_sum) >> S;+endmodule+|]++renameExample, shuffleExample :: IO (GenVerilog (SourceInfo ()))+renameExample = GenVerilog <$> Hog.sample (renameVariables m')+shuffleExample = GenVerilog <$> Hog.sample (shuffleLines m')
src/Verismith/Tool.hs view
@@ -1,55 +1,63 @@-{-|-Module : Verismith.Tool-Description : Simulator implementations.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Simulator implementations.--}-+-- |+-- Module : Verismith.Tool+-- Description : Simulator implementations.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Simulator implementations. module Verismith.Tool- (- -- * Simulators+ ( -- * Simulators+ -- ** Icarus- Icarus(..)- , defaultIcarus+ Icarus (..),+ defaultIcarus,+ -- * Synthesisers+ -- ** Yosys- , Yosys(..)- , defaultYosys+ Yosys (..),+ defaultYosys,+ -- ** Vivado- , Vivado(..)- , defaultVivado+ Vivado (..),+ defaultVivado,+ -- ** XST- , XST(..)- , defaultXST+ XST (..),+ defaultXST,+ -- ** Quartus- , Quartus(..)- , defaultQuartus+ Quartus (..),+ defaultQuartus,+ -- ** Quartus Light- , QuartusLight(..)- , defaultQuartusLight+ QuartusLight (..),+ defaultQuartusLight,+ -- ** Identity- , Identity(..)- , defaultIdentity+ Identity (..),+ defaultIdentity,+ -- * Equivalence- , runEquiv+ runEquiv,+ -- * Simulation- , runSim+ runSim,+ -- * Synthesis- , runSynth- , logger- )+ runSynth,+ logger,+ ) where -import Verismith.Tool.Icarus-import Verismith.Tool.Identity-import Verismith.Tool.Internal-import Verismith.Tool.Quartus-import Verismith.Tool.QuartusLight-import Verismith.Tool.Vivado-import Verismith.Tool.XST-import Verismith.Tool.Yosys+import Verismith.Tool.Icarus+import Verismith.Tool.Identity+import Verismith.Tool.Internal+import Verismith.Tool.Quartus+import Verismith.Tool.QuartusLight+import Verismith.Tool.Vivado+import Verismith.Tool.XST+import Verismith.Tool.Yosys
src/Verismith/Tool/Icarus.hs view
@@ -1,62 +1,63 @@-{-|-Module : Verismith.Tool.Icarus-Description : Icarus verilog module.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Icarus verilog module.--}-+-- |+-- Module : Verismith.Tool.Icarus+-- Description : Icarus verilog module.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Icarus verilog module. module Verismith.Tool.Icarus- ( Icarus(..)- , defaultIcarus- , runSimIc- , runSimIcEC- )+ ( Icarus (..),+ defaultIcarus,+ runSimIc,+ runSimIcEMI,+ runSimIcEC,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Control.Lens-import Control.Monad (void)-import Crypto.Hash (Digest, hash)-import Crypto.Hash.Algorithms (SHA256)-import Data.Binary (encode)-import Data.Bits-import qualified Data.ByteArray as BA (convert)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Lazy (toStrict)-import qualified Data.ByteString.Lazy as L (ByteString)-import Data.Char (digitToInt)-import Data.Foldable (fold)-import Data.List (transpose)-import Data.Maybe (listToMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Numeric (readInt)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (liftSh)-import Verismith.CounterEg (CounterEg (..))-import Verismith.Result-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec-import Verismith.Verilog.CodeGen-import Verismith.Verilog.Internal-import Verismith.Verilog.Mutate+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.List.NonEmpty (NonEmpty (..), fromList)+import Data.Maybe (listToMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Numeric (readInt)+import Shelly+import Shelly.Lifted (liftSh)+import Verismith.CounterEg (CounterEg (..))+import Verismith.Result+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Internal+import Verismith.Verilog.Mutate+import Prelude hiding (FilePath) -data Icarus = Icarus { icarusPath :: FilePath- , vvpPath :: FilePath- }- deriving (Eq)+data Icarus = Icarus+ { icarusPath :: FilePath,+ vvpPath :: FilePath+ }+ deriving (Eq) instance Show Icarus where- show _ = "iverilog"+ show _ = "iverilog" instance Tool Icarus where toText _ = "iverilog"@@ -66,36 +67,40 @@ runSimWithFile = runSimIcarusWithFile instance NFData Icarus where- rnf = rwhnf+ 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+addDisplay :: [Statement ann] -> [Statement ann]+addDisplay s =+ concat $+ transpose+ [ s,+ replicate l $ TimeCtrl 1 Nothing,+ replicate l . SysTaskEnable $ Task "display" ["%b", Id "y"]+ ]+ where+ l = length s -assignFunc :: [Port] -> ByteString -> Statement+assignFunc :: [Port] -> ByteString -> Statement ann assignFunc inp bs =- NonBlockAssign- . Assign conc Nothing- . Number- . BitVec (B.length bs * 8)- $ bsToI bs- where conc = RegConcat (portToExpr <$> inp)+ NonBlockAssign+ . Assign conc Nothing+ . Number+ . BitVec (B.length bs * 8)+ $ bsToI bs+ where+ conc = RegConcat (portToExpr <$> inp) convert :: Text -> ByteString convert =- toStrict- . (encode :: Integer -> L.ByteString)- . maybe 0 fst- . listToMaybe- . readInt 2 (`elem` ("01" :: String)) digitToInt- . T.unpack+ toStrict+ . (encode :: Integer -> L.ByteString)+ . maybe 0 fst+ . listToMaybe+ . readInt 2 (`elem` ("01" :: String)) digitToInt+ . T.unpack mask :: Text -> Text mask = T.replace "x" "0"@@ -103,109 +108,209 @@ callback :: ByteString -> Text -> ByteString callback b t = b <> convert (mask t) -runSimIcarus :: Icarus -> SourceInfo -> [ByteString] -> ResultSh ByteString+runSimIcarus :: (Show ann) => Icarus -> (SourceInfo ann) -> [ByteString] -> ResultSh ByteString runSimIcarus sim rinfo bss = do- let tb = ModDecl- "main"- []- []- [ Initial- $ fold (addDisplay $ assignFunc (_modInPorts m) <$> bss)- <> (SysTaskEnable $ Task "finish" [])- ]- []- let newtb = instantiateMod m tb- let modWithTb = Verilog [newtb, m]- liftSh . writefile "main.v" $ genSource modWithTb- annotate (SimFail mempty) $ runSimWithFile sim "main.v" bss- where m = rinfo ^. mainModule+ let tb =+ ModDecl+ "main"+ []+ []+ [ Initial $+ fold (addDisplay $ assignFunc (_modInPorts m) <$> bss)+ <> (SysTaskEnable $ Task "finish" [])+ ]+ []+ let newtb = instantiateMod m tb+ let modWithTb = Verilog [newtb, m]+ liftSh . writefile "main.v" $ genSource modWithTb+ annotate (SimFail mempty) $ runSimWithFile sim "main.v" bss+ where+ m = rinfo ^. mainModule -runSimIcarusWithFile- :: Icarus -> FilePath -> [ByteString] -> ResultSh ByteString+runSimIcarusWithFile ::+ Icarus -> FilePath -> [ByteString] -> ResultSh ByteString runSimIcarusWithFile sim f _ = annotate (SimFail mempty) . liftSh $ do- dir <- pwd- logCommand_ dir "icarus"- $ run (icarusPath sim) ["-o", "main", toTextIgnore f]- B.take 8 . BA.convert . (hash :: ByteString -> Digest SHA256) <$> logCommand- dir- "vvp"- (runFoldLines (mempty :: ByteString) callback (vvpPath sim) ["main"])+ dir <- pwd+ logCommand_ dir "icarus" $+ run (icarusPath sim) ["-o", "main", toTextIgnore f]+ B.take 8 . BA.convert . (hash :: ByteString -> Digest SHA256)+ <$> logCommand+ dir+ "vvp"+ (runFoldLines (mempty :: ByteString) callback (vvpPath sim) ["main"]) fromBytes :: ByteString -> Integer fromBytes = B.foldl' f 0 where f a b = a `shiftL` 8 .|. fromIntegral b -tbModule :: [ByteString] -> ModDecl -> Verilog+tbModule :: [ByteString] -> (ModDecl ann) -> (Verilog ann) tbModule bss top =- Verilog [ instantiateMod top $ ModDecl "testbench" [] []- [ Initial- $ fold [ BlockAssign (Assign "clk" Nothing 0)- , BlockAssign (Assign inConcat Nothing 0)- ]- <> fold ((\r -> TimeCtrl 10- (Just $ BlockAssign (Assign inConcat Nothing r)))- . fromInteger . fromBytes <$> bss)- <> (TimeCtrl 10 . Just . SysTaskEnable $ Task "finish" [])- , Always . TimeCtrl 5 . Just $ BlockAssign- (Assign "clk" Nothing (UnOp UnNot (Id "clk")))- , Always . EventCtrl (EPosEdge "clk") . Just . SysTaskEnable- $ Task "strobe" ["%b", Id "y"]- ] []- ]+ Verilog+ [ instantiateMod top $+ ModDecl+ "testbench"+ []+ []+ [ Initial $+ fold+ [ BlockAssign (Assign "clk" Nothing 0),+ BlockAssign (Assign inConcat Nothing 0)+ ]+ <> fold+ ( ( \r ->+ TimeCtrl+ 10+ (Just $ BlockAssign (Assign inConcat Nothing r))+ )+ . fromInteger+ . fromBytes+ <$> bss+ )+ <> (TimeCtrl 10 . Just . SysTaskEnable $ Task "finish" []),+ Always . TimeCtrl 5 . Just $+ BlockAssign+ (Assign "clk" Nothing (UnOp UnNot (Id "clk"))),+ Always . EventCtrl (EPosEdge "clk") . Just . SysTaskEnable $+ Task "strobe" ["%b", Id "y"]+ ]+ []+ ] where inConcat = (RegConcat . filter (/= (Id "clk")) $ (Id . fromPort <$> (top ^. modInPorts))) -counterTestBench :: CounterEg -> ModDecl -> Verilog+tbModule' :: [Identifier] -> [ByteString] -> (ModDecl ann) -> (Verilog ann)+tbModule' ids bss top =+ Verilog+ [ instantiateMod top $+ ModDecl+ "testbench"+ []+ []+ [ Initial $+ fold+ [ BlockAssign (Assign "clk" Nothing 0),+ BlockAssign (Assign inConcat Nothing 0),+ if null ids then mempty else BlockAssign (Assign inIds Nothing 0)+ ]+ <> fold+ ( ( \r ->+ TimeCtrl+ 10+ (Just $ BlockAssign (Assign inConcat Nothing r))+ )+ . fromInteger+ . fromBytes+ <$> bss+ )+ <> (TimeCtrl 10 . Just . SysTaskEnable $ Task "finish" []),+ Always . TimeCtrl 5 . Just $+ BlockAssign+ (Assign "clk" Nothing (UnOp UnNot (Id "clk"))),+ Always . EventCtrl (EPosEdge "clk") . Just . SysTaskEnable $+ Task "strobe" ["%b", Concat (fromList $ fmap Id outputs)]+ ]+ []+ ]+ where+ inConcat =+ ( RegConcat+ . filter (flip notElem $ fmap Id ids)+ . filter (/= (Id "clk"))+ $ (Id . fromPort <$> (top ^. modInPorts))+ )+ inIds = RegConcat $ fmap Id ids+ outputs = top ^.. modOutPorts . traverse . portName++counterTestBench :: CounterEg -> (ModDecl ann) -> (Verilog ann) counterTestBench (CounterEg _ states) m = tbModule filtered m where filtered = convert . fold . fmap snd . filter ((/= "clk") . fst) <$> states -runSimIc' :: (Synthesiser b) => ([ByteString] -> ModDecl -> Verilog)- -> FilePath- -> Icarus- -> b- -> SourceInfo- -> [ByteString]- -> Maybe ByteString- -> ResultSh ByteString+runSimIc' ::+ (Synthesiser b, Show ann) =>+ ([ByteString] -> (ModDecl ann) -> (Verilog ann)) ->+ FilePath ->+ Icarus ->+ b ->+ (SourceInfo ann) ->+ [ByteString] ->+ Maybe ByteString ->+ ResultSh ByteString runSimIc' fun datadir sim1 synth1 srcInfo bss bs = do- dir <- liftSh pwd- let top = srcInfo ^. mainModule- let tb = fun bss top- liftSh . writefile tbname $ icarusTestbench datadir tb synth1- liftSh $ exe dir "icarus" "iverilog" ["-o", exename, toTextIgnore tbname]- s <- liftSh- $ B.take 8- . BA.convert- . (hash :: ByteString -> Digest SHA256)+ dir <- liftSh pwd+ let top = srcInfo ^. mainModule+ let tb = fun bss top+ liftSh . writefile tbname $ icarusTestbench datadir tb synth1+ liftSh $ exe dir "icarus" "iverilog" ["-o", exename, toTextIgnore tbname]+ s <-+ liftSh $+ B.take 8+ . BA.convert+ . (hash :: ByteString -> Digest SHA256) <$> logCommand- dir- "vvp"- (runFoldLines (mempty :: ByteString)- callback- (vvpPath sim1)- [exename])- case (bs, s) of- (Nothing, s') -> ResultT . return $ Pass s'- (Just bs', s') -> if bs' == s'- then ResultT . return $ Pass s'- else ResultT . return $ Fail (SimFail s')+ dir+ "vvp"+ ( runFoldLines+ (mempty :: ByteString)+ callback+ (vvpPath sim1)+ [exename]+ )+ case (bs, s) of+ (Nothing, s') -> ResultT . return $ Pass s'+ (Just bs', s') ->+ if bs' == s'+ then ResultT . return $ Pass s'+ else ResultT . return $ Fail (SimFail s') where exe dir name e = void . errExit False . logCommand dir name . timeout e tbname = fromText $ toText synth1 <> "_testbench.v" exename = toText synth1 <> "_main" -runSimIc :: (Synthesiser b)- => FilePath -- ^ Data directory.- -> Icarus -- ^ Icarus simulator.- -> b -- ^ Synthesis tool to be tested.- -> SourceInfo -- ^ Original generated program to test.- -> [ByteString] -- ^ Test vectors to be passed as inputs to the generated Verilog.- -> Maybe ByteString -- ^ What the correct output should be. If- -- 'Nothing' is passed, then just return 'Pass- -- ByteString' with the answer.- -> ResultSh ByteString+runSimIc ::+ (Synthesiser b, Show ann) =>+ -- | Data directory.+ FilePath ->+ -- | Icarus simulator.+ Icarus ->+ -- | Synthesis tool to be tested.+ b ->+ -- | Original generated program to test.+ SourceInfo ann ->+ -- | Test vectors to be passed as inputs to the generated Verilog.+ [ByteString] ->+ -- | What the correct output should be. If 'Nothing' is passed, then just return 'Pass ByteString'+ -- with the answer.+ Maybe ByteString ->+ ResultSh ByteString runSimIc = runSimIc' tbModule -runSimIcEC :: (Synthesiser b) => FilePath -> Icarus -> b- -> SourceInfo -> CounterEg -> Maybe ByteString -> ResultSh ByteString+runSimIcEMI ::+ (Synthesiser b, Show ann) =>+ -- | EMI Ids+ [Identifier] ->+ -- | Data directory.+ FilePath ->+ -- | Icarus simulator.+ Icarus ->+ -- | Synthesis tool to be tested.+ b ->+ -- | Original generated program to test.+ SourceInfo ann ->+ -- | Test vectors to be passed as inputs to the generated Verilog.+ [ByteString] ->+ -- | What the correct output should be. If 'Nothing' is passed, then just return 'Pass ByteString'+ -- with the answer.+ Maybe ByteString ->+ ResultSh ByteString+runSimIcEMI ids = runSimIc' (tbModule' ids)++runSimIcEC ::+ (Synthesiser b, Show ann) =>+ FilePath ->+ Icarus ->+ b ->+ (SourceInfo ann) ->+ CounterEg ->+ Maybe ByteString ->+ ResultSh ByteString runSimIcEC a b c d e = runSimIc' (const $ counterTestBench e) a b c d []
src/Verismith/Tool/Identity.hs view
@@ -1,50 +1,49 @@-{-|-Module : Verismith.Tool.Identity-Description : The identity simulator and synthesiser.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--The identity simulator and synthesiser.--}-+-- |+-- Module : Verismith.Tool.Identity+-- Description : The identity simulator and synthesiser.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- The identity simulator and synthesiser. module Verismith.Tool.Identity- ( Identity(..)- , defaultIdentity- )+ ( Identity (..),+ defaultIdentity,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly (FilePath)-import Shelly.Lifted (writefile)-import Verismith.Tool.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Text (Text, unpack)+import Shelly (FilePath)+import Shelly.Lifted (writefile)+import Verismith.Tool.Internal+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data Identity = Identity { identityDesc :: {-# UNPACK #-} !Text- , identityOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data Identity = Identity+ { identityDesc :: !Text,+ identityOutput :: !FilePath+ }+ deriving (Eq) instance Tool Identity where- toText (Identity d _) = d+ toText (Identity d _) = d instance Show Identity where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser Identity where- runSynth = runSynthIdentity- synthOutput = identityOutput- setSynthOutput (Identity a _) = Identity a+ runSynth = runSynthIdentity+ synthOutput = identityOutput+ setSynthOutput (Identity a _) = Identity a instance NFData Identity where- rnf = rwhnf+ rnf = rwhnf -runSynthIdentity :: Identity -> SourceInfo -> ResultSh ()+runSynthIdentity :: (Show ann) => Identity -> (SourceInfo ann) -> ResultSh () runSynthIdentity (Identity _ out) = writefile out . genSource defaultIdentity :: Identity
src/Verismith/Tool/Internal.hs view
@@ -1,113 +1,124 @@-{-|-Module : Verismith.Tool.Internal-Description : Class of the simulator.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Class of the simulator and the synthesize tool.--}- {-# LANGUAGE DeriveFunctor #-} +-- |+-- Module : Verismith.Tool.Internal+-- Description : Class of the simulator.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Class of the simulator and the synthesize tool. module Verismith.Tool.Internal- ( ResultSh- , resultSh- , Tool(..)- , Simulator(..)- , Synthesiser(..)- , Failed(..)- , renameSource- , checkPresent- , checkPresentModules- , replace- , replaceMods- , rootPath- , timeout- , timeout_- , bsToI- , noPrint- , logger- , logCommand- , logCommand_- , execute- , execute_- , (<?>)- , annotate- )+ ( ResultSh,+ resultSh,+ Tool (..),+ Simulator (..),+ Synthesiser (..),+ Failed (..),+ renameSource,+ checkPresent,+ checkPresentModules,+ replace,+ replaceMods,+ rootPath,+ timeout,+ timeout_,+ bsToI,+ noPrint,+ logger,+ logCommand,+ logCommand_,+ execute,+ execute_,+ (<?>),+ annotate,+ ) where -import Control.Lens-import Control.Monad (forM, void)-import Control.Monad.Catch (throwM)-import Data.Bits (shiftL)-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.Maybe (catMaybes)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Format (defaultTimeLocale, formatTime)-import Data.Time.LocalTime (getZonedTime)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (MonadSh, liftSh)-import System.FilePath.Posix (takeBaseName)-import Verismith.CounterEg (CounterEg)-import Verismith.Internal-import Verismith.Result-import Verismith.Verilog.AST+import Control.Lens+import Control.Monad (forM, void)+import Control.Monad.Catch (throwM)+import Data.Bits (shiftL)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.LocalTime (getZonedTime)+import Shelly+import Shelly.Lifted (MonadSh, liftSh)+import System.FilePath.Posix (takeBaseName)+import Verismith.CounterEg (CounterEg)+import Verismith.Result+import Verismith.Utils+import Verismith.Verilog.AST+import Prelude hiding (FilePath) -- | 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+class (Tool a) => Simulator a where+ runSim ::+ (Show ann) =>+ -- | Simulator instance+ a ->+ -- | Run information+ SourceInfo ann ->+ -- | Inputs to simulate+ [ByteString] ->+ -- | Returns the value of the hash at the output of the testbench.+ ResultSh ByteString+ runSimWithFile ::+ a ->+ FilePath ->+ [ByteString] ->+ ResultSh ByteString -data Failed = EmptyFail- | EquivFail (Maybe CounterEg)- | EquivError- | SimFail ByteString- | SynthFail- | TimeoutError- deriving (Eq)+data Failed+ = EmptyFail+ | EquivFail (Maybe CounterEg)+ | EquivError+ | SimFail ByteString+ | SynthFail+ | TimeoutError+ deriving (Eq) instance Show Failed where- show EmptyFail = "EmptyFail"- show (EquivFail _) = "EquivFail"- show EquivError = "EquivError"- show (SimFail bs) = "SimFail " <> T.unpack (T.take 10 $ showBS bs)- show SynthFail = "SynthFail"- show TimeoutError = "TimeoutError"+ show EmptyFail = "EmptyFail"+ show (EquivFail _) = "EquivFail"+ show EquivError = "EquivError"+ show (SimFail bs) = "SimFail " <> T.unpack (T.take 10 $ showBS bs)+ show SynthFail = "SynthFail"+ show TimeoutError = "TimeoutError" instance Semigroup Failed where- EmptyFail <> a = a- b <> _ = b+ EmptyFail <> a = a+ b <> _ = b instance Monoid Failed where- mempty = EmptyFail+ mempty = EmptyFail -- | Synthesiser type class.-class Tool a => Synthesiser a where- runSynth :: a -- ^ Synthesiser tool instance- -> SourceInfo -- ^ Run information- -> ResultSh () -- ^ does not return any values- synthOutput :: a -> FilePath- setSynthOutput :: a -> FilePath -> a+class (Tool a) => Synthesiser a where+ runSynth ::+ (Show ann) =>+ -- | Synthesiser tool instance+ a ->+ -- | Run information+ SourceInfo ann ->+ -- | does not return any values+ ResultSh ()+ synthOutput :: a -> FilePath+ setSynthOutput :: a -> FilePath -> a -renameSource :: (Synthesiser a) => a -> SourceInfo -> SourceInfo+renameSource :: (Synthesiser a) => a -> SourceInfo ann -> SourceInfo ann renameSource a src =- src & infoSrc . _Wrapped . traverse . modId . _Wrapped %~ (<> toText a)+ src & infoSrc . _Wrapped . traverse . modId . _Wrapped %~ (<> toText a) -- | Type synonym for a 'ResultT' that will be used throughout 'Verismith'. This -- has instances for 'MonadSh' and 'MonadIO' if the 'Monad' it is parametrised@@ -116,46 +127,48 @@ resultSh :: ResultSh a -> Sh a resultSh s = do- result <- runResultT s- case result of- Fail e -> throwM . RunFailed "" [] 1 $ showT e- Pass s' -> return s'+ result <- runResultT s+ case result of+ Fail e -> throwM . RunFailed "" [] 1 $ showT e+ Pass s' -> return s' checkPresent :: FilePath -> Text -> Sh (Maybe Text) checkPresent fp t = do- errExit False $ run_ "grep" [t, toTextIgnore fp]- i <- lastExitCode- if i == 0 then return $ Just t else return Nothing+ errExit False $ run_ "grep" [t, toTextIgnore fp]+ i <- lastExitCode+ if i == 0 then return $ Just t else return Nothing -- | Checks what modules are present in the synthesised output, as some modules -- may have been inlined. This could be improved if the parser worked properly.-checkPresentModules :: FilePath -> SourceInfo -> Sh [Text]+checkPresentModules :: FilePath -> SourceInfo ann -> Sh [Text] checkPresentModules fp (SourceInfo _ src) = do- vals <- forM (src ^.. _Wrapped . traverse . modId . _Wrapped)- $ checkPresent fp- return $ catMaybes vals+ vals <-+ forM (src ^.. _Wrapped . traverse . modId . _Wrapped) $+ checkPresent fp+ return $ catMaybes vals -- | Uses sed to replace a string in a text file. replace :: FilePath -> Text -> Text -> Sh () replace fp t1 t2 = do- errExit False . noPrint $ run_- "sed"- ["-i", "s/" <> t1 <> "/" <> t2 <> "/g", toTextIgnore fp]+ errExit False . noPrint $+ run_+ "sed"+ ["-i", "s/" <> t1 <> "/" <> t2 <> "/g", toTextIgnore fp] -- | This is used because rename only renames the definitions of modules of -- course, so instead this just searches and replaces all the module names. This -- should find all the instantiations and definitions. This could again be made -- much simpler if the parser works.-replaceMods :: FilePath -> Text -> SourceInfo -> Sh ()+replaceMods :: FilePath -> Text -> SourceInfo ann -> Sh () replaceMods fp t (SourceInfo _ src) =- void- . forM (src ^.. _Wrapped . traverse . modId . _Wrapped)- $ (\a -> replace fp a (a <> t))+ void+ . forM (src ^.. _Wrapped . traverse . modId . _Wrapped)+ $ (\a -> replace fp a (a <> t)) rootPath :: Sh FilePath rootPath = do- current <- pwd- maybe current fromText <$> get_env "VERISMITH_ROOT"+ current <- pwd+ maybe current fromText <$> get_env "VERISMITH_ROOT" timeout :: FilePath -> [Text] -> Sh Text timeout = command1 "timeout" ["300"] . toTextIgnore@@ -176,18 +189,20 @@ logger :: Text -> Sh () logger t = do- fn <- pwd- currentTime <- liftIO getZonedTime- echo- $ "Verismith "- <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime)- <> bname fn- <> " - "- <> t- where bname = T.pack . takeBaseName . T.unpack . toTextIgnore+ fn <- pwd+ currentTime <- liftIO getZonedTime+ echo $+ "Verismith "+ <> T.pack (formatTime defaultTimeLocale "%H:%M:%S " currentTime)+ <> bname fn+ <> " - "+ <> t+ where+ bname = T.pack . takeBaseName . T.unpack . toTextIgnore logCommand :: FilePath -> Text -> Sh a -> Sh a-logCommand fp name = log_stderr_with (l "_stderr.log")+logCommand fp name =+ log_stderr_with (l "_stderr.log") . log_stdout_with (l ".log") where l s t = appendFile (file s) (T.unpack t) >> appendFile (file s) "\n"@@ -196,29 +211,29 @@ logCommand_ :: FilePath -> Text -> Sh a -> Sh () logCommand_ fp name = void . logCommand fp name -execute- :: (MonadSh m, Monad m)- => Failed- -> FilePath- -> Text- -> FilePath- -> [Text]- -> ResultT Failed m Text+execute ::+ (MonadSh m, Monad m) =>+ Failed ->+ FilePath ->+ Text ->+ FilePath ->+ [Text] ->+ ResultT Failed m Text execute f dir name e cs = do- (res, exitCode) <- liftSh $ do- res <- errExit False . logCommand dir name $ timeout e cs- (,) res <$> lastExitCode- case exitCode of- 0 -> ResultT . return $ Pass res- 124 -> ResultT . return $ Fail TimeoutError- _ -> ResultT . return $ Fail f+ (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_ ::+ (MonadSh m, Monad m) =>+ Failed ->+ FilePath ->+ Text ->+ FilePath ->+ [Text] ->+ ResultT Failed m () execute_ a b c d = void . execute a b c d
src/Verismith/Tool/Quartus.hs view
@@ -1,76 +1,78 @@-{-|-Module : Verismith.Tool.Quartus-Description : Quartus synthesiser implementation.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Quartus synthesiser implementation.--}-+-- |+-- Module : Verismith.Tool.Quartus+-- Description : Quartus synthesiser implementation.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Quartus synthesiser implementation. module Verismith.Tool.Quartus- ( Quartus(..)- , defaultQuartus- )+ ( Quartus (..),+ defaultQuartus,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (liftSh)-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Text (Text, unpack)+import Shelly+import Shelly.Lifted (liftSh)+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data Quartus = Quartus { quartusBin :: !(Maybe FilePath)- , quartusDesc :: {-# UNPACK #-} !Text- , quartusOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data Quartus = Quartus+ { quartusBin :: !(Maybe FilePath),+ quartusDesc :: !Text,+ quartusOutput :: !FilePath+ }+ deriving (Eq) instance Tool Quartus where- toText (Quartus _ t _) = t+ toText (Quartus _ t _) = t instance Show Quartus where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser Quartus where- runSynth = runSynthQuartus- synthOutput = quartusOutput- setSynthOutput (Quartus a b _) = Quartus a b+ runSynth = runSynthQuartus+ synthOutput = quartusOutput+ setSynthOutput (Quartus a b _) = Quartus a b instance NFData Quartus where- rnf = rwhnf+ rnf = rwhnf defaultQuartus :: Quartus defaultQuartus = Quartus Nothing "quartus" "syn_quartus.v" -runSynthQuartus :: Quartus -> SourceInfo -> ResultSh ()+runSynthQuartus :: (Show ann) => Quartus -> (SourceInfo ann) -> ResultSh () runSynthQuartus sim (SourceInfo top src) = do- dir <- liftSh pwd- let ex = execute_ SynthFail dir "quartus"- liftSh $ do- writefile inpf $ genSource src- noPrint $ run_ "sed" [ "-i"- , "s/^module/(* multstyle = \"logic\" *) module/;"- , toTextIgnore inpf- ]- writefile quartusSdc $ "create_clock -period 5 -name clk [get_ports clock]"- writefile quartusTcl $ quartusSynthConfig sim quartusSdc top inpf- ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl]- liftSh $ do- cp (fromText "simulation/vcs" </> fromText top <.> "vo")- $ synthOutput sim- run_- "sed"- [ "-ri"- , "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;"- , toTextIgnore $ synthOutput sim- ]+ dir <- liftSh pwd+ let ex = execute_ SynthFail dir "quartus"+ liftSh $ do+ writefile inpf $ genSource src+ noPrint $+ run_+ "sed"+ [ "-i",+ "s/^module/(* multstyle = \"logic\" *) module/;",+ toTextIgnore inpf+ ]+ writefile quartusSdc $ "create_clock -period 5 -name clk [get_ports clock]"+ writefile quartusTcl $ quartusSynthConfig sim quartusSdc top inpf+ ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl]+ liftSh $ do+ cp (fromText "simulation/vcs" </> fromText top <.> "vo") $+ synthOutput sim+ run_+ "sed"+ [ "-ri",+ "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;",+ toTextIgnore $ synthOutput sim+ ] where inpf = "rtl.v" exec s = maybe (fromText s) (</> fromText s) $ quartusBin sim
src/Verismith/Tool/QuartusLight.hs view
@@ -1,76 +1,78 @@-{-|-Module : Verismith.Tool.QuartusLight-Description : QuartusLight synthesiser implementation.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--QuartusLight synthesiser implementation.--}-+-- |+-- Module : Verismith.Tool.QuartusLight+-- Description : QuartusLight synthesiser implementation.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- QuartusLight synthesiser implementation. module Verismith.Tool.QuartusLight- ( QuartusLight(..)- , defaultQuartusLight- )+ ( QuartusLight (..),+ defaultQuartusLight,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (liftSh)-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Text (Text, unpack)+import Shelly+import Shelly.Lifted (liftSh)+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data QuartusLight = QuartusLight { quartusLightBin :: !(Maybe FilePath)- , quartusLightDesc :: {-# UNPACK #-} !Text- , quartusLightOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data QuartusLight = QuartusLight+ { quartusLightBin :: !(Maybe FilePath),+ quartusLightDesc :: !Text,+ quartusLightOutput :: !FilePath+ }+ deriving (Eq) instance Tool QuartusLight where- toText (QuartusLight _ t _) = t+ toText (QuartusLight _ t _) = t instance Show QuartusLight where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser QuartusLight where- runSynth = runSynthQuartusLight- synthOutput = quartusLightOutput- setSynthOutput (QuartusLight a b _) = QuartusLight a b+ runSynth = runSynthQuartusLight+ synthOutput = quartusLightOutput+ setSynthOutput (QuartusLight a b _) = QuartusLight a b instance NFData QuartusLight where- rnf = rwhnf+ rnf = rwhnf defaultQuartusLight :: QuartusLight defaultQuartusLight = QuartusLight Nothing "quartus" "syn_quartus.v" -runSynthQuartusLight :: QuartusLight -> SourceInfo -> ResultSh ()+runSynthQuartusLight :: (Show ann) => QuartusLight -> (SourceInfo ann) -> ResultSh () runSynthQuartusLight sim (SourceInfo top src) = do- dir <- liftSh pwd- let ex = execute_ SynthFail dir "quartus"- liftSh $ do- writefile inpf $ genSource src- noPrint $ run_ "sed" [ "-i"- , "s/^module/(* multstyle = \"logic\" *) module/;"- , toTextIgnore inpf- ]- writefile quartusSdc "create_clock -period 5 -name clk [get_ports clock]"- writefile quartusTcl $ quartusLightSynthConfig sim quartusSdc top inpf- ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl]- liftSh $ do- cp (fromText "simulation/vcs" </> fromText top <.> "vo")- $ synthOutput sim- run_- "sed"- [ "-ri"- , "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;"- , toTextIgnore $ synthOutput sim- ]+ dir <- liftSh pwd+ let ex = execute_ SynthFail dir "quartus"+ liftSh $ do+ writefile inpf $ genSource src+ noPrint $+ run_+ "sed"+ [ "-i",+ "s/^module/(* multstyle = \"logic\" *) module/;",+ toTextIgnore inpf+ ]+ writefile quartusSdc "create_clock -period 5 -name clk [get_ports clock]"+ writefile quartusTcl $ quartusLightSynthConfig sim quartusSdc top inpf+ ex (exec "quartus_sh") ["-t", toTextIgnore quartusTcl]+ liftSh $ do+ cp (fromText "simulation/vcs" </> fromText top <.> "vo") $+ synthOutput sim+ run_+ "sed"+ [ "-ri",+ "s,^// DATE.*,,; s,^tri1 (.*);,wire \\1 = 1;,; /^\\/\\/ +synopsys/ d;",+ toTextIgnore $ synthOutput sim+ ] where inpf = "rtl.v" exec s = maybe (fromText s) (</> fromText s) $ quartusLightBin sim
src/Verismith/Tool/Template.hs view
@@ -1,184 +1,193 @@-{-|-Module : Verismith.Tool.Template-Description : Template file for different configuration files-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Template file for different configuration files.--}- {-# LANGUAGE QuasiQuotes #-} +-- |+-- Module : Verismith.Tool.Template+-- Description : Template file for different configuration files+-- Copyright : (c) 2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Template file for different configuration files. module Verismith.Tool.Template- ( yosysSynthConfigStd- , yosysSatConfig- , yosysSimConfig- , quartusLightSynthConfig- , quartusSynthConfig- , xstSynthConfig- , vivadoSynthConfig- , sbyConfig- , icarusTestbench- )+ ( yosysSynthConfigStd,+ yosysSatConfig,+ yosysSimConfig,+ quartusLightSynthConfig,+ quartusSynthConfig,+ xstSynthConfig,+ vivadoSynthConfig,+ sbyConfig,+ icarusTestbench,+ ) where -import Control.Lens ((^..))-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Prelude hiding (FilePath)-import Shelly-import Text.Shakespeare.Text (st)-import Verismith.Tool.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.Lens ((^..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Shelly+import Verismith.Tool.Internal+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) rename :: Text -> [Text] -> Text rename end entries =- T.intercalate "\n"- $ flip mappend end- . mappend "rename "- . doubleName- <$> entries+ T.intercalate "\n" $+ flip mappend end+ . mappend "rename "+ . doubleName+ <$> entries {-# INLINE rename #-} doubleName :: Text -> Text doubleName n = n <> " " <> n {-# INLINE doubleName #-} -outputText :: Synthesiser a => a -> Text+outputText :: (Synthesiser a) => a -> Text outputText = toTextIgnore . synthOutput -yosysSynthConfig :: Synthesiser a => Text -> a -> FilePath -> Text-yosysSynthConfig t a fp = [st|read_verilog #{toTextIgnore fp}-#{t}-write_verilog #{outputText a}-|]+yosysSynthConfig :: (Synthesiser a) => Text -> a -> FilePath -> Text+yosysSynthConfig t a fp =+ T.unlines+ [ "read_verilog " <> toTextIgnore fp,+ t,+ "write_verilog " <> outputText a+ ] -yosysSynthConfigStd :: Synthesiser a => a -> FilePath -> Text+yosysSynthConfigStd :: (Synthesiser a) => a -> FilePath -> Text yosysSynthConfigStd = yosysSynthConfig "synth" -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}-|]+yosysSatConfig :: (Synthesiser a, Synthesiser b) => a -> b -> (SourceInfo ann) -> Text+yosysSatConfig sim1 sim2 (SourceInfo top src) =+ T.unlines+ [ "read_verilog " <> outputText sim1,+ rename "_1" mis,+ "read_verilog syn_" <> outputText sim2 <> ".v",+ rename "_2" mis,+ "read_verilog " <> top <> ".v",+ "proc; opt_clean",+ "flatten " <> top,+ "sat -timeout 20 -show-all -verify-no-timeout -ignore_div_by_zero -prove y_1 y_2 " <> top+ ] where mis = src ^.. getSourceId yosysSimConfig :: Text-yosysSimConfig = [st|read_verilog rtl.v; proc;;-rename mod mod_rtl-|]--quartusLightSynthConfig :: Synthesiser a => a -> FilePath -> Text -> FilePath -> Text-quartusLightSynthConfig q sdc top fp = [st|load_package flow--project_new -overwrite #{top}--set_global_assignment -name FAMILY "Cyclone V"-set_global_assignment -name SYSTEMVERILOG_FILE #{toTextIgnore fp}-set_global_assignment -name TOP_LEVEL_ENTITY #{top}-set_global_assignment -name SDC_FILE #{toTextIgnore sdc}-set_global_assignment -name INI_VARS "qatm_force_vqm=on;"-set_global_assignment -name NUM_PARALLEL_PROCESSORS 2-set_instance_assignment -name VIRTUAL_PIN ON -to *--execute_module -tool map-execute_module -tool fit-execute_module -tool sta -args "--mode=implement"-execute_module -tool eda -args "--simulation --tool=vcs"--project_close-|]--quartusSynthConfig :: Synthesiser a => a -> FilePath -> Text -> FilePath -> Text-quartusSynthConfig q sdc top fp = [st|load_package flow--project_new -overwrite #{top}--set_global_assignment -name FAMILY "Cyclone 10 GX"-set_global_assignment -name SYSTEMVERILOG_FILE #{toTextIgnore fp}-set_global_assignment -name TOP_LEVEL_ENTITY #{top}-set_global_assignment -name SDC_FILE #{toTextIgnore sdc}-set_global_assignment -name INI_VARS "qatm_force_vqm=on;"-set_global_assignment -name NUM_PARALLEL_PROCESSORS 2-set_instance_assignment -name VIRTUAL_PIN ON -to *+yosysSimConfig = "read_verilog rtl.v; proc;;\nrename mod mod_rtl" -execute_module -tool syn-execute_module -tool eda -args "--simulation --tool=vcs"+quartusLightSynthConfig :: (Synthesiser a) => a -> FilePath -> Text -> FilePath -> Text+quartusLightSynthConfig q sdc top fp =+ T.unlines+ [ "load_package flow",+ "",+ "project_new -overwrite " <> top,+ "",+ "set_global_assignment -name FAMILY \"Cyclone V\"",+ "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp,+ "set_global_assignment -name TOP_LEVEL_ENTITY " <> top,+ "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc,+ "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"",+ "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2",+ "set_instance_assignment -name VIRTUAL_PIN ON -to *",+ "",+ "execute_module -tool map",+ "execute_module -tool fit",+ "execute_module -tool sta -args \"--mode=implement\"",+ "execute_module -tool eda -args \"--simulation --tool=vcs\"",+ "",+ "project_close"+ ] -project_close-|]+quartusSynthConfig :: (Synthesiser a) => a -> FilePath -> Text -> FilePath -> Text+quartusSynthConfig q sdc top fp =+ T.unlines+ [ "load_package flow",+ "",+ "project_new -overwrite " <> top,+ "",+ "set_global_assignment -name FAMILY \"Cyclone 10 GX\"",+ "set_global_assignment -name SYSTEMVERILOG_FILE " <> toTextIgnore fp,+ "set_global_assignment -name TOP_LEVEL_ENTITY " <> top,+ "set_global_assignment -name SDC_FILE " <> toTextIgnore sdc,+ "set_global_assignment -name INI_VARS \"qatm_force_vqm=on;\"",+ "set_global_assignment -name NUM_PARALLEL_PROCESSORS 2",+ "set_instance_assignment -name VIRTUAL_PIN ON -to *",+ "",+ "execute_module -tool syn",+ "execute_module -tool eda -args \"--simulation --tool=vcs\"",+ "",+ "project_close"+ ] 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"-|]+xstSynthConfig top =+ T.unlines+ [ "run",+ "-ifn " <> top <> ".prj -ofn " <> top <> " -p artix7 -top " <> top,+ "-iobuf NO -ram_extract NO -rom_extract NO -use_dsp48 NO",+ "-fsm_extract YES -fsm_encoding Auto",+ "-change_error_to_warning \"HDLCompiler:226 HDLCompiler:1832\""+ ] vivadoSynthConfig :: Text -> Text -> Text-vivadoSynthConfig top outf = [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}-|]--sbyConfig :: (Synthesiser a, Synthesiser b) => Maybe Text -> FilePath -> a -> b -> SourceInfo -> Text-sbyConfig mt datadir sim1 sim2 (SourceInfo top _) = [st|[options]-multiclock on-mode prove-aigsmt #{fromMaybe "none" mt}--[engines]-abc pdr--[script]-#{readL}-read -formal #{outputText sim1}-read -formal #{outputText sim2}-read -formal top.v-prep -top #{top}+vivadoSynthConfig top outf =+ T.unlines+ [ "# CRITICAL WARNING: [Synth 8-5821] Potential divide by zero",+ "set_msg_config -id {Synth 8-5821} -new_severity {WARNING}",+ "",+ "read_verilog rtl.v",+ "synth_design -part xc7k70t -top " <> top,+ "write_verilog -force " <> outf+ ] -[files]-#{depList}-#{outputText sim2}-#{outputText sim1}-top.v-|]+sbyConfig :: (Synthesiser a, Synthesiser b) => Maybe Text -> FilePath -> a -> b -> (SourceInfo ann) -> Text+sbyConfig mt datadir sim1 sim2 (SourceInfo top _) =+ T.unlines+ [ "[options]",+ "multiclock on",+ "mode prove",+ "aigsmt " <> fromMaybe "none" mt,+ "",+ "[engines]",+ "abc pdr",+ "",+ "[script]",+ readL,+ "read -formal " <> outputText sim1,+ "read -formal " <> outputText sim2,+ "read -formal top.v",+ "prep -top " <> top,+ "",+ "[files]",+ depList,+ outputText sim2,+ outputText sim1,+ "top.v"+ ] where deps = ["cells_cmos.v", "cells_cyclone_v.v", "cells_verific.v", "cells_xilinx_7.v", "cells_yosys.v"] depList =- T.intercalate "\n"- $ toTextIgnore- . (datadir </> fromText "data" </>)- . fromText- <$> deps+ T.intercalate "\n" $+ toTextIgnore+ . (datadir </> fromText "data" </>)+ . fromText+ <$> deps readL = T.intercalate "\n" $ mappend "read -formal " <$> deps -icarusTestbench :: (Synthesiser a) => 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}-|]+icarusTestbench :: (Synthesiser a, Show ann) => FilePath -> (Verilog ann) -> a -> Text+icarusTestbench datadir t synth1 =+ T.unlines+ [ "`include \"" <> ddir <> "/data/cells_cmos.v\"",+ "`include \"" <> ddir <> "/data/cells_cyclone_v.v\"",+ "`include \"" <> ddir <> "/data/cells_verific.v\"",+ "`include \"" <> ddir <> "/data/cells_xilinx_7.v\"",+ "`include \"" <> ddir <> "/data/cells_yosys.v\"",+ "`include \"" <> toTextIgnore (synthOutput synth1) <> "\"",+ "",+ genSource t+ ] where ddir = toTextIgnore datadir
src/Verismith/Tool/Vivado.hs view
@@ -1,71 +1,73 @@-{-|-Module : Verismith.Tool.Vivado-Description : Vivado Synthesiser implementation.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Vivado Synthesiser implementation.--}-+-- |+-- Module : Verismith.Tool.Vivado+-- Description : Vivado Synthesiser implementation.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Vivado Synthesiser implementation. module Verismith.Tool.Vivado- ( Vivado(..)- , defaultVivado- )+ ( Vivado (..),+ defaultVivado,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (liftSh)-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Text (Text, unpack)+import Shelly+import Shelly.Lifted (liftSh)+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data Vivado = Vivado { vivadoBin :: !(Maybe FilePath)- , vivadoDesc :: {-# UNPACK #-} !Text- , vivadoOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data Vivado = Vivado+ { vivadoBin :: !(Maybe FilePath),+ vivadoDesc :: !Text,+ vivadoOutput :: !FilePath+ }+ deriving (Eq) instance Tool Vivado where- toText (Vivado _ t _) = t+ toText (Vivado _ t _) = t instance Show Vivado where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser Vivado where- runSynth = runSynthVivado- synthOutput = vivadoOutput- setSynthOutput (Vivado a b _) = Vivado a b+ runSynth = runSynthVivado+ synthOutput = vivadoOutput+ setSynthOutput (Vivado a b _) = Vivado a b instance NFData Vivado where- rnf = rwhnf+ rnf = rwhnf defaultVivado :: Vivado defaultVivado = Vivado Nothing "vivado" "syn_vivado.v" -runSynthVivado :: Vivado -> SourceInfo -> ResultSh ()+runSynthVivado :: (Show ann) => Vivado -> (SourceInfo ann) -> ResultSh () runSynthVivado sim (SourceInfo top src) = do- dir <- liftSh pwd- liftSh $ do- writefile vivadoTcl . vivadoSynthConfig top . toTextIgnore $ synthOutput- sim- writefile "rtl.v" $ genSource src- run_- "sed"- [ "s/^module/(* use_dsp48=\"no\" *) (* use_dsp=\"no\" *) module/;"- , "-i"- , "rtl.v"- ]- let exec_ n = execute_- SynthFail- dir- "vivado"- (maybe (fromText n) (</> fromText n) $ vivadoBin sim)- exec_ "vivado" ["-mode", "batch", "-source", toTextIgnore vivadoTcl]- where vivadoTcl = fromText ("vivado_" <> top) <.> "tcl"+ dir <- liftSh pwd+ liftSh $ do+ writefile vivadoTcl . vivadoSynthConfig top . toTextIgnore $+ synthOutput+ sim+ writefile "rtl.v" $ genSource src+ run_+ "sed"+ [ "s/^module/(* use_dsp48=\"no\" *) (* use_dsp=\"no\" *) module/;",+ "-i",+ "rtl.v"+ ]+ let exec_ n =+ execute_+ SynthFail+ dir+ "vivado"+ (maybe (fromText n) (</> fromText n) $ vivadoBin sim)+ exec_ "vivado" ["-mode", "batch", "-source", toTextIgnore vivadoTcl]+ where+ vivadoTcl = fromText ("vivado_" <> top) <.> "tcl"
src/Verismith/Tool/XST.hs view
@@ -1,84 +1,84 @@-{-|-Module : Verismith.Tool.XST-Description : XST (ise) simulator implementation.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--XST (ise) simulator implementation.--}- {-# LANGUAGE QuasiQuotes #-} +-- |+-- Module : Verismith.Tool.XST+-- Description : XST (ise) simulator implementation.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- XST (ise) simulator implementation. module Verismith.Tool.XST- ( XST(..)- , defaultXST- )+ ( XST (..),+ defaultXST,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly-import Shelly.Lifted (liftSh)-import Text.Shakespeare.Text (st)-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Text (Text, unpack)+import Shelly+import Shelly.Lifted (liftSh)+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Prelude hiding (FilePath) -data XST = XST { xstBin :: !(Maybe FilePath)- , xstDesc :: {-# UNPACK #-} !Text- , xstOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data XST = XST+ { xstBin :: !(Maybe FilePath),+ xstDesc :: !Text,+ xstOutput :: !FilePath+ }+ deriving (Eq) instance Tool XST where- toText (XST _ t _) = t+ toText (XST _ t _) = t instance Show XST where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser XST where- runSynth = runSynthXST- synthOutput = xstOutput- setSynthOutput (XST a b _) = XST a b+ runSynth = runSynthXST+ synthOutput = xstOutput+ setSynthOutput (XST a b _) = XST a b instance NFData XST where- rnf = rwhnf+ rnf = rwhnf defaultXST :: XST defaultXST = XST Nothing "xst" "syn_xst.v" -runSynthXST :: XST -> SourceInfo -> ResultSh ()+runSynthXST :: (Show ann) => XST -> (SourceInfo ann) -> ResultSh () runSynthXST sim (SourceInfo top src) = do- dir <- liftSh pwd- let exec n = execute_- SynthFail- dir- "xst"- (maybe (fromText n) (</> fromText n) $ xstBin sim)- liftSh $ do- writefile xstFile $ xstSynthConfig top- writefile prjFile [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- ]+ dir <- liftSh pwd+ let exec n =+ execute_+ SynthFail+ dir+ "xst"+ (maybe (fromText n) (</> fromText n) $ xstBin sim)+ liftSh $ do+ writefile xstFile $ xstSynthConfig top+ writefile prjFile "verilog work \"rtl.v\""+ writefile "rtl.v" $ genSource src+ exec "xst" ["-ifn", toTextIgnore xstFile]+ exec+ "netgen"+ [ "-w",+ "-ofmt",+ "verilog",+ toTextIgnore $ modFile <.> "ngc",+ toTextIgnore $ synthOutput sim+ ]+ liftSh . noPrint $+ run_+ "sed"+ [ "-i",+ "/^`ifndef/,/^`endif/ d; s/ *Timestamp: .*//;",+ toTextIgnore $ synthOutput sim+ ] where modFile = fromText top xstFile = modFile <.> "xst"
src/Verismith/Tool/Yosys.hs view
@@ -1,54 +1,52 @@-{-|-Module : Verismith.Tool.Yosys-Description : Yosys simulator implementation.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Yosys simulator implementation.--}- {-# LANGUAGE QuasiQuotes #-} +-- |+-- Module : Verismith.Tool.Yosys+-- Description : Yosys simulator implementation.+-- Copyright : (c) 2018-2022, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Yosys simulator implementation. module Verismith.Tool.Yosys- ( Yosys(..)- , defaultYosys- , runEquiv- , runEquivYosys- )+ ( Yosys (..),+ defaultYosys,+ runEquiv,+ runEquivYosys,+ ) where -import Control.DeepSeq (NFData, rnf, rwhnf)-import Control.Lens-import Control.Monad (void)-import Data.Either (fromRight)-import Data.Text (Text, unpack)-import Prelude hiding (FilePath)-import Shelly (FilePath, (</>))-import qualified Shelly as S-import Shelly.Lifted (liftSh, readfile)-import Text.Shakespeare.Text (st)-import Verismith.CounterEg (parseCounterEg)-import Verismith.Result-import Verismith.Tool.Internal-import Verismith.Tool.Template-import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen-import Verismith.Verilog.Mutate+import Control.DeepSeq (NFData, rnf, rwhnf)+import Control.Lens+import Control.Monad (void)+import Data.Either (fromRight)+import Data.Text (Text, unpack)+import Shelly (FilePath, (</>))+import qualified Shelly as S+import Shelly.Lifted (liftSh, readfile)+import Verismith.CounterEg (parseCounterEg)+import Verismith.Result+import Verismith.Tool.Internal+import Verismith.Tool.Template+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Mutate+import Prelude hiding (FilePath) -data Yosys = Yosys { yosysBin :: !(Maybe FilePath)- , yosysDesc :: {-# UNPACK #-} !Text- , yosysOutput :: {-# UNPACK #-} !FilePath- }- deriving (Eq)+data Yosys = Yosys+ { yosysBin :: !(Maybe FilePath),+ yosysDesc :: !Text,+ yosysOutput :: !FilePath+ }+ deriving (Eq) instance Tool Yosys where- toText (Yosys _ t _) = t+ toText (Yosys _ t _) = t instance Show Yosys where- show t = unpack $ toText t+ show t = unpack $ toText t instance Synthesiser Yosys where runSynth = runSynthYosys@@ -56,7 +54,7 @@ setSynthOutput (Yosys a b _) = Yosys a b instance NFData Yosys where- rnf = rwhnf+ rnf = rwhnf defaultYosys :: Yosys defaultYosys = Yosys Nothing "yosys" "syn_yosys.v"@@ -64,70 +62,83 @@ yosysPath :: Yosys -> FilePath yosysPath sim = maybe (S.fromText "yosys") (</> S.fromText "yosys") $ yosysBin sim -runSynthYosys :: Yosys -> SourceInfo -> ResultSh ()+runSynthYosys :: (Show ann) => Yosys -> (SourceInfo ann) -> ResultSh () runSynthYosys sim (SourceInfo _ src) = do- dir <- liftSh $ do- dir' <- S.pwd- S.writefile inpf $ genSource src- return dir'- execute_- SynthFail- dir- "yosys"- (yosysPath sim)- [ "-p"- , "read_verilog " <> inp <> "; synth; write_verilog -noattr " <> out- ]+ dir <- liftSh $ do+ dir' <- S.pwd+ S.writefile inpf $ genSource src+ return dir'+ execute_+ SynthFail+ dir+ "yosys"+ (yosysPath sim)+ [ "-p",+ "read_verilog " <> inp <> "; synth; write_verilog -noattr " <> out+ ] where inpf = "rtl.v"- inp = S.toTextIgnore inpf- out = S.toTextIgnore $ synthOutput sim+ inp = S.toTextIgnore inpf+ out = S.toTextIgnore $ synthOutput sim -runEquivYosys- :: (Synthesiser a, Synthesiser b)- => Yosys- -> a- -> b- -> SourceInfo- -> ResultSh ()+runEquivYosys ::+ (Synthesiser a, Synthesiser b, Show ann) =>+ Yosys ->+ a ->+ b ->+ (SourceInfo ann) ->+ ResultSh () runEquivYosys yosys sim1 sim2 srcInfo = do- liftSh $ do- S.writefile "top.v"- . genSource- . initMod- . makeTop 2- $ srcInfo- ^. mainModule- S.writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo- runSynth sim1 srcInfo- runSynth sim2 srcInfo- liftSh $ S.run_ (yosysPath yosys) [S.toTextIgnore checkFile]- where checkFile = S.fromText [st|test.#{toText sim1}.#{toText sim2}.ys|]+ liftSh $ do+ S.writefile "top.v"+ . genSource+ . initMod+ . makeTop False 2+ $ srcInfo+ ^. mainModule+ S.writefile checkFile $ yosysSatConfig sim1 sim2 srcInfo+ runSynth sim1 srcInfo+ runSynth sim2 srcInfo+ liftSh $ S.run_ (yosysPath yosys) [S.toTextIgnore checkFile]+ where+ checkFile = S.fromText $ "test." <> toText sim1 <> "." <> toText sim2 <> ".ys" -runEquiv- :: (Synthesiser a, Synthesiser b) => Maybe Text -> FilePath -> a -> b -> SourceInfo -> ResultSh ()+runEquiv ::+ (Synthesiser a, Synthesiser b, Show ann) =>+ Maybe Text ->+ FilePath ->+ a ->+ b ->+ (SourceInfo ann) ->+ ResultSh () runEquiv mt datadir sim1 sim2 srcInfo = do- dir <- liftSh S.pwd- liftSh $ do- S.writefile "top.v"- . genSource- . initMod- . makeTopAssert- $ srcInfo- ^. mainModule- replaceMods (synthOutput sim1) "_1" srcInfo- replaceMods (synthOutput sim2) "_2" srcInfo- S.writefile "proof.sby" $ sbyConfig mt datadir sim1 sim2 srcInfo- e <- liftSh $ do- exe dir "symbiyosys" "sby" ["-f", "proof.sby"]- S.lastExitCode- case e of- 0 -> ResultT . return $ Pass ()- 2 -> case mt of- Nothing -> ResultT . return . Fail $ EquivFail Nothing- Just _ -> ResultT $ Fail . EquivFail . Just . fromRight mempty- . parseCounterEg <$> readfile "proof/engine_0/trace.smtc"- 124 -> ResultT . return $ Fail TimeoutError- _ -> ResultT . return $ Fail EquivError+ dir <- liftSh S.pwd+ liftSh $ do+ S.writefile "top.v"+ . genSource+ . initMod+ . makeTopAssert+ $ srcInfo+ ^. mainModule+ replaceMods (synthOutput sim1) "_1" srcInfo+ replaceMods (synthOutput sim2) "_2" srcInfo+ S.writefile "proof.sby" $ sbyConfig mt datadir sim1 sim2 srcInfo+ e <- liftSh $ do+ exe dir "symbiyosys" "sby" ["-f", "proof.sby"]+ S.lastExitCode+ case e of+ 0 -> ResultT . return $ Pass ()+ 2 -> case mt of+ Nothing -> ResultT . return . Fail $ EquivFail Nothing+ Just _ ->+ ResultT $+ Fail+ . EquivFail+ . Just+ . fromRight mempty+ . parseCounterEg+ <$> readfile "proof/engine_0/trace.smtc"+ 124 -> ResultT . return $ Fail TimeoutError+ _ -> ResultT . return $ Fail EquivError where exe dir name e = void . S.errExit False . logCommand dir name . timeout e
+ src/Verismith/Utils.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Verismith+-- Description : Verismith+-- Copyright : (c) 2018-2023, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+module Verismith.Utils+ ( generateByteString,+ nonEmpty,+ foldrMap1,+ foldrMap1',+ foldrMapM1,+ mkpair,+ uncurry3,+ safe,+ showT,+ showBS,+ comma,+ commaNL,+ )+where++import Control.Applicative+import Data.ByteString (ByteString, pack)+import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import qualified Data.ByteString.Lazy as L+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import System.Random (mkStdGen, newStdGen, randoms)++-- List and nonempty list utils++nonEmpty :: b -> (NonEmpty a -> b) -> [a] -> b+nonEmpty e ne = maybe e ne . NE.nonEmpty++foldrMap1 :: (a -> b) -> (a -> b -> b) -> NonEmpty a -> b+foldrMap1 f g (h :| t) = nonEmpty (f h) (\x -> g h $ foldrMap1 f g x) t++foldrMap1' :: b -> (a -> b) -> (a -> b -> b) -> [a] -> b+foldrMap1' d f g = nonEmpty d (foldrMap1 f g)++foldrMapM1 :: (Applicative m, Monad m) => (a -> m b) -> (a -> b -> m b) -> NonEmpty a -> m b+foldrMapM1 f g (h :| t) = nonEmpty (f h) (\x -> foldrMapM1 f g x >>= g h) t++mkpair :: Applicative f => f a -> f b -> f (a, b)+mkpair = liftA2 (,)++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c++generateByteString :: (Maybe Int) -> Int -> Int -> IO [ByteString]+generateByteString mseed size n = do+ fmap pack . chunksOf size . take (size * n) . randoms+ <$> case mseed of+ Just seed' -> return $ mkStdGen seed'+ Nothing -> newStdGen+ where+ chunksOf i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i+ chunksOf i xs = repeatedly (splitAt i) xs+ repeatedly _ [] = []+ repeatedly f as = b : repeatedly f as'+ where+ (b, as') = f as++-- | 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"
src/Verismith/Verilog.hs view
@@ -1,106 +1,117 @@-{-|-Module : Verismith.Verilog-Description : Verilog implementation with random generation and mutations.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Verilog implementation with random generation and mutations.--}- {-# LANGUAGE QuasiQuotes #-} +-- |+-- Module : Verismith.Verilog+-- Description : Verilog implementation with random generation and mutations.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Verilog implementation with random generation and mutations. module Verismith.Verilog- ( SourceInfo(..)- , Verilog(..)- , parseVerilog- , GenVerilog(..)- , genSource+ ( SourceInfo (..),+ Verilog (..),+ parseVerilog,+ GenVerilog (..),+ genSource,+ -- * Primitives+ -- ** Identifier- , Identifier(..)+ Identifier (..),+ -- ** Control- , Delay(..)- , Event(..)+ Delay (..),+ Event (..),+ -- ** Operators- , BinaryOperator(..)- , UnaryOperator(..)+ BinaryOperator (..),+ UnaryOperator (..),+ -- ** Task- , Task(..)- , taskName- , taskExpr+ Task (..),+ taskName,+ taskExpr,+ -- ** Left hand side value- , LVal(..)- , regId- , regExprId- , regExpr- , regSizeId- , regSizeRange- , regConc+ LVal (..),+ regId,+ regExprId,+ regExpr,+ regSizeId,+ regSizeRange,+ regConc,+ -- ** Ports- , PortDir(..)- , PortType(..)- , Port(..)- , portType- , portSigned- , portSize- , portName+ PortDir (..),+ PortType (..),+ Port (..),+ portType,+ portSigned,+ portSize,+ portName,+ -- * Expression- , Expr(..)- , ConstExpr(..)- , constToExpr- , exprToConst- , constNum+ Expr (..),+ ConstExpr (..),+ constToExpr,+ exprToConst,+ constNum,+ -- * Assignment- , Assign(..)- , assignReg- , assignDelay- , assignExpr- , ContAssign(..)- , contAssignNetLVal- , contAssignExpr+ Assign (..),+ assignReg,+ assignDelay,+ assignExpr,+ ContAssign (..),+ contAssignNetLVal,+ contAssignExpr,+ -- * Statment- , Statement(..)- , statDelay- , statDStat- , statEvent- , statEStat- , statements- , stmntBA- , stmntNBA- , stmntTask- , stmntSysTask- , stmntCondExpr- , stmntCondTrue- , stmntCondFalse+ Statement (..),+ statDelay,+ statDStat,+ statEvent,+ statEStat,+ statements,+ stmntBA,+ stmntNBA,+ stmntTask,+ stmntSysTask,+ stmntCondExpr,+ stmntCondTrue,+ stmntCondFalse,+ -- * Module- , ModDecl(..)- , modId- , modOutPorts- , modInPorts- , modItems- , ModItem(..)- , modContAssign- , modInstId- , modInstName- , modInstConns- , traverseModItem- , declDir- , declPort- , ModConn(..)- , modConnName- , modExpr+ ModDecl (..),+ modId,+ modOutPorts,+ modInPorts,+ modItems,+ ModItem (..),+ modContAssign,+ modInstId,+ modInstName,+ modInstConns,+ traverseModItem,+ declDir,+ declPort,+ ModConn (..),+ modConnName,+ modExpr,+ -- * Useful Lenses and Traversals- , getModule- , getSourceId+ getModule,+ getSourceId,+ -- * Quote- , verilog- )+ verilog,+ ) where -import Verismith.Verilog.AST-import Verismith.Verilog.CodeGen-import Verismith.Verilog.Parser-import Verismith.Verilog.Quote+import Verismith.Verilog.AST+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Parser+import Verismith.Verilog.Quote
src/Verismith/Verilog/AST.hs view
@@ -1,620 +1,819 @@-{-|-Module : Verismith.Verilog.AST-Description : Definition of the Verilog AST types.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Poratbility : POSIX--Defines the types to build a Verilog AST.--}--{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE 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- , CaseType(..)- , CasePair(..)- , Statement(..)- , statDelay- , statDStat- , statEvent- , statEStat- , statements- , stmntBA- , stmntNBA- , stmntTask- , stmntSysTask- , stmntCondExpr- , stmntCondTrue- , stmntCondFalse- , stmntCaseType- , stmntCaseExpr- , stmntCasePair- , stmntCaseDefault- , forAssign- , forExpr- , forIncr- , forStmnt- -- * Module- , ModDecl(..)- , modId- , modOutPorts- , modInPorts- , modItems- , modParams- , ModItem(..)- , modContAssign- , modInstId- , modInstName- , modInstConns- , _Initial- , _Always- , paramDecl- , localParamDecl- , traverseModItem- , declDir- , declPort- , declVal- , ModConn(..)- , modConnName- , modExpr- -- * 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---- | Task call, which is similar to function calls.-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)---- | Type for continuous assignment.------ @--- assign x = 2'b1;--- @-data ContAssign = ContAssign { _contAssignNetLVal :: {-# UNPACK #-} !Identifier- , _contAssignExpr :: !Expr- } deriving (Eq, Show, Ord, Data, Generic, NFData)---- | Case pair which contains an expression followed by a statement which will--- get executed if the expression matches the expression in the case statement.-data CasePair = CasePair { _casePairExpr :: !Expr- , _casePairStmnt :: !Statement- } deriving (Eq, Show, Ord, Data, Generic, NFData)---- | Type of case statement, which determines how it is interpreted.-data CaseType = CaseStandard- | CaseX- | CaseZ- 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- }- | StmntCase { _stmntCaseType :: !CaseType- , _stmntCaseExpr :: !Expr- , _stmntCasePair :: ![CasePair]- , _stmntCaseDefault :: !(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---- | Top level type which contains all the source code and associated--- information.-data SourceInfo = SourceInfo { _infoTop :: {-# UNPACK #-} !Text- , _infoSrc :: !Verilog- }- deriving (Eq, Show, Ord, Data, Generic, NFData)--instance Semigroup SourceInfo where- (SourceInfo t v) <> (SourceInfo _ v2) = SourceInfo t $ v <> v2--instance Monoid SourceInfo where- mempty = SourceInfo mempty mempty--$(makeLenses ''Expr)-$(makeLenses ''ConstExpr)-$(makeLenses ''Task)-$(makeLenses ''LVal)-$(makeLenses ''PortType)-$(makeLenses ''Port)-$(makeLenses ''ModConn)-$(makeLenses ''Assign)-$(makeLenses ''ContAssign)-$(makeLenses ''Statement)-$(makeLenses ''ModItem)-$(makeLenses ''Parameter)-$(makeLenses ''LocalParam)-$(makeLenses ''ModDecl)-$(makeLenses ''SourceInfo)-$(makeWrapped ''Verilog)-$(makeWrapped ''Identifier)-$(makeWrapped ''Delay)-$(makePrisms ''ModItem)--$(makeBaseFunctor ''Event)-$(makeBaseFunctor ''Expr)-$(makeBaseFunctor ''ConstExpr)--getModule :: Traversal' Verilog ModDecl-getModule = _Wrapped . traverse-{-# INLINE getModule #-}--getSourceId :: Traversal' Verilog Text-getSourceId = getModule . modId . _Wrapped-{-# INLINE getSourceId #-}---- | 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+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Verismith.Verilog.AST+-- Description : Definition of the Verilog AST types.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Poratbility : POSIX+--+-- Defines the types to build a Verilog AST.+module Verismith.Verilog.AST+ ( -- * Top level types+ SourceInfo (..),+ infoTop,+ infoSrc,+ Verilog (..),++ -- * 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 (..),+ _Id,+ 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+ CaseType (..),+ CasePair (..),+ Statement (..),+ statDelay,+ statDStat,+ statEvent,+ statEStat,+ statements,+ stmntBA,+ stmntNBA,+ stmntTask,+ stmntSysTask,+ stmntCondExpr,+ stmntCondTrue,+ stmntCondFalse,+ stmntCaseType,+ stmntCaseExpr,+ stmntCasePair,+ stmntCaseDefault,+ forAssign,+ forExpr,+ forIncr,+ forStmnt,++ -- * Module+ ModDecl (..),+ modId,+ modOutPorts,+ modInPorts,+ modItems,+ modParams,+ _ModDeclAnn,+ _ModDecl,+ ModItem (..),+ modContAssign,+ modInstId,+ modInstName,+ modInstConns,+ _Initial,+ _Always,+ paramDecl,+ localParamDecl,+ traverseModItem,+ declDir,+ declPort,+ declVal,+ ModConn (..),+ modConnName,+ modExpr,++ -- * Useful Lenses and Traversals+ aModule,+ getModule,+ getSourceId,+ mainModule,+ Annotations (..),+ )+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 GHC.Generics (Generic)+import Verismith.Verilog.BitVec++class (Functor m) => Annotations m where+ removeAnn :: m a -> m a+ clearAnn :: m a -> m ()+ clearAnn = fmap (\_ -> ()) . removeAnn+ collectAnn :: m a -> [a]++-- | 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)++$(makeWrapped ''Identifier)++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)++$(makeWrapped ''Delay)++instance Num Delay where+ Delay a + Delay b = Delay $ a + b+ Delay a - Delay b = Delay $ a - b+ Delay a * Delay b = Delay $ a * b+ negate (Delay a) = Delay $ negate a+ abs (Delay a) = Delay $ abs a+ signum (Delay a) = Delay $ signum a+ fromInteger = Delay . fromInteger++-- | 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)++-- | 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)++$(makeLenses ''ConstExpr)++$(makeBaseFunctor ''ConstExpr)++constToExpr :: ConstExpr -> Expr+constToExpr (ConstNum a) = Number a+constToExpr (ParamId a) = Id a+constToExpr (ConstConcat a) = Concat $ fmap constToExpr a+constToExpr (ConstUnOp a b) = UnOp a $ constToExpr b+constToExpr (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++-- | 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++-- | Verilog expression, which can either be a primary expression, unary+-- expression, binary operator expression or a conditional expression.+data Expr+ = Number {-# UNPACK #-} !BitVec+ | Id {-# UNPACK #-} !Identifier+ | VecSelect {-# UNPACK #-} !Identifier !Expr+ | RangeSelect {-# UNPACK #-} !Identifier !Range+ | Concat !(NonEmpty Expr)+ | UnOp !UnaryOperator !Expr+ | BinOp !Expr !BinaryOperator !Expr+ | Cond !Expr !Expr !Expr+ | Appl !Identifier !Expr+ | Str {-# UNPACK #-} !Text+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''Expr)+$(makePrisms ''Expr)++$(makeBaseFunctor ''Expr)++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++-- | 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)++$(makeBaseFunctor ''Event)++instance Plated Event where+ plate = uniplate++-- | Task call, which is similar to function calls.+data Task = Task+ { _taskName :: {-# UNPACK #-} !Identifier,+ _taskExpr :: [Expr]+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''Task)++-- | 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)++$(makeLenses ''LVal)++instance IsString LVal where+ fromString = RegId . fromString++-- | Different port direction that are supported in Verilog.+data PortDir+ = PortIn+ | PortOut+ | PortInOut+ deriving (Eq, Show, Ord, Data, Generic, NFData)++-- | 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)++$(makeLenses ''PortType)++-- | 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 ann)' itself, which uses a list of output+-- and input ports.+data Port = Port+ { _portType :: !PortType,+ _portSigned :: !Bool,+ _portSize :: {-# UNPACK #-} !Range,+ _portName :: {-# UNPACK #-} !Identifier+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''Port)++-- | 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)++$(makeLenses ''ModConn)++data Assign = Assign+ { _assignReg :: !LVal,+ _assignDelay :: !(Maybe Delay),+ _assignExpr :: !Expr+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''Assign)++-- | Type for continuous assignment.+--+-- @+-- assign x = 2'b1;+-- @+data ContAssign = ContAssign+ { _contAssignNetLVal :: {-# UNPACK #-} !Identifier,+ _contAssignExpr :: !Expr+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''ContAssign)++-- | Case pair which contains an expression followed by a statement which will+-- get executed if the expression matches the expression in the case statement.+data CasePair a = CasePair+ { _casePairExpr :: !Expr,+ _casePairStmnt :: !(Statement a)+ }+ deriving (Eq, Show, Ord, Functor, Data, Generic, NFData)++traverseStmntCasePair ::+ (Functor f) =>+ (Statement a1 -> f (Statement a2)) ->+ CasePair a1 ->+ f (CasePair a2)+traverseStmntCasePair f (CasePair a s) = CasePair a <$> f s++-- | Type of case statement, which determines how it is interpreted.+data CaseType+ = CaseStandard+ | CaseX+ | CaseZ+ deriving (Eq, Show, Ord, Data, Generic, NFData)++-- | Statements in Verilog.+data Statement a+ = -- | Time control (@#NUM@)+ TimeCtrl+ { _statDelay :: {-# UNPACK #-} !Delay,+ _statDStat :: Maybe (Statement a)+ }+ | EventCtrl+ { _statEvent :: !Event,+ _statEStat :: Maybe (Statement a)+ }+ | -- | Sequential block (@begin ... end@)+ SeqBlock {_statements :: [Statement a]}+ | -- | blocking assignment (@=@)+ BlockAssign {_stmntBA :: !Assign}+ | -- | Non blocking assignment (@<=@)+ NonBlockAssign {_stmntNBA :: !Assign}+ | TaskEnable {_stmntTask :: !Task}+ | SysTaskEnable {_stmntSysTask :: !Task}+ | CondStmnt+ { _stmntCondExpr :: Expr,+ _stmntCondTrue :: Maybe (Statement a),+ _stmntCondFalse :: Maybe (Statement a)+ }+ | StmntCase+ { _stmntCaseType :: !CaseType,+ _stmntCaseExpr :: !Expr,+ _stmntCasePair :: ![CasePair a],+ _stmntCaseDefault :: !(Maybe (Statement a))+ }+ | -- | Loop bounds shall be statically computable for a for loop.+ ForLoop+ { _forAssign :: !Assign,+ _forExpr :: Expr,+ _forIncr :: !Assign,+ _forStmnt :: Statement a+ }+ | StmntAnn a (Statement a)+ deriving (Eq, Show, Ord, Data, Functor, Generic, NFData)++$(makeLenses ''Statement)++instance Plated (Statement a) where+ plate f (TimeCtrl d s) = TimeCtrl d <$> traverse f s+ plate f (EventCtrl d s) = EventCtrl d <$> traverse f s+ plate f (SeqBlock s) = SeqBlock <$> traverse f s+ plate f (CondStmnt e s1 s2) = CondStmnt e <$> traverse f s1 <*> traverse f s2+ plate f (StmntCase a b c d) =+ StmntCase a b+ <$> traverse (traverseStmntCasePair f) c+ <*> traverse f d+ plate f (ForLoop a b c d) = ForLoop a b c <$> f d+ plate _ a = pure a++instance Semigroup (Statement a) 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 a) where+ mempty = SeqBlock []++instance Annotations Statement where+ removeAnn (StmntAnn _ s) = removeAnn s+ removeAnn (TimeCtrl e s) = TimeCtrl e $ fmap removeAnn s+ removeAnn (EventCtrl e s) = EventCtrl e $ fmap removeAnn s+ removeAnn (SeqBlock s) = SeqBlock $ fmap removeAnn s+ removeAnn (CondStmnt c ms1 ms2) = CondStmnt c (fmap removeAnn ms1) $ fmap removeAnn ms2+ removeAnn (StmntCase ct ce cp cdef) = StmntCase ct ce (fmap removeAnn cp) $ fmap removeAnn cdef+ removeAnn (ForLoop a b c s) = ForLoop a b c $ removeAnn s+ removeAnn s = s+ collectAnn (StmntAnn _ s) = collectAnn s+ collectAnn (TimeCtrl _ s) = concatMap collectAnn s+ collectAnn (EventCtrl _ s) = concatMap collectAnn s+ collectAnn (SeqBlock s) = concatMap collectAnn s+ collectAnn (CondStmnt _ ms1 ms2) = concatMap collectAnn ms1 <> concatMap collectAnn ms2+ collectAnn (StmntCase _ _ cp cdef) = concatMap collectAnn cp <> concatMap collectAnn cdef+ collectAnn (ForLoop _ _ _ s) = collectAnn s+ collectAnn _ = []++instance Annotations CasePair where+ removeAnn (CasePair e s) = CasePair e $ removeAnn s+ collectAnn (CasePair _ s) = collectAnn s++-- | Parameter that can be assigned in blocks or modules using @parameter@.+data Parameter = Parameter+ { _paramIdent :: {-# UNPACK #-} !Identifier,+ _paramValue :: ConstExpr+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''Parameter)++-- | Local parameter that can be assigned anywhere using @localparam@. It cannot+-- be changed by initialising the module.+data LocalParam = LocalParam+ { _localParamIdent :: {-# UNPACK #-} !Identifier,+ _localParamValue :: ConstExpr+ }+ deriving (Eq, Show, Ord, Data, Generic, NFData)++$(makeLenses ''LocalParam)++-- | Module item which is the body of the module expression.+data ModItem a+ = ModCA {_modContAssign :: !ContAssign}+ | ModInst+ { _modInstId :: {-# UNPACK #-} !Identifier,+ _modInstDecl :: [ModConn],+ _modInstName :: {-# UNPACK #-} !Identifier,+ _modInstConns :: [ModConn]+ }+ | Initial !(Statement a)+ | Always !(Statement a)+ | Property+ { _moditemPropLabel :: {-# UNPACK #-} !Identifier,+ _moditemPropEvent :: !Event,+ _moditemPropBodyL :: Maybe Expr,+ _moditemPropBodyR :: Expr+ }+ | Decl+ { _declDir :: !(Maybe PortDir),+ _declPort :: !Port,+ _declVal :: Maybe ConstExpr+ }+ | ParamDecl {_paramDecl :: NonEmpty Parameter}+ | LocalParamDecl {_localParamDecl :: NonEmpty LocalParam}+ | ModItemAnn a (ModItem a)+ deriving (Eq, Show, Ord, Functor, Data, Generic, NFData)++$(makePrisms ''ModItem)++$(makeLenses ''ModItem)++instance Annotations ModItem where+ removeAnn (ModItemAnn _ mi) = removeAnn mi+ removeAnn (Initial s) = Initial $ removeAnn s+ removeAnn (Always s) = Always $ removeAnn s+ removeAnn mi = mi+ collectAnn (ModItemAnn _ mi) = collectAnn mi+ collectAnn (Initial s) = collectAnn s+ collectAnn (Always s) = collectAnn s+ collectAnn mi = []++-- | 'module' module_identifier [list_of_ports] ';' { module_item } 'end_module'+data ModDecl a+ = ModDecl+ { _modId :: {-# UNPACK #-} !Identifier,+ _modOutPorts :: ![Port],+ _modInPorts :: ![Port],+ _modItems :: ![ModItem a],+ _modParams :: ![Parameter]+ }+ | ModDeclAnn a (ModDecl a)+ deriving (Eq, Show, Ord, Functor, Data, Generic, NFData)++instance Plated (ModDecl a) where+ plate f (ModDeclAnn b m) = ModDeclAnn b <$> plate f m+ plate _ m = pure m++$(makeLenses ''ModDecl)+$(makePrisms ''ModDecl)++instance Annotations ModDecl where+ removeAnn (ModDecl i out inp mis params) = ModDecl i out inp (fmap removeAnn mis) params+ removeAnn (ModDeclAnn _ mi) = mi+ collectAnn (ModDecl _ _ _ mis _) = concatMap collectAnn mis+ collectAnn (ModDeclAnn a mi) = a : collectAnn mi++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 ann) -> f (ModItem ann)+traverseModItem f (ModCA (ContAssign a e)) = ModCA . ContAssign a <$> f e+traverseModItem f (ModInst a b c e) =+ ModInst a b c <$> sequenceA (traverseModConn f <$> e)+traverseModItem _ e = pure e++-- | The complete sourcetext for the Verilog module.+newtype Verilog a = Verilog {getVerilog :: [ModDecl a]}+ deriving (Eq, Show, Ord, Functor, Data, Generic, NFData)++$(makeWrapped ''Verilog)++instance Semigroup (Verilog a) where+ Verilog a <> Verilog b = Verilog $ a <> b++instance Monoid (Verilog a) where+ mempty = Verilog mempty++instance Annotations Verilog where+ removeAnn (Verilog v) = Verilog $ fmap removeAnn v+ collectAnn (Verilog v) = concatMap collectAnn v++-- | Top level type which contains all the source code and associated+-- information.+data SourceInfo a = SourceInfo+ { _infoTop :: {-# UNPACK #-} !Text,+ _infoSrc :: !(Verilog a)+ }+ deriving (Eq, Show, Ord, Functor, Data, Generic, NFData)++$(makeLenses ''SourceInfo)++instance Semigroup (SourceInfo a) where+ (SourceInfo t v) <> (SourceInfo _ v2) = SourceInfo t $ v <> v2++instance Monoid (SourceInfo a) where+ mempty = SourceInfo mempty mempty++instance Annotations SourceInfo where+ removeAnn (SourceInfo t v) = SourceInfo t $ removeAnn v+ collectAnn (SourceInfo t v) = collectAnn v++-- | Attributes which can be set to various nodes in the AST.+--+-- @+-- (* synthesis *)+-- @+data Attribute+ = AttrAssign Identifier ConstExpr+ | AttrName Identifier+ deriving (Eq, Show, Ord, Data, Generic, NFData)++-- | Annotations which can be added to the AST. These are supported in all the+-- nodes of the AST and a custom type can be declared for them.+data Annotation a+ = Ann a+ | AnnAttrs [Attribute]+ deriving (Eq, Show, Ord, Data, Generic, NFData)++getModule :: Traversal' (Verilog a) (ModDecl a)+getModule = _Wrapped . traverse+{-# INLINE getModule #-}++getSourceId :: Traversal' (Verilog a) 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 a) (ModDecl a)+aModule t = lens get_ set_+ where+ set_ (SourceInfo top main) v =+ SourceInfo top (main & getModule %~ update (getIdentifier t) v)+ update top v m@(ModDecl (Identifier i) _ _ _ _)+ | i == top = v+ | otherwise = m+ update top v (ModDeclAnn _ m) = update top v m+ get_ (SourceInfo _ main) =+ head . filter (f $ getIdentifier t) $ main ^.. getModule+ f top (ModDecl (Identifier i) _ _ _ _) = i == top+ f top (ModDeclAnn _ m) = f top m++-- | May need to change this to Traversal to be safe. For now it will fail when+-- the main has not been properly set with.+mainModule :: Lens' (SourceInfo a) (ModDecl a)+mainModule = lens get_ set_+ where+ set_ (SourceInfo top main) v =+ SourceInfo top (main & getModule %~ update top v)+ update top v m@(ModDecl (Identifier i) _ _ _ _)+ | i == top = v+ | otherwise = m+ update top v (ModDeclAnn _ m) = update top v m+ get_ (SourceInfo top main) = head . filter (f top) $ main ^.. getModule+ f top (ModDecl (Identifier i) _ _ _ _) = i == top+ f top (ModDeclAnn _ m) = f top m
src/Verismith/Verilog/BitVec.hs view
@@ -1,119 +1,122 @@-{-|-Module : Verismith.Verilog.BitVec-Description : Unsigned BitVec implementation.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Unsigned BitVec implementation.--}--{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} +-- |+-- Module : Verismith.Verilog.BitVec+-- Description : Unsigned BitVec implementation.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Unsigned BitVec implementation. module Verismith.Verilog.BitVec- ( BitVecF(..)- , BitVec- , bitVec- , select- )+ ( BitVecF (..),+ BitVec,+ bitVec,+ select,+ ) where -import Control.DeepSeq (NFData)-import Data.Bits-import Data.Data-import Data.Ratio-import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Data.Bits+import Data.Data+import Data.Ratio+import GHC.Generics (Generic) -- | Bit Vector that stores the bits in an arbitrary container together with the -- size.-data BitVecF a = BitVec { width :: {-# UNPACK #-} !Int- , value :: !a- }- deriving (Show, Eq, Ord, Data, Functor, Foldable, Traversable, Generic, NFData)+data BitVecF a = BitVec+ { width :: {-# UNPACK #-} !Int,+ value :: !a+ }+ deriving (Show, Eq, Ord, Data, Functor, Foldable, Traversable, Generic, NFData) -- | Specialisation of the above with Integer, so that infinitely large bit -- vectors can be stored. type BitVec = BitVecF Integer instance (Enum a) => Enum (BitVecF a) where- toEnum i = BitVec (width' $ fromIntegral i) $ toEnum i- fromEnum (BitVec _ v) = fromEnum v+ toEnum i = BitVec (width' $ fromIntegral i) $ toEnum i+ fromEnum (BitVec _ v) = fromEnum v instance (Num a, Bits a) => Num (BitVecF a) where- BitVec w1 v1 + BitVec w2 v2 = bitVec (max w1 w2) (v1 + v2)- BitVec w1 v1 - BitVec w2 v2 = bitVec (max w1 w2) (v1 - v2)- BitVec w1 v1 * BitVec w2 v2 = bitVec (max w1 w2) (v1 * v2)- abs = id- signum (BitVec _ v) = if v == 0 then bitVec 1 0 else bitVec 1 1- fromInteger i = bitVec (width' i) $ fromInteger i+ BitVec w1 v1 + BitVec w2 v2 = bitVec (max w1 w2) (v1 + v2)+ BitVec w1 v1 - BitVec w2 v2 = bitVec (max w1 w2) (v1 - v2)+ BitVec w1 v1 * BitVec w2 v2 = bitVec (max w1 w2) (v1 * v2)+ abs = id+ signum (BitVec _ v) = if v == 0 then bitVec 1 0 else bitVec 1 1+ fromInteger i = bitVec (width' i) $ fromInteger i instance (Integral a, Bits a) => Real (BitVecF a) where- toRational (BitVec _ n) = fromIntegral n % 1+ toRational (BitVec _ n) = fromIntegral n % 1 instance (Integral a, Bits a) => Integral (BitVecF a) where- quotRem (BitVec w1 v1) (BitVec w2 v2) = both (BitVec $ max w1 w2) $ quotRem v1 v2- toInteger (BitVec _ v) = toInteger v+ quotRem (BitVec w1 v1) (BitVec w2 v2) = both (BitVec $ max w1 w2) $ quotRem v1 v2+ toInteger (BitVec _ v) = toInteger v instance (Num a, Bits a) => Bits (BitVecF a) where- BitVec w1 v1 .&. BitVec w2 v2 = bitVec (max w1 w2) (v1 .&. v2)- BitVec w1 v1 .|. BitVec w2 v2 = bitVec (max w1 w2) (v1 .|. v2)- BitVec w1 v1 `xor` BitVec w2 v2 = bitVec (max w1 w2) (v1 `xor` v2)- complement (BitVec w v) = bitVec w $ complement v- shift (BitVec w v) i = bitVec w $ shift v i- rotate = rotateBitVec- bit i = fromInteger $ bit i- testBit (BitVec _ v) = testBit v- bitSize (BitVec w _) = w- bitSizeMaybe (BitVec w _) = Just w- isSigned _ = False- popCount (BitVec _ v) = popCount v+ BitVec w1 v1 .&. BitVec w2 v2 = bitVec (max w1 w2) (v1 .&. v2)+ BitVec w1 v1 .|. BitVec w2 v2 = bitVec (max w1 w2) (v1 .|. v2)+ BitVec w1 v1 `xor` BitVec w2 v2 = bitVec (max w1 w2) (v1 `xor` v2)+ complement (BitVec w v) = bitVec w $ complement v+ shift (BitVec w v) i = bitVec w $ shift v i+ rotate = rotateBitVec+ bit i = fromInteger $ bit i+ testBit (BitVec _ v) = testBit v+ bitSize (BitVec w _) = w+ bitSizeMaybe (BitVec w _) = Just w+ isSigned _ = False+ popCount (BitVec _ v) = popCount v instance (Num a, Bits a) => FiniteBits (BitVecF a) where- finiteBitSize (BitVec w _) = w+ finiteBitSize (BitVec w _) = w -instance Bits a => Semigroup (BitVecF a) where- (BitVec w1 v1) <> (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2)+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+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 ::+ (Integral a, Bits a, Integral b, Bits b) =>+ BitVecF a ->+ (BitVecF b, BitVecF b) ->+ BitVecF a select (BitVec _ v) (msb, lsb) =- bitVec (from $ msb - lsb + 1) . shiftR (fromIntegral v) $ from lsb- where from = fromIntegral . value+ bitVec (from $ msb - lsb + 1) . shiftR (fromIntegral v) $ from lsb+ where+ from = fromIntegral . value -- | Rotate bits in a 'BitVec'. rotateBitVec :: (Num a, Bits a) => BitVecF a -> Int -> BitVecF a-rotateBitVec b@(BitVec s _) n | n >= 0 = iterate rotateL1 b !! n- | otherwise = iterate rotateR1 b !! abs n+rotateBitVec b@(BitVec s _) n+ | n >= 0 = iterate rotateL1 b !! n+ | otherwise = iterate rotateR1 b !! abs n where rotateR1 n' = testBits 0 (s - 1) n' .|. shiftR n' 1 rotateL1 n' = testBits (s - 1) 0 n' .|. shiftL n' 1 testBits a b' n' = if testBit n' a then bit b' else zeroBits width' :: Integer -> Int-width' a | a == 0 = 1- | otherwise = width'' a+width' a+ | a == 0 = 1+ | otherwise = width'' a where- width'' a' | a' == 0 = 0- | a' == -1 = 1- | otherwise = 1 + width'' (shiftR a' 1)+ width'' a'+ | a' == 0 = 0+ | a' == -1 = 1+ | otherwise = 1 + width'' (shiftR a' 1) both :: (a -> b) -> (a, a) -> (b, b) both f (a, b) = (f a, f b)
src/Verismith/Verilog/CodeGen.hs view
@@ -1,36 +1,34 @@-{-|-Module : Verismith.Verilog.CodeGen-Description : Code generation for Verilog AST.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--This module generates the code from the Verilog AST defined in-"Verismith.Verilog.AST".--}- {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} +-- |+-- Module : Verismith.Verilog.CodeGen+-- Description : Code generation for Verilog AST.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- This module generates the code from the Verilog AST defined in+-- "Verismith.Verilog.AST". module Verismith.Verilog.CodeGen- ( -- * Code Generation- GenVerilog(..)- , Source(..)- , render- )+ ( -- * Code Generation+ GenVerilog (..),+ Source (..),+ render,+ ) where -import Data.Data (Data)-import Data.List.NonEmpty (NonEmpty (..), toList)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Numeric (showHex)-import Verismith.Internal hiding (comma)-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..), toList)+import Data.Text (Text)+import qualified Data.Text as T+import Prettyprinter+import Numeric (showHex)+import Verismith.Utils 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@@ -38,48 +36,50 @@ class Source a where genSource :: a -> Text --- | Map a 'Maybe Statement' to 'Text'. If it is 'Just statement', the generated+-- | Map a 'Maybe (Statement ann)' 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 :: (Show ann) => Maybe (Statement ann) -> Doc a defMap = maybe semi statement --- | Convert the 'Verilog' type to 'Text' so that it can be rendered.-verilogSrc :: Verilog -> Doc a+-- | Convert the 'Verilog ann' type to 'Text' so that it can be rendered.+verilogSrc :: (Show ann) => (Verilog ann) -> 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"+-- | Generate the 'ModDecl ann' for a module and convert it to 'Text'.+moduleDecl :: (Show ann) => ModDecl ann -> Doc a+moduleDecl (ModDecl i outP inP items ps) =+ vsep+ [ sep ["module" <+> identifier i, params ps, ports <> semi],+ indent 2 modI,+ "endmodule" ] where ports- | null outP && null inP = ""- | otherwise = parens . align . sep . punctuate comma $ modPort <$> outIn- modI = vsep $ moduleItem <$> items+ | null outP && null inP = ""+ | otherwise = parens . align . sep . punctuate comma $ modPort <$> outIn+ modI = vsep $ moduleItem <$> items outIn = outP ++ inP- params [] = ""- params (p : pps) = hcat ["#", paramList (p :| pps)]+ params [] = ""+ params (p : pps) = hcat ["#(", paramList (p :| pps), ")"]+moduleDecl (ModDeclAnn a m) = sep [hsep ["/*", pretty $ show a, "*/"], moduleDecl m] -- | Generates a parameter list. Can only be called with a 'NonEmpty' list. paramList :: NonEmpty Parameter -> Doc a-paramList ps = tupled . toList $ parameter <$> ps+paramList ps = vsep . punctuate ", " . 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+localParamList ps = vsep . punctuate ", " . toList $ localParam <$> ps -- | Generates the assignment for a 'Parameter'. parameter :: Parameter -> Doc a parameter (Parameter name val) =- hsep ["parameter", identifier name, "=", constExpr val]+ hsep ["parameter", identifier name, "=", constExpr val] -- | Generates the assignment for a 'LocalParam'. localParam :: LocalParam -> Doc a localParam (LocalParam name val) =- hsep ["localparameter", identifier name, "=", constExpr val]+ hsep ["localparameter", identifier name, "=", constExpr val] identifier :: Identifier -> Doc a identifier (Identifier i) = pretty i@@ -99,116 +99,138 @@ -- | Generate the 'Port' description. port :: Port -> Doc a port (Port tp sgn r name) =- hsep $ pType tp : addOpt sgn "signed" [range r, identifier name]+ hsep $ pType tp : addOpt sgn "signed" [range r, identifier name] range :: Range -> Doc a range (Range msb lsb) = brackets $ hcat [constExpr msb, colon, constExpr lsb] -- | Convert the 'PortDir' type to 'Text'. portDir :: PortDir -> Doc a-portDir PortIn = "input"-portDir PortOut = "output"+portDir PortIn = "input"+portDir PortOut = "output" portDir PortInOut = "inout" --- | Generate a 'ModItem'.-moduleItem :: ModItem -> Doc a-moduleItem (ModCA ca ) = contAssign ca-moduleItem (ModInst i name conn) = (<> semi) $ hsep- [ identifier i- , identifier name- , parens . hsep $ punctuate comma (mConn <$> conn)- ]-moduleItem (Initial stat ) = nest 2 $ vsep ["initial", statement stat]-moduleItem (Always stat ) = nest 2 $ vsep ["always", statement stat]-moduleItem (Decl dir p ini) = (<> semi) . hsep .- addMay (portDir <$> dir) . (port p :) $ addMay (makeIni <$> ini) []+-- | Generate a '(ModItem ann)'.+moduleItem :: (Show ann) => ModItem ann -> Doc a+moduleItem (ModCA ca) = contAssign ca+moduleItem (ModInst i param name conn) =+ (<> semi) $+ hsep+ [ identifier i,+ "#" <> (parens . hsep $ punctuate comma (mConn <$> param)),+ identifier name,+ parens . hsep $ punctuate comma (mConn <$> conn)+ ]+moduleItem (Initial stat) = nest 2 $ vsep ["initial", statement stat]+moduleItem (Always stat) = nest 2 $ vsep ["always", statement stat]+moduleItem (Decl dir p ini) =+ (<> semi)+ . hsep+ . addMay (portDir <$> dir)+ . (port p :)+ $ addMay (makeIni <$> ini) [] where- makeIni = ("=" <+>) . constExpr-moduleItem (ParamDecl p) = hcat [paramList p, semi]+ makeIni = ("=" <+>) . constExpr+moduleItem (ParamDecl p) = hcat [paramList p, semi] moduleItem (LocalParamDecl p) = hcat [localParamList p, semi]+moduleItem (ModItemAnn a mi) = sep [hsep ["/*", pretty $ show a, "*/"], moduleItem mi]+moduleItem (Property l e bl br) =+ sep+ [ hcat [identifier l, ":"],+ "assume property",+ parens $ event e,+ hcat+ [ case bl of+ Just bl' -> sep [expr bl', "|=>", expr br]+ Nothing -> expr br,+ semi+ ]+ ] mConn :: ModConn -> Doc a-mConn (ModConn c ) = expr c+mConn (ModConn c) = expr c mConn (ModConnNamed n c) = hcat [dot, identifier n, parens $ expr c] -- | Generate continuous assignment contAssign :: ContAssign -> Doc a contAssign (ContAssign val e) =- (<> semi) $ hsep ["assign", identifier val, "=", align $ expr e]+ (<> semi) $ hsep ["assign", identifier val, "=", align $ expr e] -- | Generate 'Expr' to 'Text'. expr :: Expr -> Doc a expr (BinOp eRhs bin eLhs) = parens $ hsep [expr eRhs, binaryOp bin, expr eLhs]-expr (Number b ) = showNum b-expr (Id i ) = identifier i-expr (VecSelect i e ) = hcat [identifier i, brackets $ expr e]-expr (RangeSelect i r ) = hcat [identifier i, range r]+expr (Number b) = showNum b+expr (Id i) = identifier i+expr (VecSelect i e) = hcat [identifier i, brackets $ expr e]+expr (RangeSelect i r) = hcat [identifier i, range r] expr (Concat c) = braces . nest 4 . sep . punctuate comma $ toList (expr <$> c)-expr (UnOp u e ) = parens $ hcat [unaryOp u, expr e]+expr (UnOp u e) = parens $ hcat [unaryOp u, expr e] expr (Cond l t f) =- parens . nest 4 $ sep [expr l <+> "?", hsep [expr t, colon, expr f]]+ parens . nest 4 $ sep [expr l <+> "?", hsep [expr t, colon, expr f]] expr (Appl f e) = hcat [identifier f, parens $ expr e]-expr (Str t ) = dquotes $ pretty t+expr (Str t) = dquotes $ pretty t showNum :: BitVec -> Doc a-showNum (BitVec s n) = parens- $ hcat [minus, pretty $ showT s, "'h", pretty $ T.pack (showHex (abs n) "")]+showNum (BitVec s n) =+ parens $+ hcat [minus, pretty $ showT s, "'h", pretty $ T.pack (showHex (abs n) "")] where- minus | signum n >= 0 = mempty- | otherwise = "-"+ minus+ | signum n >= 0 = mempty+ | otherwise = "-" constExpr :: ConstExpr -> Doc a constExpr (ConstNum b) = showNum b-constExpr (ParamId i) = identifier i+constExpr (ParamId i) = identifier i constExpr (ConstConcat c) =- braces . hsep . punctuate comma $ toList (constExpr <$> c)+ braces . hsep . punctuate comma $ toList (constExpr <$> c) constExpr (ConstUnOp u e) = parens $ hcat [unaryOp u, constExpr e] constExpr (ConstBinOp eRhs bin eLhs) =- parens $ hsep [constExpr eRhs, binaryOp bin, constExpr eLhs]+ parens $ hsep [constExpr eRhs, binaryOp bin, constExpr eLhs] constExpr (ConstCond l t f) =- parens $ hsep [constExpr l, "?", constExpr t, colon, constExpr f]+ parens $ hsep [constExpr l, "?", constExpr t, colon, constExpr f] constExpr (ConstStr t) = dquotes $ pretty t -- | Convert 'BinaryOperator' to 'Text'. binaryOp :: BinaryOperator -> Doc a-binaryOp BinPlus = "+"-binaryOp BinMinus = "-"-binaryOp BinTimes = "*"-binaryOp BinDiv = "/"-binaryOp BinMod = "%"-binaryOp BinEq = "=="-binaryOp BinNEq = "!="-binaryOp BinCEq = "==="-binaryOp BinCNEq = "!=="-binaryOp BinLAnd = "&&"-binaryOp BinLOr = "||"-binaryOp BinLT = "<"-binaryOp BinLEq = "<="-binaryOp BinGT = ">"-binaryOp BinGEq = ">="-binaryOp BinAnd = "&"-binaryOp BinOr = "|"-binaryOp BinXor = "^"-binaryOp BinXNor = "^~"+binaryOp BinPlus = "+"+binaryOp BinMinus = "-"+binaryOp BinTimes = "*"+binaryOp BinDiv = "/"+binaryOp BinMod = "%"+binaryOp BinEq = "=="+binaryOp BinNEq = "!="+binaryOp BinCEq = "==="+binaryOp BinCNEq = "!=="+binaryOp BinLAnd = "&&"+binaryOp BinLOr = "||"+binaryOp BinLT = "<"+binaryOp BinLEq = "<="+binaryOp BinGT = ">"+binaryOp BinGEq = ">="+binaryOp BinAnd = "&"+binaryOp BinOr = "|"+binaryOp BinXor = "^"+binaryOp BinXNor = "^~" binaryOp BinXNorInv = "~^"-binaryOp BinPower = "**"-binaryOp BinLSL = "<<"-binaryOp BinLSR = ">>"-binaryOp BinASL = "<<<"-binaryOp BinASR = ">>>"+binaryOp BinPower = "**"+binaryOp BinLSL = "<<"+binaryOp BinLSR = ">>"+binaryOp BinASL = "<<<"+binaryOp BinASR = ">>>" -- | Convert 'UnaryOperator' to 'Text'. unaryOp :: UnaryOperator -> Doc a-unaryOp UnPlus = "+"-unaryOp UnMinus = "-"-unaryOp UnLNot = "!"-unaryOp UnNot = "~"-unaryOp UnAnd = "&"-unaryOp UnNand = "~&"-unaryOp UnOr = "|"-unaryOp UnNor = "~|"-unaryOp UnXor = "^"-unaryOp UnNxor = "~^"+unaryOp UnPlus = "+"+unaryOp UnMinus = "-"+unaryOp UnLNot = "!"+unaryOp UnNot = "~"+unaryOp UnAnd = "&"+unaryOp UnNand = "~&"+unaryOp UnOr = "|"+unaryOp UnNor = "~|"+unaryOp UnXor = "^"+unaryOp UnNxor = "~^" unaryOp UnNxorInv = "^~" event :: Event -> Doc a@@ -216,13 +238,13 @@ -- | Generate verilog code for an 'Event'. eventRec :: Event -> Doc a-eventRec (EId i) = identifier i-eventRec (EExpr e) = expr e-eventRec EAll = "*"+eventRec (EId i) = identifier i+eventRec (EExpr e) = expr e+eventRec EAll = "*" eventRec (EPosEdge i) = hsep ["posedge", identifier i] eventRec (ENegEdge i) = hsep ["negedge", identifier i]-eventRec (EOr a b ) = hsep [eventRec a, "or", eventRec b]-eventRec (EComb a b ) = hsep $ punctuate comma [eventRec a, eventRec b]+eventRec (EOr a b) = hsep [eventRec a, "or", eventRec b]+eventRec (EComb a b) = hsep $ punctuate comma [eventRec a, eventRec b] -- | Generates verilog code for a 'Delay'. delay :: Delay -> Doc a@@ -230,65 +252,72 @@ -- | Generate the verilog code for an 'LVal'. lVal :: LVal -> Doc a-lVal (RegId i ) = identifier i+lVal (RegId i) = identifier i lVal (RegExpr i e) = hsep [identifier i, expr e] lVal (RegSize i r) = hsep [identifier i, range r] lVal (RegConcat e) = braces . hsep $ punctuate comma (expr <$> e) pType :: PortType -> Doc a pType Wire = "wire"-pType Reg = "reg"+pType Reg = "reg" genAssign :: Text -> Assign -> Doc a genAssign op (Assign r d e) =- hsep . (lVal r : ) . (pretty op :) $ addMay (delay <$> d) [expr e]+ hsep . (lVal r :) . (pretty op :) $ addMay (delay <$> d) [expr e] caseType :: CaseType -> Doc a caseType CaseStandard = "case" caseType CaseX = "casex" caseType CaseZ = "casez" -casePair :: CasePair -> Doc a+casePair :: (Show ann) => (CasePair ann) -> Doc a casePair (CasePair e s) =- vsep [hsep [expr e, colon], indent 2 $ statement s]+ vsep [hsep [expr e, colon], indent 2 $ statement s] -statement :: Statement -> Doc a-statement (TimeCtrl d stat) = hsep [delay d, defMap stat]+statement :: (Show ann) => Statement ann -> 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]+ vsep ["begin", indent 2 . vsep $ statement <$> s, "end"]+statement (BlockAssign a) = hcat [genAssign "=" a, semi] statement (NonBlockAssign a) = hcat [genAssign "<=" a, semi]-statement (TaskEnable t) = hcat [task t, semi]-statement (SysTaskEnable t) = hcat ["$", task t, semi]+statement (TaskEnable t) = hcat [task t, semi]+statement (SysTaskEnable t) = hcat ["$", task t, semi] statement (CondStmnt e t Nothing) =- vsep [hsep ["if", parens $ expr e], indent 2 $ defMap t]+ vsep [hsep ["if", parens $ expr e], indent 2 $ defMap t] statement (StmntCase t e ls d) =- vcat [hcat [caseType t, parens $ expr e],- vcat $ casePair <$> ls,- indent 2 $ vsep ["default:", indent 2 $ defMap d],- "endcase"]-statement (CondStmnt e t f) = vsep- [ hsep ["if", parens $ expr e]- , indent 2 $ defMap t- , "else"- , indent 2 $ defMap f+ vcat+ [ hcat [caseType t, parens $ expr e],+ vcat $ casePair <$> ls,+ indent 2 $ vsep ["default:", indent 2 $ defMap d],+ "endcase" ]-statement (ForLoop a e incr stmnt) = vsep+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+ [ "for",+ parens . hsep $+ punctuate+ semi+ [genAssign "=" a, expr e, genAssign "=" incr]+ ],+ indent 2 $ statement stmnt ]+statement (StmntAnn a s) = sep [hsep ["/*", pretty $ show a, "*/"], statement s] task :: Task -> Doc a task (Task i e)- | null e = identifier i- | otherwise = hsep- [identifier i, parens . hsep $ punctuate comma (expr <$> e)]+ | null e = identifier i+ | otherwise =+ hsep+ [identifier i, parens . hsep $ punctuate comma (expr <$> e)] -- | Render the 'Text' to 'IO'. This is equivalent to 'putStrLn'. render :: (Source a) => a -> IO ()@@ -297,58 +326,58 @@ -- Instances instance Source Identifier where- genSource = showT . identifier+ genSource = showT . identifier instance Source Task where- genSource = showT . task+ genSource = showT . task -instance Source Statement where- genSource = showT . statement+instance (Show ann) => Source (Statement ann) where+ genSource = showT . statement instance Source PortType where- genSource = showT . pType+ genSource = showT . pType instance Source ConstExpr where- genSource = showT . constExpr+ genSource = showT . constExpr instance Source LVal where- genSource = showT . lVal+ genSource = showT . lVal instance Source Delay where- genSource = showT . delay+ genSource = showT . delay instance Source Event where- genSource = showT . event+ genSource = showT . event instance Source UnaryOperator where- genSource = showT . unaryOp+ genSource = showT . unaryOp instance Source Expr where- genSource = showT . expr+ genSource = showT . expr instance Source ContAssign where- genSource = showT . contAssign+ genSource = showT . contAssign -instance Source ModItem where- genSource = showT . moduleItem+instance (Show ann) => Source (ModItem ann) where+ genSource = showT . moduleItem instance Source PortDir where- genSource = showT . portDir+ genSource = showT . portDir instance Source Port where- genSource = showT . port+ genSource = showT . port -instance Source ModDecl where- genSource = showT . moduleDecl+instance (Show ann) => Source (ModDecl ann) where+ genSource = showT . moduleDecl -instance Source Verilog where- genSource = showT . verilogSrc+instance (Show ann) => Source (Verilog ann) where+ genSource = showT . verilogSrc -instance Source SourceInfo where- genSource (SourceInfo _ src) = genSource src+instance (Show ann) => Source (SourceInfo ann) where+ genSource (SourceInfo _ src) = genSource src -newtype GenVerilog a = GenVerilog { unGenVerilog :: a }- deriving (Eq, Ord, Data)+newtype GenVerilog a = GenVerilog {unGenVerilog :: a}+ deriving (Eq, Ord, Data) instance (Source a) => Show (GenVerilog a) where- show = T.unpack . genSource . unGenVerilog+ show = T.unpack . genSource . unGenVerilog
+ src/Verismith/Verilog/Distance.hs view
@@ -0,0 +1,182 @@+-- |+-- Module : Verismith.Verilog.Distance+-- Description : Definition of the distance function for the abstract syntax tree.+-- Copyright : (c) 2020, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Poratbility : POSIX+--+-- Define the distance function for the abstract syntax tree, so that different+-- Verilog files can be compared. This allows us to define a metric on how+-- different two pieces of Verilog are. Currently, differences in expressions are+-- ignored, as these are not that interesting.+module Verismith.Verilog.Distance where++import Data.Functor.Foldable (cata)+import Data.Text (Text, unpack)+import Verismith.Verilog.AST+import Verismith.Verilog.Eval++data Pair a b = Pair a b+ deriving (Show)++instance (Eq b) => Eq (Pair a b) where+ Pair _ a == Pair _ b = a == b++instance (Ord b) => Ord (Pair a b) where+ Pair _ a <= Pair _ b = a <= b++eqDistance :: (Eq a) => a -> a -> Int+eqDistance a b = if a == b then 0 else 1+{-# INLINE eqDistance #-}++emptyDistance :: a -> a -> Int+emptyDistance _ _ = 0+{-# INLINE emptyDistance #-}++class Distance a where+ distance :: a -> a -> Int+ udistance :: a -> a -> Int+ udistance = distance+ dempty :: a -> Int+ dempty _ = 1++minimumloc :: (Distance a) => a -> [a] -> Pair Int Int+minimumloc ah [] = Pair 0 $ dempty ah+minimumloc ah b = minimum $ (\(loc, el) -> Pair loc (udistance ah el)) <$> zip [0 ..] b++removeAt :: Int -> [a] -> [a]+removeAt loc lst =+ let (a, b) = splitAt loc lst+ in if null b then a else a ++ tail b++remdist :: (Distance a) => [a] -> [a] -> Int+remdist [] a = distance [] a+remdist a [] = distance [] a+remdist (x : xs) b+ | cost <= dx = udistance xs (removeAt loc b) + cost+ | otherwise = udistance xs b + dx+ where+ Pair loc cost = minimumloc x b+ dx = dempty x++instance (Distance a) => Distance [a] where+ distance [] [] = 0+ distance [] l = sum $ dempty <$> l+ distance l [] = sum $ dempty <$> l+ distance a@(ah : at) b@(bh : bt) =+ let cost = distance ah bh+ in if cost == 0+ then distance at bt+ else+ minimum+ [ distance at b + dempty ah,+ distance bt a + dempty bh,+ distance at bt + cost+ ]++ udistance a b =+ minimum+ [ remdist a b,+ remdist b a+ ]++ dempty [] = 0+ dempty (a : b) = maximum [dempty a, dempty b]++instance (Distance a) => Distance (Maybe a) where+ distance Nothing a = dempty a+ distance a Nothing = dempty a+ distance (Just a) (Just b) = distance a b++ udistance (Just a) (Just b) = udistance a b+ udistance a b = distance a b++ dempty Nothing = 0+ dempty (Just a) = dempty a++instance Distance Char where+ distance = eqDistance++instance Distance Bool where+ distance = eqDistance++instance Distance Integer where+ distance = eqDistance++instance Distance Text where+ distance t1 t2 = distance (unpack t1) (unpack t2)++instance Distance Identifier where+ distance = eqDistance++eval :: ConstExpr -> Integer+eval c = toInteger (cata (evaluateConst []) c)++instance Distance ConstExpr where+ distance c1 c2 = distance (eval c1) $ eval c2+ udistance c1 c2 = udistance (eval c1) $ eval c2++instance Distance Parameter where+ distance _ _ = 0++instance Distance PortType where+ distance = eqDistance++instance Distance PortDir where+ distance = eqDistance++instance Distance (Statement a) where+ distance (TimeCtrl _ s1) (TimeCtrl _ s2) = distance s1 s2+ distance (EventCtrl _ s1) (EventCtrl _ s2) = distance s1 s2+ distance (SeqBlock s1) (SeqBlock s2) = distance s1 s2+ distance (CondStmnt _ st1 sf1) (CondStmnt _ st2 sf2) = distance st1 st2 + distance sf1 sf2+ distance (ForLoop _ _ _ s1) (ForLoop _ _ _ s2) = distance s1 s2+ distance (StmntAnn _ s1) s2 = distance s1 s2+ distance (BlockAssign _) (BlockAssign _) = 0+ distance (NonBlockAssign _) (NonBlockAssign _) = 0+ distance (TaskEnable _) (TaskEnable _) = 0+ distance (SysTaskEnable _) (SysTaskEnable _) = 0+ distance (StmntCase _ _ _ _) (StmntCase _ _ _ _) = 0+ distance _ _ = 1++instance Distance (ModItem a) where+ distance (ModCA _) (ModCA _) = 0+ distance (ModInst _ _ _ _) (ModInst _ _ _ _) = 0+ distance (Initial _) (Initial _) = 0+ distance (Always s1) (Always s2) = distance s1 s2+ distance (Decl _ _ _) (Decl _ _ _) = 0+ distance (ParamDecl _) (ParamDecl _) = 0+ distance (LocalParamDecl _) (LocalParamDecl _) = 0+ distance _ _ = 1++instance Distance Range where+ distance (Range a1 b1) (Range a2 b2) =+ distance a1 a2 + distance b1 b2+ udistance (Range a1 b1) (Range a2 b2) =+ udistance a1 a2 + udistance b1 b2++instance Distance Port where+ distance (Port t1 s1 r1 _) (Port t2 s2 r2 _) =+ distance t1 t2 + distance s1 s2 + distance r1 r2+ udistance (Port t1 s1 r1 _) (Port t2 s2 r2 _) =+ udistance t1 t2 + udistance s1 s2 + udistance r1 r2+ dempty (Port t1 s1 r1 _) = 1 + dempty t1 + dempty s1 + dempty r1++instance Distance (ModDecl a) where+ distance (ModDecl _ min1 mout1 mis1 mp1) (ModDecl _ min2 mout2 mis2 mp2) =+ distance min1 min2 + distance mout1 mout2 + distance mis1 mis2 + distance mp1 mp2+ udistance (ModDecl _ min1 mout1 mis1 mp1) (ModDecl _ min2 mout2 mis2 mp2) =+ udistance min1 min2 + udistance mout1 mout2 + udistance mis1 mis2 + udistance mp1 mp2+ dempty (ModDecl _ min mout mis mp) = 1 + dempty min + dempty mout + dempty mis + dempty mp++instance Distance (Verilog a) where+ distance (Verilog m1) (Verilog m2) = distance m1 m2+ udistance (Verilog m1) (Verilog m2) = udistance m1 m2+ dempty (Verilog m) = 1 + dempty m++instance Distance (SourceInfo a) where+ distance (SourceInfo _ v1) (SourceInfo _ v2) = distance v1 v2+ udistance (SourceInfo _ v1) (SourceInfo _ v2) = udistance v1 v2+ dempty (SourceInfo _ v) = 1 + dempty v
src/Verismith/Verilog/Eval.hs view
@@ -1,27 +1,25 @@-{-|-Module : Verismith.Verilog.Eval-Description : Evaluation of Verilog expressions and statements.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Evaluation of Verilog expressions and statements.--}-+-- |+-- Module : Verismith.Verilog.Eval+-- Description : Evaluation of Verilog expressions and statements.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Evaluation of Verilog expressions and statements. module Verismith.Verilog.Eval- ( evaluateConst- , resize- )+ ( evaluateConst,+ resize,+ ) where -import Data.Bits-import Data.Foldable (fold)-import Data.Functor.Foldable hiding (fold)-import Data.Maybe (listToMaybe)-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec+import Data.Bits+import Data.Foldable (fold)+import Data.Functor.Foldable hiding (fold)+import Data.Maybe (listToMaybe)+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec type Bindings = [Parameter] @@ -32,85 +30,95 @@ paramValue_ (Parameter _ v) = v applyUnary :: (Num a, FiniteBits a) => UnaryOperator -> a -> a-applyUnary UnPlus a = a+applyUnary UnPlus a = a applyUnary UnMinus a = negate a-applyUnary UnLNot a | a == 0 = 0- | otherwise = 1+applyUnary UnLNot a+ | a == 0 = 0+ | otherwise = 1 applyUnary UnNot a = complement a-applyUnary UnAnd a | finiteBitSize a == popCount a = 1- | otherwise = 0-applyUnary UnNand a | finiteBitSize a == popCount a = 0- | otherwise = 1-applyUnary UnOr a | popCount a == 0 = 0- | otherwise = 1-applyUnary UnNor a | popCount a == 0 = 1- | otherwise = 0-applyUnary UnXor a | popCount a `mod` 2 == 0 = 0- | otherwise = 1-applyUnary UnNxor a | popCount a `mod` 2 == 0 = 1- | otherwise = 0-applyUnary UnNxorInv a | popCount a `mod` 2 == 0 = 1- | otherwise = 0+applyUnary UnAnd a+ | finiteBitSize a == popCount a = 1+ | otherwise = 0+applyUnary UnNand a+ | finiteBitSize a == popCount a = 0+ | otherwise = 1+applyUnary UnOr a+ | popCount a == 0 = 0+ | otherwise = 1+applyUnary UnNor a+ | popCount a == 0 = 1+ | otherwise = 0+applyUnary UnXor a+ | popCount a `mod` 2 == 0 = 0+ | otherwise = 1+applyUnary UnNxor a+ | popCount a `mod` 2 == 0 = 1+ | otherwise = 0+applyUnary UnNxorInv a+ | popCount a `mod` 2 == 0 = 1+ | otherwise = 0 -compXor :: Bits c => c -> c -> c+compXor :: (Bits c) => c -> c -> c compXor a = complement . xor a -toIntegral :: Num p => (t1 -> t2 -> Bool) -> t1 -> t2 -> p+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 BinPlus = (+)+applyBinary BinMinus = (-)+applyBinary BinTimes = (*)+applyBinary BinDiv = quot+applyBinary BinMod = rem+applyBinary BinEq = toIntegral (==)+applyBinary BinNEq = toIntegral (/=)+applyBinary BinCEq = toIntegral (==)+applyBinary BinCNEq = toIntegral (/=)+applyBinary BinLAnd = undefined+applyBinary BinLOr = undefined+applyBinary BinLT = toIntegral (<)+applyBinary BinLEq = toIntegral (<=)+applyBinary BinGT = toIntegral (>)+applyBinary BinGEq = toIntegral (>=)+applyBinary BinAnd = (.&.)+applyBinary BinOr = (.|.)+applyBinary BinXor = xor+applyBinary BinXNor = compXor applyBinary BinXNorInv = compXor-applyBinary BinPower = undefined-applyBinary BinLSL = toInt shiftL-applyBinary BinLSR = toInt shiftR-applyBinary BinASL = toInt shiftL-applyBinary BinASR = toInt shiftR+applyBinary BinPower = undefined+applyBinary BinLSL = toInt shiftL+applyBinary BinLSR = toInt shiftR+applyBinary BinASL = toInt shiftL+applyBinary BinASR = toInt shiftR -- | Evaluates a 'ConstExpr' using a context of 'Bindings' as input. evaluateConst :: Bindings -> ConstExprF BitVec -> BitVec evaluateConst _ (ConstNumF b) = b evaluateConst p (ParamIdF i) =- cata (evaluateConst p) . maybe 0 paramValue_ . listToMaybe $ filter- ((== i) . paramIdent_)- p-evaluateConst _ (ConstConcatF c ) = fold c-evaluateConst _ (ConstUnOpF unop c ) = applyUnary unop c+ cata (evaluateConst p) . maybe 0 paramValue_ . listToMaybe $+ filter+ ((== i) . paramIdent_)+ p+evaluateConst _ (ConstConcatF c) = fold c+evaluateConst _ (ConstUnOpF unop c) = applyUnary unop c evaluateConst _ (ConstBinOpF a binop b) = applyBinary binop a b-evaluateConst _ (ConstCondF a b c) = if a > 0 then b else c-evaluateConst _ (ConstStrF _ ) = 0+evaluateConst _ (ConstCondF a b c) = if a > 0 then b else c+evaluateConst _ (ConstStrF _) = 0 -- | Apply a function to all the bitvectors. Would be fixed by having a -- 'Functor' instance for a polymorphic 'ConstExpr'. applyBitVec :: (BitVec -> BitVec) -> ConstExpr -> ConstExpr-applyBitVec f (ConstNum b ) = ConstNum $ f b-applyBitVec f (ConstConcat c ) = ConstConcat $ fmap (applyBitVec f) c+applyBitVec f (ConstNum b) = ConstNum $ f b+applyBitVec f (ConstConcat c) = ConstConcat $ fmap (applyBitVec f) c applyBitVec f (ConstUnOp unop c) = ConstUnOp unop $ applyBitVec f c applyBitVec f (ConstBinOp a binop b) =- ConstBinOp (applyBitVec f a) binop (applyBitVec f b)+ ConstBinOp (applyBitVec f a) binop (applyBitVec f b) applyBitVec f (ConstCond a b c) = ConstCond (abv a) (abv b) (abv c)- where abv = applyBitVec f+ where+ abv = applyBitVec f applyBitVec _ a = a -- | This probably could be implemented using some recursion scheme in the
src/Verismith/Verilog/Internal.hs view
@@ -1,77 +1,79 @@-{-|-Module : Verismith.Verilog.Internal-Description : Defaults and common functions.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Defaults and common functions.--}-+-- |+-- Module : Verismith.Verilog.Internal+-- Description : Defaults and common functions.+-- Copyright : (c) 2018-2019, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Defaults and common functions. module Verismith.Verilog.Internal- ( regDecl- , wireDecl- , emptyMod- , setModName- , addModPort- , addModDecl- , testBench- , addTestBench- , defaultPort- , portToExpr- , modName- , yPort- , wire- , reg- )+ ( regDecl,+ wireDecl,+ emptyMod,+ setModName,+ addModPort,+ addModDecl,+ testBench,+ addTestBench,+ defaultPort,+ portToExpr,+ modName,+ yPort,+ wire,+ reg,+ ) where -import Control.Lens-import Data.Text (Text)-import Verismith.Verilog.AST+import Control.Lens+import Data.Text (Text)+import Verismith.Verilog.AST -regDecl :: Identifier -> ModItem+regDecl :: Identifier -> (ModItem ann) regDecl i = Decl Nothing (Port Reg False (Range 1 0) i) Nothing -wireDecl :: Identifier -> ModItem+wireDecl :: Identifier -> (ModItem ann) wireDecl i = Decl Nothing (Port Wire False (Range 1 0) i) Nothing -- | Create an empty module.-emptyMod :: ModDecl+emptyMod :: (ModDecl ann) emptyMod = ModDecl "" [] [] [] [] -- | Set a module name for a module declaration.-setModName :: Text -> ModDecl -> ModDecl+setModName :: Text -> (ModDecl ann) -> (ModDecl ann) setModName str = modId .~ Identifier str -- | Add a input port to the module declaration.-addModPort :: Port -> ModDecl -> ModDecl+addModPort :: Port -> (ModDecl ann) -> (ModDecl ann) addModPort port = modInPorts %~ (:) port -addModDecl :: ModDecl -> Verilog -> Verilog+addModDecl :: (ModDecl ann) -> (Verilog ann) -> (Verilog ann) addModDecl desc = _Wrapped %~ (:) desc -testBench :: ModDecl-testBench = ModDecl+testBench :: (ModDecl ann)+testBench =+ ModDecl "main" [] []- [ regDecl "a"- , regDecl "b"- , wireDecl "c"- , ModInst "and"- "and_gate"- [ModConn $ Id "c", ModConn $ Id "a", ModConn $ Id "b"]- , Initial $ SeqBlock- [ BlockAssign . Assign (RegId "a") Nothing $ Number 1- , BlockAssign . Assign (RegId "b") Nothing $ Number 1- ]+ [ regDecl "a",+ regDecl "b",+ wireDecl "c",+ ModInst+ "and"+ []+ "and_gate"+ [ModConn $ Id "c", ModConn $ Id "a", ModConn $ Id "b"],+ Initial $+ SeqBlock+ [ BlockAssign . Assign (RegId "a") Nothing $ Number 1,+ BlockAssign . Assign (RegId "b") Nothing $ Number 1+ ] ] [] -addTestBench :: Verilog -> Verilog+addTestBench :: (Verilog ann) -> (Verilog ann) addTestBench = addModDecl testBench defaultPort :: Identifier -> Port@@ -80,7 +82,7 @@ portToExpr :: Port -> Expr portToExpr (Port _ _ _ i) = Id i -modName :: ModDecl -> Text+modName :: (ModDecl ann) -> Text modName = getIdentifier . view modId yPort :: Identifier -> Port
src/Verismith/Verilog/Lex.x view
@@ -39,7 +39,7 @@ @binaryNumber = @size? @binaryBase @binaryValue @octalNumber = @size? @octalBase @octalValue @hexNumber = @size? @hexBase @hexValue- + -- $exp = [eE] -- $sign = [\+\-] -- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber
src/Verismith/Verilog/Mutate.hs view
@@ -1,177 +1,185 @@-{-|-Module : Verismith.Verilog.Mutate-Description : Functions to mutate the Verilog AST.-Copyright : (c) 2018-2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Functions to mutate the Verilog AST from "Verismith.Verilog.AST" to generate more-random patterns, such as nesting wires instead of creating new ones.--}- {-# LANGUAGE FlexibleInstances #-} +-- |+-- Module : Verismith.Verilog.Mutate+-- Description : Functions to mutate the Verilog AST.+-- Copyright : (c) 2018-2022, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Functions to mutate the Verilog AST from "Verismith.Verilog.AST" to generate more+-- random patterns, such as nesting wires instead of creating new ones. module Verismith.Verilog.Mutate- ( Mutate(..)- , inPort- , findAssign- , idTrans- , replace- , nestId- , nestSource- , nestUpTo- , allVars- , instantiateMod- , instantiateMod_- , instantiateModSpec_- , filterChar- , initMod- , makeIdFrom- , makeTop- , makeTopAssert- , simplify- , removeId- , combineAssigns- , combineAssigns_- , declareMod- , fromPort- )+ ( Mutate (..),+ inPort,+ findAssign,+ idTrans,+ replace,+ nestId,+ nestSource,+ nestUpTo,+ allVars,+ instantiateMod,+ instantiateMod_,+ instantiateModSpec_,+ filterChar,+ initMod,+ makeIdFrom,+ makeTop,+ makeTopAssert,+ simplify,+ removeId,+ combineAssigns,+ combineAssigns_,+ declareMod,+ fromPort,+ ) where -import Control.Lens-import Data.Foldable (fold)-import Data.Maybe (catMaybes, fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T-import Verismith.Circuit.Internal-import Verismith.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec-import Verismith.Verilog.CodeGen-import Verismith.Verilog.Internal+import Control.Lens+import Data.Foldable (fold)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Verismith.Circuit.Internal+import Verismith.Utils+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec+import Verismith.Verilog.CodeGen+import Verismith.Verilog.Internal class Mutate a where- mutExpr :: (Expr -> Expr) -> a -> a+ mutExpr :: (Expr -> Expr) -> a -> a instance Mutate Identifier where- mutExpr _ = id+ mutExpr _ = id instance Mutate Delay where- mutExpr _ = id+ mutExpr _ = id instance Mutate Event where- mutExpr f (EExpr e) = EExpr $ f e- mutExpr _ a = a+ mutExpr f (EExpr e) = EExpr $ f e+ mutExpr _ a = a instance Mutate BinaryOperator where- mutExpr _ = id+ mutExpr _ = id instance Mutate UnaryOperator where- mutExpr _ = id+ mutExpr _ = id instance Mutate Expr where- mutExpr f = f+ mutExpr f = f instance Mutate ConstExpr where- mutExpr _ = id+ mutExpr _ = id instance Mutate Task where- mutExpr f (Task i e) = Task i $ fmap f e+ mutExpr f (Task i e) = Task i $ fmap f e instance Mutate LVal where- mutExpr f (RegExpr a e) = RegExpr a $ f e- mutExpr _ a = a+ mutExpr f (RegExpr a e) = RegExpr a $ f e+ mutExpr _ a = a instance Mutate PortDir where- mutExpr _ = id+ mutExpr _ = id instance Mutate PortType where- mutExpr _ = id+ mutExpr _ = id instance Mutate Range where- mutExpr _ = id+ mutExpr _ = id instance Mutate Port where- mutExpr _ = id+ mutExpr _ = id instance Mutate ModConn where- mutExpr f (ModConn e) = ModConn $ f e- mutExpr f (ModConnNamed a e) = ModConnNamed a $ f e+ mutExpr f (ModConn e) = ModConn $ f e+ mutExpr f (ModConnNamed a e) = ModConnNamed a $ f e instance Mutate Assign where- mutExpr f (Assign a b c) = Assign a b $ f c+ mutExpr f (Assign a b c) = Assign a b $ f c instance Mutate ContAssign where- mutExpr f (ContAssign a e) = ContAssign a $ f e+ mutExpr f (ContAssign a e) = ContAssign a $ f e -instance Mutate 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 a1 e a2 $ mutExpr f s+instance Mutate (CasePair ann) where+ mutExpr f (CasePair e s) = CasePair (f e) $ mutExpr f s +instance Mutate (Statement ann) where+ mutExpr f (TimeCtrl d s) = TimeCtrl d $ mutExpr f <$> s+ mutExpr f (EventCtrl e s) = EventCtrl e $ mutExpr f <$> s+ mutExpr f (SeqBlock s) = SeqBlock $ mutExpr f <$> s+ mutExpr f (BlockAssign a) = BlockAssign $ mutExpr f a+ mutExpr f (NonBlockAssign a) = NonBlockAssign $ mutExpr f a+ mutExpr f (TaskEnable a) = TaskEnable $ mutExpr f a+ mutExpr f (SysTaskEnable a) = SysTaskEnable $ mutExpr f a+ mutExpr f (CondStmnt a b c) = CondStmnt (f a) (mutExpr f <$> b) $ mutExpr f <$> c+ mutExpr f (ForLoop a1 e a2 s) = ForLoop a1 e a2 $ mutExpr f s+ mutExpr f (StmntAnn a s) = StmntAnn a $ mutExpr f s+ mutExpr f (StmntCase t e cp cd) = StmntCase t (f e) (mutExpr f cp) $ mutExpr f cd+ instance Mutate Parameter where- mutExpr _ = id+ mutExpr _ = id instance Mutate LocalParam where- mutExpr _ = id+ 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 (ModItem ann) where+ mutExpr f (ModCA (ContAssign a e)) = ModCA . ContAssign a $ f e+ mutExpr f (ModInst a params b conns) = ModInst a (mutExpr f params) b $ mutExpr f conns+ mutExpr f (Initial s) = Initial $ mutExpr f s+ mutExpr f (Always s) = Always $ mutExpr f s+ mutExpr f (ModItemAnn a s) = ModItemAnn a $ mutExpr f s+ mutExpr _ d@Decl {} = d+ mutExpr _ p@ParamDecl {} = p+ mutExpr _ l@LocalParamDecl {} = l -instance Mutate ModDecl 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 (ModDecl ann) where+ mutExpr f (ModDecl a b c d e) =+ ModDecl (mutExpr f a) (mutExpr f b) (mutExpr f c) (mutExpr f d) (mutExpr f e)+ mutExpr f (ModDeclAnn a m) = ModDeclAnn a $ mutExpr f m -instance Mutate Verilog where- mutExpr f (Verilog a) = Verilog $ mutExpr f a+instance Mutate (Verilog ann) 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 (SourceInfo ann) 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 [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 (Maybe a) where+ mutExpr f a = mutExpr f <$> a -instance Mutate a => Mutate (GenVerilog a) where- mutExpr f (GenVerilog a) = GenVerilog $ 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+-- | Return if the 'Identifier' is in a '(ModDecl ann)'.+inPort :: Identifier -> (ModDecl ann) -> Bool inPort i m = inInput where inInput =- any (\a -> a ^. portName == i) $ m ^. modInPorts ++ m ^. modOutPorts+ any (\a -> a ^. portName == i) $ m ^. modInPorts ++ m ^. modOutPorts -- | Find the last assignment of a specific wire/reg to an expression, and -- returns that expression.-findAssign :: Identifier -> [ModItem] -> Maybe Expr+findAssign :: Identifier -> [ModItem ann] -> Maybe Expr findAssign i items = safe last . catMaybes $ isAssign <$> items where- isAssign (ModCA (ContAssign val expr)) | val == i = Just expr- | otherwise = Nothing+ isAssign (ModCA (ContAssign val expr))+ | val == i = Just expr+ | otherwise = Nothing isAssign _ = Nothing -- | Transforms an expression by replacing an Identifier with an -- expression. This is used inside 'transformOf' and 'traverseExpr' to replace -- the 'Identifier' recursively. idTrans :: Identifier -> Expr -> Expr -> Expr-idTrans i expr (Id id') | id' == i = expr- | otherwise = Id id'+idTrans i expr (Id id')+ | id' == i = expr+ | otherwise = Id id' idTrans _ _ e = e -- | Replaces the identifier recursively in an expression.@@ -184,30 +192,30 @@ -- 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 :: Identifier -> (ModDecl ann) -> (ModDecl ann) nestId i m- | not $ inPort i m- = let expr = fromMaybe def . findAssign i $ m ^. modItems- in m & get %~ replace i expr- | otherwise- = m+ | not $ inPort i m =+ let expr = fromMaybe def . findAssign i $ m ^. modItems+ in m & get %~ replace i expr+ | otherwise =+ m where get = modItems . traverse . modContAssign . contAssignExpr def = Id i -- | Replaces an identifier by a expression in all the module declaration.-nestSource :: Identifier -> Verilog -> Verilog+nestSource :: Identifier -> (Verilog ann) -> (Verilog ann) 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 :: Int -> (Verilog ann) -> (Verilog ann) nestUpTo i src =- foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i]+ foldl (flip nestSource) src $ Identifier . fromNode <$> [1 .. i] -allVars :: ModDecl -> [Identifier]+allVars :: (ModDecl ann) -> [Identifier] allVars m =- (m ^.. modOutPorts . traverse . portName)- <> (m ^.. modInPorts . traverse . portName)+ (m ^.. modOutPorts . traverse . portName)+ <> (m ^.. modInPorts . traverse . portName) -- $setup -- >>> import Verismith.Verilog.CodeGen@@ -226,24 +234,27 @@ -- endmodule -- <BLANKLINE> -- <BLANKLINE>-instantiateMod :: ModDecl -> ModDecl -> ModDecl+instantiateMod :: (ModDecl ann) -> (ModDecl ann) -> (ModDecl ann) instantiateMod m main = main & modItems %~ ((out ++ regIn ++ [inst]) ++) where out = Decl Nothing <$> m ^. modOutPorts <*> pure Nothing regIn =- Decl Nothing- <$> (m ^. modInPorts & traverse . portType .~ Reg)- <*> pure Nothing- inst = ModInst (m ^. modId)- (m ^. modId <> (Identifier . showT $ count + 1))- conns+ Decl Nothing+ <$> (m ^. modInPorts & traverse . portType .~ Reg)+ <*> pure Nothing+ inst =+ ModInst+ (m ^. modId)+ []+ (m ^. modId <> (Identifier . showT $ count + 1))+ conns count =- length- . filter (== m ^. modId)- $ main- ^.. modItems- . traverse- . modInstId+ length+ . filter (== m ^. modId)+ $ main+ ^.. modItems+ . traverse+ . modInstId conns = uncurry ModConnNamed . fmap Id <$> zip (allVars m) (allVars m) -- | Instantiate without adding wire declarations. It also does not count the@@ -252,14 +263,14 @@ -- >>> GenVerilog $ instantiateMod_ m -- m m(y, x); -- <BLANKLINE>-instantiateMod_ :: ModDecl -> ModItem-instantiateMod_ m = ModInst (m ^. modId) (m ^. modId) conns+instantiateMod_ :: (ModDecl ann) -> (ModItem ann)+instantiateMod_ m = ModInst (m ^. modId) [] (m ^. modId) conns where conns =- ModConn- . Id- <$> (m ^.. modOutPorts . traverse . portName)- ++ (m ^.. modInPorts . traverse . portName)+ ModConn+ . Id+ <$> (m ^.. modOutPorts . traverse . portName)+ ++ (m ^.. modInPorts . traverse . portName) -- | Instantiate without adding wire declarations. It also does not count the -- current instantiations of the same module.@@ -267,17 +278,17 @@ -- >>> GenVerilog $ instantiateModSpec_ "_" m -- m m(.y(y), .x(x)); -- <BLANKLINE>-instantiateModSpec_ :: Text -> ModDecl -> ModItem-instantiateModSpec_ outChar m = ModInst (m ^. modId) (m ^. modId) conns+instantiateModSpec_ :: Bool -> Text -> (ModDecl ann) -> (ModItem ann)+instantiateModSpec_ named outChar m = ModInst (m ^. modId) [] (m ^. modId) conns where- conns = zipWith ModConnNamed ids (Id <$> instIds)- ids = filterChar outChar (name modOutPorts) <> name modInPorts+ conns = (if named then zipWith ModConnNamed ids else map ModConn) (Id <$> instIds)+ ids = filterChar outChar (name modOutPorts) <> name modInPorts instIds = name modOutPorts <> name modInPorts name v = m ^.. v . traverse . portName filterChar :: Text -> [Identifier] -> [Identifier] filterChar t ids =- ids & traverse . _Wrapped %~ (\x -> fromMaybe x . safe head $ T.splitOn t x)+ ids & traverse . _Wrapped %~ (\x -> fromMaybe x . safe head $ T.splitOn t x) -- | Initialise all the inputs and outputs to a module. --@@ -288,7 +299,7 @@ -- endmodule -- <BLANKLINE> -- <BLANKLINE>-initMod :: ModDecl -> ModDecl+initMod :: (ModDecl ann) -> (ModDecl ann) initMod m = m & modItems %~ ((out ++ inp) ++) where out = Decl (Just PortOut) <$> (m ^. modOutPorts) <*> pure Nothing@@ -301,30 +312,32 @@ -- | 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 []+makeTop :: Bool -> Int -> (ModDecl ann) -> (ModDecl ann)+makeTop named i m = ModDecl (m ^. modId) ys (m ^. modInPorts) modIt [] where- ys = yPort . flip makeIdFrom "y" <$> [1 .. i]- modIt = instantiateModSpec_ "_" . modN <$> [1 .. i]+ ys = yPort . flip makeIdFrom "y" <$> [1 .. i]+ modIt = instantiateModSpec_ named "_" . modN <$> [1 .. i] modN n =- m & modId %~ makeIdFrom n & modOutPorts .~ [yPort (makeIdFrom n "y")]+ m & modId %~ makeIdFrom n & modOutPorts .~ [yPort (makeIdFrom n "y")] -- | Make a top module with an assert that requires @y_1@ to always be equal to -- @y_2@, which can then be proven using a formal verification tool.-makeTopAssert :: ModDecl -> ModDecl-makeTopAssert = (modItems %~ (++ [assert])) . makeTop 2+makeTopAssert :: (ModDecl ann) -> (ModDecl ann)+makeTopAssert = (modItems %~ (++ [assert])) . makeTop False 2 where- assert = Always . EventCtrl e . Just $ SeqBlock- [TaskEnable $ Task "assert" [BinOp (Id "y_1") BinEq (Id "y_2")]]+ assert =+ Always . EventCtrl e . Just $+ SeqBlock+ [TaskEnable $ Task "assert" [BinOp (Id "y_1") BinEq (Id "y_2")]] e = EPosEdge "clk" -- | Provide declarations for all the ports that are passed to it. If they are -- registers, it should assign them to 0.-declareMod :: [Port] -> ModDecl -> ModDecl+declareMod :: [Port] -> (ModDecl ann) -> (ModDecl ann) declareMod ports = initMod . (modItems %~ (fmap decl ports ++)) where decl p@(Port Reg _ _ _) = Decl Nothing p (Just 0)- decl p = Decl Nothing p Nothing+ decl p = Decl Nothing p Nothing -- | Simplify an 'Expr' by using constants to remove 'BinaryOperator' and -- simplify expressions. To make this work effectively, it should be run until@@ -336,30 +349,30 @@ -- >>> GenVerilog . simplify $ (Id "y") + (Id "x") -- (y + x) simplify :: Expr -> Expr-simplify (BinOp (Number (BitVec _ 1)) BinAnd e) = e-simplify (BinOp e BinAnd (Number (BitVec _ 1))) = e-simplify (BinOp (Number (BitVec _ 0)) BinAnd _) = Number 0-simplify (BinOp _ BinAnd (Number (BitVec _ 0))) = Number 0-simplify (BinOp e BinPlus (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinPlus e) = e+simplify (BinOp (Number (BitVec _ 1)) BinAnd e) = e+simplify (BinOp e BinAnd (Number (BitVec _ 1))) = e+simplify (BinOp (Number (BitVec _ 0)) BinAnd _) = Number 0+simplify (BinOp _ BinAnd (Number (BitVec _ 0))) = Number 0+simplify (BinOp e BinPlus (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinPlus e) = e simplify (BinOp e BinMinus (Number (BitVec _ 0))) = e simplify (BinOp (Number (BitVec _ 0)) BinMinus e) = e simplify (BinOp e BinTimes (Number (BitVec _ 1))) = e simplify (BinOp (Number (BitVec _ 1)) BinTimes e) = e simplify (BinOp _ BinTimes (Number (BitVec _ 0))) = Number 0 simplify (BinOp (Number (BitVec _ 0)) BinTimes _) = Number 0-simplify (BinOp e BinOr (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinOr e) = e-simplify (BinOp e BinLSL (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinLSL e) = e-simplify (BinOp e BinLSR (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinLSR e) = e-simplify (BinOp e BinASL (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinASL e) = e-simplify (BinOp e BinASR (Number (BitVec _ 0))) = e-simplify (BinOp (Number (BitVec _ 0)) BinASR e) = e-simplify (UnOp UnPlus e) = e-simplify e = e+simplify (BinOp e BinOr (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinOr e) = e+simplify (BinOp e BinLSL (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinLSL e) = e+simplify (BinOp e BinLSR (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinLSR e) = e+simplify (BinOp e BinASL (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinASL e) = e+simplify (BinOp e BinASR (Number (BitVec _ 0))) = e+simplify (BinOp (Number (BitVec _ 0)) BinASR e) = e+simplify (UnOp UnPlus e) = e+simplify e = e -- | Remove all 'Identifier' that do not appeare in the input list from an -- 'Expr'. The identifier will be replaced by @1'b0@, which can then later be@@ -370,32 +383,34 @@ removeId :: [Identifier] -> Expr -> Expr removeId i = transform trans where- trans (Id ident) | ident `notElem` i = Number 0- | otherwise = Id ident+ trans (Id ident)+ | ident `notElem` i = Number 0+ | otherwise = Id ident trans e = e -combineAssigns :: Port -> [ModItem] -> [ModItem]+combineAssigns :: Port -> [ModItem ann] -> [ModItem ann] combineAssigns p a =- a- <> [ ModCA- . ContAssign (p ^. portName)- . UnOp UnXor- . fold- $ Id+ a+ <> [ ModCA+ . ContAssign (p ^. portName)+ . UnOp UnXor+ . fold+ $ Id <$> assigns- ]- where assigns = a ^.. traverse . modContAssign . contAssignNetLVal+ ]+ where+ assigns = a ^.. traverse . modContAssign . contAssignNetLVal -combineAssigns_ :: Bool -> Port -> [Port] -> ModItem+combineAssigns_ :: Bool -> Port -> [Port] -> (ModItem ann) combineAssigns_ comb p ps =- ModCA- . ContAssign (p ^. portName)- . (if comb then UnOp UnXor else id)- . fold- $ Id- <$> ps+ ModCA+ . ContAssign (p ^. portName)+ . (if comb then UnOp UnXor else id)+ . fold+ $ Id+ <$> ps ^.. traverse- . portName+ . portName fromPort :: Port -> Identifier fromPort (Port _ _ _ i) = i
src/Verismith/Verilog/Parser.hs view
@@ -1,50 +1,50 @@-{-|-Module : Verismith.Verilog.Parser-Description : Minimal Verilog parser to reconstruct the AST.-Copyright : (c) 2019, Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Minimal Verilog parser to reconstruct the AST. This parser does not support the-whole Verilog syntax, as the AST does not support it either.--}-+-- |+-- Module : Verismith.Verilog.Parser+-- Description : Minimal Verilog parser to reconstruct the AST.+-- Copyright : (c) 2019-2022, Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Minimal Verilog parser to reconstruct the AST. This parser does not support the+-- whole Verilog syntax, as the AST does not support it either. module Verismith.Verilog.Parser- ( -- * Parser- parseVerilog- , parseVerilogFile- , parseSourceInfoFile+ ( -- * Parser+ parseVerilog,+ parseVerilogFile,+ parseSourceInfoFile,+ -- ** Internal parsers- , parseEvent- , parseStatement- , parseModItem- , parseModDecl- , Parser- )+ parseEvent,+ parseStatement,+ parseModItem,+ parseModDecl,+ Parser,+ ) where -import Control.Lens-import Control.Monad (void)-import Data.Bifunctor (bimap)-import Data.Bits-import Data.Functor (($>))-import Data.Functor.Identity (Identity)-import Data.List (isInfixOf, isPrefixOf, null)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Text.Parsec hiding (satisfy)-import Text.Parsec.Expr-import Verismith.Internal-import Verismith.Verilog.AST-import Verismith.Verilog.BitVec-import Verismith.Verilog.Internal-import Verismith.Verilog.Lex-import Verismith.Verilog.Preprocess-import Verismith.Verilog.Token+import Control.Lens+import Control.Monad (void)+import Data.Bifunctor (bimap)+import Data.Bits+import Data.Functor (($>))+import Data.Functor.Identity (Identity)+import Data.List (isInfixOf, isPrefixOf, null)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+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.Utils+import Verismith.Verilog.AST+import Verismith.Verilog.BitVec+import Verismith.Verilog.Internal+import Verismith.Verilog.Lex+import Verismith.Verilog.Preprocess+import Verismith.Verilog.Token type Parser = Parsec [Token] () @@ -53,13 +53,13 @@ data Decimal = Decimal Int Integer instance Num Decimal where- (Decimal sa na) + (Decimal sb nb) = Decimal (max sa sb) (na + nb)- (Decimal sa na) - (Decimal sb nb) = Decimal (max sa sb) (na - nb)- (Decimal sa na) * (Decimal sb nb) = Decimal (max sa sb) (na * nb)- negate (Decimal s n) = Decimal s $ negate n- abs (Decimal s n) = Decimal s $ abs n- signum (Decimal s n) = Decimal s $ signum n- fromInteger = Decimal 32 . fromInteger+ (Decimal sa na) + (Decimal sb nb) = Decimal (max sa sb) (na + nb)+ (Decimal sa na) - (Decimal sb nb) = Decimal (max sa sb) (na - nb)+ (Decimal sa na) * (Decimal sb nb) = Decimal (max sa sb) (na * nb)+ negate (Decimal s n) = Decimal s $ negate n+ abs (Decimal s n) = Decimal s $ abs n+ signum (Decimal s n) = Decimal s $ signum n+ fromInteger = Decimal 32 . fromInteger -- | This parser succeeds whenever the given predicate returns true when called -- with parsed `Token`. Same as 'Text.Parsec.Char.satisfy'.@@ -74,7 +74,7 @@ nextPos :: SourcePos -> Token -> [Token] -> SourcePos nextPos pos _ (Token _ _ (Position _ l c) : _) =- setSourceColumn (setSourceLine pos l) c+ setSourceColumn (setSourceLine pos l) c nextPos pos _ [] = pos -- | Parses given `TokenName`.@@ -113,56 +113,56 @@ parseVecSelect :: Parser Expr parseVecSelect = do- i <- identifier- expr <- brackets parseExpr- return $ VecSelect i expr+ i <- identifier+ expr <- brackets parseExpr+ return $ VecSelect i expr parseRangeSelect :: Parser Expr parseRangeSelect = do- i <- identifier- range <- parseRange- return $ RangeSelect i range+ i <- identifier+ range <- parseRange+ return $ RangeSelect i range systemFunc :: Parser String systemFunc = satisfy' matchId where matchId (Token IdSystem s _) = Just s- matchId _ = Nothing+ matchId _ = Nothing parseFun :: Parser Expr parseFun = do- f <- systemFunc- expr <- parens parseExpr- return $ Appl (Identifier $ T.pack f) expr+ f <- systemFunc+ expr <- parens parseExpr+ return $ Appl (Identifier $ T.pack f) expr parserNonEmpty :: [a] -> Parser (NonEmpty a) parserNonEmpty (a : b) = return $ a :| b-parserNonEmpty [] = fail "Concatenation cannot be empty."+parserNonEmpty [] = fail "Concatenation cannot be empty." parseTerm :: Parser Expr parseTerm =- parens parseExpr- <|> (Concat <$> (braces (commaSep parseExpr) >>= parserNonEmpty))- <|> parseFun- <|> parseNum- <|> try parseVecSelect- <|> try parseRangeSelect- <|> parseVar- <?> "simple expr"+ parens parseExpr+ <|> (Concat <$> (braces (commaSep parseExpr) >>= parserNonEmpty))+ <|> parseFun+ <|> parseNum+ <|> try parseVecSelect+ <|> try parseRangeSelect+ <|> parseVar+ <?> "simple expr" -- | Parses the ternary conditional operator. It will behave in a right -- associative way. parseCond :: Expr -> Parser Expr parseCond e = do- tok' SymQuestion- expr <- parseExpr- tok' SymColon- Cond e expr <$> parseExpr+ tok' SymQuestion+ expr <- parseExpr+ tok' SymColon+ Cond e expr <$> parseExpr parseExpr :: Parser Expr parseExpr = do- e <- parseExpr'- option e . try $ parseCond e+ e <- parseExpr'+ option e . try $ parseCond e parseConstExpr :: Parser ConstExpr parseConstExpr = fmap exprToConst parseExpr@@ -171,50 +171,50 @@ -- each. parseTable :: [[ParseOperator Expr]] parseTable =- [ [prefix SymBang (UnOp UnLNot), prefix SymTildy (UnOp UnNot)]- , [ prefix SymAmp (UnOp UnAnd)- , prefix SymBar (UnOp UnOr)- , prefix SymTildyAmp (UnOp UnNand)- , prefix SymTildyBar (UnOp UnNor)- , prefix SymHat (UnOp UnXor)- , prefix SymTildyHat (UnOp UnNxor)- , prefix SymHatTildy (UnOp UnNxorInv)- ]- , [prefix SymPlus (UnOp UnPlus), prefix SymDash (UnOp UnMinus)]- , [binary SymAsterAster (sBinOp BinPower) AssocRight]- , [ binary SymAster (sBinOp BinTimes) AssocLeft- , binary SymSlash (sBinOp BinDiv) AssocLeft- , binary SymPercent (sBinOp BinMod) AssocLeft- ]- , [ binary SymPlus (sBinOp BinPlus) AssocLeft- , binary SymDash (sBinOp BinPlus) AssocLeft- ]- , [ binary SymLtLt (sBinOp BinLSL) AssocLeft- , binary SymGtGt (sBinOp BinLSR) AssocLeft- ]- , [ binary SymLtLtLt (sBinOp BinASL) AssocLeft- , binary SymGtGtGt (sBinOp BinASR) AssocLeft- ]- , [ binary SymLt (sBinOp BinLT) AssocNone- , binary SymGt (sBinOp BinGT) AssocNone- , binary SymLtEq (sBinOp BinLEq) AssocNone- , binary SymGtEq (sBinOp BinLEq) AssocNone- ]- , [ binary SymEqEq (sBinOp BinEq) AssocNone- , binary SymBangEq (sBinOp BinNEq) AssocNone- ]- , [ binary SymEqEqEq (sBinOp BinEq) AssocNone- , binary SymBangEqEq (sBinOp BinNEq) AssocNone- ]- , [binary SymAmp (sBinOp BinAnd) AssocLeft]- , [ binary SymHat (sBinOp BinXor) AssocLeft- , binary SymHatTildy (sBinOp BinXNor) AssocLeft- , binary SymTildyHat (sBinOp BinXNorInv) AssocLeft- ]- , [binary SymBar (sBinOp BinOr) AssocLeft]- , [binary SymAmpAmp (sBinOp BinLAnd) AssocLeft]- , [binary SymBarBar (sBinOp BinLOr) AssocLeft]- ]+ [ [prefix SymBang (UnOp UnLNot), prefix SymTildy (UnOp UnNot)],+ [ prefix SymAmp (UnOp UnAnd),+ prefix SymBar (UnOp UnOr),+ prefix SymTildyAmp (UnOp UnNand),+ prefix SymTildyBar (UnOp UnNor),+ prefix SymHat (UnOp UnXor),+ prefix SymTildyHat (UnOp UnNxor),+ prefix SymHatTildy (UnOp UnNxorInv)+ ],+ [prefix SymPlus (UnOp UnPlus), prefix SymDash (UnOp UnMinus)],+ [binary SymAsterAster (sBinOp BinPower) AssocRight],+ [ binary SymAster (sBinOp BinTimes) AssocLeft,+ binary SymSlash (sBinOp BinDiv) AssocLeft,+ binary SymPercent (sBinOp BinMod) AssocLeft+ ],+ [ binary SymPlus (sBinOp BinPlus) AssocLeft,+ binary SymDash (sBinOp BinMinus) 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 BinGEq) 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)@@ -225,38 +225,50 @@ commaSep :: Parser a -> Parser [a] commaSep = flip sepBy $ tok SymComma +toNE :: Parser [a] -> Parser (NonEmpty a)+toNE p = do+ p' <- p+ case p' of+ a : b -> return $ a :| b+ _ -> fail "List is empty."++commaSepNE :: Parser a -> Parser (NonEmpty a)+commaSepNE = toNE . commaSep+ parseContAssign :: Parser ContAssign parseContAssign = do- var <- tok KWAssign *> identifier- expr <- tok SymEq *> parseExpr- tok' SymSemi- return $ ContAssign var expr+ var <- tok KWAssign *> identifier+ expr <- tok SymEq *> parseExpr+ tok' SymSemi+ return $ ContAssign var expr numLit :: Parser String numLit = satisfy' matchId where matchId (Token LitNumber s _) = Just s- matchId _ = Nothing+ matchId _ = Nothing number :: Parser Decimal number = number' <$> numLit where number' :: String -> Decimal- number' a | all (`elem` ['0' .. '9']) a = fromInteger $ read a- | head a == '\'' = fromInteger $ f a- | "'" `isInfixOf` a = Decimal (read w) (f b)- | otherwise = error $ "Invalid number format: " ++ a+ number' a+ | all (`elem` ['0' .. '9']) a = fromInteger $ read a+ | head a == '\'' = fromInteger $ f a+ | "'" `isInfixOf` a = Decimal (read w) (f b)+ | otherwise = error $ "Invalid number format: " ++ a where w = takeWhile (/= '\'') a b = dropWhile (/= '\'') a f a'- | "'d" `isPrefixOf` a' = read $ drop 2 a'- | "'h" `isPrefixOf` a' = read $ "0x" ++ drop 2 a'- | "'b" `isPrefixOf` a' = foldl- (\n b' -> shiftL n 1 .|. (if b' == '1' then 1 else 0))- 0- (drop 2 a')- | otherwise = error $ "Invalid number format: " ++ a'+ | "'d" `isPrefixOf` a' = read $ drop 2 a'+ | "'h" `isPrefixOf` a' = read $ "0x" ++ drop 2 a'+ | "'b" `isPrefixOf` a' =+ foldl+ (\n b' -> shiftL n 1 .|. (if b' == '1' then 1 else 0))+ 0+ (drop 2 a')+ | otherwise = error $ "Invalid number format: " ++ a' -- toInteger' :: Decimal -> Integer -- toInteger' (Decimal _ n) = n@@ -268,61 +280,62 @@ -- added to the difference. parseRange :: Parser Range parseRange = do- rangeH <- tok SymBrackL *> parseConstExpr- rangeL <- tok SymColon *> parseConstExpr- tok' SymBrackR- return $ Range rangeH rangeL+ rangeH <- tok SymBrackL *> parseConstExpr+ rangeL <- tok SymColon *> parseConstExpr+ tok' SymBrackR+ return $ Range rangeH rangeL strId :: Parser String strId = satisfy' matchId where- matchId (Token IdSimple s _) = Just s+ matchId (Token IdSimple s _) = Just s matchId (Token IdEscaped s _) = Just s- matchId _ = Nothing+ matchId _ = Nothing identifier :: Parser Identifier identifier = Identifier . T.pack <$> strId -parseNetDecl :: Maybe PortDir -> Parser ModItem+parseNetDecl :: Maybe PortDir -> Parser (ModItem ann) parseNetDecl pd = do- t <- option Wire type_- sign <- option False (tok KWSigned $> True)- range <- option 1 parseRange- name <- identifier- i <- option Nothing (fmap Just (tok' SymEq *> parseConstExpr))- tok' SymSemi- return $ Decl pd (Port t sign range name) i- where type_ = tok KWWire $> Wire <|> tok KWReg $> Reg+ t <- option Wire type_+ sign <- option False (tok KWSigned $> True)+ range <- option 1 parseRange+ name <- identifier+ i <- option Nothing (fmap Just (tok' SymEq *> parseConstExpr))+ tok' SymSemi+ return $ Decl pd (Port t sign range name) i+ where+ type_ = tok KWWire $> Wire <|> tok KWReg $> Reg parsePortDir :: Parser PortDir parsePortDir =- tok KWOutput- $> PortOut- <|> tok KWInput- $> PortIn- <|> tok KWInout- $> PortInOut+ tok KWOutput+ $> PortOut+ <|> tok KWInput+ $> PortIn+ <|> tok KWInout+ $> PortInOut -parseDecl :: Parser ModItem+parseDecl :: Parser (ModItem ann) parseDecl = (Just <$> parsePortDir >>= parseNetDecl) <|> parseNetDecl Nothing -parseConditional :: Parser Statement+parseConditional :: Parser (Statement ann) parseConditional = do- expr <- tok' KWIf *> parens parseExpr- true <- maybeEmptyStatement- false <- option Nothing (tok' KWElse *> maybeEmptyStatement)- return $ CondStmnt expr true false+ expr <- tok' KWIf *> parens parseExpr+ true <- maybeEmptyStatement+ false <- option Nothing (tok' KWElse *> maybeEmptyStatement)+ return $ CondStmnt expr true false parseLVal :: Parser LVal parseLVal = fmap RegConcat (braces $ commaSep parseExpr) <|> ident where ident = do- i <- identifier- (try (ex i) <|> try (sz i) <|> return (RegId i))+ i <- identifier+ (try (ex i) <|> try (sz i) <|> return (RegId i)) ex i = do- e <- tok' SymBrackL *> parseExpr- tok' SymBrackR- return $ RegExpr i e+ e <- tok' SymBrackL *> parseExpr+ tok' SymBrackR+ return $ RegExpr i e sz i = RegSize i <$> parseRange parseDelay :: Parser Delay@@ -330,182 +343,244 @@ parseAssign :: TokenName -> Parser Assign parseAssign t = do- lval <- parseLVal- tok' t- delay <- option Nothing (fmap Just parseDelay)- expr <- parseExpr- return $ Assign lval delay expr+ lval <- parseLVal+ tok' t+ delay <- option Nothing (fmap Just parseDelay)+ expr <- parseExpr+ return $ Assign lval delay expr -parseLoop :: Parser Statement+parseLoop :: Parser (Statement ann) parseLoop = do- a <- tok' KWFor *> tok' SymParenL *> parseAssign SymEq- expr <- tok' SymSemi *> parseExpr- incr <- tok' SymSemi *> parseAssign SymEq- tok' SymParenR- statement <- parseStatement- return $ ForLoop a expr incr statement+ a <- tok' KWFor *> tok' SymParenL *> parseAssign SymEq+ expr <- tok' SymSemi *> parseExpr+ incr <- tok' SymSemi *> parseAssign SymEq+ tok' SymParenR+ statement <- parseStatement+ return $ ForLoop a expr incr statement +parseDefaultPair :: Parser (Statement a)+parseDefaultPair = tok' KWDefault *> tok' SymColon *> parseStatement++parseCasePair :: Parser (CasePair ann)+parseCasePair = do+ expr <- parseExpr <* tok' SymColon+ CasePair expr <$> parseStatement++parseCase :: Parser (Statement ann)+parseCase = do+ expr <- tok' KWCase *> parseExpr+ cp <- manyTill parseCasePair (lookAhead ((parseDefaultPair $> ()) <|> tok' KWEndcase))+ def <- option Nothing $ Just <$> parseDefaultPair+ tok' KWEndcase+ return (StmntCase CaseStandard expr cp def)+ eventList :: TokenName -> Parser [Event] eventList t = do- l <- sepBy parseEvent' (tok t)- if null l then fail "Could not parse list" else return l+ l <- sepBy parseEvent' (tok t)+ if null l then fail "Could not parse list" else return l parseEvent :: Parser Event parseEvent =- tok' SymAtAster- $> EAll- <|> try (tok' SymAt *> tok' SymParenLAsterParenR $> EAll)- <|> try- ( tok' SymAt- *> tok' SymParenL- *> tok' SymAster- *> tok' SymParenR- $> EAll- )- <|> try (tok' SymAt *> parens parseEvent')- <|> try (tok' SymAt *> parens (foldr1 EOr <$> eventList KWOr))- <|> try (tok' SymAt *> parens (foldr1 EComb <$> eventList SymComma))+ (tok' SymAtAster $> EAll)+ <|> try (tok' SymAt *> tok' SymParenLAsterParenR $> EAll)+ <|> try+ ( tok' SymAt+ *> parens (tok' SymAster)+ $> EAll+ )+ <|> try (tok' SymAt *> parens parseEvent')+ <|> try (tok' SymAt *> parens (foldr1 EOr <$> eventList KWOr))+ <|> try (tok' SymAt *> parens (foldr1 EComb <$> eventList SymComma)) parseEvent' :: Parser Event parseEvent' =- try (tok' KWPosedge *> fmap EPosEdge identifier)- <|> try (tok' KWNegedge *> fmap ENegEdge identifier)- <|> try (fmap EId identifier)- <|> try (fmap EExpr parseExpr)+ try (tok' KWPosedge *> fmap EPosEdge identifier)+ <|> try (tok' KWNegedge *> fmap ENegEdge identifier)+ <|> try (fmap EId identifier)+ <|> try (fmap EExpr parseExpr) -parseEventCtrl :: Parser Statement+parseEventCtrl :: Parser (Statement ann) parseEventCtrl = do- event <- parseEvent- statement <- option Nothing maybeEmptyStatement- return $ EventCtrl event statement+ event <- parseEvent+ statement <- option Nothing maybeEmptyStatement+ return $ EventCtrl event statement -parseDelayCtrl :: Parser Statement+parseDelayCtrl :: Parser (Statement ann) parseDelayCtrl = do- delay <- parseDelay- statement <- option Nothing maybeEmptyStatement- return $ TimeCtrl delay statement+ delay <- parseDelay+ statement <- option Nothing maybeEmptyStatement+ return $ TimeCtrl delay statement -parseBlocking :: Parser Statement+parseBlocking :: Parser (Statement ann) parseBlocking = do- a <- parseAssign SymEq- tok' SymSemi- return $ BlockAssign a+ a <- parseAssign SymEq+ tok' SymSemi+ return $ BlockAssign a -parseNonBlocking :: Parser Statement+parseNonBlocking :: Parser (Statement ann) parseNonBlocking = do- a <- parseAssign SymLtEq- tok' SymSemi- return $ NonBlockAssign a+ a <- parseAssign SymLtEq+ tok' SymSemi+ return $ NonBlockAssign a -parseSeq :: Parser Statement+parseSeq :: Parser (Statement ann) parseSeq = do- seq' <- tok' KWBegin *> many parseStatement- tok' KWEnd- return $ SeqBlock seq'+ seq' <- tok' KWBegin *> many parseStatement+ tok' KWEnd+ return $ SeqBlock seq' -parseStatement :: Parser Statement+parseStatement :: Parser (Statement ann) parseStatement =- parseSeq- <|> parseConditional- <|> parseLoop- <|> parseEventCtrl- <|> parseDelayCtrl- <|> try parseBlocking- <|> parseNonBlocking+ parseSeq+ <|> parseConditional+ <|> parseLoop+ <|> parseCase+ <|> parseEventCtrl+ <|> parseDelayCtrl+ <|> try parseBlocking+ <|> parseNonBlocking -maybeEmptyStatement :: Parser (Maybe Statement)+maybeEmptyStatement :: Parser (Maybe (Statement ann)) maybeEmptyStatement =- (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement)+ (tok' SymSemi >> return Nothing) <|> (Just <$> parseStatement) -parseAlways :: Parser ModItem+parseAlways :: Parser (ModItem ann) parseAlways = tok' KWAlways *> (Always <$> parseStatement) -parseInitial :: Parser ModItem+parseInitial :: Parser (ModItem ann) parseInitial = tok' KWInitial *> (Initial <$> parseStatement) namedModConn :: Parser ModConn namedModConn = do- target <- tok' SymDot *> identifier- expr <- parens parseExpr- return $ ModConnNamed target expr+ target <- tok' SymDot *> identifier+ expr <- parens parseExpr+ return $ ModConnNamed target expr parseModConn :: Parser ModConn parseModConn = try (fmap ModConn parseExpr) <|> namedModConn -parseModInst :: Parser ModItem+parseModInst :: Parser (ModItem ann) parseModInst = do- m <- identifier- name <- identifier- modconns <- parens (commaSep parseModConn)- tok' SymSemi- return $ ModInst m name modconns+ m <- identifier+ params <- option [] $ tok' SymPound *> parens (commaSep parseModConn)+ name <- identifier+ modconns <- parens (commaSep parseModConn)+ tok' SymSemi+ return $ ModInst m params name modconns -parseModItem :: Parser ModItem+parseParam :: Parser Parameter+parseParam = do+ i <- tok' KWParameter *> identifier+ expr <- tok' SymEq *> parseConstExpr+ return $ Parameter i expr++parseParam' :: Parser Parameter+parseParam' = do+ i <- identifier+ expr <- tok' SymEq *> parseConstExpr+ return $ Parameter i expr++parseParams :: Parser [Parameter]+parseParams = tok' SymPound *> parens (commaSep parseParam)++parseParamDecl :: Parser (ModItem ann)+parseParamDecl =+ ParamDecl <$> (tok' KWParameter *> commaSepNE parseParam' <* tok' SymSemi)++parseModItem :: Parser (ModItem ann) parseModItem =- try (ModCA <$> parseContAssign)- <|> try parseDecl- <|> parseAlways- <|> parseInitial- <|> parseModInst+ try (ModCA <$> parseContAssign)+ <|> try parseDecl+ <|> parseAlways+ <|> parseInitial+ <|> parseModInst+ <|> parseParamDecl parseModList :: Parser [Identifier] parseModList = list <|> return [] where list = parens $ commaSep identifier -filterDecl :: PortDir -> ModItem -> Bool+filterDecl :: PortDir -> (ModItem ann) -> Bool filterDecl p (Decl (Just p') _ _) = p == p'-filterDecl _ _ = False+filterDecl _ _ = False -modPorts :: PortDir -> [ModItem] -> [Port]+modPorts :: PortDir -> [ModItem ann] -> [Port] modPorts p mis = filter (filterDecl p) mis ^.. traverse . declPort -parseParam :: Parser Parameter-parseParam = do- i <- tok' KWParameter *> identifier- expr <- tok' SymEq *> parseConstExpr- return $ Parameter i expr+parseModDecl :: Parser (ModDecl ann)+parseModDecl = do+ name <- tok KWModule *> identifier+ paramList <- option [] $ try parseParams+ _ <- fmap defaultPort <$> parseModList+ tok' SymSemi+ modItem <- option [] . try $ many1 parseModItem+ tok' KWEndmodule+ return $+ ModDecl+ name+ (modPorts PortOut modItem)+ (modPorts PortIn modItem)+ modItem+ paramList -parseParams :: Parser [Parameter]-parseParams = tok' SymPound *> parens (commaSep parseParam)+mergeMaybe :: Maybe a -> Maybe a -> Maybe a+mergeMaybe (Just a) Nothing = Just a+mergeMaybe Nothing (Just a) = Just a+mergeMaybe a _ = a -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+mergeType :: PortType -> PortType -> PortType+mergeType Reg Wire = Reg+mergeType Wire Reg = Reg+mergeType a _ = a +mergePorts :: Port -> Port -> Port+mergePorts (Port t1 s1 r1 n1) (Port t2 s2 r2 n2) =+ Port (mergeType t1 t2) (s1 || s2) (if r1 == 0 then r2 else r1) n1++mergeIO :: ModItem a -> ModItem a -> ModItem a+mergeIO (Decl a1 b1 c1) (Decl a2 b2 c2) = Decl (mergeMaybe a1 a2) (mergePorts b1 b2) (mergeMaybe c1 c2)+mergeIO a _ = a++genmoditem :: Map.Map Identifier (ModItem a) -> ModItem a -> Map.Map Identifier (ModItem a)+genmoditem m (Decl a b c) =+ Map.insertWith mergeIO (b ^. portName) (Decl a b c) m+genmoditem m b = m++modifyelements :: [ModItem a] -> [ModItem a]+modifyelements ma = ndecl <> nodecl+ where+ ndecl = Map.elems $ foldl genmoditem Map.empty ma+ isDecl Decl {} = True+ isDecl _ = False+ nodecl = filter isDecl ma+ -- | Parses a 'String' into 'Verilog' by skipping any beginning whitespace -- and then parsing multiple Verilog source.-parseVerilogSrc :: Parser Verilog+parseVerilogSrc :: Parser (Verilog ann) 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 ::+ -- | Name of parsed object.+ Text ->+ -- | Content to be parsed.+ Text ->+ -- | Returns 'String' with error+ -- message if parse fails.+ Either Text (Verilog ann) parseVerilog s =- bimap showT id- . parse parseVerilogSrc (T.unpack s)- . alexScanTokens- . preprocess [] (T.unpack s)- . T.unpack+ bimap showT id -- (_Wrapped.traverse.modItems %~ modifyelements)+ . parse parseVerilogSrc (T.unpack s)+ . alexScanTokens+ . preprocess [] (T.unpack s)+ . T.unpack -parseVerilogFile :: Text -> IO Verilog+parseVerilogFile :: Text -> IO (Verilog ann) parseVerilogFile file = do- src <- T.readFile $ T.unpack file- case parseVerilog file src of- Left s -> error $ T.unpack s- Right r -> return r+ src <- T.readFile $ T.unpack file+ case parseVerilog file src of+ Left s -> error $ T.unpack s+ Right r -> return r -parseSourceInfoFile :: Text -> Text -> IO SourceInfo+parseSourceInfoFile :: Text -> Text -> IO (SourceInfo ann) parseSourceInfoFile top = fmap (SourceInfo top) . parseVerilogFile
src/Verismith/Verilog/Preprocess.hs view
@@ -1,23 +1,21 @@-{-|-Module : Verismith.Verilog.Preprocess-Description : Simple preprocessor for `define and comments.-Copyright : (c) 2011-2015 Tom Hawkins, 2019 Yann Herklotz-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Simple preprocessor for `define and comments.--The code is from https://github.com/tomahawkins/verilog.--Edits to the original code are warning fixes and formatting changes.--}-+-- |+-- Module : Verismith.Verilog.Preprocess+-- Description : Simple preprocessor for `define and comments.+-- Copyright : (c) 2011-2015 Tom Hawkins, 2019 Yann Herklotz+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Simple preprocessor for `define and comments.+--+-- The code is from https://github.com/tomahawkins/verilog.+--+-- Edits to the original code are warning fixes and formatting changes. module Verismith.Verilog.Preprocess- ( uncomment- , preprocess- )+ ( uncomment,+ preprocess,+ ) where -- | Remove comments from code. There is no difference between @(* *)@ and@@ -27,84 +25,87 @@ uncomment file = uncomment' where uncomment' a = case a of- "" -> ""- '/' : '/' : rest -> " " ++ removeEOL rest- '/' : '*' : rest -> " " ++ remove rest- '(' : '*' : rest -> " " ++ remove rest- '"' : rest -> '"' : ignoreString rest- b : rest -> b : uncomment' rest-+ "" -> ""+ '/' : '/' : rest -> " " ++ removeEOL rest+ '/' : '*' : rest -> " " ++ remove rest+ '(' : '*' : ')' : rest -> '(' : '*' : ')' : rest ++ remove rest+ '(' : '*' : rest -> " " ++ remove rest+ '"' : rest -> '"' : ignoreString rest+ b : rest -> b : uncomment' rest removeEOL a = case a of- "" -> ""- '\n' : rest -> '\n' : uncomment' rest- '\t' : rest -> '\t' : removeEOL rest- _ : rest -> ' ' : removeEOL rest-+ "" -> ""+ '\n' : rest -> '\n' : uncomment' rest+ '\t' : rest -> '\t' : removeEOL rest+ _ : rest -> ' ' : removeEOL rest remove a = case a of- "" -> error $ "File ended without closing comment (*/): " ++ file- '"' : rest -> removeString rest- '\n' : rest -> '\n' : remove rest- '\t' : rest -> '\t' : remove rest- '*' : '/' : rest -> " " ++ uncomment' rest- '*' : ')' : rest -> " " ++ uncomment' rest- _ : rest -> " " ++ remove rest-+ "" -> error $ "File ended without closing comment (*/): " ++ file+ '"' : rest -> removeString rest+ '\n' : rest -> '\n' : remove rest+ '\t' : rest -> '\t' : remove rest+ '*' : '/' : rest -> " " ++ uncomment' rest+ '*' : ')' : rest -> " " ++ uncomment' rest+ _ : rest -> " " ++ remove rest removeString a = case a of- "" -> error $ "File ended without closing string: " ++ file- '"' : rest -> " " ++ remove rest- '\\' : '"' : rest -> " " ++ removeString rest- '\n' : rest -> '\n' : removeString rest- '\t' : rest -> '\t' : removeString rest- _ : rest -> ' ' : removeString rest-+ "" -> error $ "File ended without closing string: " ++ file+ '"' : rest -> " " ++ remove rest+ '\\' : '"' : rest -> " " ++ removeString rest+ '\n' : rest -> '\n' : removeString rest+ '\t' : rest -> '\t' : removeString rest+ _ : rest -> ' ' : removeString rest ignoreString a = case a of- "" -> error $ "File ended without closing string: " ++ file- '"' : rest -> '"' : uncomment' rest- '\\' : '"' : rest -> "\\\"" ++ ignoreString rest- b : rest -> b : ignoreString rest+ "" -> error $ "File ended without closing string: " ++ file+ '"' : rest -> '"' : uncomment' rest+ '\\' : '"' : rest -> "\\\"" ++ ignoreString rest+ b : rest -> b : ignoreString rest -- | A simple `define preprocessor. preprocess :: [(String, String)] -> FilePath -> String -> String-preprocess env file content = unlines $ pp True [] env $ lines $ uncomment- file- content+preprocess env file content =+ unlines $+ pp True [] env $+ lines $+ uncomment+ file+ content where pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String]- pp _ _ _ [] = []+ pp _ _ _ [] = [] pp on stack env_ (a : rest) = case words a of- "`define" : name : value ->- ""- : pp- on- stack- (if on- then (name, ppLine env_ $ unwords value) : env_- else env_- )- rest- "`ifdef" : name : _ ->- "" : pp (on && elem name (map fst env_)) (on : stack) env_ rest- "`ifndef" : name : _ ->- "" : pp (on && notElem name (map fst env_)) (on : stack) env_ rest- "`else" : _- | not $ null stack- -> "" : pp (head stack && not on) stack env_ rest- | otherwise- -> error $ "`else without associated `ifdef/`ifndef: " ++ file- "`endif" : _- | not $ null stack- -> "" : pp (head stack) (tail stack) env_ rest- | otherwise- -> error $ "`endif without associated `ifdef/`ifndef: " ++ file- _ -> (if on then ppLine env_ a else "") : pp on stack env_ rest+ "`define" : name : value ->+ "" :+ pp+ on+ stack+ ( if on+ then (name, ppLine env_ $ unwords value) : env_+ else env_+ )+ rest+ "`ifdef" : name : _ ->+ "" : pp (on && elem name (map fst env_)) (on : stack) env_ rest+ "`ifndef" : name : _ ->+ "" : pp (on && notElem name (map fst env_)) (on : stack) env_ rest+ "`else" : _+ | not $ null stack ->+ "" : pp (head stack && not on) stack env_ rest+ | otherwise ->+ error $ "`else without associated `ifdef/`ifndef: " ++ file+ "`endif" : _+ | not $ null stack ->+ "" : pp (head stack) (tail stack) env_ rest+ | otherwise ->+ error $ "`endif without associated `ifdef/`ifndef: " ++ file+ "`timescale" : _ -> pp on stack env_ rest+ _ -> (if on then ppLine env_ a else "") : pp on stack env_ rest ppLine :: [(String, String)] -> String -> String-ppLine _ "" = ""+ppLine _ "" = "" ppLine env ('`' : a) = case lookup name env of- Just value -> value ++ ppLine env rest- Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env+ Just value -> value ++ ppLine env rest+ Nothing -> error $ "Undefined macro: `" ++ name ++ " Env: " ++ show env where- name = takeWhile+ name =+ takeWhile (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) a rest = drop (length name) a
src/Verismith/Verilog/Quote.hs view
@@ -1,30 +1,29 @@-{-|-Module : Verismith.Verilog.Quote-Description : QuasiQuotation for verilog code in Haskell.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--QuasiQuotation for verilog code in Haskell.--}- {-# LANGUAGE TemplateHaskell #-} +-- |+-- Module : Verismith.Verilog.Quote+-- Description : QuasiQuotation for verilog code in Haskell.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- QuasiQuotation for verilog code in Haskell. module Verismith.Verilog.Quote- ( verilog- )+ ( verilog,+ ) where -import Data.Data-import qualified Data.Text as T-import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Verismith.Verilog.Parser+import Data.Data+import qualified Data.Text as T+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Verismith.Verilog.AST (Verilog)+import Verismith.Verilog.Parser -liftDataWithText :: Data a => a -> Q Exp+liftDataWithText :: (Data a) => a -> Q Exp liftDataWithText = dataToExpQ $ fmap liftText . cast liftText :: T.Text -> Q Exp@@ -33,18 +32,19 @@ -- | Quasiquoter for verilog, so that verilog can be written inline and be -- parsed to an AST at compile time. verilog :: QuasiQuoter-verilog = QuasiQuoter- { quoteExp = quoteVerilog- , quotePat = undefined- , quoteType = undefined- , quoteDec = undefined+verilog =+ QuasiQuoter+ { quoteExp = quoteVerilog,+ quotePat = undefined,+ quoteType = undefined,+ quoteDec = undefined } quoteVerilog :: String -> TH.Q TH.Exp quoteVerilog s = do- loc <- TH.location- let pos = T.pack $ TH.loc_filename loc- v <- case parseVerilog pos (T.pack s) of- Right e -> return e- Left e -> fail $ show e- liftDataWithText v+ loc <- TH.location+ let pos = T.pack $ TH.loc_filename loc+ v <- case parseVerilog pos (T.pack s) of+ Right e -> return e+ Left e -> fail $ show e+ liftDataWithText (v :: Verilog ())
src/Verismith/Verilog/Token.hs view
@@ -1,29 +1,27 @@-{-|-Module : Verismith.Verilog.Token-Description : Tokens for Verilog parsing.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Tokens for Verilog parsing.--}-+-- |+-- Module : Verismith.Verilog.Token+-- Description : Tokens for Verilog parsing.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Tokens for Verilog parsing. module Verismith.Verilog.Token- ( Token(..)- , TokenName(..)- , Position(..)- , tokenString- )+ ( Token (..),+ TokenName (..),+ Position (..),+ tokenString,+ ) where -import Text.Printf+import Text.Printf tokenString :: Token -> String tokenString (Token _ s _) = s -data Position = Position String Int Int deriving Eq+data Position = Position String Int Int deriving (Eq) instance Show Position where show (Position f l c) = printf "%s:%d:%d" f l c
+ src/Verismith/Verilog2005.hs view
@@ -0,0 +1,24 @@+-- Module : Verismith.Verilog2005+-- Description : Verilog 2005 compliant implementation with context free random generation.+-- Copyright : (c) 2023, Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX++module Verismith.Verilog2005+ ( parseVerilog2005,+ genSource,+ runGarbageGeneration,+ NumberProbability,+ CategoricalProbability,+ Verilog2005 (..),+ PrintingOpts (..)+ )+where++import Verismith.Config (CategoricalProbability (..), NumberProbability (..))+import Verismith.Verilog2005.AST+import Verismith.Verilog2005.Generator+import Verismith.Verilog2005.Parser+import Verismith.Verilog2005.PrettyPrinter
+ src/Verismith/Verilog2005/AST.hs view
@@ -0,0 +1,1721 @@+-- Module : Verismith.Verilog2005.AST+-- Description : Partial Verilog 2005 AST.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Verismith.Verilog2005.AST+ ( GenMinTypMax (..),+ CMinTypMax,+ MinTypMax,+ Identifier (..),+ Identified (..),+ UnaryOperator (..),+ BinaryOperator (..),+ Number (..),+ GenPrim (..),+ HierIdent (..),+ GenDimRange (..),+ DimRange,+ CDimRange,+ GenExpr (..),+ CExpr (..),+ Expr (..),+ Attribute (..),+ Attributes,+ Attributed (..),+ AttrIded (..),+ Range2 (..),+ GenRangeExpr (..),+ RangeExpr,+ CRangeExpr,+ NumIdent (..),+ Delay3 (..),+ Delay2 (..),+ Delay1 (..),+ SignRange (..),+ SpecTerm (..),+ EventPrefix (..),+ Dir (..),+ AbsType (..),+ ComType (..),+ NetType (..),+ Strength (..),+ DriveStrength (..),+ dsDefault,+ ChargeStrength (..),+ LValue (..),+ NetLValue,+ VarLValue,+ Assign (..),+ NetAssign,+ VarAssign,+ Parameter (..),+ ParamOver (..),+ ParamAssign (..),+ PortAssign (..),+ EventPrim (..),+ EventControl (..),+ DelayEventControl (..),+ ProcContAssign (..),+ LoopStatement (..),+ FCaseItem (..),+ CaseItem (..),+ FunctionStatement (..),+ AttrFStmt,+ MybFStmt,+ Statement (..),+ AttrStmt,+ MybStmt,+ NInputType (..),+ EdgeDesc (..),+ InstanceName (..),+ GICMos (..),+ GIEnable (..),+ GIMos (..),+ GINIn (..),+ GINOut (..),+ GIPassEn (..),+ GIPass (..),+ GIPull (..),+ TimingCheckEvent (..),+ ControlledTimingCheckEvent (..),+ STCArgs (..),+ STCAddArgs (..),+ ModulePathCondition (..),+ SpecPath (..),+ PathDelayValue (..),+ SpecifyItem (..),+ SpecifySingleItem,+ SpecifyBlockedItem,+ SpecParamDecl (..),+ NetProp (..),+ NetDecl (..),+ NetInit (..),+ BlockDecl (..),+ StdBlockDecl (..),+ TFBlockDecl (..),+ GenCaseItem (..),+ UDPInst (..),+ ModInst (..),+ UknInst (..),+ ModGenCondItem (..),+ GenerateCondBlock (..),+ ModGenItem (..),+ ModGenBlockedItem,+ ModGenSingleItem,+ ModuleItem (..),+ GenerateBlock,+ ModuleBlock (..),+ SigLevel (..),+ ZOX (..),+ CombRow (..),+ Edge (..),+ SeqIn (..),+ SeqRow (..),+ PrimTable (..),+ PrimPort (..),+ PrimitiveBlock (..),+ Dot1Ident (..),+ Cell_inst (..),+ LLU (..),+ ConfigItem (..),+ ConfigBlock (..),+ Verilog2005 (..),+ SystemFunction (..),+ Logic (..),+ sfMap,+ BXZ (..),+ OXZ (..),+ HXZ (..),+ hiPath,+ mbIdent,+ pbIdent,+ _CIInst,+ ciCell_inst,+ cbIdent,+ cbBody,+ )+where++import Control.Lens+import Data.Functor.Compose+import Data.Functor.Classes+import Data.ByteString (ByteString)+import Data.ByteString.Internal (c2w, packChars)+import Data.Data+import Data.Data.Lens+import Data.String (IsString (..))+import Text.Show (showListWith)+import Text.Printf (printf)+import qualified Data.HashMap.Strict as HashMap+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Vector.Unboxed as V+import GHC.Generics (Generic)+import Numeric.Natural+import Verismith.Verilog2005.Token (BXZ (..), HXZ (..), OXZ (..), ZOX (..))++-- | Minimum, Typical, Maximum+data GenMinTypMax et+ = MTMSingle !et+ | MTMFull+ { _mtmMin :: !et,+ _mtmTyp :: !et,+ _mtmMax :: !et+ }+ deriving (Show, Eq, Data, Generic)++type CMinTypMax = GenMinTypMax CExpr++type MinTypMax = GenMinTypMax Expr++-- | Identifier, do not use for other things (like a string literal), used for biplate+newtype Identifier = Identifier ByteString+ deriving (Show, Eq, Data, Generic)++instance IsString Identifier where+ fromString =+ Identifier . packChars . concatMap+ (\c -> if ' ' < c && c <= '~' then [c] else printf "\\%02x" c)++-- | Quickly add an identifier to all members of a sum type, other uses are discouraged+data Identified t = Identified {_identIdent :: !Identifier, _identData :: !t}+ deriving (Show, Eq, Data, Generic)++instance Functor Identified where+ fmap f (Identified i x) = Identified i $ f x++showHelper :: (Int -> a -> ShowS) -> Identified a -> ShowS+showHelper fp (Identified i x) = showString "Identified " . shows i . showChar ' ' . fp 0 x++instance Show1 Identified where+ liftShowsPrec fp _ p = showHelper fp+ liftShowList fp _ = showListWith $ showHelper fp+instance Eq1 Identified where+ liftEq f (Identified ia a) (Identified ib b) = ia == ib && f a b++-- | Unary operators+data UnaryOperator+ = UnPlus+ | UnMinus+ | UnLNot+ | UnNot+ | UnAnd+ | UnNand+ | UnOr+ | UnNor+ | UnXor+ | UnXNor+ deriving (Eq, Data, Generic, Enum, Bounded)++instance Show UnaryOperator where+ show x = case x of+ UnPlus -> "+"+ UnMinus -> "-"+ UnLNot -> "!"+ UnNot -> "~"+ UnAnd -> "&"+ UnNand -> "~&"+ UnOr -> "|"+ UnNor -> "~|"+ UnXor -> "^"+ UnXNor -> "~^"++-- | Binary operators+data BinaryOperator+ = BinPlus+ | BinMinus+ | BinTimes+ | BinDiv+ | BinMod+ | BinEq+ | BinNEq+ | BinCEq+ | BinCNEq+ | BinLAnd+ | BinLOr+ | BinLT+ | BinLEq+ | BinGT+ | BinGEq+ | BinAnd+ | BinOr+ | BinXor+ | BinXNor+ | BinPower+ | BinLSL+ | BinLSR+ | BinASL+ | BinASR+ deriving (Eq, Data, Generic, Enum, Bounded)++instance Show BinaryOperator where+ show x = case x of+ BinPlus -> "+"+ BinMinus -> "-"+ BinTimes -> "*"+ BinDiv -> "/"+ BinMod -> "%"+ BinEq -> "=="+ BinNEq -> "!="+ BinCEq -> "==="+ BinCNEq -> "!=="+ BinLAnd -> "&&"+ BinLOr -> "||"+ BinLT -> "<"+ BinLEq -> "<="+ BinGT -> ">"+ BinGEq -> ">="+ BinAnd -> "&"+ BinOr -> "|"+ BinXor -> "^"+ BinXNor -> "~^"+ BinPower -> "**"+ BinLSL -> "<<"+ BinLSR -> ">>"+ BinASL -> "<<<"+ BinASR -> ">>>"++data Number+ = NBinary !(NonEmpty BXZ)+ | NOctal !(NonEmpty OXZ)+ | NDecimal !Natural+ | NHex !(NonEmpty HXZ)+ | NXZ !Bool+ deriving (Show, Eq, Data, Generic)++-- | Parametric primary expression+data GenPrim i r a+ = PrimNumber+ { _pnSize :: !(Maybe Natural),+ _pnSigned :: !Bool,+ _pnValue :: !Number+ }+ | PrimReal !ByteString+ | PrimIdent+ { _piIdent :: !i,+ _piSub :: !r+ }+ | PrimConcat !(NonEmpty (GenExpr i r a))+ | PrimMultConcat+ { _pmcMul :: !(GenExpr Identifier (Maybe CRangeExpr) a),+ _pmcExpr :: !(NonEmpty (GenExpr i r a))+ }+ | PrimFun+ { _pfIdent :: !i,+ _pfAttr :: !a,+ _pfArg :: ![GenExpr i r a]+ }+ | PrimSysFun+ { _psfIdent :: !ByteString,+ _psfArg :: ![GenExpr i r a]+ }+ | PrimMinTypMax !(GenMinTypMax (GenExpr i r a))+ | PrimString !ByteString+ deriving (Show, Eq, Data, Generic)++-- | Hierarchical identifier+data HierIdent = HierIdent {_hiPath :: ![(Identifier, Maybe CExpr)], _hiIdent :: !Identifier}+ deriving (Show, Eq, Data, Generic)++-- | Indexing for dimension and range+data GenDimRange e = GenDimRange {_gdrDim :: ![e], _gdrRange :: !(GenRangeExpr e)}+ deriving (Show, Eq, Data, Generic)++type DimRange = GenDimRange Expr++type CDimRange = GenDimRange CExpr++-- | Parametric expression+data GenExpr i r a+ = ExprPrim !(GenPrim i r a)+ | ExprUnOp+ { _euOp :: !UnaryOperator,+ _euAttr :: !a,+ _euPrim :: !(GenPrim i r a)+ }+ | ExprBinOp+ { _ebLhs :: !(GenExpr i r a),+ _ebOp :: !BinaryOperator,+ _ebAttr :: !a,+ _ebRhs :: !(GenExpr i r a)+ }+ | ExprCond+ { _ecCond :: !(GenExpr i r a),+ _ecAttr :: !a,+ _ecTrue :: !(GenExpr i r a),+ _ecFalse :: !(GenExpr i r a)+ }+ deriving (Show, Eq, Data, Generic)++instance (Data i, Data r, Data a) => Plated (GenExpr i r a) where+ plate = uniplate++newtype CExpr = CExpr (GenExpr Identifier (Maybe CRangeExpr) Attributes)+ deriving (Show, Eq, Data, Generic)++newtype Expr = Expr (GenExpr HierIdent (Maybe DimRange) Attributes)+ deriving (Show, Eq, Data, Generic)++-- | Attributes which can be set to various nodes in the AST.+data Attribute = Attribute+ { _attrIdent :: !ByteString,+ _attrValue :: !(Maybe (GenExpr Identifier (Maybe CRangeExpr) ()))+ }+ deriving (Show, Eq, Data, Generic)++type Attributes = [[Attribute]]++data Attributed t = Attributed {_attrAttr :: !Attributes, _attrData :: !t}+ deriving (Show, Eq, Data, Generic)++instance Functor Attributed where+ fmap f (Attributed a x) = Attributed a $ f x++instance Applicative Attributed where+ pure = Attributed []+ (<*>) (Attributed a1 f) (Attributed a2 x) = Attributed (a1 <> a2) $ f x++instance Foldable Attributed where+ foldMap f (Attributed _ x) = f x++instance Traversable Attributed where+ sequenceA (Attributed a x) = fmap (Attributed a) x++data AttrIded t = AttrIded {_aiAttr :: !Attributes, _aiIdent :: !Identifier, _aiData :: !t}+ deriving (Show, Eq, Data, Generic)++instance Functor AttrIded where+ fmap f (AttrIded a s x) = AttrIded a s $ f x++-- | Range2+data Range2 = Range2 {_r2MSB :: !CExpr, _r2LSB :: !CExpr}+ deriving (Show, Eq, Data, Generic)++-- | Range expressions+data GenRangeExpr e+ = GRESingle !e+ | GREPair !Range2+ | GREBaseOff+ { _greBase :: !e,+ _greMin_plus :: !Bool,+ _greOffset :: !CExpr+ }+ deriving (Show, Eq, Data, Generic)++type RangeExpr = GenRangeExpr Expr++type CRangeExpr = GenRangeExpr CExpr++-- TODO? this can definitely be omitted and expressed as a MTM+-- | Number or Identifier+data NumIdent+ = NIIdent !Identifier+ | NIReal !ByteString+ | NINumber !Natural+ deriving (Show, Eq, Data, Generic)++-- TODO? Base and 1 can be expressed as 3, not 2 though, option delay means delay 0+-- | Delay3+data Delay3+ = D3Base !NumIdent+ | D31 !MinTypMax+ | D32 { _d32Rise :: !MinTypMax, _d32Fall :: !MinTypMax }+ | D33 { _d33Rise :: !MinTypMax, _d33Fall :: !MinTypMax, _d33HighZ :: !MinTypMax }+ deriving (Show, Eq, Data, Generic)++-- | Delay2+data Delay2+ = D2Base !NumIdent+ | D21 !MinTypMax+ | D22 { _d22Rise :: !MinTypMax, _d22Fall :: !MinTypMax }+ deriving (Show, Eq, Data, Generic)++-- | Delay1+data Delay1+ = D1Base !NumIdent+ | D11 !MinTypMax+ deriving (Show, Eq, Data, Generic)++-- | Signedness and range are often together+data SignRange = SignRange {_srSign :: !Bool, _srRange :: !(Maybe Range2)}+ deriving (Show, Eq, Data, Generic)++-- | Specify terminal+data SpecTerm = SpecTerm {_stIdent :: !Identifier, _stRange :: !(Maybe CRangeExpr)}+ deriving (Show, Eq, Data, Generic)++-- | Event expression prefix+data EventPrefix = EPAny | EPPos | EPNeg+ deriving (Show, Eq, Bounded, Enum, Data, Generic)++-- | Port datatransfer directions+data Dir = DirIn | DirOut | DirInOut+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show Dir where+ show x = case x of DirIn -> "input"; DirOut -> "output"; DirInOut -> "inout"++-- | Abstract types for variables, parameters, functions and tasks+data AbsType = ATInteger | ATReal | ATRealtime | ATTime+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show AbsType where+ show x = case x of+ ATInteger -> "integer"+ ATReal -> "real"+ ATRealtime -> "realtime"+ ATTime -> "time"++-- | Function, parameter and task type+data ComType t+ = CTAbstract !AbsType+ | CTConcrete+ { _ctcExtra :: !t,+ _ctcSignRange :: !SignRange+ }+ deriving (Show, Eq, Data, Generic)++-- | Net type+data NetType+ = NTSupply1+ | NTSupply0+ | NTTri+ | NTTriAnd+ | NTTriOr+ | NTTri1+ | NTTri0+ | NTUwire+ | NTWire+ | NTWAnd+ | NTWOr+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show NetType where+ show x = case x of+ NTSupply1 -> "supply1"+ NTSupply0 -> "supply0"+ NTTri -> "tri"+ NTTriAnd -> "triand"+ NTTriOr -> "trior"+ NTTri1 -> "tri1"+ NTTri0 -> "tri0"+ NTUwire -> "uwire"+ NTWire -> "wire"+ NTWAnd -> "wand"+ NTWOr -> "wor"++-- | Net drive strengths+data Strength = StrSupply | StrStrong {-default-} | StrPull | StrWeak+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show Strength where+ show x = case x of+ StrSupply -> "supply"+ StrStrong -> "strong"+ StrPull -> "pull"+ StrWeak -> "weak"++data DriveStrength+ = DSNormal+ { _ds0 :: !Strength,+ _ds1 :: !Strength+ }+ | DSHighZ+ { _dsHZ :: !Bool,+ _dsStr :: !Strength+ }+ deriving (Show, Eq, Data, Generic)++dsDefault = DSNormal {_ds0 = StrStrong, _ds1 = StrStrong}++-- | Capacitor charge+data ChargeStrength = CSSmall | CSMedium {-default-} | CSLarge+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show ChargeStrength where+ show x = case x of CSSmall -> "(small)"; CSMedium -> "(medium)"; CSLarge -> "(large)"++-- | Left side of assignments+data LValue dr+ = LVSingle+ { _lvIdent :: !HierIdent,+ _lvDimRange :: !(Maybe dr)+ }+ | LVConcat !(NonEmpty (LValue dr))+ deriving (Show, Eq, Data, Generic)++type NetLValue = LValue CDimRange++type VarLValue = LValue DimRange++-- | Assignment+data Assign dr = Assign {_aLValue :: !(LValue dr), _aValue :: !Expr}+ deriving (Show, Eq, Data, Generic)++type NetAssign = Assign CDimRange+type VarAssign = Assign DimRange++-- | Parameter+data Parameter = Parameter {_paramType :: !(ComType ()), _paramValue :: !CMinTypMax}+ deriving (Show, Eq, Data, Generic)++-- | DefParam assignment+data ParamOver = ParamOver {_poIdent :: !HierIdent, _poValue :: !CMinTypMax}+ deriving (Show, Eq, Data, Generic)++-- | Parameter assignment list+data ParamAssign+ = ParamPositional ![Expr]+ | ParamNamed ![Identified (Maybe MinTypMax)]+ deriving (Show, Eq, Data, Generic)++-- | Port assignment list+data PortAssign+ = PortNamed ![AttrIded (Maybe Expr)]+ | PortPositional ![Attributed (Maybe Expr)]+ deriving (Show, Eq, Data, Generic)++-- | Event primitive+data EventPrim = EventPrim {_epOp :: !EventPrefix, _epExpr :: !Expr}+ deriving (Show, Eq, Data, Generic)++-- | Event control+data EventControl+ = ECIdent !HierIdent+ | ECExpr !(NonEmpty EventPrim)+ | ECDeps+ deriving (Show, Eq, Data, Generic)++-- | Delay or Event control+data DelayEventControl+ = DECDelay !Delay1+ | DECEvent !EventControl+ | DECRepeat+ { _decrExpr :: !Expr,+ _decrEvent :: !EventControl+ }+ deriving (Show, Eq, Data, Generic)++-- | Procedural continuous assignment+data ProcContAssign+ = PCAAssign !VarAssign+ | PCADeassign !VarLValue+ | PCAForce !(Either VarAssign NetAssign)+ | PCARelease !(Either VarLValue NetLValue)+ deriving (Show, Eq, Data, Generic)++-- | Loop statement+data LoopStatement+ = LSForever+ | LSRepeat !Expr+ | LSWhile !Expr+ | LSFor+ { _lsfInit :: !VarAssign,+ _lsfCond :: !Expr,+ _lsfUpd :: !VarAssign+ }+ deriving (Show, Eq, Data, Generic)++-- | Case item+data FCaseItem = FCaseItem {_fciPat :: !(NonEmpty Expr), _fciVal :: !MybFStmt}+ deriving (Show, Eq, Data, Generic)+data CaseItem = CaseItem {_ciPat :: !(NonEmpty Expr), _ciVal :: !MybStmt}+ deriving (Show, Eq, Data, Generic)++-- | Function statement, more limited than general statement because they are purely combinational+data FunctionStatement+ = FSBlockAssign !VarAssign+ | FSCase+ { _fscType :: !ZOX,+ _fscExpr :: !Expr,+ _fscBody :: ![FCaseItem],+ _fscDef :: !MybFStmt+ }+ | FSIf+ { _fsiExpr :: !Expr,+ _fsiTrue :: !MybFStmt,+ _fsiFalse :: !MybFStmt+ }+ | FSDisable !HierIdent+ | FSLoop+ { _fslHead :: !LoopStatement,+ _fslBody :: !AttrFStmt+ }+ | FSBlock+ { _fsbHeader :: !(Maybe (Identifier, [AttrIded StdBlockDecl])),+ _fsbPar_seq :: !Bool,+ _fsbStmt :: ![AttrFStmt]+ }+ deriving (Show, Eq, Data, Generic)++instance Plated FunctionStatement where+ plate = uniplate++type AttrFStmt = Attributed FunctionStatement++type MybFStmt = Attributed (Maybe FunctionStatement)++-- | Statement+data Statement+ = SBlockAssign+ { _sbaBlock :: !Bool,+ _sbaAssign :: !VarAssign,+ _sbaDelev :: !(Maybe DelayEventControl)+ }+ | SCase+ { _scType :: !ZOX,+ _scExpr :: !Expr,+ _scBody :: ![CaseItem],+ _scDef :: !MybStmt+ }+ | SIf+ { _siExpr :: !Expr,+ _siTrue :: !MybStmt,+ _siFalse :: !MybStmt+ }+ | SDisable !HierIdent+ | SEventTrigger+ { _setIdent :: !HierIdent,+ _setIndex :: ![Expr]+ }+ | SLoop+ { _slHead :: !LoopStatement,+ _slBody :: !AttrStmt+ }+ | SProcContAssign !ProcContAssign+ | SProcTimingControl+ { _sptcControl :: !(Either Delay1 EventControl),+ _sptcStmt :: !MybStmt+ }+ | SBlock+ { _sbHeader :: !(Maybe (Identifier, [AttrIded StdBlockDecl])),+ _sbPar_seq :: !Bool,+ _sbStmt :: ![AttrStmt]+ }+ | SSysTaskEnable+ { _ssteIdent :: !ByteString,+ _ssteArgs :: ![Maybe Expr]+ }+ | STaskEnable+ { _steIdent :: !HierIdent,+ _steArgs :: ![Expr]+ }+ | SWait+ { _swExpr :: !Expr,+ _swStmt :: !MybStmt+ }+ deriving (Show, Eq, Data, Generic)++instance Plated Statement where+ plate = uniplate++type AttrStmt = Attributed Statement++type MybStmt = Attributed (Maybe Statement)++-- | N-input logic gate types+data NInputType = NITAnd | NITOr | NITXor+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show NInputType where+ show x = case x of NITAnd -> "and"; NITOr -> "or"; NITXor -> "xor"++-- | Instance name+data InstanceName = InstanceName { _INIdent :: !Identifier, _INRange :: !(Maybe Range2) }+ deriving (Show, Eq, Data, Generic)++-- | Gate instances+data GICMos = GICMos+ { _gicmName :: !(Maybe InstanceName),+ _gicmOutput :: !NetLValue,+ _gicmInput :: !Expr,+ _gicmNControl :: !Expr,+ _gicmPControl :: !Expr+ }+ deriving (Show, Eq, Data, Generic)++data GIEnable = GIEnable+ { _gieName :: !(Maybe InstanceName),+ _gieOutput :: !NetLValue,+ _gieInput :: !Expr,+ _gieEnable :: !Expr+ }+ deriving (Show, Eq, Data, Generic)++data GIMos = GIMos+ { _gimName :: !(Maybe InstanceName),+ _gimOutput :: !NetLValue,+ _gimInput :: !Expr,+ _gimEnable :: !Expr+ }+ deriving (Show, Eq, Data, Generic)++data GINIn = GINIn+ { _giniName :: !(Maybe InstanceName),+ _giniOutput :: !NetLValue,+ _giniInput :: !(NonEmpty Expr)+ }+ deriving (Show, Eq, Data, Generic)++data GINOut = GINOut+ { _ginoName :: !(Maybe InstanceName),+ _ginoOutput :: !(NonEmpty NetLValue),+ _ginoInput :: !Expr+ }+ deriving (Show, Eq, Data, Generic)++data GIPassEn = GIPassEn+ { _gipeName :: !(Maybe InstanceName),+ _gipeLhs :: !NetLValue,+ _gipeRhs :: !NetLValue,+ _gipeEnable :: !Expr+ }+ deriving (Show, Eq, Data, Generic)++data GIPass = GIPass+ { _gipsName :: !(Maybe InstanceName),+ _gipsLhs :: !NetLValue,+ _gipsRhs :: !NetLValue+ }+ deriving (Show, Eq, Data, Generic)++data GIPull = GIPull+ { _giplName :: !(Maybe InstanceName),+ _giplOutput :: !NetLValue+ }+ deriving (Show, Eq, Data, Generic)++-- | Edge descriptor, a 6 Bool array (01, 0x, 10, 1x, x0, x1)+type EdgeDesc = V.Vector Bool++-- | Timing check (controlled) event+data TimingCheckEvent = TimingCheckEvent+ { _tceEvCtl :: !(Maybe EdgeDesc),+ _tceSpecTerm :: !SpecTerm,+ _tceTimChkCond :: !(Maybe (Bool, Expr))+ }+ deriving (Show, Eq, Data, Generic)++data ControlledTimingCheckEvent = ControlledTimingCheckEvent+ { _ctceEvCtl :: !EdgeDesc,+ _ctceSpecTerm :: !SpecTerm,+ _ctceTimChkCond :: !(Maybe (Bool, Expr))+ }+ deriving (Show, Eq, Data, Generic)++-- | System timing check common arguments+data STCArgs = STCArgs+ { _stcaDataEvent :: !TimingCheckEvent,+ _stcaRefEvent :: !TimingCheckEvent,+ _stcaTimChkLim :: !Expr,+ _stcaNotifier :: !(Maybe Identifier)+ }+ deriving (Show, Eq, Data, Generic)++-- | Setuphold and Recrem additionnal arguments+data STCAddArgs = STCAddArgs+ { _stcaaTimChkLim :: !Expr,+ _stcaaStampCond :: !(Maybe MinTypMax),+ _stcaaChkTimCond :: !(Maybe MinTypMax),+ _stcaaDelayedRef :: !(Maybe (Identified (Maybe CMinTypMax))),+ _stcaaDelayedData :: !(Maybe (Identified (Maybe CMinTypMax)))+ }+ deriving (Show, Eq, Data, Generic)++-- | Module path condition+data ModulePathCondition+ = MPCCond !(GenExpr Identifier () Attributes)+ | MPCNone+ | MPCAlways+ deriving (Show, Eq, Data, Generic)++-- | Specify path declaration+data SpecPath+ = SPParallel+ { _sppInput :: !SpecTerm,+ _sppOutput :: !SpecTerm+ }+ | SPFull+ { _spfInput :: !(NonEmpty SpecTerm),+ _spfOutput :: !(NonEmpty SpecTerm)+ }+ deriving (Show, Eq, Data, Generic)++-- | Specify Item path delcaration delay value list+data PathDelayValue+ = PDV1 !CMinTypMax+ | PDV2 !CMinTypMax !CMinTypMax+ | PDV3 !CMinTypMax !CMinTypMax !CMinTypMax+ | PDV6 !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax+ | PDV12+ !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax+ !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax !CMinTypMax+ deriving (Show, Eq, Data, Generic)++-- | Specify block item+-- | f is either Identity or NonEmpty+-- | it is used to abstract between several specify items in a block and a single comma separated one+data SpecifyItem f+ = SISpecParam+ { _sipcRange :: !(Maybe Range2),+ _sipcDecl :: !(f SpecParamDecl)+ }+ | SIPulsestyleOnevent !(f SpecTerm)+ | SIPulsestyleOndetect !(f SpecTerm)+ | SIShowcancelled !(f SpecTerm)+ | SINoshowcancelled !(f SpecTerm)+ | SIPathDeclaration+ { _sipdCond :: !ModulePathCondition,+ _sipdConn :: !SpecPath,+ _sipdPolarity :: !(Maybe Bool),+ _sipdEDS :: !(Maybe (Expr, Maybe Bool)),+ _sipdValue :: !PathDelayValue+ }+ | SISetup !STCArgs+ | SIHold !STCArgs+ | SISetupHold+ { _sishArgs :: !STCArgs,+ _sishAddArgs :: !STCAddArgs+ }+ | SIRecovery !STCArgs+ | SIRemoval !STCArgs+ | SIRecrem+ { _sirArgs :: !STCArgs,+ _sirAddArgs :: !STCAddArgs+ }+ | SISkew !STCArgs+ | SITimeSkew+ { _sitsArgs :: !STCArgs,+ _sitsEvBased :: !(Maybe CExpr),+ _sitsRemActive :: !(Maybe CExpr)+ }+ | SIFullSkew+ { _sifsArgs :: !STCArgs,+ _sifsTimChkLim :: !Expr,+ _sifsEvBased :: !(Maybe CExpr),+ _sifsRemActive :: !(Maybe CExpr)+ }+ | SIPeriod+ { _sipCRefEvent :: !ControlledTimingCheckEvent,+ _sipTimCtlLim :: !Expr,+ _sipNotif :: !(Maybe Identifier)+ }+ | SIWidth+ { _siwRefEvent :: !ControlledTimingCheckEvent,+ _siwTimCtlLim :: !Expr,+ _siwThresh :: !(Maybe CExpr),+ _siwNotif :: !(Maybe Identifier)+ }+ | SINoChange+ { _sincRefEvent :: !TimingCheckEvent,+ _sincDataEvent :: !TimingCheckEvent,+ _sincStartEdgeOff :: !MinTypMax,+ _sincEndEdgeOff :: !MinTypMax,+ _sincNotif :: !(Maybe Identifier)+ }++deriving instance (Show1 f, forall a. Show a => Show (f a)) => Show (SpecifyItem f)+deriving instance (Eq1 f, forall a. Eq a => Eq (f a)) => Eq (SpecifyItem f)+deriving instance (Typeable f, forall a. Data a => Data (f a)) => Data (SpecifyItem f)+deriving instance (forall a. Generic a => Generic (f a)) => Generic (SpecifyItem f)++type SpecifySingleItem = SpecifyItem NonEmpty+type SpecifyBlockedItem = SpecifyItem Identity++-- | Specparam declaration+data SpecParamDecl+ = SPDAssign+ { _spdaIdent :: !Identifier,+ _spdaValue :: !CMinTypMax+ }+ | SPDPathPulse -- Not completely accurate input/output as it is ambiguous+ { _spdpInOut :: !(Maybe (SpecTerm, SpecTerm)),+ _spdpReject :: !CMinTypMax,+ _spdpError :: !CMinTypMax+ }+ deriving (Show, Eq, Data, Generic)++-- | Net common properties+data NetProp = NetProp+ { _npSigned :: !Bool,+ _npVector :: !(Maybe (Maybe Bool, Range2)),+ _npDelay :: !(Maybe Delay3)+ }+ deriving (Show, Eq, Data, Generic)++-- | Net declaration+data NetDecl = NetDecl {_ndIdent :: !Identifier, _ndDim :: ![Range2]}+ deriving (Show, Eq, Data, Generic)++-- | Net initialisation+data NetInit = NetInit {_niIdent :: !Identifier, _niValue :: !Expr}+ deriving (Show, Eq, Data, Generic)++-- | Block declaration+-- | t is used to abstract between block_decl and modgen_decl+-- | f is used to abstract between the separated and grouped modgen_item+data BlockDecl f t+ = BDReg+ { _bdrgSR :: !SignRange,+ _bdrgData :: !(f t)+ }+ | BDInt !(f t)+ | BDReal !(f t)+ | BDTime !(f t)+ | BDRealTime !(f t)+ | BDEvent !(f [Range2])+ | BDLocalParam+ { _bdlpType :: !(ComType ()),+ _bdlpValue :: !(f CMinTypMax)+ }++deriving instance (Show t, forall a. Show a => Show (f a)) => Show (BlockDecl f t)+deriving instance (Eq t, forall a. Eq a => Eq (f a)) => Eq (BlockDecl f t)+deriving instance (Typeable t, Data t, Typeable f, forall a. Data a => Data (f a)) => Data (BlockDecl f t)+deriving instance (Generic t, forall a. Generic a => Generic (f a)) => Generic (BlockDecl f t)++-- | Block item declaration (for statement blocks [begin/fork], tasks, and functions)+data StdBlockDecl+ = SBDBlockDecl !(BlockDecl Identity [Range2])+ | SBDParameter !Parameter+ deriving (Show, Eq, Data, Generic)++-- | Task and Function block declaration+data TFBlockDecl t+ = TFBDStd !StdBlockDecl+ | TFBDPort+ { _tfbdpDir :: !t,+ _tfbdpType :: !(ComType Bool)+ }+ deriving (Show, Eq, Data, Generic)++-- | Case generate branch+data GenCaseItem = GenCaseItem {_gciPat :: !(NonEmpty CExpr), _gciVal :: !GenerateCondBlock}+ deriving (Show, Eq, Data, Generic)++-- | UDP named instantiation+data UDPInst = UDPInst+ { _udpiName :: !(Maybe InstanceName),+ _udpiLValue :: !NetLValue,+ _udpiArgs :: !(NonEmpty Expr)+ }+ deriving (Show, Eq, Data, Generic)++-- | Module named instantiation+data ModInst = ModInst { _miName :: !InstanceName, _miPort :: !PortAssign }+ deriving (Show, Eq, Data, Generic)++-- | Unknown named instantiation+data UknInst = UknInst+ { _uiName :: !InstanceName,+ _uiArg0 :: !NetLValue,+ _uiArgs :: !(NonEmpty Expr)+ }+ deriving (Show, Eq, Data, Generic)++-- | Module or Generate conditional item because scoping rules are special+data ModGenCondItem+ = MGCIIf+ { _mgiiExpr :: !CExpr,+ _mgiiTrue :: !GenerateCondBlock,+ _mgiiFalse :: !GenerateCondBlock+ }+ | MGCICase+ { _mgicExpr :: !CExpr,+ _mgicBranch :: ![GenCaseItem],+ _mgicDefault :: !GenerateCondBlock+ }+ deriving (Show, Eq, Data, Generic)++-- | Generate Block or Conditional Item or nothing because scoping rules are special+data GenerateCondBlock+ = GCBEmpty+ | GCBBlock !GenerateBlock+ | GCBConditional !(Attributed ModGenCondItem)+ deriving (Show, Eq, Data, Generic)++-- | Module or Generate item+-- | f is either Identity or NonEmpty+-- | it is used to abstract between several modgen items in a block and a single comma separated one+data ModGenItem f+ = MGINetInit+ { _mginiType :: !NetType,+ _mginiDrive :: !DriveStrength,+ _mginiProp :: !NetProp,+ _mginiInit :: !(f NetInit)+ }+ | MGINetDecl+ { _mgindType :: !NetType,+ _mgindProp :: !NetProp,+ _mgindDecl :: !(f NetDecl)+ }+ | MGITriD+ { _mgitdDrive :: !DriveStrength,+ _mgitdProp :: !NetProp,+ _mgitdInit :: !(f NetInit)+ }+ | MGITriC+ { _mgitcCharge :: !ChargeStrength,+ _mgitcProp :: !NetProp,+ _mgitcDecl :: !(f NetDecl)+ }+ | MGIBlockDecl !(BlockDecl (Compose f Identified) (Either [Range2] CExpr))+ | MGIGenVar !(f Identifier)+ | MGITask+ { _mgitAuto :: !Bool,+ _mgitIdent :: !Identifier,+ _mgitDecl :: ![AttrIded (TFBlockDecl Dir)],+ _mgitBody :: !MybStmt+ }+ | MGIFunc+ { _mgifAuto :: !Bool,+ _mgifType :: !(Maybe (ComType ())),+ _mgifIdent :: !Identifier,+ _mgifDecl :: ![AttrIded (TFBlockDecl ())],+ _mgifBody :: !FunctionStatement+ }+ | MGIDefParam !(f ParamOver)+ | MGIContAss+ { _mgicaStrength :: !DriveStrength,+ _mgicaDelay :: !(Maybe Delay3),+ _mgicaAssign :: !(f NetAssign)+ }+ | MGICMos+ { _mgicmR :: !Bool,+ _mgicmDelay :: !(Maybe Delay3),+ _mgicmInst :: !(f GICMos)+ }+ | MGIEnable+ { _mgieR :: !Bool,+ _mgie1_0 :: !Bool,+ _mgieStrength :: !DriveStrength,+ _mgieDelay :: !(Maybe Delay3),+ _mgieInst :: !(f GIEnable)+ }+ | MGIMos+ { _mgimR :: !Bool,+ _mgimN_P :: !Bool,+ _mgimDelay :: !(Maybe Delay3),+ _mgimInst :: !(f GIMos)+ }+ | MGINIn+ { _mgininType :: !NInputType,+ _mgininN :: !Bool,+ _mgininStrength :: !DriveStrength,+ _mgininDelay :: !(Maybe Delay2),+ _mgininInst :: !(f GINIn)+ }+ | MGINOut+ { _mginoR :: !Bool,+ _mginoStrength :: !DriveStrength,+ _mginoDelay :: !(Maybe Delay2),+ _mginoInst :: !(f GINOut)+ }+ | MGIPassEn+ { _mgipeR :: !Bool,+ _mgipe1_0 :: !Bool,+ _mgipeDelay :: !(Maybe Delay2),+ _mgipeInst :: !(f GIPassEn)+ }+ | MGIPass+ { _mgipsR :: !Bool,+ _mgipsInst :: !(f GIPass)+ }+ | MGIPull+ { _mgiplUp_down :: !Bool,+ _mgiplStrength :: !DriveStrength,+ _mgiplInst :: !(f GIPull)+ }+ | MGIUDPInst+ { _mgiudpiUDP :: !Identifier,+ _mgiudpiStrength :: !DriveStrength,+ _mgiudpiDelay :: !(Maybe Delay2),+ _mgiudpiInst :: !(f UDPInst)+ }+ | MGIModInst+ { _mgimiMod :: !Identifier,+ _mgimiParams :: !ParamAssign,+ _mgimiInst :: !(f ModInst)+ }+ | MGIUnknownInst -- Sometimes identifying what is instantiated is impossible+ { _mgiuiType :: !Identifier,+ _mgiuiParam :: !(Maybe (Either Expr (Expr, Expr))),+ _mgiuiInst :: !(f UknInst)+ }+ | MGIInitial !AttrStmt+ | MGIAlways !AttrStmt+ | MGILoopGen+ { _mgilgInitIdent :: !Identifier,+ _mgilgInitValue :: !CExpr,+ _mgilgCond :: !CExpr,+ _mgilgUpdIdent :: !Identifier,+ _mgilgUpdValue :: !CExpr,+ _mgilgBody :: !GenerateBlock+ }+ | MGICondItem !ModGenCondItem++deriving instance (Show1 f, forall a. Show a => Show (f a)) => Show (ModGenItem f)+deriving instance (Eq1 f, forall a. Eq a => Eq (f a)) => Eq (ModGenItem f)+deriving instance (Typeable f, forall a. Data a => Data (f a)) => Data (ModGenItem f)+deriving instance (forall a. Generic a => Generic (f a)) => Generic (ModGenItem f)++type ModGenBlockedItem = ModGenItem Identity+type ModGenSingleItem = ModGenItem NonEmpty++instance Plated ModGenBlockedItem where+ plate = uniplate++-- | Module item: body of module+-- | Caution: if MIPort sign is False then it can be overriden by a MGINetDecl/Init+data ModuleItem+ = MIMGI !(Attributed ModGenBlockedItem)+ | MIPort !(AttrIded (Dir, SignRange))+ | MIParameter !(AttrIded Parameter)+ | MIGenReg ![Attributed ModGenBlockedItem]+ | MISpecParam+ { _mispAttribute :: !Attributes,+ _mispRange :: !(Maybe Range2),+ _mispDecl :: !SpecParamDecl+ }+ | MISpecBlock ![SpecifyBlockedItem]+ deriving (Show, Eq, Data, Generic)++type GenerateBlock = Identified [Attributed ModGenBlockedItem]++-- | Module block+-- TODO: remember whether the module is a module or macromodule because implementation dependent+data ModuleBlock = ModuleBlock+ { _mbAttr :: !Attributes,+ _mbIdent :: !Identifier,+ _mbPortInter :: ![Identified [Identified (Maybe CRangeExpr)]],+ _mbBody :: ![ModuleItem],+ _mbTimescale :: !(Maybe (Int, Int)),+ _mbCell :: !Bool,+ _mbPull :: !(Maybe Bool),+ _mbDefNetType :: !(Maybe NetType)+ }+ deriving (Show, Eq, Data, Generic)++-- | Signal level+data SigLevel = L0 | L1 | LX | LQ | LB+ deriving (Eq, Bounded, Enum, Data, Generic)++instance Show SigLevel where+ show x = case x of L0 -> "0"; L1 -> "1"; LX -> "x"; LQ -> "?"; LB -> "b"++-- | Combinatorial table row+data CombRow = CombRow {_crInput :: !(NonEmpty SigLevel), _crOutput :: !ZOX}+ deriving (Show, Eq, Data, Generic)++-- | Edge specifier+data Edge+ = EdgePos_neg !Bool+ | EdgeDesc+ { _edFrom :: !SigLevel,+ _edTo :: !SigLevel+ }+ deriving (Eq, Data, Generic)++instance Show Edge where+ show x = case x of+ EdgePos_neg b -> if b then "p" else "n"+ EdgeDesc LQ LQ -> "*"+ EdgeDesc f t -> '(' : show f ++ show t ++ ")"++-- | Seqential table inputs: a list of input levels with at most 1 edge specifier+data SeqIn+ = SIComb !(NonEmpty SigLevel)+ | SISeq ![SigLevel] !Edge ![SigLevel]+ deriving (Eq, Data, Generic)++instance Show SeqIn where+ show x = case x of+ SIComb l -> concatMap show l+ SISeq l0 e l1 -> concatMap show l0 ++ show e ++ concatMap show l1++-- | Sequential table row+data SeqRow = SeqRow+ { _srowInput :: !SeqIn,+ _srowState :: !SigLevel,+ _srowNext :: !(Maybe ZOX)+ }+ deriving (Show, Eq, Data, Generic)++-- | Primitive transition table+data PrimTable+ = CombTable !(NonEmpty CombRow)+ | SeqTable+ { _stInit :: !(Maybe ZOX),+ _stRow :: !(NonEmpty SeqRow)+ }+ deriving (Show, Eq, Data, Generic)++-- | Primitive port type+data PrimPort+ = PPInput+ | PPOutput+ | PPReg+ | PPOutReg !(Maybe CExpr) -- no sem+ deriving (Show, Eq, Data, Generic)++-- | Primitive block+data PrimitiveBlock = PrimitiveBlock+ { _pbAttr :: !Attributes,+ _pbIdent :: !Identifier,+ _pbOutput :: !Identifier,+ _pbInput :: !(NonEmpty Identifier),+ _pbPortDecl :: !(NonEmpty (AttrIded PrimPort)),+ _pbBody :: !PrimTable+ }+ deriving (Show, Eq, Data, Generic)++-- | Library prefixed cell+data Dot1Ident = Dot1Ident {_d1iLib :: !(Maybe ByteString), _d1iCell :: !Identifier}+ deriving (Show, Eq, Data, Generic)++-- | Cell or instance+data Cell_inst+ = CICell !Dot1Ident+ | CIInst !(NonEmpty Identifier)+ deriving (Show, Eq, Data, Generic)++-- | Liblist or Use+data LLU+ = LLULiblist ![ByteString]+ | LLUUse+ { _lluUIdent :: !Dot1Ident,+ _lluUConfig :: !Bool+ }+ deriving (Show, Eq, Data, Generic)++-- | Items in a config block+data ConfigItem = ConfigItem+ { _ciCell_inst :: !Cell_inst,+ _ciLLU :: !LLU+ }+ deriving (Show, Eq, Data, Generic)++-- | Config Block: Identifier, Design lines, Configuration items+data ConfigBlock = ConfigBlock+ { _cbIdent :: !Identifier,+ _cbDesign :: ![Dot1Ident],+ _cbBody :: ![ConfigItem],+ _cbDef :: ![ByteString]+ }+ deriving (Show, Eq, Data, Generic)++-- | Internal representation of Verilog2005 AST+data Verilog2005 = Verilog2005+ { _vModule :: ![ModuleBlock],+ _vPrimitive :: ![PrimitiveBlock],+ _vConfig :: ![ConfigBlock]+ }+ deriving (Show, Eq, Data, Generic)++instance Semigroup Verilog2005 where+ (<>) v2a v2b =+ v2a+ { _vModule = _vModule v2a <> _vModule v2b,+ _vPrimitive = _vPrimitive v2a <> _vPrimitive v2b,+ _vConfig = _vConfig v2a <> _vConfig v2b+ }++instance Monoid Verilog2005 where+ mempty = Verilog2005 [] [] []++$(makeLenses ''HierIdent)+$(makeLenses ''ModuleBlock)+$(makeLenses ''PrimitiveBlock)+$(makePrisms ''Cell_inst)+$(makeLenses ''ConfigItem)+$(makeLenses ''ConfigBlock)++data Logic = LAnd | LOr | LNand | LNor+ deriving (Eq, Data)++instance Show Logic where+ show x = case x of LAnd -> "and"; LOr -> "or"; LNand -> "nand"; LNor -> "nor"++data SystemFunction+ = SFDisplay+ | SFDisplayb+ | SFDisplayh+ | SFDisplayo+ | SFStrobe+ | SFStrobeb+ | SFStrobeh+ | SFStrobeo+ | SFWrite+ | SFWriteb+ | SFWriteh+ | SFWriteo+ | SFMonitor+ | SFMonitorb+ | SFMonitorh+ | SFMonitoro+ | SFMonitoroff+ | SFMonitoron+ | SFFclose+ | SFFdisplay+ | SFFdisplayb+ | SFFdisplayh+ | SFFdisplayo+ | SFFstrobe+ | SFFstrobeb+ | SFFstrobeh+ | SFFstrobeo+ | SFSwrite+ | SFSwriteb+ | SFSwriteh+ | SFSwriteo+ | SFFscanf+ | SFFread+ | SFFseek+ | SFFflush+ | SFFeof+ | SFSdfannotate+ | SFFopen+ | SFFwrite+ | SFFwriteb+ | SFFwriteh+ | SFFwriteo+ | SFFmonitor+ | SFFmonitorb+ | SFFmonitorh+ | SFFmonitoro+ | SFSformat+ | SFFgetc+ | SFUngetc+ | SFFgets+ | SFSscanf+ | SFRewind+ | SFFtell+ | SFFerror+ | SFReadmemb+ | SFReadmemh+ | SFPrinttimescale+ | SFTimeformat+ | SFFinish+ | SFStop+ | SFQinitialize+ | SFQremove+ | SFQexam+ | SFQadd+ | SFQfull+ | SFRealtime+ | SFTime+ | SFStime+ | SFBitstoreal+ | SFItor+ | SFSigned+ | SFRealtobits+ | SFRtoi+ | SFUnsigned+ | SFRandom+ | SFDisterlang+ | SFDistnormal+ | SFDistt+ | SFDistchisquare+ | SFDistexponential+ | SFDistpoisson+ | SFDistuniform+ | SFClog2+ | SFLn+ | SFLog10+ | SFExp+ | SFSqrt+ | SFPow+ | SFFloor+ | SFCeil+ | SFSin+ | SFCos+ | SFTan+ | SFAsin+ | SFAcos+ | SFAtan+ | SFAtan2+ | SFHypot+ | SFSinh+ | SFCosh+ | SFTanh+ | SFAsinh+ | SFAcosh+ | SFAtanh+ | SFTestplusargs+ | SFValueplusargs+ | SFPla+ { _sfpSync :: !Bool,+ _sfpLogic :: !Logic,+ _sfpPla_arr :: !Bool+ }+ | SFSVPast+ | SFSVStable+ | SFSVRose+ | SFSVFell+ deriving (Eq, Data)++instance Show SystemFunction where+ show x = case x of+ SFDisplay -> "display"+ SFDisplayb -> "displayb"+ SFDisplayh -> "displayh"+ SFDisplayo -> "displayo"+ SFStrobe -> "strobe"+ SFStrobeb -> "strobeb"+ SFStrobeh -> "strobeh"+ SFStrobeo -> "strobeo"+ SFWrite -> "write"+ SFWriteb -> "writeb"+ SFWriteh -> "writeh"+ SFWriteo -> "writeo"+ SFMonitor -> "monitor"+ SFMonitorb -> "monitorb"+ SFMonitorh -> "monitorh"+ SFMonitoro -> "monitoro"+ SFMonitoroff -> "monitoroff"+ SFMonitoron -> "monitoron"+ SFFclose -> "fclose"+ SFFdisplay -> "fdisplay"+ SFFdisplayb -> "fdisplayb"+ SFFdisplayh -> "fdisplayh"+ SFFdisplayo -> "fdisplayo"+ SFFstrobe -> "fstrobe"+ SFFstrobeb -> "fstrobeb"+ SFFstrobeh -> "fstrobeh"+ SFFstrobeo -> "fstrobeo"+ SFSwrite -> "swrite"+ SFSwriteb -> "swriteb"+ SFSwriteh -> "swriteh"+ SFSwriteo -> "swriteo"+ SFFscanf -> "fscanf"+ SFFread -> "fread"+ SFFseek -> "fseek"+ SFFflush -> "fflush"+ SFFeof -> "feof"+ SFSdfannotate -> "sdf_annotate"+ SFFopen -> "fopen"+ SFFwrite -> "fwrite"+ SFFwriteb -> "fwriteb"+ SFFwriteh -> "fwriteh"+ SFFwriteo -> "fwriteo"+ SFFmonitor -> "fmonitor"+ SFFmonitorb -> "fmonitorb"+ SFFmonitorh -> "fmonitorh"+ SFFmonitoro -> "fmonitoro"+ SFSformat -> "sformat"+ SFFgetc -> "fgetc"+ SFUngetc -> "ungetc"+ SFFgets -> "gets"+ SFSscanf -> "sscanf"+ SFRewind -> "rewind"+ SFFtell -> "ftell"+ SFFerror -> "ferror"+ SFReadmemb -> "readmemb"+ SFReadmemh -> "readmemh"+ SFPrinttimescale -> "printtimescale"+ SFTimeformat -> "timeformat"+ SFFinish -> "finish"+ SFStop -> "stop"+ SFQinitialize -> "q_initialize"+ SFQremove -> "q_remove"+ SFQexam -> "q_exam"+ SFQadd -> "q_add"+ SFQfull -> "q_full"+ SFRealtime -> "realtime"+ SFTime -> "time"+ SFStime -> "stime"+ SFBitstoreal -> "bitstoreal"+ SFItor -> "itor"+ SFSigned -> "signed"+ SFRealtobits -> "realtobits"+ SFRtoi -> "rtoi"+ SFUnsigned -> "unsigned"+ SFRandom -> "random"+ SFDisterlang -> "dist_erlang"+ SFDistnormal -> "dist_normal"+ SFDistt -> "dist_t"+ SFDistchisquare -> "dist_chi_square"+ SFDistexponential -> "dist_exponential"+ SFDistpoisson -> "dist_poisson"+ SFDistuniform -> "dist_uniform"+ SFClog2 -> "clog2"+ SFLn -> "ln"+ SFLog10 -> "log10"+ SFExp -> "exp"+ SFSqrt -> "sqrt"+ SFPow -> "pow"+ SFFloor -> "floor"+ SFCeil -> "ceil"+ SFSin -> "sin"+ SFCos -> "cos"+ SFTan -> "tan"+ SFAsin -> "asin"+ SFAcos -> "acos"+ SFAtan -> "atan"+ SFAtan2 -> "atan2"+ SFHypot -> "hypot"+ SFSinh -> "sinh"+ SFCosh -> "cosh"+ SFTanh -> "tanh"+ SFAsinh -> "asinh"+ SFAcosh -> "acosh"+ SFAtanh -> "atanh"+ SFTestplusargs -> "test$plusargs"+ SFValueplusargs -> "value$plusargs"+ SFPla {_sfpSync = True, _sfpLogic = LAnd, _sfpPla_arr = False} -> "sync$and$array"+ SFPla {_sfpSync = True, _sfpLogic = LAnd, _sfpPla_arr = True} -> "sync$and$plane"+ SFPla {_sfpSync = True, _sfpLogic = LOr, _sfpPla_arr = False} -> "sync$or$array"+ SFPla {_sfpSync = True, _sfpLogic = LOr, _sfpPla_arr = True} -> "sync$or$plane"+ SFPla {_sfpSync = True, _sfpLogic = LNand, _sfpPla_arr = False} -> "sync$nand$array"+ SFPla {_sfpSync = True, _sfpLogic = LNand, _sfpPla_arr = True} -> "sync$nand$plane"+ SFPla {_sfpSync = True, _sfpLogic = LNor, _sfpPla_arr = False} -> "sync$nor$array"+ SFPla {_sfpSync = True, _sfpLogic = LNor, _sfpPla_arr = True} -> "sync$nor$plane"+ SFPla {_sfpSync = False, _sfpLogic = LAnd, _sfpPla_arr = False} -> "async$and$array"+ SFPla {_sfpSync = False, _sfpLogic = LAnd, _sfpPla_arr = True} -> "async$and$plane"+ SFPla {_sfpSync = False, _sfpLogic = LOr, _sfpPla_arr = False} -> "async$or$array"+ SFPla {_sfpSync = False, _sfpLogic = LOr, _sfpPla_arr = True} -> "async$or$plane"+ SFPla {_sfpSync = False, _sfpLogic = LNand, _sfpPla_arr = False} -> "async$nand$array"+ SFPla {_sfpSync = False, _sfpLogic = LNand, _sfpPla_arr = True} -> "async$nand$plane"+ SFPla {_sfpSync = False, _sfpLogic = LNor, _sfpPla_arr = False} -> "async$nor$array"+ SFPla {_sfpSync = False, _sfpLogic = LNor, _sfpPla_arr = True} -> "async$nor$plane"+ SFSVPast -> "past"+ SFSVStable -> "stable"+ SFSVRose -> "rose"+ SFSVFell -> "fell"++sfMap :: HashMap.HashMap ByteString SystemFunction+sfMap =+ HashMap.fromList+ [ ("display", SFDisplay),+ ("displayb", SFDisplayb),+ ("displayh", SFDisplayh),+ ("displayo", SFDisplayo),+ ("strobe", SFStrobe),+ ("strobeb", SFStrobeb),+ ("strobeh", SFStrobeh),+ ("strobeo", SFStrobeo),+ ("write", SFWrite),+ ("writeb", SFWriteb),+ ("writeh", SFWriteh),+ ("writeo", SFWriteo),+ ("monitor", SFMonitor),+ ("monitorb", SFMonitorb),+ ("monitorh", SFMonitorh),+ ("monitoro", SFMonitoro),+ ("monitoroff", SFMonitoroff),+ ("monitoron", SFMonitoron),+ ("fclose", SFFclose),+ ("fdisplay", SFFdisplay),+ ("fdisplayb", SFFdisplayb),+ ("fdisplayh", SFFdisplayh),+ ("fdisplayo", SFFdisplayo),+ ("fstrobe", SFFstrobe),+ ("fstrobeb", SFFstrobeb),+ ("fstrobeh", SFFstrobeh),+ ("fstrobeo", SFFstrobeo),+ ("swrite", SFSwrite),+ ("swriteb", SFSwriteb),+ ("swriteh", SFSwriteh),+ ("swriteo", SFSwriteo),+ ("fscanf", SFFscanf),+ ("fread", SFFread),+ ("fseek", SFFseek),+ ("fflush", SFFflush),+ ("feof", SFFeof),+ ("sdf_annotate", SFSdfannotate),+ ("fopen", SFFopen),+ ("fwrite", SFFwrite),+ ("fwriteb", SFFwriteb),+ ("fwriteh", SFFwriteh),+ ("fwriteo", SFFwriteo),+ ("fmonitor", SFFmonitor),+ ("fmonitorb", SFFmonitorb),+ ("fmonitorh", SFFmonitorh),+ ("fmonitoro", SFFmonitoro),+ ("sformat", SFSformat),+ ("fgetc", SFFgetc),+ ("ungetc", SFUngetc),+ ("gets", SFFgets),+ ("sscanf", SFSscanf),+ ("rewind", SFRewind),+ ("ftell", SFFtell),+ ("ferror", SFFerror),+ ("readmemb", SFReadmemb),+ ("readmemh", SFReadmemh),+ ("printtimescale", SFPrinttimescale),+ ("timeformat", SFTimeformat),+ ("finish", SFFinish),+ ("stop", SFStop),+ ("q_initialize", SFQinitialize),+ ("q_remove", SFQremove),+ ("q_exam", SFQexam),+ ("q_add", SFQadd),+ ("q_full", SFQfull),+ ("realtime", SFRealtime),+ ("time", SFTime),+ ("stime", SFStime),+ ("bitstoreal", SFBitstoreal),+ ("itor", SFItor),+ ("signed", SFSigned),+ ("realtobits", SFRealtobits),+ ("rtoi", SFRtoi),+ ("unsigned", SFUnsigned),+ ("random", SFRandom),+ ("dist_erlang", SFDisterlang),+ ("dist_normal", SFDistnormal),+ ("dist_t", SFDistt),+ ("dist_chi_square", SFDistchisquare),+ ("dist_exponential", SFDistexponential),+ ("dist_poisson", SFDistpoisson),+ ("dist_uniform", SFDistuniform),+ ("clog2", SFClog2),+ ("ln", SFLn),+ ("log10", SFLog10),+ ("exp", SFExp),+ ("sqrt", SFSqrt),+ ("pow", SFPow),+ ("floor", SFFloor),+ ("ceil", SFCeil),+ ("sin", SFSin),+ ("cos", SFCos),+ ("tan", SFTan),+ ("asin", SFAsin),+ ("acos", SFAcos),+ ("atan", SFAtan),+ ("atan2", SFAtan2),+ ("hypot", SFHypot),+ ("sinh", SFSinh),+ ("cosh", SFCosh),+ ("tanh", SFTanh),+ ("asinh", SFAsinh),+ ("acosh", SFAcosh),+ ("atanh", SFAtanh),+ ("test$plusargs", SFTestplusargs),+ ("value$plusargs", SFValueplusargs),+ ("sync$and$array", SFPla {_sfpSync = True, _sfpLogic = LAnd, _sfpPla_arr = False}),+ ("sync$and$plane", SFPla {_sfpSync = True, _sfpLogic = LAnd, _sfpPla_arr = True}),+ ("sync$or$array", SFPla {_sfpSync = True, _sfpLogic = LOr, _sfpPla_arr = False}),+ ("sync$or$plane", SFPla {_sfpSync = True, _sfpLogic = LOr, _sfpPla_arr = True}),+ ("sync$nand$array", SFPla {_sfpSync = True, _sfpLogic = LNand, _sfpPla_arr = False}),+ ("sync$nand$plane", SFPla {_sfpSync = True, _sfpLogic = LNand, _sfpPla_arr = True}),+ ("sync$nor$array", SFPla {_sfpSync = True, _sfpLogic = LNor, _sfpPla_arr = False}),+ ("sync$nor$plane", SFPla {_sfpSync = True, _sfpLogic = LNor, _sfpPla_arr = True}),+ ("async$and$array", SFPla {_sfpSync = False, _sfpLogic = LAnd, _sfpPla_arr = False}),+ ("async$and$plane", SFPla {_sfpSync = False, _sfpLogic = LAnd, _sfpPla_arr = True}),+ ("async$or$array", SFPla {_sfpSync = False, _sfpLogic = LOr, _sfpPla_arr = False}),+ ("async$or$plane", SFPla {_sfpSync = False, _sfpLogic = LOr, _sfpPla_arr = True}),+ ("async$nand$array", SFPla {_sfpSync = False, _sfpLogic = LNand, _sfpPla_arr = False}),+ ("async$nand$plane", SFPla {_sfpSync = False, _sfpLogic = LNand, _sfpPla_arr = True}),+ ("async$nor$array", SFPla {_sfpSync = False, _sfpLogic = LNor, _sfpPla_arr = False}),+ ("async$nor$plane", SFPla {_sfpSync = False, _sfpLogic = LNor, _sfpPla_arr = True}),+ ("past", SFSVPast),+ ("stable", SFSVStable),+ ("rose", SFSVRose),+ ("fell", SFSVFell)+ ]
+ src/Verismith/Verilog2005/Generator.hs view
@@ -0,0 +1,1036 @@+-- Module : Verismith.Verilog2005.Generator+-- Description : AST random generator+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : stable+-- Portability : POSIX+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}++module Verismith.Verilog2005.Generator+ ( runGarbageGeneration,+ GarbageOpts,+ GenM,+ defGarbageOpts,+ )+where++import Control.Applicative (liftA2, liftA3)+import Data.Functor.Compose+import Control.Lens hiding ((<.>))+import Control.Monad (join, replicateM)+import Control.Monad.Reader+import Control.Monad.State.Lazy+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.IntMap.Strict as IntMap+import Data.List.NonEmpty (NonEmpty (..), toList)+import qualified Data.List.NonEmpty as NE+import Data.Tuple+import qualified Data.Vector.Unboxed as VU+import Numeric.Natural+import System.Random.MWC.Probability+import Verismith.Config+import Verismith.Utils (mkpair)+import Verismith.Verilog2005.AST+import Verismith.Verilog2005.Lexer+import Verismith.Verilog2005.Randomness++infixl 4 <.>++-- | Compose through several monad+(<.>) :: (Monad m, Applicative m) => m (a -> m b) -> m a -> m b+(<.>) mf mx = join $ mf <*> mx++-- | Attenuate the weight of a categorical probability if told so+-- | This avoids infinite size AST+attenuateCat :: (NonEmpty (Bool, a)) -> Double -> CategoricalProbability -> CategoricalProbability+attenuateCat l d p = case p of+ CPDiscrete wl -> CPDiscrete $ NE.zipWith (\a w -> w * if fst a then d else 1) l wl+ CPBiasedUniform wl wb ->+ let im = IntMap.fromListWith (+) $ map swap wl+ in CPDiscrete $+ NE.map (\(k, a) -> IntMap.findWithDefault wb k im * if fst a then d else 1) $+ NE.zip [0..] l++-- | Attenuate the weight of a numerical probability+-- | by aprroximately multiplying by a factor raised to the value of the outcome+-- | making higer numbers exponentially less likely than smaller ones+-- | This avoids infinite size AST+attenuateNum :: Double -> NumberProbability -> NumberProbability+attenuateNum d p =+ if d == 1+ then p+ else case p of+ NPUniform l h ->+ NPDiscrete $+ if d == 0 then [(1, l)] else NE.fromList (zipWith mkdistrfor [1 ..] [l .. h])+ NPBinomial off t p ->+ if d == 0+ then NPDiscrete [(1, off)]+ else NPBinomial off t $ p * d+ NPNegativeBinomial off pf f ->+ if d == 0+ then NPDiscrete [(1, off)]+ else NPNegativeBinomial off (1 - (1 - pf) * d) f+ NPPoisson off p ->+ if d == 0+ then NPDiscrete [(1, off)]+ else NPPoisson off $ p * d+ NPDiscrete l -> NPDiscrete $ if d == 0 then [NE.head l] else NE.map (uncurry mkdistrfor) l+ NPLinearComb l -> NPLinearComb $ NE.map (\(p, np) -> (p, attenuateNum d np)) l+ where+ mkdistrfor bw n = (bw * d ** fromIntegral n, n)++type GenM' = GenM GarbageOpts++-- | Apply an attenuation multiplier to avoid infinitely deep recursion+applyAttenuation :: Int -> GarbageAttenuationOpts -> GarbageAttenuationOpts+applyAttenuation n x = x & gaoCurrent *~ _gaoDecrease x ** fromIntegral n++tameExprRecursion :: Int -> GenM' a -> GenM' a+tameExprRecursion n = local (_1 . goExpr . geoAttenuation %~ applyAttenuation n)++repeatExprRecursive :: (GarbageOpts -> NumberProbability) -> GenM' a -> GenM' [a]+repeatExprRecursive p m = do+ n <- sampleAttenuatedNum (_geoAttenuation . _goExpr) p+ tameExprRecursion n $ replicateM n m++tameStmtRecursion :: Int -> GenM' a -> GenM' a+tameStmtRecursion n = local (_1 . goStatement . gstoAttenuation %~ applyAttenuation n)++repeatStmtRecursive :: (GarbageOpts -> NumberProbability) -> GenM' a -> GenM' [a]+repeatStmtRecursive p m = do+ n <- sampleAttenuatedNum (_gstoAttenuation . _goStatement) p+ tameStmtRecursion n $ replicateM n m++tameModGenRecursion :: Int -> GenM' a -> GenM' a+tameModGenRecursion n = local (_1 . goGenerate . ggoAttenuation %~ applyAttenuation n)++repeatModGenRecursive :: (GarbageOpts -> NumberProbability) -> GenM' a -> GenM' [a]+repeatModGenRecursive p m = do+ n <- sampleAttenuatedNum (_ggoAttenuation . _goGenerate) p+ tameModGenRecursion n $ replicateM n m++-- | Branching with attenuation+sampleAttenuatedBranch ::+ (GarbageOpts -> GarbageAttenuationOpts)+ -> (GarbageOpts -> CategoricalProbability)+ -> (NonEmpty (Bool, GenM' a))+ -> GenM' a+sampleAttenuatedBranch f p l = do+ gen <- asks snd+ d <- asks $ p . fst+ a <- asks $ _gaoCurrent . f . fst+ join $ sampleIn (toList $ NE.map snd l) gen (attenuateCat l a d)++-- | Number with attenuation+sampleAttenuatedNum ::+ (GarbageOpts -> GarbageAttenuationOpts) -> (GarbageOpts -> NumberProbability) -> GenM' Int+sampleAttenuatedNum f p = do+ gen <- asks snd+ d <- asks $ p . fst+ a <- asks $ _gaoCurrent . f . fst+ sampleNumberProbability gen $ attenuateNum a d++-- | Letters available for simple identifiers+idSimpleLetter :: B.ByteString -- 0-9$ are forbidden as first letters+idSimpleLetter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789$"++digitCharacter :: B.ByteString+digitCharacter = "0123456789"++-- Start of actual generation++garbageSimpleBS :: GenM' B.ByteString+garbageSimpleBS =+ avoidKW <$> sampleFromString (i _gioSimpleLetter) (B.take 53 idSimpleLetter)+ <.> sampleString (i _gioSimpleLetters) (i _gioSimpleLetter) idSimpleLetter+ where+ i x = x . _goIdentifier+ avoidKW fl t =+ let s = B.cons fl t+ in if isKW s+ then do+ x <- sampleFromString (i _gioSimpleLetter) idSimpleLetter+ avoidKW fl $ B.cons x t+ else return s++garbageEscapedBS :: GenM' B.ByteString+garbageEscapedBS =+ B.pack <$> sampleN (i _gioEscapedLetters) (toEnum <$> sampleSegment (i _gioEscapedLetter) 33 126)+ where i x = x . _goIdentifier++garbageBS :: GenM' B.ByteString+garbageBS = choice (_gioEscaped_Simple . _goIdentifier) garbageEscapedBS garbageSimpleBS++garbageIdent :: GenM' Identifier+garbageIdent = Identifier <$> garbageBS++garbageIdentified :: GenM' x -> GenM' (Identified x)+garbageIdentified = liftA2 Identified garbageIdent++garbageSysIdent :: GenM' B.ByteString+garbageSysIdent =+ B.cons <$> sampleFromString (i _gioSystemFirstLetter) idSimpleLetter+ <*> sampleString (i _gioSystemLetters) (i _gioSimpleLetter) idSimpleLetter+ where i x = x . _goIdentifier++garbageHierIdent :: GenM' HierIdent+garbageHierIdent = do+ hip <- repeatExprRecursive _goPathDepth $+ mkpair garbageIdent $ sampleMaybe (_geoDimRange . _goExpr) garbageCExpr+ HierIdent hip <$> garbageIdent++garbageInteger :: GenM' Natural+garbageInteger =+ parseDecimal <$> sampleString (e _geoDecimalSymbols) (e _geoDecimalSymbol) digitCharacter+ where e x = x . _goExpr++garbageReal :: GenM' B.ByteString+garbageReal =+ choice+ (e _geoFixed_Floating)+ ( do+ p <- number+ f <- number+ return $ p <> "." <> f+ )+ ( do+ p <- number+ f <- sampleString (e _geoDecimalSymbols) (e _geoDecimalSymbol) digitCharacter+ s <- sampleFrom (e _geoExponentSign) ["", "+", "-"]+ e <- number+ return $ p <> (if B.null f then "" else B.cons (c2w '.') f) <> "e" <> s <> e+ )+ where+ e x = x . _goExpr+ number = sampleNEString (e _geoDecimalSymbols) (e _geoDecimalSymbol) digitCharacter++garbageNumIdent :: GenM' NumIdent+garbageNumIdent =+ sampleBranch+ _goIntRealIdent+ [ NINumber <$> garbageInteger,+ NIReal <$> garbageReal,+ NIIdent <$> garbageIdent+ ]++garbagePrim :: GenM' i -> Bool -> GenM' r -> GenM' a -> GenM' (GenPrim i r a)+garbagePrim ident attrng grng gattr =+ sampleAttenuatedBranch+ (e _geoAttenuation)+ (e _geoPrimary)+ [ mknum $ NXZ <$> sampleBernoulli (e _geoX_Z),+ mknum $ NBinary <$> sampleNE (e _geoBinarySymbols) (sampleEnum $ e _geoBinarySymbol),+ mknum $ NOctal <$> sampleNE (e _geoOctalSymbols) (sampleEnum $ e _geoOctalSymbol),+ mknum $ NDecimal <$> garbageInteger,+ mknum $ NHex <$> sampleNE (e _geoHexadecimalSymbols) (sampleEnum $ e _geoHexadecimalSymbol),+ (False, PrimReal <$> garbageReal),+ ( False,+ PrimString . makeString . map w2c+ <$> sampleN (e _geoStringCharacters) (sampleEnum $ e _geoStringCharacter)+ ),+ (attrng, PrimIdent <$> ident <*> grng),+ ( True,+ do+ n <- succ <$> sNum (e _geoConcatenations)+ PrimConcat . NE.fromList <$> tameExprRecursion n (replicateM n gexpr)+ ),+ ( True,+ do+ n <- succ <$> sNum (e _geoConcatenations)+ tameExprRecursion (n + 1) $+ PrimMultConcat <$> garbageGenExpr+ garbageIdent+ True+ (sampleMaybe (_geoDimRange . _goExpr) garbageCRangeExpr)+ gattr+ <*> fmap NE.fromList (replicateM n gexpr)+ ),+ ( True,+ do+ n <- succ <$> sNum (_ggoTaskFunPorts . _goGenerate)+ tameExprRecursion n $ PrimFun <$> ident <*> gattr <*> replicateM n gexpr+ ),+ (True, PrimSysFun <$> garbageSysIdent <*> repeatExprRecursive (e _geoSysFunArgs) gexpr),+ (True, PrimMinTypMax <$> garbageGenMinTypMax gexpr)+ ]+ where+ e x = x . _goExpr+ sNum = sampleAttenuatedNum (e _geoAttenuation)+ mknum x =+ ( False,+ do+ sz <- sampleSegment (e _geoLiteralWidth) 0 65535+ sn <- sampleBernoulli (e _geoLiteralSigned)+ PrimNumber (if sz == 0 then Nothing else Just (toEnum sz)) sn <$> x+ )+ gexpr = garbageGenExpr ident attrng grng gattr++garbageGenExpr :: GenM' i -> Bool -> GenM' r -> GenM' a -> GenM' (GenExpr i r a)+garbageGenExpr ident attrng grng gattr =+ sampleAttenuatedBranch+ (e _geoAttenuation)+ (e _geoItem)+ [ (False, ExprPrim <$> garbagePrim ident attrng grng gattr),+ ( False,+ ExprUnOp <$> sampleEnum (e _geoUnary) <*> gattr <*> garbagePrim ident attrng grng gattr+ ),+ ( True,+ tameExprRecursion 2 $ ExprBinOp <$> gexpr <*> sampleEnum (e _geoBinary) <*> gattr <*> gexpr+ ),+ (True, tameExprRecursion 3 $ ExprCond <$> gexpr <*> gattr <*> gexpr <*> gexpr)+ ]+ where+ e x = x . _goExpr+ gexpr = garbageGenExpr ident attrng grng gattr++garbageGenMinTypMax :: GenM' e -> GenM' (GenMinTypMax e)+garbageGenMinTypMax gexpr =+ choice+ (_geoMinTypMax . _goExpr)+ (tameExprRecursion 3 $ MTMFull <$> gexpr <*> gexpr <*> gexpr)+ (tameExprRecursion 1 $ MTMSingle <$> gexpr)++garbageRange2 :: GenM' Range2+garbageRange2 = tameExprRecursion 2 $ Range2 <$> garbageCExpr <*> garbageCExpr++garbageDims :: GenM' [Range2]+garbageDims = repeatExprRecursive (_gtoDimensions . _goType) garbageRange2++garbageGenRangeExpr :: GenM' e -> GenM' (GenRangeExpr e)+garbageGenRangeExpr ge =+ sampleBranch+ (e _geoRange)+ [ GRESingle <$> ge,+ GREPair <$> garbageRange2,+ tameExprRecursion 2 $+ GREBaseOff <$> ge <*> sampleBernoulli (e _geoRangeOffsetPos_Neg) <*> garbageCExpr+ ]+ where e x = x . _goExpr++garbageGenDimRange :: GenM' e -> GenM' (GenDimRange e)+garbageGenDimRange ge = do+ n <- sampleAttenuatedNum (_geoAttenuation . _goExpr) (_gtoDimensions . _goType)+ tameExprRecursion (n + 1) $ GenDimRange <$> replicateM n ge <*> garbageGenRangeExpr ge++garbageExpr :: GenM' Expr+garbageExpr =+ Expr <$> garbageGenExpr+ garbageHierIdent+ True+ (sampleMaybe (_geoDimRange . _goExpr) garbageDimRange)+ garbageAttributes++garbageCExpr :: GenM' CExpr+garbageCExpr =+ CExpr <$> garbageGenExpr+ garbageIdent+ True+ (sampleMaybe (_geoDimRange . _goExpr) garbageCRangeExpr)+ garbageAttributes++garbageRangeExpr :: GenM' RangeExpr+garbageRangeExpr = garbageGenRangeExpr garbageExpr++garbageCRangeExpr :: GenM' CRangeExpr+garbageCRangeExpr = garbageGenRangeExpr garbageCExpr++garbageDimRange :: GenM' DimRange+garbageDimRange = garbageGenDimRange garbageExpr++garbageCDimRange :: GenM' CDimRange+garbageCDimRange = garbageGenDimRange garbageCExpr++garbageMinTypMax :: GenM' MinTypMax+garbageMinTypMax = garbageGenMinTypMax garbageExpr++garbageCMinTypMax :: GenM' CMinTypMax+garbageCMinTypMax = garbageGenMinTypMax garbageCExpr++garbageBareCMTM :: GenM' CMinTypMax+garbageBareCMTM =+ choice+ (_goBareMinTypMax)+ (MTMFull <$> garbageCExpr <*> garbageCExpr <*> garbageCExpr)+ (MTMSingle <$> garbageCExpr)++garbageAttributes :: GenM' Attributes+garbageAttributes =+ repeatExprRecursive _goAttributes $+ repeatExprRecursive _goAttributes $+ Attribute <$> garbageBS <*> sampleMaybe _goAttributeOptionalValue gattr+ where+ gattr =+ garbageGenExpr+ garbageIdent+ True+ (sampleMaybe (_geoDimRange . _goExpr) garbageCRangeExpr)+ (pure ())++garbageAttributed :: GenM' x -> GenM' (Attributed x)+garbageAttributed = liftA2 Attributed garbageAttributes++garbageAttrIded :: GenM' x -> GenM' (AttrIded x)+garbageAttrIded = liftA3 AttrIded garbageAttributes garbageIdent++garbageDelay1 :: GenM' Delay1+garbageDelay1 =+ sampleBranch+ _goDelay+ [ D1Base <$> garbageNumIdent,+ D11 <$> garbageMinTypMax+ ]++garbageDelay2 :: GenM' Delay2+garbageDelay2 =+ sampleBranch+ _goDelay+ [ D2Base <$> garbageNumIdent,+ D21 <$> garbageMinTypMax,+ D22 <$> garbageMinTypMax <*> garbageMinTypMax+ ]++garbageDelay3 :: GenM' Delay3+garbageDelay3 =+ sampleBranch+ _goDelay+ [ D3Base <$> garbageNumIdent,+ D31 <$> garbageMinTypMax,+ D32 <$> garbageMinTypMax <*> garbageMinTypMax,+ D33 <$> garbageMinTypMax <*> garbageMinTypMax <*> garbageMinTypMax+ ]++garbageLValue :: GenM' dr -> GenM' (LValue dr)+garbageLValue gdr = do+ l <- repeatExprRecursive _goLValues $ garbageLValue gdr+ case l of+ [] -> LVSingle <$> garbageHierIdent <*> sampleMaybe _goOptionalLValue gdr+ h : t -> return $ LVConcat $ h :| t++garbageNetLV :: GenM' NetLValue+garbageNetLV = garbageLValue garbageCDimRange++garbageVarLV :: GenM' VarLValue+garbageVarLV = garbageLValue garbageDimRange++garbageVarAssign :: GenM' VarAssign+garbageVarAssign = Assign <$> garbageVarLV <*> garbageExpr++garbageNetAssign :: GenM' NetAssign+garbageNetAssign = Assign <$> garbageNetLV <*> garbageExpr++garbageEvCtl :: GenM' EventControl+garbageEvCtl =+ sampleBranch+ (s _gstoEvent)+ [ pure ECDeps,+ ECIdent <$> garbageHierIdent,+ ECExpr <$> sampleNE+ (s _gstoEvents)+ (EventPrim <$> sampleEnum (s _gstoEventPrefix) <*> garbageExpr)+ ]+ where s x = x . _goStatement++garbageDelEvCtl :: GenM' DelayEventControl+garbageDelEvCtl =+ sampleBranch+ (_gstoDelayEventRepeat . _goStatement)+ [ DECDelay <$> garbageDelay1,+ DECEvent <$> garbageEvCtl,+ DECRepeat <$> garbageExpr <*> garbageEvCtl+ ]++garbageLoopStatement :: GenM' LoopStatement+garbageLoopStatement =+ sampleBranch+ (_gstoLoop . _goStatement)+ [ pure LSForever,+ LSRepeat <$> garbageExpr,+ LSWhile <$> garbageExpr,+ LSFor <$> garbageVarAssign <*> garbageExpr <*> garbageVarAssign+ ]++garbageStmtBlockHeader :: GenM' (Maybe (Identifier, [AttrIded StdBlockDecl]))+garbageStmtBlockHeader =+ sampleMaybe (s _gstoBlockHeader) $+ mkpair garbageIdent $+ sampleN (s _gstoBlockDecls) $+ garbageAttrIded $ sampleBranch (s _gstoBlockDecl) stdBlockDeclList+ where+ s x = x . _goStatement++garbageFunctionStatement :: GenM' FunctionStatement+garbageFunctionStatement =+ sampleAttenuatedBranch+ (s _gstoAttenuation)+ (s _gstoItem)+ [ (False, FSBlockAssign <$> garbageVarAssign),+ ( True,+ do+ x <- sampleEnum $ s _gstoCase+ e <- garbageExpr + pn <- sampleAttenuatedNum (s _gstoAttenuation) (s _gstoCaseBranches)+ d <- tameStmtRecursion pn gmybfstmt+ let n = if d == Attributed [] Nothing then pn + 1 else pn+ c <-+ tameStmtRecursion n $+ replicateM n $+ FCaseItem <$> sampleNE (s _gstoCaseBranchPatterns) garbageExpr <*> gmybfstmt+ return $ FSCase x e c d+ ),+ (True, tameStmtRecursion 2 $ FSIf <$> garbageExpr <*> gmybfstmt <*> gmybfstmt),+ (False, FSDisable <$> garbageHierIdent),+ (True, FSLoop <$> garbageLoopStatement <*> tameStmtRecursion 1 gattrfstmt),+ ( True,+ FSBlock <$> garbageStmtBlockHeader+ <*> sampleBernoulli (s _gstoBlockPar_Seq)+ <*> repeatStmtRecursive (s _gstoItems) gattrfstmt+ )+ ]+ where+ s x = x . _goStatement+ gmybfstmt = garbageAttributed $ sampleMaybe (s _gstoOptional) garbageFunctionStatement+ gattrfstmt = garbageAttributed garbageFunctionStatement++garbageStatement :: GenM' Statement+garbageStatement =+ sampleAttenuatedBranch+ (s _gstoAttenuation)+ (s _gstoItem)+ [ ( False,+ SBlockAssign <$> sampleBernoulli (s _gstoAssignmentBlocking)+ <*> garbageVarAssign+ <*> sampleMaybe (s _gstoOptionalDelEvCtl) garbageDelEvCtl+ ),+ ( True,+ do+ x <- sampleEnum $ s _gstoCase+ e <- garbageExpr + pn <- sampleAttenuatedNum (s _gstoAttenuation) (s _gstoCaseBranches)+ d <- tameStmtRecursion pn garbageMybStmt+ let n = if d == Attributed [] Nothing then pn + 1 else pn+ c <-+ tameStmtRecursion n $+ replicateM n $+ CaseItem <$> sampleNE (s _gstoCaseBranchPatterns) garbageExpr <*> garbageMybStmt+ return $ SCase x e c d+ ),+ (True, tameStmtRecursion 2 $ SIf <$> garbageExpr <*> garbageMybStmt <*> garbageMybStmt),+ (False, SDisable <$> garbageHierIdent),+ (True, SLoop <$> garbageLoopStatement <*> tameStmtRecursion 1 garbageAttrStmt),+ ( True,+ SBlock <$> garbageStmtBlockHeader+ <*> sampleBernoulli (s _gstoBlockPar_Seq)+ <*> repeatStmtRecursive (s _gstoItems) garbageAttrStmt+ ),+ ( False,+ SEventTrigger <$> garbageHierIdent <*> sampleN (_gtoDimensions . _goType) garbageExpr+ ),+ ( False,+ SProcContAssign <$> sampleBranch+ (s _gstoProcContAssign)+ [ PCAAssign <$> garbageVarAssign,+ PCADeassign <$> garbageVarLV,+ PCAForce <$> sampleEither (s _gstoPCAVar_Net) garbageVarAssign garbageNetAssign,+ PCARelease <$> sampleEither (s _gstoPCAVar_Net) garbageVarLV garbageNetLV+ ]+ ),+ ( True,+ SProcTimingControl <$> sampleBranch+ (s _gstoDelayEventRepeat)+ [Left <$> garbageDelay1, Right <$> garbageEvCtl]+ <*> tameStmtRecursion 1 garbageMybStmt+ ),+ ( False,+ SSysTaskEnable <$> garbageSysIdent+ <*> sampleN (s _gstoSysTaskPorts) (sampleMaybe (s _gstoSysTaskOptionalPort) garbageExpr)+ ),+ ( False,+ STaskEnable <$> garbageHierIdent <*> sampleN (_ggoTaskFunPorts . _goGenerate) garbageExpr+ ),+ (True, SWait <$> garbageExpr <*> tameStmtRecursion 1 garbageMybStmt)+ ]+ where s x = x . _goStatement++garbageMybStmt :: GenM' MybStmt+garbageMybStmt = garbageAttributed $ sampleMaybe (_gstoOptional . _goStatement) garbageStatement++garbageAttrStmt :: GenM' AttrStmt+garbageAttrStmt = garbageAttributed garbageStatement++garbageSR :: GenM' SignRange+garbageSR =+ SignRange <$> sampleBernoulli (t _gtoConcreteSignedness)+ <*> sampleMaybe (t _gtoConcreteBitRange) garbageRange2+ where t x = x . _goType++garbageComType :: GenM' x -> GenM' (ComType x)+garbageComType m =+ choice+ (t _gtoAbstract_Concrete)+ (CTAbstract <$> sampleEnum (t _gtoAbstract))+ (CTConcrete <$> m <*> garbageSR)+ where t x = x . _goType++garbageParameter :: GenM' Parameter+garbageParameter = Parameter <$> (garbageComType $ pure ()) <*> garbageBareCMTM++blockDeclList :: (forall x. GenM' x -> GenM' (f x)) -> GenM' t -> [GenM' (BlockDecl f t)]+blockDeclList f m =+ [ BDReg <$> garbageSR <*> f m,+ BDInt <$> f m,+ BDReal <$> f m,+ BDTime <$> f m,+ BDRealTime <$> f m,+ BDEvent <$> f garbageDims,+ BDLocalParam <$> (garbageComType $ pure ()) <*> f garbageBareCMTM+ ]++stdBlockDeclList :: [GenM' StdBlockDecl]+stdBlockDeclList =+ map (fmap SBDBlockDecl) (blockDeclList (fmap Identity) garbageDims)+ ++ [SBDParameter <$> garbageParameter]++garbageDriveStrength :: GenM' DriveStrength+garbageDriveStrength = do+ x <- strall+ y <- strall+ case (x, y) of+ (Just a, Just b) -> return $ DSNormal a b+ (Nothing, Just b) -> return $ DSHighZ False b+ (Just a, Nothing) -> return $ DSHighZ True a+ _ -> garbageDriveStrength+ where strall = sampleMaybeEnum _goDriveStrength++garbageTFBlockDecl :: GenM' x -> GenM' (TFBlockDecl x)+garbageTFBlockDecl m =+ sampleBranch (g _ggoTaskFunDecl) $ map (fmap TFBDStd) stdBlockDeclList +++ [TFBDPort <$> m <*> garbageComType (sampleBernoulli $ g _ggoTaskFunRegister)]+ where g x = x . _goGenerate++garbageInstanceName :: GenM' InstanceName+garbageInstanceName =+ InstanceName <$> garbageIdent <*> sampleMaybe (_ggoInstOptionalRange . _goGenerate) garbageRange2++garbageGateInst :: (forall x. GenM' x -> GenM' (f x)) -> GenM' (ModGenItem f)+garbageGateInst f =+ sampleBranch+ (g _ggoGateInst)+ [ mkf (MGICMos False <$> optd3) $+ GICMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr <*> garbageExpr,+ mkf (MGICMos True <$> optd3) $+ GICMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr <*> garbageExpr,+ mkf (MGIEnable False False <$> garbageDriveStrength <*> optd3) $+ GIEnable <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIEnable False True <$> garbageDriveStrength <*> optd3) $+ GIEnable <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIEnable True False <$> garbageDriveStrength <*> optd3) $+ GIEnable <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIEnable True True <$> garbageDriveStrength <*> optd3) $+ GIEnable <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIMos False False <$> optd3) $+ GIMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIMos False True <$> optd3) $+ GIMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIMos True False <$> optd3) $+ GIMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf (MGIMos True True <$> optd3) $+ GIMos <$> optname <*> garbageNetLV <*> garbageExpr <*> garbageExpr,+ mkf+ (flip MGINIn False <$> sampleEnum (g _ggoGateNInputType) <*> garbageDriveStrength <*> optd2)+ (GINIn <$> optname <*> garbageNetLV <*> sampleNE (g _ggoGateInputs) garbageExpr),+ mkf+ (flip MGINIn True <$> sampleEnum (g _ggoGateNInputType) <*> garbageDriveStrength <*> optd2)+ (GINIn <$> optname <*> garbageNetLV <*> sampleNE (g _ggoGateInputs) garbageExpr),+ mkf (MGINOut False <$> garbageDriveStrength <*> optd2) $+ GINOut <$> optname <*> sampleNE (g _ggoGateOutputs) garbageNetLV <*> garbageExpr,+ mkf (MGINOut True <$> garbageDriveStrength <*> optd2) $+ GINOut <$> optname <*> sampleNE (g _ggoGateOutputs) garbageNetLV <*> garbageExpr,+ mkf (MGIPassEn False False <$> optd2) $+ GIPassEn <$> optname <*> garbageNetLV <*> garbageNetLV <*> garbageExpr,+ mkf (MGIPassEn False True <$> optd2) $+ GIPassEn <$> optname <*> garbageNetLV <*> garbageNetLV <*> garbageExpr,+ mkf (MGIPassEn True False <$> optd2) $+ GIPassEn <$> optname <*> garbageNetLV <*> garbageNetLV <*> garbageExpr,+ mkf (MGIPassEn True True <$> optd2) $+ GIPassEn <$> optname <*> garbageNetLV <*> garbageNetLV <*> garbageExpr,+ mkf (pure $ MGIPass False) $ GIPass <$> optname <*> garbageNetLV <*> garbageNetLV,+ mkf (pure $ MGIPass True) $ GIPass <$> optname <*> garbageNetLV <*> garbageNetLV,+ mkf (MGIPull False <$> garbageDriveStrength) $ GIPull <$> optname <*> garbageNetLV,+ mkf (MGIPull True <$> garbageDriveStrength) $ GIPull <$> optname <*> garbageNetLV+ ]+ where+ g x = x . _goGenerate+ mkf c m = c <*> f m+ optname = sampleMaybe (g _ggoGateOptIdent) garbageInstanceName+ optd3 = sampleMaybe (g _ggoInstOptionalDelay) garbageDelay3+ optd2 = sampleMaybe (g _ggoInstOptionalDelay) garbageDelay2++garbageGenIf :: GenM' ModGenCondItem+garbageGenIf =+ tameModGenRecursion 2 $ MGCIIf <$> garbageCExpr <*> garbageGenCondBlock <*> garbageGenCondBlock++garbageGenCase :: GenM' ModGenCondItem+garbageGenCase = do+ e <- garbageCExpr+ pn <- sampleAttenuatedNum (g _ggoAttenuation) (g _ggoCaseBranches)+ d <- tameModGenRecursion pn garbageGenCondBlock+ let n = if d == GCBEmpty then pn + 1 else pn+ c <-+ tameModGenRecursion n $+ replicateM n $+ GenCaseItem <$> sampleNE (g _ggoCaseBranchPatterns) garbageCExpr <*> garbageGenCondBlock+ return $ MGCICase e c d+ where g x = x . _goGenerate++-- do not generate unknown instantiations, there is no need to+garbageModGenItem :: (forall x. GenM' x -> GenM' (f x)) -> GenM' (ModGenItem f)+garbageModGenItem f =+ sampleAttenuatedBranch+ (g _ggoAttenuation)+ (g _ggoItem)+ [ ( False,+ MGINetInit <$> sampleEnum (g _ggoNetType) <*> garbageDriveStrength <*> gnetprop <*> f gnetinit+ ),+ (False, MGINetDecl <$> sampleEnum (g _ggoNetType) <*> gnetprop <*> f gnetdecl),+ (False, MGITriD <$> garbageDriveStrength <*> gnetprop <*> f gnetinit),+ (False, MGITriC <$> sampleEnum (g _ggoChargeStrength) <*> gnetprop <*> f gnetdecl),+ ( False,+ MGIBlockDecl <$> sampleBranch (g _ggoDeclItem)+ (blockDeclList+ (fmap Compose . f . garbageIdentified)+ (sampleEither (g _ggoDeclDim_Init) garbageDims garbageCExpr))+ ),+ (False, MGIGenVar <$> f garbageIdent),+ ( False,+ MGITask <$> sampleBernoulli (g _ggoTaskFunAutomatic)+ <*> garbageIdent+ <*> sampleN+ (g _ggoTaskFunPorts)+ (garbageAttrIded $ garbageTFBlockDecl $ sampleEnum $ g _ggoTaskPortDirection)+ <*> garbageMybStmt+ ),+ ( False,+ MGIFunc <$> sampleBernoulli (g _ggoTaskFunAutomatic)+ <*> sampleMaybe (g _ggoFunRetType) (garbageComType $ pure ())+ <*> garbageIdent+ <*> (toList+ <$> sampleNE (g _ggoTaskFunPorts) (garbageAttrIded $ garbageTFBlockDecl $ pure ()))+ <*> garbageFunctionStatement+ ),+-- TODO MAYBE: make a BareCMinTypMax and use it here+ (False, MGIDefParam <$> f (ParamOver <$> garbageHierIdent <*> garbageCMinTypMax)),+ (False, MGIContAss <$> garbageDriveStrength <*> optd3 <*> f garbageNetAssign),+ (False, garbageGateInst f),+ ( False,+ MGIUDPInst <$> garbageIdent+ <*> garbageDriveStrength+ <*> optd2+ <*> f+ ( UDPInst+ <$> sampleMaybe (g _ggoPrimitiveOptIdent) garbageInstanceName+ <*> garbageNetLV+ <*> sampleNE (_gpoPorts . _goPrimitive) garbageExpr+ )+ ),+ ( False,+ MGIModInst <$> garbageIdent+ <*> choice+ (m _gmoNamed_Positional)+ ( ParamNamed <$> sampleN+ (m _gmoParameters)+-- TODO MAYBE: make a BareCMinTypMax and use it here+ (garbageIdentified $ sampleMaybe (m _gmoOptionalParameter) garbageMinTypMax)+ )+ (ParamPositional <$> sampleN (m _gmoParameters) garbageExpr)+ <*> f (ModInst <$> garbageInstanceName+ <*> choice+ (m _gmoNamed_Positional)+ (PortNamed <$> sampleN (m _gmoPorts) (garbageAttrIded optexpr))+ (PortPositional <$> sampleN (m _gmoPorts) (garbageAttributed optexpr)))+ ),+ (False, MGIInitial <$> garbageAttrStmt),+ (False, MGIAlways <$> garbageAttrStmt),+ ( True,+ MGILoopGen <$> garbageIdent+ <*> garbageCExpr+ <*> garbageCExpr+ <*> garbageIdent+ <*> garbageCExpr+ <*> garbageGenerateBlock+ ),+ (True, MGICondItem <$> garbageGenIf),+ (True, MGICondItem <$> garbageGenCase)+ ]+ where+ g x = x . _goGenerate+ m x = x . _goModule+ optd3 = sampleMaybe (g _ggoInstOptionalDelay) garbageDelay3+ optd2 = sampleMaybe (g _ggoInstOptionalDelay) garbageDelay2+ optexpr = sampleMaybe (m _gmoOptionalPort) garbageExpr+ optblock = sampleMaybe (g _ggoOptionalBlock) garbageGenerateBlock+ gnetprop = NetProp <$> sampleBernoulli (_gtoConcreteSignedness . _goType)+ <*> sampleMaybe (g _ggoNetRange)+ (mkpair (sampleMaybeEnum $ g _ggoNetVectoring) garbageRange2)+ <*> optd3+ gnetdecl = NetDecl <$> garbageIdent <*> garbageDims+ gnetinit = NetInit <$> garbageIdent <*> garbageExpr++garbageModGenBlockedItem :: GenM' (Attributed ModGenBlockedItem)+garbageModGenBlockedItem = garbageAttributed $ garbageModGenItem $ fmap Identity++garbageGenerateBlock :: GenM' GenerateBlock+garbageGenerateBlock =+ garbageIdentified $ repeatModGenRecursive (_ggoItems . _goGenerate) $ garbageModGenBlockedItem++garbageGenCondBlock :: GenM' GenerateCondBlock+garbageGenCondBlock =+ sampleAttenuatedBranch+ (g _ggoAttenuation)+ (g _ggoCondBlock)+ [ (False, pure GCBEmpty),+ (True, GCBBlock <$> garbageGenerateBlock),+ (True, GCBConditional <$> garbageAttributed garbageGenIf),+ (True, GCBConditional <$> garbageAttributed garbageGenCase)+ ]+ where g x = x . _goGenerate++garbageSpecTerm :: GenM' SpecTerm+garbageSpecTerm =+ SpecTerm <$> garbageIdent <*> sampleMaybe (_gsyoTermRange . _goSpecify) garbageCRangeExpr++garbagePPIdentifier :: GenM' Identifier+garbagePPIdentifier =+ Identifier <$> choice (_gsyoPathPulseEscaped_Simple . _goSpecify) garbageEscapedBS garbageSimpleBS++garbagePPTerm :: GenM' SpecTerm+garbagePPTerm =+ SpecTerm <$> garbagePPIdentifier+ <*> sampleMaybe (_gsyoPathPulseRange . _goSpecify) garbageCRangeExpr++garbageSPRange :: GenM' (Maybe Range2)+garbageSPRange = sampleMaybe (_gsyoParamRange . _goSpecify) garbageRange2++garbageSpecParamAssign :: GenM' SpecParamDecl+garbageSpecParamAssign = SPDAssign <$> garbageIdent <*> garbageCMinTypMax++garbageNoPathPulse :: GenM' SpecParamDecl+garbageNoPathPulse = SPDPathPulse Nothing <$> garbageCMinTypMax <*> garbageCMinTypMax++garbagePathPulse :: GenM' SpecParamDecl+garbagePathPulse =+ SPDPathPulse . Just <$> mkpair garbagePPTerm garbagePPTerm+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax++garbageSpecifyItem :: GenM' SpecifyBlockedItem+garbageSpecifyItem =+ sampleBranch+ (s _gsyoItem)+ [ SISpecParam <$> garbageSPRange <*> fmap Identity garbageSpecParamAssign,+ SISpecParam <$> garbageSPRange <*> fmap Identity garbageNoPathPulse,+ SISpecParam <$> garbageSPRange <*> fmap Identity garbagePathPulse,+ SIPulsestyleOnevent <$> gst,+ SIPulsestyleOndetect <$> gst,+ SIShowcancelled <$> gst,+ SINoshowcancelled <$> gst,+ do+ cond <- sampleBranch+ (p _gspoCondition)+ [ pure MPCNone,+ pure MPCAlways,+ MPCCond <$> garbageGenExpr garbageIdent False (pure ()) garbageAttributes+ ]+ conn <- choice+ (p _gspoFull_Parallel)+ ( SPFull <$> sampleNE (p _gspoFullSources) garbageSpecTerm+ <*> sampleNE (p _gspoFullDestinations) garbageSpecTerm+ )+ (SPParallel <$> garbageSpecTerm <*> garbageSpecTerm)+ pol <- sampleMaybeEnum $ p _gspoPolarity+ eds <- sampleMaybe (p _gspoEdgeSensitive) $+ mkpair garbageExpr $ sampleMaybeEnum $ p _gspoEdgeSensitivity+ pdv <- sampleBranch+ (p _gspoDelayKind)+ [ PDV1 <$> garbageCMinTypMax,+ PDV2 <$> garbageCMinTypMax <*> garbageCMinTypMax,+ PDV3 <$> garbageCMinTypMax <*> garbageCMinTypMax <*> garbageCMinTypMax,+ PDV6 <$> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax,+ PDV12 <$> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ <*> garbageCMinTypMax+ ]+ return $ SIPathDeclaration cond conn pol eds pdv,+ SISetup <$> gstca,+ SIHold <$> gstca,+ SISetupHold <$> gstca <*> gstcaa,+ SIRecovery <$> gstca,+ SIRemoval <$> gstca,+ SIRecrem <$> gstca <*> gstcaa,+ SISkew <$> gstca,+ SITimeSkew <$> gstca <*> gmce <*> gmce,+ SIFullSkew <$> gstca <*> garbageExpr <*> gmce <*> gmce,+ SIPeriod <$> gctce <*> garbageExpr <*> sampleMaybe (t _gstcoOptionalArg) garbageIdent,+ do+ (me, i) <- choice (t _gstcoOptionalArg) (pure (Nothing, Nothing)) $+ mkpair (Just <$> garbageCExpr) $ sampleMaybe (t _gstcoOptionalArg) garbageIdent+ cre <- gctce+ tcl <- garbageExpr+ return $ SIWidth cre tcl me i,+ SINoChange <$> gtce+ <*> gtce+ <*> garbageMinTypMax+ <*> garbageMinTypMax+ <*> sampleMaybe (t _gstcoOptionalArg) garbageIdent+ ]+ where+ s x = x . _goSpecify+ p x = s $ x . _gsyoPath+ t x = s $ x . _gsyoTimingCheck+ gst = Identity <$> garbageSpecTerm+ gmce = sampleMaybe (t _gstcoOptionalArg) garbageCExpr+ gtcc = mkpair (sampleBernoulli $ t _gstcoCondNeg_Pos) garbageExpr+ ged = do+ v <- VU.replicateM 6 (sampleBernoulli $ t _gstcoEventEdge)+ return (if VU.or v then v else VU.replicate 6 True)+ gtce =+ TimingCheckEvent <$> sampleMaybe (t _gstcoEvent) ged+ <*> garbageSpecTerm+ <*> sampleMaybe (t _gstcoCondition) gtcc+ gctce =+ ControlledTimingCheckEvent <$> ged+ <*> garbageSpecTerm+ <*> sampleMaybe (t _gstcoCondition) gtcc+ gstca =+ STCArgs <$> gtce <*> gtce <*> garbageExpr <*> sampleMaybe (t _gstcoOptionalArg) garbageIdent+ gstcaa = STCAddArgs <$> garbageExpr <*> gmmtm <*> gmmtm <*> gde <*> gde+ gmmtm = sampleMaybe (t _gstcoOptionalArg) garbageMinTypMax+ gde = sampleMaybe (t _gstcoOptionalArg) $+ garbageIdentified $ sampleMaybe (t _gstcoDelayedMinTypMax) garbageCMinTypMax++garbageModuleBlock :: Bool -> GenM' ModuleBlock+garbageModuleBlock ts = do+ nah <- asks $ m _gmoNonAsciiHeader . fst+ header <- sampleN (m _gmoPorts) $+ if nah+ then + garbageIdentified $+ sampleN (m _gmoPortLValues) $+ garbageIdentified $ sampleMaybe (m _gmoPortRange) garbageCRangeExpr+ else (\i -> Identified i [Identified i Nothing]) <$> garbageIdent+ ModuleBlock <$> garbageAttributes+ <*> garbageIdent+ <*> pure header+ <*> sampleN+ (m _gmoItems)+ ( sampleBranch+ (m _gmoItem)+ [ MIMGI <$> garbageModGenBlockedItem,+ MIPort <$> garbageAttrIded (mkpair (sampleEnum $ m _gmoPortDir) garbageSR),+ MIParameter <$> garbageAttrIded garbageParameter,+ MIGenReg <$> sampleN (_ggoItems . _goGenerate) garbageModGenBlockedItem,+ MISpecBlock <$> sampleN (_gsyoItems . _goSpecify) garbageSpecifyItem,+ MISpecParam <$> garbageAttributes <*> garbageSPRange <*> garbageSpecParamAssign,+ MISpecParam <$> garbageAttributes <*> garbageSPRange <*> garbageNoPathPulse,+ MISpecParam <$> garbageAttributes <*> garbageSPRange <*> garbagePathPulse+ ]+ )+ <*> (if ts then Just <$> mkpair gts gts else pure Nothing)+ <*> sampleBernoulli (m _gmoCell)+ <*> sampleMaybeEnum (m _gmoUnconnectedDrive)+ <*> sampleMaybeEnum (m _gmoDefaultNetType)+ where+ m x = x . _goModule+ gts = sampleSegment (m _gmoTimeMagnitude) (-15) 2++garbagePrimitiveBlock :: GenM' PrimitiveBlock+garbagePrimitiveBlock =+ PrimitiveBlock <$> garbageAttributes+ <*> garbageIdent+ <*> garbageIdent+ <*> sampleNE (p _gpoPorts) garbageIdent+ <*> sampleNE (p _gpoPorts) (garbageAttrIded $+ sampleBranch (p _gpoPortType)+ [ pure PPInput,+ pure PPOutput,+ pure PPReg,+ PPOutReg <$> sampleMaybe (p _gpoRegInit) garbageCExpr -- no sem+ ])+ <*> choice+ (p _gpoSeq_Comb)+ ( SeqTable+ <$> sampleMaybeEnum (p _gpoCombInit)+ <*> sampleNE (p _gpoTableRows) gseqrow+ )+ (CombTable <$> sampleNE (p _gpoTableRows) (CombRow <$> gnein <*> goutlv))+ where+ p x = x . _goPrimitive+ ginlv = sampleEnum $ p _gpoInLevel+ goutlv = sampleEnum $ p _gpoOutLevel+ gnein = sampleNE (p _gpoPorts) ginlv+ glin = sampleN (p _gpoPorts) ginlv+ gedgeseq =+ SISeq <$> glin+ <*> sampleBranch+ (p _gpoEdgeSimplePosNeg)+ [ EdgeDesc <$> ginlv <*> ginlv,+ pure $ EdgePos_neg True,+ pure $ EdgePos_neg False+ ]+ <*> glin+ gseqrow =+ SeqRow <$> choice (p _gpoEdgeSensitive) (SIComb <$> gnein) gedgeseq+ <*> ginlv+ <*> sampleMaybe (p _gpoOutputNoChange) goutlv++garbageVerilog2005 :: GenM' Verilog2005+garbageVerilog2005 =+ Verilog2005+ <$> (sampleBernoulli (m _gmoTimeScale) >>= sampleN (m _gmoBlocks) . garbageModuleBlock)+ <*> sampleN (_gpoBlocks . _goPrimitive) garbagePrimitiveBlock+ <*> sampleN+ (c _gcoBlocks)+ ( ConfigBlock <$> garbageIdent+ <*> sampleN (c _gcoDesigns) gdot1+ <*> sampleN+ (c _gcoItems)+ ( ConfigItem+ <$> choice+ (c _gcoCell_Inst)+ (CICell <$> gdot1)+ (CIInst <$> sampleNE _goPathDepth garbageIdent)+ <*> choice+ (c _gcoLiblist_Use)+ (LLULiblist <$> glibs)+ (LLUUse <$> gdot1 <*> sampleBernoulli (c _gcoConfig))+ )+ <*> glibs+ )+ where+ m x = x . _goModule+ c x = x . _goConfig+ glibs = sampleN (c _gcoLibraries) garbageBS+ gdot1 = Dot1Ident <$> sampleMaybe (c _gcoLibraryScope) garbageBS <*> garbageIdent++runGarbageGeneration :: Config -> IO Verilog2005+runGarbageGeneration c = do+ let conf = _configGarbageGenerator c+ gen <- maybe createSystemRandom initialize $ _goSeed conf+ runReaderT garbageVerilog2005 (conf, gen)
+ src/Verismith/Verilog2005/Lexer.x view
@@ -0,0 +1,851 @@+-- Module : Verismith.Verilog2005.Lexer+-- Description : Partial Verilog 2005 lexer to reconstruct the AST.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX++{+{-# OPTIONS_GHC -w #-}++module Verismith.Verilog2005.Lexer+ ( scanTokens+ , parseDecimal+ , isKW+ , isIdentSimple+ , VerilogVersion (..)+ , makeString+ )+where++import Data.Bits+import Data.Word (Word8)+import Numeric.Natural+import GHC.Natural+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (mapMaybe)+import Text.Printf (printf)+import Control.Monad.State.Strict+import Control.Monad.Except+import Control.Exception+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Lazy as LBS+import Data.ByteString.Internal (c2w, w2c, unpackChars, packChars)+import qualified Data.HashMap.Strict as HashMap+import Verismith.Verilog2005.Token+}++%encoding "latin1"++$white = [\ \t\n\f]+$all = [\0-\255]++-- | Comments and white space+@oneLineComment = "//" .*+@blockComment = "/*" [$all # \*]* (\*+ [$all # [\*\/]] [$all # \*]*)* \*+ \/++-- | Operators+@unaryOperator = [~!] | "~&" | "~|"+@binaryOperator = [\/\<\>\%] | "==" | "!=" | "===" | "!==" | "&&" | "||" | "**" | ">=" | "<<" | ">>" | "<<<" | ">>>"++-- | Identifiers+$identifierFirstChar = [a-z A-Z _]+$identifierChar = [a-z A-Z 0-9 _ \$]+@escapedIdentifier = \\ [\!-\~]*+@simpleIdentifier = $identifierFirstChar $identifierChar*+@systemIdentifier = \$ $identifierChar++@compilerDirective = ` ( @simpleIdentifier | @escapedIdentifier )++-- | Table symbols, and edges+$tableout = [01 xX]+$tablein = [bB \?]+$tableedge = [fF pP rR nN \*]+@edgedesc = [01] [01 xX zZ] | [xX zZ] [01]++-- | Numeric building blocks+$decimalDigit = 0-9+$specialDigit = [xX zZ \?]+$binaryDigit = [$specialDigit 0-1]+$octalDigit = [$specialDigit 0-7]+$hexDigit = [$specialDigit 0-9 a-f A-F]++@unsigned = $decimalDigit (_ | $decimalDigit)*+@xzValue = $specialDigit _*+@binValue = $binaryDigit (_ | $binaryDigit)*+@octValue = $octalDigit (_ | $octalDigit)*+@hexValue = $hexDigit (_ | $hexDigit)*++@fixed = @unsigned \. @unsigned+@real = @fixed | @unsigned (\. @unsigned)? [eE] [\+\-]? @unsigned++-- | Strings++$stringChar = [$all # [\\"]]+@string = \" $stringChar* (\\ . $stringChar*)* \"++-- | Timescale tokens+@tsvalue = 1(00?)?+@tsunit = [munpf]?s++tokens :-+ <0,table,edge,pre2,pre8,pre10,pre16,ts0,ts1,ts2,ts3,ts4> {+ $white+ ;+ @blockComment ;+ @oneLineComment ;+ @compilerDirective { cdcident }+ }++ <0> {+ @real { to LitReal }+ @string { to (LitString . SBS.tail . SBS.init) }+ @simpleIdentifier { toa kwident }+ @escapedIdentifier { to (escSimpleIdent . SBS.tail) }+ @systemIdentifier { to (IdSystem . SBS.tail) }+ \'[sS]?[bB] { toa (numberBase BBin) }+ \'[sS]?[oO] { toa (numberBase BOct) }+ \'[sS]?[dD] { toa (numberBase BDec) }+ \'[sS]?[hH] { toa (numberBase BHex) }+ & { tok AmAmp }+ ! { tok UnBang }+ = { tok SymEq }+ @ { tok SymAt }+ \| { tok AmBar }+ \^ { tok AmHat }+ \~ { tok UnTilde }+ \/ { tok BinSlash }+ \% { tok BinPercent }+ \< { tok BinLt }+ \> { tok BinGt }+ \{ { tok SymBraceL }+ \} { tok SymBraceR }+ \+ { tok SymPlus }+ \? { tok SymQuestion }+ \# { tok SymPound }+ \* { tok SymAster }+ \. { tok SymDot }+ \$ { tok SymDollar }+ "^~" { tok AmTildeHat } -- Sorry+ "~^" { tok AmTildeHat }+ "~&" { tok UnTildeAmp }+ "~|" { tok UnTildeBar }+ "==" { tok BinEqEq }+ "!=" { tok BinBangEq }+ "&&" { tok BinAmpAmp }+ "||" { tok BinBarBar }+ "**" { tok BinAsterAster }+ ">=" { tok BinGtEq }+ "<<" { tok BinLtLt }+ ">>" { tok BinGtGt }+ "(*" { tok SymParenAster }+ "*)" { tok SymAsterParen }+ "<=" { tok SymLtEq }+ "+:" { tok SymPlusColon }+ "-:" { tok SymDashColon }+ "->" { tok SymDashGt }+ "=>" { tok SymEqGt }+ "*>" { tok SymAsterGt }+ "===" { tok BinEqEqEq }+ "!==" { tok BinBangEqEq }+ "<<<" { tok BinLtLtLt }+ ">>>" { tok BinGtGtGt }+ "&&&" { tok SymAmpAmpAmp }+ }++ <ts0> @tsvalue { startcode ts1 (to tsValue) }+ <ts1> @tsunit { startcode ts2 (to tsUnit) }+ <ts2> \/ { \_ _ -> sc ts3 >> scan }+ <ts3> @tsvalue { startcode ts4 (to tsValue) }+ <ts4> @tsunit { startcode 0 (to tsUnit) }++ <pre2> @binValue { startcode 0 (to binary) }+ <pre8> @octValue { startcode 0 (to octal) }+ <pre16> @hexValue { startcode 0 (to hex) }+ <pre10> @xzValue { startcode 0 (to xz) }+ <0,pre10> @unsigned { startcode 0 (to decimal) }+++ <0,table> {+ \( { tok SymParenL }+ \) { tok SymParenR }+ \- { tok SymDash }+ : { tok SymColon }+ \; { tok SymSemi }+ }+ <0,edge> {+ \, { tok SymComma }+ \[ { tok SymBrackL }+ \] { startcode 0 (tok SymBrackR) }+ }++ -- Reusing token constructors+ <edge> @edgedesc { to edgeDesc }+ <table> {+ $tableout { to tableOut }+ $tablein { to tableIn }+ $tableedge { to tableEdge }+ "endtable" { startcode 0 (tok KWEndtable) }+ }++{+-- not using any wrapper so I have to define things myself++data AlexInput = AlexInput+ { _aiPosition :: !Position,+ _aiPrevChar :: !Char,+ _aiInput :: !LBS.ByteString+ }++alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte (AlexInput (Position ln cl s) _ inp) = case LBS.uncons inp of+ Nothing -> Nothing+ Just (b, inp) -> Just (b, let c = w2c b in AlexInput+ ( case c of+ '\t' -> Position ln ((cl .|. 3) + 1) s+ '\n' -> Position (ln + 1) 1 s+ _ -> Position ln (cl + 1) s+ )+ c+ inp+ )++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar = _aiPrevChar++-- above was mandatory declarations for alex, below is the interesting stuff++data VerilogVersion = SV2023 | SV2017 | SV2012 | SV2009 | SV2005 | V2005 | V2001 | V2001_nc | V1995++instance Show VerilogVersion where+ show x = case x of+ SV2023 -> "1800-2023"+ SV2017 -> "1800-2017"+ SV2012 -> "1800-2012"+ SV2009 -> "1800-2009"+ SV2005 -> "1800-2005"+ V2005 -> "1364-2005"+ V2001 -> "1364-2001"+ V2001_nc -> "1364-2001-noconfig"+ V1995 -> "1364-1995"++data AlexState = AlexState+ { _asStartCode :: !Int,+ _asInput :: !AlexInput,+ _asKeywords :: ![(NonEmpty Position, VerilogVersion)],+ -- LATER: User defined compiler directives support, the value (as in key/value) type is wrong+ _asDefines :: !(HashMap.HashMap SBS.ByteString LBS.ByteString),+ _asSavedInput :: ![(Position, LBS.ByteString)]+ }++type Alex = StateT AlexState (ExceptT String IO)++scan :: Alex (Maybe PosToken)+scan = get >>= \(AlexState sc inp kw d si) -> case alexScan inp sc of+ AlexEOF -> case si of+ (p, i) : t -> put (AlexState sc (AlexInput p (_aiPrevChar inp) i) kw d t) >> scan+ [] -> case kw of+ [] -> return Nothing+ (p, vv) : _ ->+ throwError $+ printf "Missing `end_keywords to match `begin_keywords %s at %s" (show vv) $+ helperShowPositions p+ AlexError (AlexInput p pc i) ->+ throwError $+ printf+ "lexical error between %s and %s"+ (show $ _aiPosition inp)+ (helperShowPositions $ p :| map fst si)+ AlexSkip inp' _ -> modify' (\s -> s { _asInput = inp' }) >> scan+ AlexToken inp' n action -> do+ modify' $ \s -> s { _asInput = inp' }+ action (_aiPosition inp) $ LBS.toStrict $ LBS.take (toEnum n) $ _aiInput inp++scanTokens :: String -> IO (Either String [PosToken])+scanTokens f = do+ inp <- LBS.readFile f+ runExceptT $+ evalStateT loop $+ AlexState 0 (AlexInput (Position 1 1 $ PSFile f) '\n' inp) [] HashMap.empty []+ where+ loop = scan >>= maybe (pure []) (\x -> (x :) <$> loop)++type AlexAction = Position -> SBS.ByteString -> Alex (Maybe PosToken)++mkPos :: Position -> Token -> Alex (Maybe PosToken)+mkPos p t = (\l -> Just $ PosToken (p :| map fst l) t) <$> gets _asSavedInput++tok :: Token -> AlexAction+tok t p _ = mkPos p t++to :: (SBS.ByteString -> Token) -> AlexAction+to f p = mkPos p . f++toa :: (SBS.ByteString -> Alex Token) -> AlexAction+toa f p s = f s >>= mkPos p++sc :: Int -> Alex ()+sc n = modify' $ \s -> s { _asStartCode = n }++startcode :: Int -> AlexAction -> AlexAction+startcode n f p s = sc n >> f p s++alexPosError :: (NonEmpty Position) -> String -> Alex a+alexPosError p s =+ throwError $ s ++ " at " ++ helperShowPositions p++alexError :: Position -> String -> Alex a+alexError p s = gets _asSavedInput >>= flip alexPosError s . (p :|) . map fst++-- Lexer actions++tsValue :: SBS.ByteString -> Token+tsValue s = CDTSInt (SBS.length s - 1)++tsUnit :: SBS.ByteString -> Token+tsUnit s =+ CDTSUnit $+ case s of "s" -> 0 ; "ms" -> -3 ; "us" -> -6 ; "ns" -> -9 ; "ps" -> -12 ; "fs" -> -15++numberBase :: Base -> SBS.ByteString -> Alex Token+numberBase ba bs = do+ sc (case ba of BBin -> pre2 ; BOct -> pre8 ; BDec -> pre10 ; BHex -> pre16)+ return $ NumberBase (SBS.length bs == 3) ba++binary :: SBS.ByteString -> Token+binary s = LitBinary $ mapMaybe (\c -> case c of+ '0' -> Just BXZ0+ '1' -> Just BXZ1+ 'x' -> Just BXZX+ 'X' -> Just BXZX+ 'z' -> Just BXZZ+ 'Z' -> Just BXZZ+ '?' -> Just BXZZ+ _ -> Nothing) $ unpackChars s++octal :: SBS.ByteString -> Token+octal s = LitOctal $ mapMaybe (\c -> case c of+ 'x' -> Just OXZX+ 'X' -> Just OXZX+ 'z' -> Just OXZZ+ 'Z' -> Just OXZZ+ '?' -> Just OXZZ+ _ | '0' <= c && c <= '7' -> Just $ toEnum $ fromEnum c - fromEnum '0'+ _ -> Nothing) $ unpackChars s++hex :: SBS.ByteString -> Token+hex s = LitHex $ mapMaybe (\c -> case c of+ 'x' -> Just HXZX+ 'X' -> Just HXZX+ 'z' -> Just HXZZ+ 'Z' -> Just HXZZ+ '?' -> Just HXZZ+ _ | '0' <= c && c <= '9' -> Just $ toEnum $ fromEnum c - fromEnum '0'+ _ | 'a' <= c && c <= 'f' -> Just $ toEnum $ fromEnum c + 10 - fromEnum 'a'+ _ | 'A' <= c && c <= 'F' -> Just $ toEnum $ fromEnum c + 10 - fromEnum 'A'+ _ -> Nothing) $ unpackChars s++xz :: SBS.ByteString -> Token+xz s = LitXZ $ let c = SBS.head s in c == c2w 'x' || c == c2w 'X'++parseDecimal :: SBS.ByteString -> Natural+parseDecimal =+ fromInteger . SBS.foldl+ (\acc d -> if c2w '0' <= d && d <= c2w '9' then 10*acc + toInteger (d - c2w '0') else acc)+ 0++decimal :: SBS.ByteString -> Token+decimal = LitDecimal . parseDecimal++unbxz :: SBS.ByteString -> BXZ+unbxz s = case s of "0" -> BXZ0; "1" -> BXZ1; "x" -> BXZX; "X" -> BXZX; "z" -> BXZZ; "Z" -> BXZZ++edgeDesc :: SBS.ByteString -> Token+edgeDesc s = EdgeEdge (unbxz $ SBS.init s) (unbxz $ SBS.tail s)++tableOut :: SBS.ByteString -> Token+tableOut s = TableOut $ case s of "0" -> ZOXZ; "1" -> ZOXO; "x" -> ZOXX; "X" -> ZOXX++tableIn :: SBS.ByteString -> Token+tableIn s = TableIn $ case s of "b" -> True; "B" -> True; "?" -> False++tableEdge :: SBS.ByteString -> Token+tableEdge s =+ TableEdge $ case s of+ "*" -> AFRNPA+ "f" -> AFRNPF+ "F" -> AFRNPF+ "r" -> AFRNPR+ "R" -> AFRNPR+ "n" -> AFRNPN+ "N" -> AFRNPN+ "p" -> AFRNPP+ "P" -> AFRNPP++cdcident :: AlexAction+cdcident p s = case HashMap.lookup (SBS.tail s) cdMap of+ Just a -> a p+ Nothing -> do+ defs <- gets _asDefines+ case HashMap.lookup s defs of+ Nothing ->+ alexError p $+ printf "Compiler directive %s not declared nor supported, preprocess input file" $+ show s+ Just i ->+ alexError p $+ printf+ "User defined compiler directive replacement in not implemented, %s was encountered"+ (show s)++kwident :: SBS.ByteString -> Alex Token+kwident s = case SBS.stripPrefix "PATHPULSE$" s of+ Just ss -> return $ TknPP ss+ Nothing -> do+ vv <- gets _asKeywords+ let m = HashMap.lookup s $ case vv of+ (_, V1995) : _ -> kwV1995Map+ (_, V2001) : _ -> kwV2001Map+ (_, V2001_nc) : _ -> kwV2001NCMap+ (_, SV2005) : _ -> kwSV2005Map+ (_, SV2009) : _ -> kwSV2009Map+ (_, SV2012) : _ -> kwSV2012Map+ (_, SV2017) : _ -> kwSV2012Map+ (_, SV2023) : _ -> kwSV2012Map+ _ -> kwV2005Map+ case m of+ Nothing -> return $ if isKW s then IdEscaped $ SBS.cons (c2w '\\') s else IdSimple s+ Just act -> act++isIdentSimple :: SBS.ByteString -> Bool+isIdentSimple s = case SBS.uncons s of+ Just (c, t) ->+ testfirst c+ && not (isKW s)+ && SBS.all (\c -> testfirst c || (c2w '0' <= c && c <= c2w '9') || c == c2w '$') t+ _ -> False+ where+ testfirst c = (c2w 'A' <= c && c <= c2w 'Z') || (c2w 'a' <= c && c <= c2w 'z') || c == c2w '_'++escSimpleIdent :: SBS.ByteString -> Token+escSimpleIdent s = if isIdentSimple s then IdSimple s else IdEscaped s++makeString :: String -> SBS.ByteString+makeString s = packChars $ concatMap esc s+ where esc c = case w2c $ c2w c of '"' -> "\\\""; '\\' -> "\\\\"; '\n' -> "\\n"; x -> [x]++cdMap :: HashMap.HashMap SBS.ByteString (Position -> Alex (Maybe PosToken))+cdMap = HashMap.fromList $+ ("include", includecompdir)+ -- LATER: `define would go here and change state to store input as is in _asDefines+ : ("line", linecompdir)+ : ("begin_keywords", beginkwcompdir)+ : ("end_keywords", endkwcompdir)+ : ("undefineall", \_ -> modify' (\s -> s { _asDefines = HashMap.empty }) >> scan)+ : ("__LINE__", \p -> mkPos p $ LitString $ packChars $ show $ _posLine p)+ : ("__FILE__", \p -> mkPos p $ LitString $ makeString $ show $ _posSource p)+ : map (\(x, y) -> (x, \p -> y >>= mkPos p))+ ( ("timescale", sc ts0 >> return CDTimescale)+ : ("resetall", modify' (\s -> s { _asDefines = HashMap.empty }) >> return CDResetall)+ -- , ("pragma", >> return CDPragma) -- TODO: Another layer of hell+ : map (\(x, y) -> (x, return y))+ [ ("celldefine", CDCelldefine)+ , ("default_nettype", CDDefaultnettype)+ -- , ("default_decay_time", CDUnknown)+ -- , ("default_trireg_strength", CDUnknown)+ -- , ("delay_mode_distributed", CDUnknown)+ -- , ("delay_mode_path", CDUnknown)+ -- , ("delay_mode_unit", CDUnknown)+ -- , ("delay_mode_zero", CDUnknown)+ , ("endcelldefine", CDEndcelldefine)+ , ("nounconnected_drive", CDNounconnecteddrive)+ , ("unconnected_drive", CDUnconnecteddrive)+ ]+ )++includecompdir :: Position -> Alex (Maybe PosToken)+includecompdir _ = do+ oldsc <- gets _asStartCode+ sc 0+ t <- scan+ case t of+ Nothing -> return Nothing+ Just (PosToken _ (LitString s)) -> do+ let f = unpackChars s+ -- LATER: search for file+ i <- liftIO $ LBS.readFile f+ modify' $ \(AlexState _ (AlexInput p pc bs) kw d si) ->+ AlexState oldsc (AlexInput (Position 1 1 $ PSFile f) pc i) kw d $ (p, bs) : si+ scan+ Just (PosToken p _) -> alexPosError p "Expected a filename to include"++linecompdir :: Position -> Alex (Maybe PosToken)+linecompdir _ = do+ oldsc <- gets _asStartCode+ sc 0+ l <- scan+ f <- scan+ c <- scan+ case l >>= \ll -> f >>= \ff -> c >>= \cc -> pure (ll, ff, cc) of+ Nothing -> return Nothing+ Just (PosToken _ (LitDecimal l), PosToken _ (LitString s), PosToken _ (LitDecimal n))+ | n < 3 -> do+ modify' $ \(AlexState _ (AlexInput p pc bs) kw d si) ->+ AlexState+ oldsc+ (AlexInput (Position (naturalToWord l - 1) 1 $ PSLine (unpackChars s) (n == 1)) pc bs)+ kw+ d+ ((p, "") : if n /= 2 then si else smashline si)+ scan+ Just (PosToken _ (LitDecimal _), PosToken _ (LitString _), PosToken p _) ->+ alexPosError p "Expected a number between 0 and 2 to override position"+ Just (PosToken _ (LitDecimal _), PosToken p _, _) ->+ alexPosError p "Expected a filename and a number between 0 and 2 to override position"+ Just (PosToken p _, _, _) ->+ alexPosError+ p+ "Expected a number, a filename and a number between 0 and 2 to override position"+ where+ smashline l =+ case dropWhile (\(p, _) -> case _posSource p of PSLine _ b -> not b; _ -> False) l of+ (Position _ _ (PSLine _ True), _) : t -> t+ ll -> ll++beginkwcompdir :: Position -> Alex (Maybe PosToken)+beginkwcompdir _ = do+ oldsc <- gets _asStartCode+ sc 0+ t <- scan+ case t of+ Nothing -> return Nothing+ Just (PosToken p (LitString s)) -> case versionFromString s of+ Nothing -> alexPosError p "Expected a standard number string (ex. 1364-2005)"+ Just vv -> do+ modify' $ \(AlexState _ i kw d si) -> AlexState oldsc i ((p, vv) : kw) d si+ return $ Just $ PosToken p CDBeginKeywords+ Just (PosToken p _) -> alexPosError p "Expected a standard number string (ex. 1364-2005)"+ where+ versionFromString s = case splitAt 5 $ unpackChars s of+ ("1800-", '2' : '0' : year) -> case year of+ "05" -> Just SV2005+ "09" -> Just SV2009+ "12" -> Just SV2012+ "17" -> Just SV2017+ "23" -> Just SV2023+ _ -> Nothing+ ("1364-", year) -> case year of+ "1995" -> Just V1995+ "2001" -> Just V2001+ "2001-noconfig" -> Just V2001_nc+ "2005" -> Just V2005+ _ -> Nothing+ _ -> Nothing++endkwcompdir :: Position -> Alex (Maybe PosToken)+endkwcompdir p = do+ mkw <- gets _asKeywords+ case mkw of+ [] -> alexError p "`end_kewords encountered without a previous matching `begin_keywords"+ _ : kw -> modify' (\s -> s { _asKeywords = kw }) >> mkPos p CDEndKeywords++isKW :: SBS.ByteString -> Bool+isKW s = HashMap.member s kwSV2012Map++kwV1995 :: [(SBS.ByteString, Alex Token)]+kwV1995 =+ [ ("always", pure KWAlways),+ ("and", pure KWAnd),+ ("assign", pure KWAssign),+ ("begin", pure KWBegin),+ ("buf", pure KWBuf),+ ("bufif0", pure KWBufif0),+ ("bufif1", pure KWBufif1),+ ("case", pure KWCase),+ ("casex", pure KWCasex),+ ("casez", pure KWCasez),+ ("cmos", pure KWCmos),+ ("deassign", pure KWDeassign),+ ("default", pure KWDefault),+ ("defparam", pure KWDefparam),+ ("disable", pure KWDisable),+ ("edge", sc edge >> pure KWEdge),+ ("else", pure KWElse),+ ("end", pure KWEnd),+ ("endcase", pure KWEndcase),+ ("endfunction", pure KWEndfunction),+ ("endmodule", pure KWEndmodule),+ ("endprimitive", pure KWEndprimitive),+ ("endspecify", pure KWEndspecify),+ ("endtable", sc 0 >> pure KWEndtable),+ ("endtask", pure KWEndtask),+ ("event", pure KWEvent),+ ("for", pure KWFor),+ ("force", pure KWForce),+ ("forever", pure KWForever),+ ("fork", pure KWFork),+ ("function", pure KWFunction),+ ("highz0", pure KWHighz0),+ ("highz1", pure KWHighz1),+ ("if", pure KWIf),+ ("ifnone", pure KWIfnone),+ ("initial", pure KWInitial),+ ("inout", pure KWInout),+ ("input", pure KWInput),+ ("integer", pure KWInteger),+ ("join", pure KWJoin),+ ("large", pure KWLarge),+ ("macromodule", pure KWMacromodule),+ ("medium", pure KWMedium),+ ("module", pure KWModule),+ ("nand", pure KWNand),+ ("negedge", pure KWNegedge),+ ("nmos", pure KWNmos),+ ("nor", pure KWNor),+ ("not", pure KWNot),+ ("notif0", pure KWNotif0),+ ("notif1", pure KWNotif1),+ ("or", pure KWOr),+ ("output", pure KWOutput),+ ("parameter", pure KWParameter),+ ("pmos", pure KWPmos),+ ("posedge", pure KWPosedge),+ ("primitive", pure KWPrimitive),+ ("pull0", pure KWPull0),+ ("pull1", pure KWPull1),+ ("pulldown", pure KWPulldown),+ ("pullup", pure KWPullup),+ ("rcmos", pure KWRcmos),+ ("real", pure KWReal),+ ("realtime", pure KWRealtime),+ ("reg", pure KWReg),+ ("release", pure KWRelease),+ ("repeat", pure KWRepeat),+ ("rnmos", pure KWRnmos),+ ("rpmos", pure KWRpmos),+ ("rtran", pure KWRtran),+ ("rtranif0", pure KWRtranif0),+ ("rtranif1", pure KWRtranif1),+ ("scalared", pure KWScalared),+ ("small", pure KWSmall),+ ("specify", pure KWSpecify),+ ("specparam", pure KWSpecparam),+ ("strong0", pure KWStrong0),+ ("strong1", pure KWStrong1),+ ("supply0", pure KWSupply0),+ ("supply1", pure KWSupply1),+ ("table", sc table >> pure KWTable),+ ("task", pure KWTask),+ ("time", pure KWTime),+ ("tran", pure KWTran),+ ("tranif0", pure KWTranif0),+ ("tranif1", pure KWTranif1),+ ("tri", pure KWTri),+ ("tri0", pure KWTri0),+ ("tri1", pure KWTri1),+ ("triand", pure KWTriand),+ ("trior", pure KWTrior),+ ("trireg", pure KWTrireg),+ ("vectored", pure KWVectored),+ ("wait", pure KWWait),+ ("wand", pure KWWand),+ ("weak0", pure KWWeak0),+ ("weak1", pure KWWeak1),+ ("while", pure KWWhile),+ ("wire", pure KWWire),+ ("wor", pure KWWor),+ ("xnor", pure KWXnor),+ ("xor", pure KWXor)+ ]++kwV2001_nc :: [(SBS.ByteString, Alex Token)]+kwV2001_nc =+ ("automatic", pure KWAutomatic)+ : ("endgenerate", pure KWEndgenerate)+ : ("generate", pure KWGenerate)+ : ("genvar", pure KWGenvar)+ : ("localparam", pure KWLocalparam)+ : ("noshowcancelled", pure KWNoshowcancelled)+ : ("pulsestyle_ondetect", pure KWPulsestyleondetect)+ : ("pulsestyle_onevent", pure KWPulsestyleonevent)+ : ("showcancelled", pure KWShowcancelled)+ : ("signed", pure KWSigned)+ : ("unsigned", pure KWUnsigned)+ : kwV1995++kwV2001 :: [(SBS.ByteString, Alex Token)]+kwV2001 =+ ("cell", pure KWCell)+ : ("config", pure KWConfig)+ : ("design", pure KWDesign)+ : ("endconfig", pure KWEndconfig)+ : ("incdir", pure KWIncdir)+ : ("include", pure KWInclude)+ : ("instance", pure KWInstance)+ : ("liblist", pure KWLiblist)+ : ("library", pure KWLibrary)+ : ("use", pure KWUse)+ : kwV2001_nc++kwV2005 :: [(SBS.ByteString, Alex Token)]+kwV2005 =+ ("uwire", pure KWUwire)+ : kwV2001++kwSV2005 :: [(SBS.ByteString, Alex Token)]+kwSV2005 =+ ("alias", pure $ TokSVKeyword "alias")+ : ("always_comb", pure $ TokSVKeyword "always_comb")+ : ("always_ff", pure $ TokSVKeyword "always_ff")+ : ("always_latch", pure $ TokSVKeyword "always_latch")+ : ("assert", pure $ TokSVKeyword "assert")+ : ("assume", pure $ TokSVKeyword "assume")+ : ("before", pure $ TokSVKeyword "before")+ : ("bind", pure $ TokSVKeyword "bind")+ : ("bins", pure $ TokSVKeyword "bins")+ : ("binsof", pure $ TokSVKeyword "binsof")+ : ("bit", pure $ TokSVKeyword "bit")+ : ("break", pure $ TokSVKeyword "break")+ : ("byte", pure $ TokSVKeyword "byte")+ : ("chandle", pure $ TokSVKeyword "chandle")+ : ("class", pure $ TokSVKeyword "class")+ : ("clocking", pure $ TokSVKeyword "clocking")+ : ("const", pure $ TokSVKeyword "const")+ : ("constraint", pure $ TokSVKeyword "constraint")+ : ("context", pure $ TokSVKeyword "context")+ : ("continue", pure $ TokSVKeyword "continue")+ : ("cover", pure $ TokSVKeyword "cover")+ : ("covergroup", pure $ TokSVKeyword "covergroup")+ : ("coverpoint", pure $ TokSVKeyword "coverpoint")+ : ("cross", pure $ TokSVKeyword "cross")+ : ("dist", pure $ TokSVKeyword "dist")+ : ("do", pure $ TokSVKeyword "do")+ : ("endclass", pure $ TokSVKeyword "endclass")+ : ("endclocking", pure $ TokSVKeyword "endclocking")+ : ("endgroup", pure $ TokSVKeyword "endgroup")+ : ("endinterface", pure $ TokSVKeyword "endinterface")+ : ("endpackage", pure $ TokSVKeyword "endpackage")+ : ("endprogram", pure $ TokSVKeyword "endprogram")+ : ("endproperty", pure $ TokSVKeyword "endproperty")+ : ("endsequence", pure $ TokSVKeyword "endsequence")+ : ("enum", pure $ TokSVKeyword "enum")+ : ("expect", pure $ TokSVKeyword "expect")+ : ("export", pure $ TokSVKeyword "export")+ : ("extends", pure $ TokSVKeyword "extends")+ : ("extern", pure $ TokSVKeyword "extern")+ : ("final", pure $ TokSVKeyword "final")+ : ("first_match", pure $ TokSVKeyword "first_match")+ : ("foreach", pure $ TokSVKeyword "foreach")+ : ("forkjoin", pure $ TokSVKeyword "forkjoin")+ : ("iff", pure $ TokSVKeyword "iff")+ : ("ignore_bins", pure $ TokSVKeyword "ignore_bins")+ : ("illegal_bins", pure $ TokSVKeyword "illegal_bins")+ : ("import", pure $ TokSVKeyword "import")+ : ("inside", pure $ TokSVKeyword "inside")+ : ("int", pure $ TokSVKeyword "int")+ : ("interface", pure $ TokSVKeyword "interface")+ : ("intersect", pure $ TokSVKeyword "intersect")+ : ("join_any", pure $ TokSVKeyword "join_any")+ : ("join_none", pure $ TokSVKeyword "join_none")+ : ("local", pure $ TokSVKeyword "local")+ : ("logic", pure $ TokSVKeyword "logic")+ : ("longint", pure $ TokSVKeyword "longint")+ : ("matches", pure $ TokSVKeyword "matches")+ : ("modport", pure $ TokSVKeyword "modport")+ : ("new", pure $ TokSVKeyword "new")+ : ("null", pure $ TokSVKeyword "null")+ : ("package", pure $ TokSVKeyword "package")+ : ("packed", pure $ TokSVKeyword "packed")+ : ("priority", pure $ TokSVKeyword "priority")+ : ("program", pure $ TokSVKeyword "program")+ : ("property", pure $ TokSVKeyword "property")+ : ("protected", pure $ TokSVKeyword "protected")+ : ("pure", pure $ TokSVKeyword "pure")+ : ("rand", pure $ TokSVKeyword "rand")+ : ("randc", pure $ TokSVKeyword "randc")+ : ("randcase", pure $ TokSVKeyword "randcase")+ : ("randsequence", pure $ TokSVKeyword "randsequence")+ : ("ref", pure $ TokSVKeyword "ref")+ : ("return", pure $ TokSVKeyword "return")+ : ("sequence", pure $ TokSVKeyword "sequence")+ : ("shortint", pure $ TokSVKeyword "shortint")+ : ("shortreal", pure $ TokSVKeyword "shortreal")+ : ("solve", pure $ TokSVKeyword "solve")+ : ("static", pure $ TokSVKeyword "static")+ : ("string", pure $ TokSVKeyword "string")+ : ("struct", pure $ TokSVKeyword "struct")+ : ("super", pure $ TokSVKeyword "super")+ : ("tagged", pure $ TokSVKeyword "tagged")+ : ("this", pure $ TokSVKeyword "this")+ : ("throughout", pure $ TokSVKeyword "throughout")+ : ("timeprecision", pure $ TokSVKeyword "timeprecision")+ : ("timeunit", pure $ TokSVKeyword "timeunit")+ : ("type", pure $ TokSVKeyword "type")+ : ("typedef", pure $ TokSVKeyword "typedef")+ : ("union", pure $ TokSVKeyword "union")+ : ("unique", pure $ TokSVKeyword "unique")+ : ("var", pure $ TokSVKeyword "var")+ : ("virtual", pure $ TokSVKeyword "virtual")+ : ("void", pure $ TokSVKeyword "void")+ : ("wait_order", pure $ TokSVKeyword "wait_order")+ : ("wildcard", pure $ TokSVKeyword "wildcard")+ : ("with", pure $ TokSVKeyword "with")+ : ("within", pure $ TokSVKeyword "within")+ : kwV2005++kwSV2009 :: [(SBS.ByteString, Alex Token)]+kwSV2009 =+ ("accept_on", pure $ TokSVKeyword "accept_on")+ : ("checker", pure $ TokSVKeyword "checker")+ : ("endchecker", pure $ TokSVKeyword "endchecker")+ : ("eventually", pure $ TokSVKeyword "eventually")+ : ("global", pure $ TokSVKeyword "global")+ : ("implies", pure $ TokSVKeyword "implies")+ : ("let", pure $ TokSVKeyword "let")+ : ("nexttime", pure $ TokSVKeyword "nexttime")+ : ("reject_on", pure $ TokSVKeyword "reject_on")+ : ("restrict", pure $ TokSVKeyword "restrict")+ : ("s_always", pure $ TokSVKeyword "s_always")+ : ("s_eventually", pure $ TokSVKeyword "s_eventually")+ : ("s_nexttime", pure $ TokSVKeyword "s_nexttime")+ : ("s_until", pure $ TokSVKeyword "s_until")+ : ("s_until_with", pure $ TokSVKeyword "s_until_with")+ : ("strong", pure $ TokSVKeyword "strong")+ : ("sync_accept_on", pure $ TokSVKeyword "sync_accept_on")+ : ("sync_reject_on", pure $ TokSVKeyword "sync_reject_on")+ : ("unique0", pure $ TokSVKeyword "unique0")+ : ("until", pure $ TokSVKeyword "until")+ : ("until_with", pure $ TokSVKeyword "until_with")+ : ("untyped", pure $ TokSVKeyword "untyped")+ : ("weak", pure $ TokSVKeyword "weak")+ : kwSV2005++kwSV2012 :: [(SBS.ByteString, Alex Token)]+kwSV2012 =+ ("implements", pure $ TokSVKeyword "implements")+ : ("interconnect", pure $ TokSVKeyword "interconnect")+ : ("nettype", pure $ TokSVKeyword "nettype")+ : ("soft", pure $ TokSVKeyword "soft")+ : kwSV2009++kwV1995Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwV1995Map = HashMap.fromList kwV1995++kwV2001Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwV2001Map = HashMap.fromList kwV2001++kwV2001NCMap :: HashMap.HashMap SBS.ByteString (Alex Token)+kwV2001NCMap = HashMap.fromList kwV2001_nc++kwV2005Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwV2005Map = HashMap.fromList kwV2005++kwSV2005Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwSV2005Map = HashMap.fromList kwSV2005++kwSV2009Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwSV2009Map = HashMap.fromList kwSV2009++kwSV2012Map :: HashMap.HashMap SBS.ByteString (Alex Token)+kwSV2012Map = HashMap.fromList kwSV2012++}
+ src/Verismith/Verilog2005/LibPretty.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+-- Module : Verismith.Verilog2005.LibPretty+-- Description : Pretty printer library with intuitive display algorithm.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX+{-# LANGUAGE OverloadedLists #-}++module Verismith.Verilog2005.LibPretty+ ( Doc,+ nullDoc,+ raw,+ alt,+ viaShow,+ lparen,+ rparen,+ lbrace,+ rbrace,+ lbracket,+ rbracket,+ langle,+ rangle,+ comma,+ colon,+ dot,+ equals,+ semi,+ squote,+ space,+ indent,+ hardline,+ newline,+ softline,+ softspace,+ encl,+ (<+>),+ (<#>),+ (<->),+ (<=>),+ (</>),+ mkopt,+ (<?+>),+ (<?#>),+ (<?=>),+ (<?/>),+ trailoptcat,+ nest,+ group,+ ng,+ block,+ layout,+ )+where++import Control.Applicative (liftA2)+import Data.Bits+import qualified Data.ByteString as SB+import Data.ByteString.Builder+import Data.ByteString.Internal (isSpaceWord8, w2c)+import qualified Data.ByteString.Lazy as LB+import Data.Char+import Data.Foldable+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe)+import Data.Semigroup+import Data.String+import Verismith.Utils hiding (comma)++infixr 6 <+>++infixr 6 <#>++infixr 6 <->++infixr 6 <=>++infixr 6 </>++infixr 6 <?+>++infixr 6 <?#>++infixr 6 <?=>++infixr 6 <?/>++-- Consider adding a constructor to keep first and last line in constant time reach+data Doc' w+ = Lines w (Doc' w) (Doc' w)+ | Line Word (Line w)++data Line w+ = Concat w (Line w) (Line w)+ | Token SB.ByteString+ | Group w (Line w)+ | Nest w (Line w)+ | Alt SB.ByteString (Doc' w)++type Doc = Doc' ()++type DocLength w = (Ord w, Semigroup w, Enum w)++emptyLine :: Line w+emptyLine = Token ""++emptyDoc :: Doc' w+emptyDoc = Line 0 emptyLine++nullLine :: Line w -> Bool+nullLine l = case l of+ Concat _ a b -> nullLine a && nullLine b+ Token t -> SB.null t+ Alt t d -> SB.null t && nullDoc d+ Group _ l -> nullLine l+ Nest _ l -> nullLine l++nullDoc :: Doc' w -> Bool+nullDoc d = case d of+ Lines _ _ _ -> False+ Line i l -> i == 0 && nullLine l++linelength :: (Semigroup w, Enum w) => Word -> Line w -> w+linelength i l = toEnum (4 * fromEnum i) <> maxLengthLine l++maxLengthLine :: Enum w => Line w -> w+maxLengthLine l = case l of+ Concat w _ _ -> w+ Token t -> toEnum $ SB.length t+ Alt t _ -> toEnum $ SB.length t+ Group w _ -> w+ Nest w _ -> w++maxLengthDoc :: (Semigroup w, Enum w) => Doc' w -> w+maxLengthDoc d = case d of+ Lines w _ _ -> w+ Line i l -> linelength i l++instance (Semigroup w, Enum w) => Semigroup (Line w) where+ (<>) a b =+ if nullLine a+ then b+ else+ if nullLine b+ then a+ else case (a, b) of+ (Group wa da, Group wb db) -> Group (wa <> wb) (da <> db)+ (_, _) -> Concat (maxLengthLine a <> maxLengthLine b) a b++instance (Semigroup w, Enum w) => Monoid (Line w) where+ mempty = emptyLine++instance IsString (Line w) where+ fromString = Token . fromString++(<#>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<#>) a b = Lines (max (maxLengthDoc a) (maxLengthDoc b)) a b++extractFirstLine :: DocLength w => Doc' w -> Doc' w -> (Word, Line w, Doc' w)+extractFirstLine a b = case a of+ Line i l -> (i, l, b)+ Lines _ l a -> extractFirstLine l $ a <#> b++extractLastLine :: DocLength w => Doc' w -> Doc' w -> (Doc' w, Word, Line w)+extractLastLine a b = case b of+ Line i l -> (a, i, l)+ Lines _ b l -> extractLastLine (a <#> b) l++instance DocLength w => Semigroup (Doc' w) where+ (<>) a b = case (a, b) of+ (Line ia la, Line ib lb) -> catline ia la ib lb+ (Line il l, Lines _ a b) -> let (ic, c, r) = extractFirstLine a b in catline il l ic c <#> r+ (Lines w a b, Line ir r) -> let (l, ic, c) = extractLastLine a b in l <#> catline ic c ir r+ (Lines _ a b, Lines _ c d) ->+ let (ll, il, lr) = extractLastLine a b+ (ir, rl, rr) = extractFirstLine c d+ in ll <#> catline il lr ir rl <#> rr+ where+ catline ia la ib lb = if nullLine la then Line (ia + ib) lb else Line ia (la <> lb)++instance DocLength w => Monoid (Doc' w) where+ mempty = emptyDoc++instance DocLength w => IsString (Doc' w) where+ fromString s =+ nonEmpty+ mempty+ ( foldrMap1 f ((<#>) . f)+ . \((h :| l) :| t) -> if h == '\n' then [h] :| (h :| l) : t else ('\n' :| h : l) :| t+ )+ $ NE.groupBy (const (/= '\n')) s+ where+ f s =+ ( \(a, b) ->+ Line (div (foldl' (\b c -> 1 + if c == '\t' then b .|. 3 else b) 0 a) 4) $ fromString b+ )+ $ span isSpace $ NE.tail s++raw :: SB.ByteString -> Doc' w+raw = Line 0 . Token++alt :: SB.ByteString -> Doc' w -> Doc' w+alt a b = Line 0 $ Alt a b++viaShow :: Show a => a -> Doc' w+viaShow = raw . fromString . show++lparen :: Doc' w+lparen = raw "("++rparen :: Doc' w+rparen = raw ")"++lbrace :: Doc' w+lbrace = raw "{"++rbrace :: Doc' w+rbrace = raw "}"++lbracket :: Doc' w+lbracket = raw "["++rbracket :: Doc' w+rbracket = raw "]"++langle :: Doc' w+langle = raw "<"++rangle :: Doc' w+rangle = raw ">"++comma :: Doc' w+comma = raw ","++colon :: Doc' w+colon = raw ":"++dot :: Doc' w+dot = raw "."++equals :: Doc' w+equals = raw "="++semi :: Doc' w+semi = raw ";"++squote :: Doc' w+squote = raw "'"++space :: Doc' w+space = raw " "++hardline :: Enum w => Doc' w+hardline = Lines (toEnum 0) emptyDoc emptyDoc++newline :: Enum w => Doc' w+newline = alt " " hardline++softline :: Enum w => Doc' w+softline = alt "" hardline++softspace :: Doc' w+softspace = alt "" $ raw " "++appendWith :: DocLength w => Line w -> Doc' w -> Doc' w -> Doc' w+appendWith l a b = case (a, b) of+ (Line ia la, Line ib lb) -> Line ia $ la <> l <> lb+ (Line i ll, Lines _ a b) -> let (_, c, r) = extractFirstLine a b in Line i (ll <> l <> c) <#> r+ (Lines _ a b, Line _ r) -> let (ll, i, c) = extractLastLine a b in ll <#> Line i (c <> l <> r)+ (Lines _ a b, Lines _ c d) ->+ let (ll, i, lr) = extractLastLine a b+ (_, rl, rr) = extractFirstLine c d+ in ll <#> Line i (lr <> l <> rl) <#> rr++(<+>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<+>) = appendWith " "++(<->) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<->) = appendWith $ Alt "" $ raw " "++(<=>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<=>) = appendWith $ Alt " " hardline++(</>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(</>) = appendWith $ Alt "" hardline++mkopt :: (Doc' w -> Doc' w -> Doc' w) -> Doc' w -> Doc' w -> Doc' w+mkopt f a b = if nullDoc a then b else if nullDoc b then a else f a b++(<?+>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<?+>) = mkopt (<+>)++(<?#>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<?#>) = mkopt (<#>)++(<?=>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<?=>) = mkopt (<=>)++(<?/>) :: DocLength w => Doc' w -> Doc' w -> Doc' w+(<?/>) = mkopt (</>)++trailoptcat :: Foldable f => (Doc' w -> Doc' w -> Doc' w) -> f (Doc' w) -> Doc' w+trailoptcat f =+ fromMaybe emptyDoc+ . foldr (\a -> maybe (if nullDoc a then Nothing else Just a) $ Just . f a) Nothing++foldDoc :: (Word -> Line w -> a) -> (a -> a -> a) -> Doc' w -> a+foldDoc f g d = case d of Lines _ a b -> g (foldDoc f g a) (foldDoc f g b); Line i l -> f i l++mapDoc :: DocLength w => (Word -> Line v -> Doc' w) -> Doc' v -> Doc' w+mapDoc f = foldDoc f (<#>)++foldLine ::+ (SB.ByteString -> a) ->+ (SB.ByteString -> Doc' w -> a) ->+ (a -> a) ->+ (a -> a) ->+ (a -> a -> a) ->+ Line w ->+ a+foldLine f g h i j l = case l of+ Token s -> f s+ Alt s d -> g s d+ Group _ l -> h $ foldLine f g h i j l+ Nest _ l -> i $ foldLine f g h i j l+ Concat _ a b -> j (foldLine f g h i j a) (foldLine f g h i j b)++group :: DocLength w => Doc' w -> Doc' w+group d = case d of+ Line i l -> Line i $ mk l+ Lines w a b -> let (il, l, r) = extractFirstLine a b in Lines w (Line il $ mk l) r+ where+ mk l = Group (maxLengthLine l) l++indent :: DocLength w => Word -> Doc' w -> Doc' w+indent i = mapDoc $ Line . (i +)++nest :: DocLength w => Doc' w -> Doc' w+nest d = case d of+ Line i l -> Line i $ mk l+ Lines _ a b -> let (il, l, r) = extractFirstLine a b in Line il (mk l) <#> indent 1 r+ where+ mk l = Nest (maxLengthLine l) l++ng :: DocLength w => Doc' w -> Doc' w+ng d = case d of+ Line i l -> Line i $ mk l+ Lines _ a b -> let (il, l, r) = extractFirstLine a b in Line il (mk l) <#> indent 1 r+ where+ mk l = let w = maxLengthLine l in Group w $ Nest w l++block :: DocLength w => Doc' w -> Doc' w -> Doc' w -> Doc' w+block l r x = l <#> indent 1 x <#> r++encl :: DocLength w => Doc' w -> Doc' w -> Doc' w -> Doc' w+encl l r x = group $ l <-> x <> r++instance Enum w => Enum (Sum w) where+ toEnum = Sum . toEnum+ fromEnum (Sum w) = fromEnum w+ succ (Sum w) = Sum $ succ w+ pred (Sum w) = Sum $ pred w++flatten :: Doc' w -> Builder+flatten =+ foldDoc+ ( \i l ->+ string8 (replicate (fromEnum i) '\t')+ <> foldLine byteString (const . byteString) id id (<>) l+ )+ (\a b -> a <> "\n" <> b)++-- | Add max line length data to the doc+preprocess :: DocLength w => Doc' v -> (Any, Doc' w)+preprocess =+ foldDoc+ ( \i ->+ fmap (Line i)+ . foldLine+ (pure . Token)+ (\s d -> (Any True, Alt s $ snd $ preprocess d))+ (\(b, l) -> (b, if getAny b then Group (maxLengthLine l) l else l))+ (\(b, l) -> (b, if getAny b then Nest (maxLengthLine l) l else l))+ (liftA2 $ \a b -> Concat (maxLengthLine a <> maxLengthLine b) a b)+ )+ $ liftA2 (<#>)++breakLine :: DocLength w => Word -> Line w -> (Any, Doc' w)+breakLine i l = case l of+ Concat _ a b -> (<>) <$> breakLine i a <*> breakLine i b+ Token s -> pure $ Line i $ Token s+ Alt _ d -> (Any True, d)+ Group _ l -> (Any True, Line i l)+ Nest _ l -> let (b, d) = breakLine i l in (b, if getAny b then nest d else d)++breakDoc :: DocLength w => w -> Doc' w -> Doc' w+breakDoc w d = case d of+ Line i l | w < linelength i l && toEnum (4*(fromEnum i)) < w ->+ let (Any b, d) = breakLine i l in if b then breakDoc w d else d+ Lines w' a b | w < w' -> breakDoc w a <#> breakDoc w b+ _ -> d++layout :: Maybe Word -> Doc' w -> LB.ByteString+layout w d =+ toLazyByteString $+ maybe+ (flatten d)+ ( \w ->+ let (Any b, d') = preprocess d+ in flatten $ if b && Sum w < maxLengthDoc d' then breakDoc (Sum w) d' else d'+ )+ w
+ src/Verismith/Verilog2005/Parser.hs view
@@ -0,0 +1,1899 @@+-- Module : Verismith.Verilog2005.Parser+-- Description : Partial Verilog 2005 parser to reconstruct the AST.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE CPP #-}++module Verismith.Verilog2005.Parser+ ( parseVerilog2005,+ )+where++import Control.Applicative (liftA2)+import Control.Lens hiding ((<|))+import Data.Functor.Compose+import Control.Monad (join)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer.CPS+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w)+import qualified Data.ByteString.Lazy as LB+import Data.Data (Data, constrIndex, toConstr)+import Data.Bifunctor+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.IntMap.Strict as IntMap+import Data.Foldable+import Data.List+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust)+import qualified Data.Vector.Unboxed as V+import Text.Parsec hiding (satisfy, uncons)+import Text.Parsec.Error+import Text.Parsec.Expr+import Text.Parsec.Pos+import Text.Printf (printf)+import Verismith.Utils+import Verismith.Verilog2005.AST+import Verismith.Verilog2005.Lexer+import Verismith.Verilog2005.PrettyPrinter+import Verismith.Verilog2005.Token+import Verismith.Verilog2005.Utils++#if MIN_VERSION_base(4,19,0)+import qualified Data.Functor as DF (unzip)+#else+import qualified Data.List.NonEmpty as DF (unzip)+#endif++-- | The parser monad with LocalCompDir (local values of compiler directives) as local state+-- | and a writer monad for the list of warnings as the base monad+type Parser = ParsecT [PosToken] LocalCompDir (Writer [String])++-- | A production rule associated to a token without data+type Produce a = (Token, a)++type LProduce a = [Produce a]++-- | A branching in the parser based on a token without data+type Branch a = Produce (Parser a)++type LBranch a = [Branch a]++-- | Same as above but parametrised by attributes+type AProduce a = Produce (Attributes -> a)++type LAProduce a = [AProduce a]++type ABranch a = AProduce (Parser a)++type LABranch a = [ABranch a]++type APBranch a = Produce (Attributes -> SourcePos -> Parser a)++type LAPBranch a = [APBranch a]++-- | An error that is not merged with other errors and expected tokens+hardfail :: String -> Parser a+hardfail m =+ mkPT $ \s -> return $ Consumed $ return $ Error $ newErrorMessage (Message m) (statePos s)++-- | Warning formatting+warn :: SourcePos -> String -> Parser ()+warn pos s = lift $ tell [printf "Line %d, column %d: %s" (sourceLine pos) (sourceColumn pos) s]++-- | Gets a number from a Token, erases the data associated with it+getConsIndex :: Data a => a -> Int+getConsIndex = constrIndex . toConstr++-- | Efficient token branching utility+mkActionMap :: LProduce a -> IntMap.IntMap a+mkActionMap =+ IntMap.fromListWithKey (\k _ _ -> error $ "Conflict on " ++ show k)+ . map (first getConsIndex)++-- | Updates the position information+nextPos :: SourcePos -> PosToken -> [PosToken] -> SourcePos+nextPos pos _ ptl = case ptl of+ PosToken (Position l c (PSDefine _) :| _) _ : _ ->+ setSourceColumn (setSourceLine pos $ fromEnum l) $ fromEnum c+ PosToken (Position l c (PSFile f) :| _) _ : _ -> newPos f (fromEnum l) (fromEnum c)+ PosToken (Position l c (PSLine f _) :| _) _ : _ -> newPos f (fromEnum l) (fromEnum c)+ [] -> pos++-- | Parse exactly one token and produce a value+producePrim :: (Token -> Maybe a) -> Parser a+producePrim f = tokenPrim show nextPos (f . _ptToken)++-- | Parse exactly one token and branches+branchPrim :: (Token -> Maybe (Parser a)) -> Parser a+branchPrim = join . producePrim++-- | Parse these annoying compiler directives that can appear anywhere+anywherecompdir :: Parser ()+anywherecompdir = skipMany $+ branchPrim $ \t -> case t of+ CDCelldefine -> Just $ modifyState $ lcdCell .~ True+ CDEndcelldefine -> Just $ modifyState $ lcdCell .~ False+ _ -> Nothing++-- | Basic one token parsing able to produce a value using a function, uninformative error on failure+fproduce :: (Token -> Maybe a) -> Parser a+fproduce f = producePrim f <* anywherecompdir++-- | Branches on a Token without data, informative error on failure+lproduce :: LProduce a -> Parser a+lproduce l =+ fproduce (\t -> IntMap.lookup (getConsIndex t) $ mkActionMap l)+ `labels` map (\(d, _) -> show d) l++-- | Maps a function on the data given by branching on a Token without data+maplproduce :: (a -> b) -> LProduce a -> LProduce b+maplproduce = map . second++-- | Same as above but for branching with attributes+maplaproduce :: (a -> b) -> LAProduce a -> LAProduce b+maplaproduce f = map $ second (f .)++-- | Try to consume the provided token, informative error on failure+consume :: Token -> Parser ()+consume et = fproduce (\at -> if at == et then Just () else Nothing) <?> show et++-- | Try to consume the provided token and returns true on success (cannot fail)+optConsume :: Token -> Parser Bool+optConsume et = option False $ fproduce $ \at -> if at == et then Just True else Nothing++-- | Branch on the next token using a function+fbranch :: (Token -> Maybe (Parser a)) -> Parser a+fbranch = join . fproduce++-- | Branch on the next token but remembers position of the branching+fpbranch :: (SourcePos -> Token -> Maybe (Parser a)) -> Parser a+fpbranch f = join $ (getPosition >>= producePrim . f) <* anywherecompdir++-- | Parse attributes then branches on the next token using a LABranch+lbranch :: LBranch a -> Parser a+lbranch = join . lproduce++-- | Parse attributes then branches on the next token using a LABranch+labranch :: LABranch a -> Parser a+labranch l = attributes >>= \a -> lproduce l >>= \p -> p a++-- | Maps a function on the data given by a branching with attributes+maplbranch :: (a -> b) -> LBranch a -> LBranch b+maplbranch = maplproduce . fmap++-- | Maps a function on the data given by a single branch with attributes+mapabranch :: (a -> b) -> ABranch a -> ABranch b+mapabranch f = second $ \p a -> f <$> p a++-- | Maps a function on the data given by a branching with attributes+maplabranch :: (a -> b) -> LABranch a -> LABranch b+maplabranch = map . mapabranch++-- | Specialised repeating combinator+monoAccum :: Monoid a => Parser a -> Parser a+monoAccum p = optionMaybe p >>= maybe (pure mempty) (\x -> (x <>) <$> monoAccum p)++-- | What many1 should have been+manyNE :: Parser a -> Parser (NonEmpty a)+manyNE = fmap NE.fromList . many1++-- | Consume a closing delimiter+closeConsume :: SourcePos -> Token -> Token -> Parser ()+closeConsume p o c =+ fproduce (\t -> if t == c then Just () else Nothing)+ <?> printf+ "closing %s to match opening %s at %d:%d"+ (show c)+ (show o)+ (sourceLine p)+ (sourceColumn p)++-- | Enclose a parser with tokens and keep track of the opening token position+enclosed :: Token -> Token -> Parser a -> Parser a+enclosed l r x = do+ p <- getPosition+ consume l+ res <- x+ closeConsume p l r+ return res++-- | Enclosed between parentheses/brackets/braces+parens :: Parser a -> Parser a+parens = enclosed SymParenL SymParenR++brackets :: Parser a -> Parser a+brackets = enclosed SymBrackL SymBrackR++braces :: Parser a -> Parser a+braces = enclosed SymBraceL SymBraceR++-- | Comma separated list+csl :: Parser a -> Parser [a]+csl p = sepBy p $ consume SymComma++-- | Comma separated list with at least 1 element+csl1 :: Parser a -> Parser (NonEmpty a)+csl1 p = NE.fromList <$> sepBy1 p (consume SymComma)++-- | Warning on 0 element to follow SystemVerilog2017 syntax when 1 is required in Verilog2005+wempty :: String -> Parser [a] -> Parser [a]+wempty s p = do+ pos <- getPosition+ l <- p+ if null l then warn pos $ printf "Zero %s is a SystemVerilog feature" s else return ()+ return l++-- | Comma separated list potentially ended by a comma to be lenient+xcsl :: String -> Parser a -> Parser [a]+xcsl s p = do+ x <- optionMaybe p+ case x of+ Nothing -> pure []+ Just h -> do+ pos <- getPosition+ b <- optConsume SymComma+ if b+ then do+ t <- xcsl s p+ if null t+ then warn pos (printf "Extraneous comma at the end of %s is not correct Verilog" s)+ else pure ()+ return $ h : t+ else return [h]++-- | Comma separated list potentially ended by a comma to be lenient+xcsl1 :: String -> Parser a -> Parser (NonEmpty a)+xcsl1 s p = do+ x <- p+ pos <- getPosition+ b <- optConsume SymComma+ if b+ then ((x <|) <$> xcsl1 s p)+ <|> warn pos (printf "Extraneous comma at the end of %s is not correct Verilog" s)+ *> return [x]+ else return [x]++-- | Just read the definition+wxcsl :: String -> Parser a -> Parser [a]+wxcsl m = wempty m . xcsl m++-- | Safe parsing comma separated list with at least 1 elements+scsl1 :: Bool -> Parser a -> (a -> Parser b) -> Parser (NonEmpty b)+scsl1 safety d p = do+ h <- d >>= p+ t <- many $ ((if safety then try else id) $ consume SymComma *> d) >>= p+ return $ h :| t++-- | Safe parsing of several elements of type B then of type C+-- | when B and C start with a common part of type A+smanythen :: Parser a -> (a -> Parser b) -> (a -> Parser c) -> Parser ([b], [c])+smanythen pa pb pc = do+ h <- optionMaybe $ pa >>= \a -> Left <$> pb a <|> Right <$> pc a+ case h of+ Nothing -> return ([], [])+ Just (Left hb) -> first (hb :) <$> smanythen pa pb pc+ Just (Right hc) -> (,) [] . (hc :) <$> many (pa >>= pc)++-- | Parenthesised comma separated list+pcsl :: Parser a -> Parser [a]+pcsl = parens . csl++pcsl1 :: Parser a -> Parser (NonEmpty a)+pcsl1 = parens . csl1++bcsl1 :: Parser a -> Parser (NonEmpty a)+bcsl1 = braces . csl1++parseBS :: Parser B.ByteString+parseBS =+ fproduce (\t -> case t of IdSimple s -> Just s; IdEscaped s -> Just s; _ -> Nothing)+ <?> "identifier"++-- | Extracts an identifier+ident :: Parser Identifier+ident = Identifier <$> parseBS++lenientIdent :: Parser Identifier+lenientIdent = do+ pos <- getPosition+ fbranch+ ( \t -> case t of+ IdSimple s -> Just $ return $ Identifier s+ IdEscaped s -> Just $ return $ Identifier s+ IdSystem s -> Just $ do+ warn+ pos+ "Dollar prefixed identifier outside system function or task is not correct Verilog"+ return $ Identifier s+ _ -> Nothing+ )+ <?> "identifier"++-- | Library prefixed cell for config blocks+dot1Ident :: Parser Dot1Ident+dot1Ident = do+ f <- parseBS+ s <- optionMaybe $ consume SymDot *> ident+ return $ case s of Nothing -> Dot1Ident Nothing $ Identifier f; Just s -> Dot1Ident (Just f) s++attribute :: Parser Attribute+attribute = do+ attr <- parseBS+ value <- optionMaybe $ consume SymEq+ *> genExpr (pure . Identifier) (optionMaybe constRangeExpr) (pure ()) Just constifyMaybeRange+ return $ Attribute attr value++-- TODO: this is likely incorrectly used but I leave this bug on purpose atm+attributeOne :: Parser [Attribute]+attributeOne = enclosed SymParenAster SymAsterParen $ NE.toList <$> csl1 attribute++-- | Flattened list of attributes+attributes :: Parser Attributes+attributes = many attributeOne++-- | Number after base+number :: Base -> Parser Number+number b = case b of+ BBin -> NBinary <$> fproduce (\t -> case t of LitBinary b -> Just $ NE.fromList b; _ -> Nothing)+ BOct -> NOctal <$> fproduce (\t -> case t of LitOctal o -> Just $ NE.fromList o; _ -> Nothing)+ BDec -> fproduce $ \t -> case t of+ LitXZ b -> Just $ NXZ b+ LitDecimal i -> Just $ NDecimal i+ _ -> Nothing+ BHex -> NHex <$> fproduce (\t -> case t of LitHex h -> Just $ NE.fromList h; _ -> Nothing)++type PGenExpr g i r a =+ (B.ByteString -> Parser i) ->+ Parser r ->+ Parser a ->+ (i -> Maybe Identifier) ->+ (Maybe DimRange -> Maybe r) ->+ Parser (g i r a)++-- | Parametric primary expression+genPrim :: PGenExpr GenPrim i r a+genPrim pi pr pa ci cr = fpbranch $ \p t -> case t of+ -- try parse braceL and let that decide the path, otherwise it is wrong for constExpr+ SymBraceL -> Just $ do+ e <- genExpr pi dimRange pa ci Just+ p2 <- getPosition+ b <- optConsume SymBraceL+ ee <- if b+ then case trConstifyGenExpr ci constifyMaybeRange e of+ Nothing -> hardfail "Replication takes a constant expression as multiplicity"+ Just e -> PrimMultConcat e <$> csl1 parseExpr <* closeConsume p2 SymBraceL SymBraceR+ else case trConstifyGenExpr Just cr e of+ Nothing -> hardfail "Invalid kind of expression"+ Just e -> PrimConcat . (e :|) <$> option [] (consume SymComma *> csl parseExpr)+ closeConsume p SymBraceL SymBraceR+ return ee+ SymParenL -> Just $ PrimMinTypMax <$> mtm parseExpr <* closeConsume p SymParenL SymParenR+ LitDecimal i -> Just $+ option (PrimNumber Nothing True $ NDecimal i) $+ fbranch $ \t -> case t of+ NumberBase s b -> Just $ PrimNumber (Just i) s <$> number b+ _ -> Nothing+ LitReal s -> Just $ return $ PrimReal s+ NumberBase s b -> Just $ PrimNumber Nothing s <$> number b+ LitString s -> Just $ return $ PrimString s+ IdSystem s ->+ Just $ PrimSysFun s <$> option [] (parens $ wempty "system function argument" $ csl parseExpr)+ IdSimple s -> Just $ idp s+ IdEscaped s -> Just $ idp s+ _ -> Nothing+ where+ parseExpr = genExpr pi pr pa ci cr+ fp s = PrimFun s <$> pa <*> parens (wempty "function argument" $ csl parseExpr)+ idp s = pi s >>= \ss -> fp ss <|> PrimIdent ss <$> pr++-- | Unary operator can only be applied on primary expressions+genBase :: PGenExpr GenExpr i r a+genBase pi pr pa ci cr = do+ op <- optionMaybe $+ mkpair+ ( fproduce $ \t -> case t of+ UnTilde -> Just UnNot+ UnBang -> Just UnLNot+ UnTildeAmp -> Just UnNand+ UnTildeBar -> Just UnNor+ AmBar -> Just UnOr+ AmHat -> Just UnXor+ AmAmp -> Just UnAnd+ AmTildeHat -> Just UnXNor+ SymPlus -> Just UnPlus+ SymDash -> Just UnMinus+ _ -> Nothing+ )+ pa+ p <- genPrim pi pr pa ci cr+ return $ maybe (ExprPrim p) (flip (uncurry ExprUnOp) p) op++-- | Facility for expression parsing+genExprBuildParser :: PGenExpr GenExpr i r a+genExprBuildParser pi pr pa ci cr =+ buildExpressionParser+ [ infixop $ \t -> case t of BinAsterAster -> Just BinPower; _ -> Nothing,+ infixop $ \t -> case t of+ SymAster -> Just BinTimes+ BinSlash -> Just BinDiv+ BinPercent -> Just BinMod+ _ -> Nothing,+ infixop $ \t -> case t of SymPlus -> Just BinPlus; SymDash -> Just BinMinus; _ -> Nothing,+ infixop $ \t -> case t of+ BinLtLt -> Just BinLSL+ BinGtGt -> Just BinLSR+ BinLtLtLt -> Just BinASL+ BinGtGtGt -> Just BinASR+ _ -> Nothing,+ infixop $ \t -> case t of+ BinLt -> Just BinLT+ SymLtEq -> Just BinLEq+ BinGt -> Just BinGT+ BinGtEq -> Just BinGEq+ _ -> Nothing,+ infixop $ \t -> case t of+ BinEqEq -> Just BinEq+ BinBangEq -> Just BinNEq+ BinEqEqEq -> Just BinCEq+ BinBangEqEq -> Just BinCNEq+ _ -> Nothing,+ infixop $ \t -> case t of AmAmp -> Just BinAnd; _ -> Nothing,+ infixop $ \t -> case t of AmHat -> Just BinXor; AmTildeHat -> Just BinXNor; _ -> Nothing,+ infixop $ \t -> case t of AmBar -> Just BinOr; _ -> Nothing,+ infixop $ \t -> case t of BinAmpAmp -> Just BinLAnd; _ -> Nothing,+ infixop $ \t -> case t of BinBarBar -> Just BinLOr; _ -> Nothing+ ]+ (genBase pi pr pa ci cr)+ where+ infixop fp = [Infix ((\op a l -> ExprBinOp l op a) <$> fproduce fp <*> pa) AssocLeft]++-- | Parametric expression+genExpr :: PGenExpr GenExpr i r a+genExpr pi pr pa ci cr = do+ e <- genExprBuildParser pi pr pa ci cr+ b <- optConsume SymQuestion+ if b+ then ExprCond e <$> pa <*> genExpr pi pr pa ci cr <* consume SymColon <*> genExpr pi pr pa ci cr+ else return e++expr :: Parser Expr+expr = Expr <$> genExpr (trHierIdent True) dimRange attributes constifyIdent Just++constExpr :: Parser CExpr+constExpr =+ CExpr+ <$> genExpr+ (pure . Identifier)+ (optionMaybe constRangeExpr)+ attributes+ Just+ constifyMaybeRange++-- | Minimum, Typical, Maximum on a base type recognised by the argument parser+mtm :: Parser a -> Parser (GenMinTypMax a)+mtm p = do+ x <- p+ b <- optConsume SymColon+ if b+ then MTMFull x <$> p <* consume SymColon <*> p+ else return $ MTMSingle x++-- | Ranges+range2 :: Parser Range2+range2 = brackets $ Range2 <$> constExpr <* consume SymColon <*> constExpr++genRangeExpr :: Parser e -> (e -> Maybe CExpr) -> Parser (GenRangeExpr e)+genRangeExpr pe constf =+ brackets $ do+ b <- pe+ f <- optionMaybe $ try $ fproduce $ \t -> case t of+ SymColon -> case constf b of+ Nothing -> Nothing+ Just m -> Just $ GREPair . Range2 m+ SymPlusColon -> Just $ GREBaseOff b False+ SymDashColon -> Just $ GREBaseOff b True+ _ -> Nothing+ maybe (pure $ GRESingle b) (flip fmap constExpr) f++constRangeExpr :: Parser (CRangeExpr)+constRangeExpr = genRangeExpr constExpr Just++-- | Specify terminal+specTerm :: Parser SpecTerm+specTerm = SpecTerm <$> ident <*> optionMaybe constRangeExpr++-- | Reference and constant minimum typical maximum+cmtmRef :: Parser (Identified (Maybe CMinTypMax))+cmtmRef = Identified <$> ident <*> optionMaybe (brackets $ mtm constExpr)++-- | Sized reference+instName :: Parser InstanceName+instName = InstanceName <$> ident <*> optionMaybe range2++-- | Signedness and range, both optional+signRange :: Parser SignRange+signRange = SignRange <$> optConsume KWSigned <*> optionMaybe range2++-- | Index for each dimension then bit range+genDimRange :: Parser e -> (e -> Maybe CExpr) -> Parser (Maybe (GenDimRange e))+genDimRange pe constf = do+ l <- many $ genRangeExpr pe constf+ case l of+ [] -> return Nothing+ h : t ->+ maybe+ (hardfail "Only the last bracketed expression is allowed to be a range")+ (pure . Just . uncurry (flip GenDimRange))+ $ foldrMapM1+ (\x -> Just (x, []))+ (\x (y, t) -> (,) y . (: t) <$> case x of GRESingle e -> Just e; _ -> Nothing)+ (h :| t)++dimRange :: Parser (Maybe DimRange)+dimRange = genDimRange expr constifyExpr++constDimRange :: Parser (Maybe CDimRange)+constDimRange = genDimRange constExpr Just++-- | Hierarchical identifier+trHierIdent :: Bool -> B.ByteString -> Parser HierIdent+trHierIdent safety s = do+ l <- many $+ mkpair+ ((if safety then try else id) $ optionMaybe (brackets constExpr) <* consume SymDot)+ ident+ return $+ hiPath %~ reverse $ + foldl'+ (\(HierIdent p i) (index, ss) -> HierIdent ((i, index) : p) ss)+ (HierIdent [] $ Identifier s)+ l++hierIdent :: Bool -> Parser HierIdent+hierIdent safety = parseBS >>= trHierIdent safety++-- | Lvalues+lval :: Parser (Maybe dr) -> Parser (LValue dr)+lval p = LVConcat <$> bcsl1 (lval p) <|> liftA2 LVSingle (hierIdent True) p++netLV :: Parser NetLValue+netLV = lval constDimRange++varLV :: Parser VarLValue+varLV = lval dimRange++-- | Assignments+varAssign :: Parser VarAssign+varAssign = Assign <$> varLV <* consume SymEq <*> expr++-- | Common abtract types for variables, parameters, functions and tasks+abstractType :: Parser AbsType+abstractType = fproduce $ \t -> case t of+ KWInteger -> Just ATInteger+ KWReal -> Just ATReal+ KWRealtime -> Just ATRealtime+ KWTime -> Just ATTime+ _ -> Nothing++-- | Common types for variables, parameters, functions and tasks+comType :: Parser t -> Parser (ComType t)+comType p = CTAbstract <$> abstractType <|> CTConcrete <$> p <*> signRange++-- | Net types+netType :: LProduce NetType+netType =+ [ (KWSupply0, NTSupply0),+ (KWSupply1, NTSupply1),+ (KWTri, NTTri),+ (KWTriand, NTTriAnd),+ (KWTrior, NTTriOr),+ (KWTri0, NTTri0),+ (KWTri1, NTTri1),+ (KWUwire, NTUwire),+ (KWWire, NTWire),+ (KWWand, NTWAnd),+ (KWWor, NTWOr)+ ]++-- | Parses local and nonlocal parameters declarations+trParamDecl :: Bool -> Parser (NonEmpty (Identifier, Parameter))+trParamDecl safety = do+ t <- comType $ pure ()+ scsl1 safety ident $ \s -> consume SymEq >> (,) s . Parameter t <$> mtm constExpr++paramDecl :: Bool -> Parser (NonEmpty (Identifier, Parameter))+paramDecl b = trParamDecl b <* consume SymSemi++-- | Function and task input arguments+funArgDecl :: Bool -> LABranch (NonEmpty (AttrIded (TFBlockDecl ())))+funArgDecl safety =+ [ ( KWInput,+ \a -> do+ kind <- comType $ optConsume KWReg+ scsl1 safety ident (\s -> return $ AttrIded a s $ TFBDPort () kind)+ )+ ]++taskArgDecl :: Bool -> LABranch (NonEmpty (AttrIded (TFBlockDecl Dir)))+taskArgDecl safety =+ [ (KWInput, pp DirIn),+ (KWInout, pp DirInOut),+ (KWOutput, pp DirOut)+ ]+ where+ pp dir a = do+ kind <- comType $ optConsume KWReg+ scsl1 safety ident (\s -> return $ AttrIded a s $ TFBDPort dir kind)++-- | Delay1/2/3+delayCom :: Parser NumIdent+delayCom = fproduce $ \t -> case t of+ LitDecimal i -> Just $ NINumber i+ LitReal s -> Just $ NIReal s+ IdSimple s -> Just $ NIIdent $ Identifier s+ IdEscaped s -> Just $ NIIdent $ Identifier s+ _ -> Nothing++delay1 :: Parser Delay1+delay1 = D1Base <$> delayCom <|> D11 <$> parens (mtm expr)++delay2 :: Parser Delay2+delay2 = do+ consume SymPound+ D2Base <$> delayCom+ <|> parens (mtm expr >>= \a -> option (D21 a) $ consume SymComma >> D22 a <$> mtm expr)++delay3 :: Parser Delay3+delay3 = do+ consume SymPound+ D3Base <$> delayCom <|> do+ l <- pcsl1 (mtm expr)+ case l of+ [a] -> return $ D31 a+ [a, b] -> return $ D32 a b+ [a, b, c] -> return $ D33 a b c+ _ -> hardfail "A delay cannot have more than 3 elemets"++-- | Drive strength+strength :: Parser (Either Bool (Strength, Bool))+strength = fproduce $ \t -> case t of+ KWSupply0 -> Just $ Right (StrSupply, False)+ KWSupply1 -> Just $ Right (StrSupply, True)+ KWStrong0 -> Just $ Right (StrStrong, False)+ KWStrong1 -> Just $ Right (StrStrong, True)+ KWPull0 -> Just $ Right (StrPull, False)+ KWPull1 -> Just $ Right (StrPull, True)+ KWWeak0 -> Just $ Right (StrWeak, False)+ KWWeak1 -> Just $ Right (StrWeak, True)+ KWHighz0 -> Just $ Left False+ KWHighz1 -> Just $ Left True+ _ -> Nothing++comDriveStrength :: Parser DriveStrength+comDriveStrength = do+ s1 <- strength+ consume SymComma+ s2 <- strength+ case (s1, s2) of+ (Left _, Left _) -> hardfail "Only one of the strength can be high impedence"+ (Left bl, Right (s, br)) ->+ if bl == br+ then hardfail "Both strength must refer to a different value"+ else return DSHighZ {_dsHZ = bl, _dsStr = s}+ (Right (s, br), Left bl) ->+ if bl == br+ then hardfail "Both strength must refer to a different value"+ else return DSHighZ {_dsHZ = bl, _dsStr = s}+ (Right (s1, b1), Right (s2, b2)) -> case (b1, b2) of+ (False, True) -> return DSNormal {_ds0 = s1, _ds1 = s2}+ (True, False) -> return DSNormal {_ds0 = s2, _ds1 = s1}+ _ -> hardfail "Both strength must refer to a different value"++driveStrength :: Parser DriveStrength+driveStrength = option dsDefault $ try $ parens comDriveStrength++-- | Best effort PATHPULSE parser+pathpulse :: Parser SpecParamDecl+pathpulse = do+ imid <- fproduce $ \t -> case t of TknPP s -> Just s; _ -> Nothing+ miid <- if B.null imid then optionMaybe parseBS else return $ Just imid+ c0 <- case miid of+ Nothing -> return $ Left Nothing+ Just iid -> do+ irng <- pMRE+ let ist = SpecTerm (Identifier iid) irng+ option (Right (iid, irng)) $ Left . Just . (,) ist <$> fbranch+ ( \t -> case t of+ SymDollar -> Just $ specTerm+ IdSystem s -> Just $ SpecTerm (Identifier s) <$> pMRE+ _ -> Nothing+ )+ c1 <- case c0 of+ Left x -> return $ Left x+ Right (iid, irng) -> case reverse $ B.split (c2w '$') iid of+ [_] -> failure+ h : t | B.null h && irng == Nothing ->+ Left . Just . (,) (SpecTerm (Identifier $ restore_id t) Nothing) <$> specTerm+ <|> pure (Right (irng, h : t))+ l -> return $ Right (irng, l)+ iost <- case c1 of+ Left x -> return x+ Right (irng, l) -> let (dollar_suffix, rest) = span B.null l in case rest of+ not_dollar : x@(_ : _) ->+ return $+ Just+ ( SpecTerm (Identifier $ restore_id $ dollar_suffix <> [not_dollar]) Nothing,+ SpecTerm (Identifier $ restore_id x) irng+ )+ _ -> failure+ consume SymEq+ parens $ do+ rej <- mtm constExpr+ err <- option rej $ consume SymComma *> mtm constExpr+ return $ SPDPathPulse iost rej err+ where+ pMRE = optionMaybe constRangeExpr+ restore_id = B.intercalate "$" . reverse+ failure = fail "Pathpulse expects two dollar separated specify terminals"++-- | Specify parameter declaration+specParam :: Parser (Maybe Range2, NonEmpty SpecParamDecl)+specParam = do+ mkpair (optionMaybe range2) $+ csl1 $ SPDAssign <$> ident <* consume SymEq <*> mtm constExpr <|> pathpulse++-- | Event control+eventControl :: Parser EventControl+eventControl = fpbranch $ \p t -> case t of+ SymAster -> Just $ return ECDeps+ SymParenAster -> Just $ closeConsume p SymParenAster SymParenR *> pure ECDeps -- yeah, f*** that+ IdSimple s -> Just $ ECIdent <$> trHierIdent False s+ IdEscaped s -> Just $ ECIdent <$> trHierIdent False s+ SymParenL ->+ Just $ consume SymAsterParen *> pure ECDeps -- yeah, f*** that+ <|> (consume SymAster *> pure ECDeps <|> ECExpr . NE.fromList <$> eventexpr)+ <* closeConsume p SymParenL SymParenR+ _ -> Nothing+ where+ eventexpr =+ sepBy1+ ( do+ p <- option EPAny $+ fproduce $ \t -> case t of+ KWPosedge -> Just EPPos+ KWNegedge -> Just EPNeg+ _ -> Nothing+ EventPrim p <$> expr+ )+ (fproduce $ \t -> case t of SymComma -> Just (); KWOr -> Just (); _ -> Nothing)++-- | Statement blocks: begin/end and fork/join+stmtBlock :: Bool -> SourcePos -> Parser Statement+stmtBlock kind pos = do+ ms <- optionMaybe $ consume SymColon *> ident+ (decl, body) <- smanythen+ attributes+ (\a -> lproduce stdBlockDecl >>= \p -> NE.toList <$> p a)+ (\a -> Attributed a <$> statement)+ let d = concat decl+ h <- case (d, ms) of+ (_ : _, Nothing) -> do+ warn pos "Declaration in an unnamed statement block is a SystemVerilog feature"+ return $+ Just (Identifier $ B.pack $ map c2w $ printf "__block_at_line_%d__" (sourceLine pos), d)+ _ -> return $ flip (,) d <$> ms+ closeConsume pos (if kind then KWFork else KWBegin) (if kind then KWJoin else KWEnd)+ return $ SBlock h kind body++-- | Statement case: case, casex and casez+caseX :: ZOX -> Parser Statement+caseX zox = do+ cond <- parens expr+ l0 <- pci+ (d, l1) <- (if null l0 then id else option (Attributed [] Nothing, [])) $+ consume KWDefault *> optional (consume SymColon) *> mkpair optStmt pci+ return $ SCase zox cond (l0 <> l1) d+ where+ pci = many $ CaseItem <$> csl1 expr <* consume SymColon <*> optStmt++blockass :: VarLValue -> Parser Statement+blockass lv = do+ bl <- fproduce $ \t -> case t of SymEq -> Just True; SymLtEq -> Just False; _ -> Nothing+ delev <- optionMaybe $+ fbranch $ \t -> case t of+ SymPound -> Just $ DECDelay <$> delay1+ SymAt -> Just $ DECEvent <$> eventControl+ KWRepeat -> Just $ DECRepeat <$> parens expr <* consume SymAt <*> eventControl+ _ -> Nothing+ e <- expr+ consume SymSemi+ return $ SBlockAssign bl (Assign lv e) delev++-- | Statement+statement :: Parser Statement+statement = fpbranch $ \p t -> case t of+ SymPound -> Just $ SProcTimingControl . Left <$> delay1 <*> optStmt+ SymAt -> Just $ SProcTimingControl . Right <$> eventControl <*> optStmt+ SymDashGt -> Just $ SEventTrigger <$> hierIdent True <*> many (brackets expr) <* consume SymSemi+ KWFork -> Just $ stmtBlock True p+ KWBegin -> Just $ stmtBlock False p+ KWCase -> Just $ caseX ZOXO <* closeConsume p KWCase KWEndcase+ KWCasez -> Just $ caseX ZOXZ <* closeConsume p KWCasez KWEndcase+ KWCasex -> Just $ caseX ZOXX <* closeConsume p KWCasex KWEndcase+ KWDisable -> Just $ SDisable <$> hierIdent False <* consume SymSemi+ KWWait -> Just $ SWait <$> parens expr <*> optStmt+ KWIf ->+ Just $+ SIf <$> parens expr <*> optStmt <*> option (Attributed [] Nothing) (consume KWElse *> optStmt)+ KWAssign -> Just $ SProcContAssign . PCAAssign <$> varAssign <* consume SymSemi+ KWDeassign -> Just $ SProcContAssign . PCADeassign <$> varLV <* consume SymSemi+ KWForce -> Just $ do+ va <- varAssign+ consume SymSemi+ return $+ SProcContAssign $+ PCAForce $+ maybe (Left va) (\nl -> Right $ Assign nl $ _aValue va) $ constifyLV $ _aLValue va+ KWRelease -> Just $ do+ vl <- varLV+ consume SymSemi+ return $ SProcContAssign $ PCARelease $ maybe (Left vl) Right $ constifyLV vl+ KWForever -> Just $ stmtLoop LSForever+ KWRepeat -> Just $ LSRepeat <$> parens expr >>= stmtLoop+ KWWhile -> Just $ LSWhile <$> parens expr >>= stmtLoop+ KWFor ->+ Just $+ parens (LSFor <$> varAssign <* consume SymSemi <*> expr <* consume SymSemi <*> varAssign)+ >>= stmtLoop+ IdSystem s ->+ Just $+ SSysTaskEnable s <$> option [] (NE.toList <$> pcsl1 (optionMaybe expr)) <* consume SymSemi+ IdSimple s -> Just $ blockassortask s+ IdEscaped s -> Just $ blockassortask s+ SymBraceL -> Just $ (LVConcat <$> csl1 varLV <* closeConsume p SymBraceL SymBraceR) >>= blockass+ _ -> Nothing+ where+ stmtLoop ls = SLoop ls <$> attrStmt+ blockassortask s = do+ hi <- trHierIdent True s+ (dimRange >>= blockass . LVSingle hi)+ <|> do+ args <- option [] $ parens $ wempty "task argument" $ csl expr+ consume SymSemi+ return $ STaskEnable hi args++attrStmt :: Parser AttrStmt+attrStmt = Attributed <$> attributes <*> statement++trOptStmt :: Attributes -> Parser MybStmt+trOptStmt a = fmap (Attributed a) $ Just <$> statement <|> consume SymSemi *> return Nothing++optStmt :: Parser MybStmt+optStmt = attributes >>= trOptStmt++-- | Block declarations except parameters, including local parameters+blockDecl :: Parser t -> LBranch (BlockDecl (Compose NonEmpty Identified) t)+blockDecl p =+ [ (KWReg, BDReg <$> signRange <*> ppl p),+ (KWInteger, BDInt <$> ppl p),+ (KWReal, BDReal <$> ppl p),+ (KWTime, BDTime <$> ppl p),+ (KWRealtime, BDRealTime <$> ppl p),+ (KWEvent, BDEvent <$> ppl (many range2)),+ (KWLocalparam, BDLocalParam <$> comType (pure ()) <*> ppl (consume SymEq *> mtm constExpr))+ ]+ where+ ppl ps = Compose <$> csl1 (Identified <$> ident <*> ps) <* consume SymSemi++-- | Standard block declarations+stdBlockDecl :: LABranch (NonEmpty (AttrIded StdBlockDecl))+stdBlockDecl =+ (KWParameter, \a -> (fmap $ \(s, p) -> AttrIded a s $ SBDParameter p) <$> paramDecl False) :+ maplproduce+ (\p a -> fmap (\(Identified i x) -> AttrIded a i $ SBDBlockDecl x) . toStdBlockDecl <$> p)+ (blockDecl $ many range2)++type GIF a = Maybe InstanceName -> NetLValue -> NonEmpty Expr -> Maybe a++-- | Gate instantiation utility functions+gateInst :: GIF a -> Parser (NonEmpty a)+gateInst f = do+ l <- csl1 $ do+ n <- optionMaybe instName+ mgi <- parens $+ f n <$> netLV <* consume SymComma <*> csl1 expr+ case mgi of Just gi -> return gi; Nothing -> hardfail "Unexpected arguments"+ consume SymSemi+ return l++-- | Strength for pullup/pulldown+pullStrength :: Bool -> Parser DriveStrength+pullStrength ud = do+ e1 <- strength+ e2 <- optionMaybe $ consume SymComma *> strength+ case (e1, e2) of+ (Left b, Nothing) | ud == b -> return DSHighZ {_dsHZ = b, _dsStr = StrStrong}+ (Left bl, Just (Right (s, br))) | bl /= br -> return DSHighZ {_dsHZ = bl, _dsStr = s}+ (Right (s, br), Just (Left bl)) | bl /= br -> return DSHighZ {_dsHZ = bl, _dsStr = s}+ (Right (s, b), Nothing) | ud == b ->+ return $+ if b then DSNormal {_ds0 = StrStrong, _ds1 = s} else DSNormal {_ds1 = StrStrong, _ds0 = s}+ (Right (s1, False), Just (Right (s2, True))) -> return DSNormal {_ds0 = s1, _ds1 = s2}+ (Right (s1, True), Just (Right (s2, False))) -> return DSNormal {_ds0 = s2, _ds1 = s1}+ _ -> hardfail "Unexpected arguments"++-- | Task and function common parts+taskFun ::+ Bool ->+ (Bool -> LABranch (NonEmpty (AttrIded (TFBlockDecl a)))) ->+ Parser ([AttrIded (TFBlockDecl a)], [MybStmt])+taskFun zeroarg arglb = do+ l <- optionMaybe $+ parens $ ww "function ports" $ concat <$> csl (NE.toList <$> labranch (arglb True))+ consume SymSemi+ let dp = case l of+ Nothing -> maplaproduce (\p -> p <* consume SymSemi) (arglb False) ++ sbd+ Just _ -> sbd+ (d, b) <- smanythen attributes (\a -> lproduce dp >>= \p -> NE.toList <$> p a) trOptStmt+ ww "function declarations" $ pure d+ case b of+ [x] -> pure ()+ _ -> do+ pos <- getPosition+ warn pos $+ printf "No or multiple statements in a %s is a SystemVerilog feature" $+ if zeroarg then "function" else "task" :: String+ return (concat d, b)+ where+ sbd = maplabranch (fmap $ fmap TFBDStd) stdBlockDecl+ ww s = if zeroarg then id else wempty s++-- | Trireg and net common properties+netProp :: Parser NetProp+netProp = do+ vs <- optionMaybe $+ fproduce $ \t -> case t of+ KWVectored -> Just True+ KWScalared -> Just False+ _ -> Nothing+ sn <- optConsume KWSigned+ vec <- if isJust vs then Just . (,) vs <$> range2 else optionMaybe $ (,) vs <$> range2+ d3 <- optionMaybe delay3+ return $ NetProp sn vec d3++-- | Uniform list of either initialisation or dimension+ediList :: Parser (Either (NonEmpty NetInit) (NonEmpty NetDecl))+ediList = do+ hdid <- ident+ hddi <- (consume SymEq >> Left <$> expr) <|> Right <$> many range2+ b <- optConsume SymComma+ if b+ then case hddi of+ Left hdi -> Left . (NetInit hdid hdi :|) <$> csl (NetInit <$> ident <* consume SymEq <*> expr)+ Right hdd -> Right . (NetDecl hdid hdd :|) <$> csl (NetDecl <$> ident <*> many range2)+ else return $ bimap ((:|[]) . NetInit hdid) ((:|[]) . NetDecl hdid) hddi++-- | Net declaration+netDecl :: NetType -> Parser ModGenSingleItem+netDecl nt = do+ ods <- optionMaybe $ parens comDriveStrength+ np <- netProp+ x <- case ods of+ Just ds -> MGINetInit nt ds np <$> csl1 (NetInit <$> ident <* consume SymEq <*> expr)+ Nothing -> either (MGINetInit nt dsDefault np) (MGINetDecl nt np) <$> ediList+ consume SymSemi+ return x++-- | Trireg declaration+triregDecl :: Parser ModGenSingleItem+triregDecl = do+ ods_cs <- optionMaybe $+ parens $+ Right <$> fproduce+ ( \t -> case t of+ KWSmall -> Just CSSmall+ KWMedium -> Just CSMedium+ KWLarge -> Just CSLarge+ _ -> Nothing+ )+ <|> Left <$> comDriveStrength+ np <- netProp+ x <- case ods_cs of+ Just (Left ds) -> MGITriD ds np <$> csl1 (NetInit <$> ident <* consume SymEq <*> expr)+ Just (Right cs) -> MGITriC cs np <$> csl1 (NetDecl <$> ident <*> many range2)+ Nothing -> either (MGITriD dsDefault np) (MGITriC CSMedium np) <$> ediList+ consume SymSemi+ return x++-- | Module or Generate region statement+comModGenItem :: LProduce (SourcePos -> Parser ModGenSingleItem)+comModGenItem =+ ( maplproduce (const . fmap MGIBlockDecl) $+ blockDecl $ (consume SymEq >> Right <$> constExpr) <|> Left <$> many range2+ )+ ++ maplproduce (const . netDecl) netType+ ++ [ (KWCmos, gateCmos False),+ (KWRcmos, gateCmos True),+ (KWBufif0, gateEnable False False),+ (KWBufif1, gateEnable False True),+ (KWNotif0, gateEnable True False),+ (KWNotif1, gateEnable True True),+ (KWNmos, gateMos False True),+ (KWPmos, gateMos False False),+ (KWRnmos, gateMos True True),+ (KWRpmos, gateMos True False),+ (KWAnd, gateNinp NITAnd False),+ (KWNand, gateNinp NITAnd True),+ (KWOr, gateNinp NITOr False),+ (KWNor, gateNinp NITOr True),+ (KWXor, gateNinp NITXor False),+ (KWXnor, gateNinp NITXor True),+ (KWBuf, gateNout False),+ (KWNot, gateNout True),+ (KWTranif0, gatePassen False False),+ (KWTranif1, gatePassen False True),+ (KWRtranif0, gatePassen True False),+ (KWRtranif1, gatePassen True True),+ (KWTran, gatePass False),+ (KWRtran, gatePass True),+ (KWPulldown, gatePull False),+ (KWPullup, gatePull True),+ (KWInitial, const $ MGIInitial <$> attrStmt),+ (KWAlways, const $ MGIAlways <$> attrStmt),+ (KWTrireg, const triregDecl),+ (KWGenvar, const $ MGIGenVar <$> csl1 ident <* consume SymSemi),+ ( KWIf,+ const $+ fmap MGICondItem $+ MGCIIf <$> parens constExpr+ <*> genCondBlock+ <*> option GCBEmpty (consume KWElse *> genCondBlock)+ ),+ ( KWBegin,+ \pos -> do+ warn pos "Generate blocks outside of for/if/case is a Verilog 2001 feature disallowed by later standards"+ s <- option "" $ consume SymColon *> ident+ gr <- many $ parseItem id []+ closeConsume pos KWBegin KWEnd+ return $+ MGICondItem $+ MGCIIf (CExpr $ genexprnumber 1) (GCBBlock $ Identified s $ concat gr) GCBEmpty+ ),+ ( KWAssign,+ const $+ MGIContAss <$> driveStrength+ <*> optionMaybe delay3+ <*> csl1 (Assign <$> netLV <* consume SymEq <*> expr)+ <* consume SymSemi+ ),+ ( KWDefparam,+ const $+ MGIDefParam <$> csl1 (ParamOver <$> hierIdent False <* consume SymEq <*> mtm constExpr)+ <* consume SymSemi+ ),+ ( KWCase,+ \pos -> do+ cond <- parens constExpr+ (d, b) <- do+ cb <- many cbranch+ (if null cb then id else option (GCBEmpty, cb)) $ do+ consume KWDefault+ option () $ consume SymColon+ mkpair genCondBlock $ (cb <>) <$> many cbranch+ closeConsume pos KWCase KWEndcase+ return $ MGICondItem $ MGCICase cond b d+ ),+ ( KWFor,+ const $+ parens+ ( MGILoopGen <$> ident+ <* consume SymEq+ <*> constExpr+ <* consume SymSemi+ <*> constExpr+ <* consume SymSemi+ <*> ident+ <* consume SymEq+ <*> constExpr+ )+ <*> (genBlock <|> Identified "" <$> genSingle)+ ),+ ( KWTask,+ \pos -> do+ auto <- optConsume KWAutomatic+ name <- ident+ (decl, body) <- taskFun True taskArgDecl+ closeConsume pos KWTask KWEndtask+ return $+ MGITask auto name decl $+ case body of+ [x] -> x+ _ -> Attributed [] $ Just $ SBlock Nothing False $ map fromMybStmt body+ ),+ ( KWFunction,+ \pos -> do+ auto <- optConsume KWAutomatic+ t <- optionMaybe (comType $ pure ())+ name <- ident+ (decl, body) <- taskFun False funArgDecl+ b <- case traverse (traverse fromStatement . fromMybStmt) body of+ Nothing ->+ hardfail+ "Events, delays, continuous assignments and tasks are forbidden in function statements"+ Just [Attributed [] x] -> return x+ Just l -> return $ FSBlock Nothing False l+ closeConsume pos KWFunction KWEndfunction+ return $ MGIFunc auto t name decl b+ )+ ]+ where+ cbranch = GenCaseItem <$> csl1 constExpr <* consume SymColon <*> genCondBlock+ gateCmos r _ =+ MGICMos r <$> optionMaybe delay3+ <*> gateInst+ (\mn lv args -> case args of [i, n, p] -> Just $ GICMos mn lv i n p; _ -> Nothing)+ gateEnable r b _ =+ MGIEnable r b <$> driveStrength+ <*> optionMaybe delay3+ <*> gateInst+ (\n lv args -> case args of [inp, en] -> Just $ GIEnable n lv inp en; _ -> Nothing)+ gateMos r np _ =+ MGIMos r np <$> optionMaybe delay3+ <*> gateInst+ (\n lv args -> case args of [inp, en] -> Just $ GIMos n lv inp en; _ -> Nothing)+ gateNinp t n _ =+ MGINIn t n <$> driveStrength+ <*> optionMaybe delay2+ <*> gateInst (\n o i -> Just $ GINIn n o i)+ gateNout r _ =+ MGINOut r <$> driveStrength+ <*> optionMaybe delay2+ <*> gateInst+ ( \n lv args ->+ fmap (\(e, t) -> GINOut n (lv :| t) e) $+ foldrMapM1 (\x -> Just (x, [])) (\x (y, t) -> (,) y . (: t) <$> expr2netlv x) args+ )+ gatePassen r b _ =+ MGIPassEn r b <$> optionMaybe delay2+ <*> gateInst+ ( \n lv args -> case args of+ [x, y] -> (flip (GIPassEn n lv) y) <$> expr2netlv x+ _ -> Nothing+ )+ gatePass r _ =+ fmap (MGIPass r) $+ gateInst $ \n lv args -> case args of [x] -> GIPass n lv <$> expr2netlv x; _ -> Nothing+ gatePull ud _ =+ MGIPull ud <$> option dsDefault (try $ parens $ pullStrength ud)+ <*> csl1 (GIPull <$> optionMaybe instName <*> parens netLV)+ <* consume SymSemi++data MPUD+ = MPUDUDPDelay (Maybe Delay2)+ | MPUDModParam ParamAssign+ | MPUDUknNone+ | MPUDUknSingle Expr+ | MPUDUknDouble Expr Expr++ismod :: MPUD -> Bool+ismod x = case x of MPUDModParam _ -> True; _ -> False++isukn :: MPUD -> Bool+isukn x = case x of MPUDModParam _ -> False; MPUDUDPDelay _ -> False; _ -> True++-- | Module parameters or udp delay+modparamudpdelay :: Parser MPUD+modparamudpdelay =+ MPUDUDPDelay . Just . D2Base <$> delayCom+ <|> parens (MPUDModParam . ParamNamed . NE.toList <$> namedparam <|> mpud)+ where+ namedparam =+ xcsl1 "parameter instantiation" $+ consume SymDot >> Identified <$> ident <*> parens (optionMaybe $ mtm expr)+ mpud = do+ l <- wxcsl "parameter instantiation or delay specification" $ mtm expr+ case mapM (\p -> case p of MTMSingle e -> Just e; _ -> Nothing) l of+ Nothing -> case l of+ [x] -> return $ MPUDUDPDelay $ Just $ D21 x+ [x, y] -> return $ MPUDUDPDelay $ Just $ D22 x y+ _ -> hardfail "Delay expression cannot have more than 2 elements"+ Just [x] -> return $ MPUDUknSingle x+ Just [x, y] -> return $ MPUDUknDouble x y+ Just l -> return $ MPUDModParam $ ParamPositional l++data MUUPayload+ = MUUPMod ModInst+ | MUUPUDP UDPInst+ | MUUPUkn UknInst++-- | The actual instance of a module or user defined primive+modudpinstance :: MPUD -> Parser MUUPayload+modudpinstance what = do+ mn <- optionMaybe instName+ args <- parens $ do+ a <- attributes+ do {+ x <- namePort a;+ PortNamed . (x :) <$> commathen (xcsl "port connections" $ attributes >>= namePort)+ }+ <|> (ordPort a >>= \x -> PortPositional . (x :) <$> commathen (csl $ attributes >>= ordPort))+ let argl = case args of+ PortPositional l@(_ : _ : _) ->+ traverse (\x -> case x of Attributed [] y -> y; _ -> Nothing) l+ _ -> Nothing+ case (mn, argl) of+ (Just n, Just (l : h : t)) | isukn what -> case expr2netlv l of+ Just lv -> return $ MUUPUkn $ UknInst n lv $ h :| t+ Nothing -> return $ MUUPMod $ ModInst n args+ (_, Just (l : h : t)) | not (ismod what) -> case expr2netlv l of+ Just lv -> return $ MUUPUDP $ UDPInst mn lv $ h :| t+ Nothing -> failure+ (Just n, Nothing) | isukn what -> return $ MUUPMod $ ModInst n args+ (Just n, _) | ismod what -> return $ MUUPMod $ ModInst n args+ _ -> failure+ where+ failure = hardfail "Got mixed elements of module and udp instatiation"+ commathen p = option [] $ consume SymComma *> p+ -- Port instantiation relying on order+ ordPort a = Attributed a <$> optionMaybe expr+ -- Port instantiation relying on name+ namePort a = consume SymDot >> AttrIded a <$> ident <*> parens (optionMaybe expr)++-- | Module or udp instantiation, they are tricky to differentiate (if not impossible sometimes)+modudpInst :: Parser ModGenSingleItem+modudpInst = do+ kind <- lenientIdent+ ds <- optionMaybe $ try $ parens comDriveStrength+ del_par <- option MPUDUknNone $+ if isJust ds then MPUDUDPDelay . Just <$> delay2 else consume SymPound *> modparamudpdelay+ insts <- csl1 $ modudpinstance del_par+ del_par <- if isukn del_par+ then maybe failure pure $ foldrM reduce_unknown del_par insts+ else pure del_par+ consume SymSemi+ return $ case del_par of+ MPUDUDPDelay d2 -> MGIUDPInst kind (maybe dsDefault id ds) d2 $ mkudp <$> insts+ MPUDModParam pa -> MGIModInst kind pa $ mkmod <$> insts+ MPUDUknNone -> MGIUnknownInst kind Nothing $ mkukn <$> insts+ MPUDUknSingle x -> MGIUnknownInst kind (Just $ Left x) $ mkukn <$> insts+ MPUDUknDouble x y -> MGIUnknownInst kind (Just $ Right (x, y)) $ mkukn <$> insts+ where+ failure = hardfail "Got mixed elements of module and udp instatiation"+ unreachable = error "Internal error, unreachable case reached"+ reduce_unknown i a = case i of+ MUUPUkn _ -> Just a+ MUUPMod _ -> case a of+ MPUDUDPDelay _ -> Nothing+ MPUDModParam _ -> Just a+ MPUDUknNone -> Just $ MPUDModParam $ ParamPositional []+ MPUDUknSingle x -> Just $ MPUDModParam $ ParamPositional [x]+ MPUDUknDouble x y -> Just $ MPUDModParam $ ParamPositional [x, y]+ MUUPUDP _ -> case a of+ MPUDModParam _ -> Nothing+ MPUDUDPDelay _ -> Just a+ MPUDUknNone -> Just $ MPUDUDPDelay $ Nothing+ MPUDUknSingle x -> Just $ MPUDUDPDelay $ Just $ D21 $ MTMSingle x+ MPUDUknDouble x y -> Just $ MPUDUDPDelay $ Just $ D22 (MTMSingle x) (MTMSingle y)+ mkmod i = case i of+ MUUPMod i -> i+ MUUPUDP _ -> unreachable+ MUUPUkn (UknInst n lv args) ->+ ModInst n $ PortPositional $ map (Attributed [] . Just) $ netlv2expr lv : NE.toList args+ mkudp i = case i of+ MUUPMod _ -> unreachable+ MUUPUDP i -> i+ MUUPUkn (UknInst n lv args) -> UDPInst (Just n) lv args+ mkukn i = case i of+ MUUPMod _ -> unreachable+ MUUPUDP _ -> unreachable+ MUUPUkn i -> i++-- | Parse a module or generate region item along other given possibilities+-- | and converts it to the right type using the provided conversion function+parseItem :: (Attributed ModGenBlockedItem -> a) -> LAPBranch (NonEmpty a) -> Parser [a]+parseItem f lb = do+ a <- attributes+ pos <- getPosition+ fmap NE.toList $+ do {+ p <- lproduce $+ lb ++ maplproduce+ (\p a pos -> fmap (f . Attributed a) . toMGBlockedItem <$> p pos)+ comModGenItem;+ p a pos+ }+ <|> (\p a -> fmap (f . Attributed a) . toMGBlockedItem <$> p) modudpInst a++-- | Generate block+genBlock :: Parser GenerateBlock+genBlock = do+ pos <- getPosition+ consume KWBegin+ i <- option "" $ consume SymColon *> ident+ b <- many $ parseItem id []+ closeConsume pos KWBegin KWEnd+ return $ Identified i $ concat b++genSingle :: Parser [Attributed ModGenBlockedItem]+genSingle = do+ a <- attributes+ pos <- getPosition+ b <- (lproduce comModGenItem >>= \p -> p pos) <|> modudpInst+ return $ Attributed a <$> toList (toMGBlockedItem b)++genCondBlock :: Parser GenerateCondBlock+genCondBlock = consume SymSemi *> return GCBEmpty <|> GCBBlock <$> genBlock <|> do+ gb <- genSingle+ return $ case gb of+ [Attributed a (MGICondItem ci)] -> GCBConditional $ Attributed a ci+ _ -> GCBBlock $ Identified "" gb++type PortInterface = Identified [Identified (Maybe CRangeExpr)]++-- | Simple port declaration (Input, Output, InOut)+portsimple ::+ Maybe NetType ->+ Bool ->+ Dir ->+ Attributes ->+ Parser (NonEmpty (NonEmpty ModuleItem, PortInterface))+portsimple dnt fullspec d a = do+ nt <- optionMaybe $ lproduce netType+ sr <- signRange+ sl <- scsl1 fullspec ident pure+ let pd i = MIPort $ AttrIded a i (d, sr)+ nd t i =+ Attributed [] $+ MGINetDecl+ t+ (NetProp (_srSign sr) ((,) Nothing <$> _srRange sr) Nothing)+ (Identity $ NetDecl i [])+ pi i = Identified i [Identified i Nothing]+ case nt of+ Just nt -> return $ (\i -> ([pd i, MIMGI $ nd nt i], pi i)) <$> sl+ Nothing | fullspec -> case dnt of+ Just nt -> return $ (\i -> ([pd i, MIMGI $ nd nt i], pi i)) <$> sl+ Nothing ->+ hardfail "Ports declared in a module header must be typed when default_nettype is none"+ Nothing -> return $ (\i -> ([pd i], pi i)) <$> sl++-- | Declaration of a port with a variable type+portvariable ::+ Bool ->+ Attributes ->+ ( Compose Identity Identified (Either [Range2] CExpr) ->+ BlockDecl (Compose Identity Identified) (Either [Range2] CExpr)+ ) ->+ Parser (NonEmpty (NonEmpty ModuleItem, PortInterface))+portvariable fullspec a f =+ scsl1 fullspec ident $+ \s -> do+ e <- optionMaybe $ consume SymEq *> constExpr+ return+ ( [ MIPort $ AttrIded a s (DirOut, SignRange False Nothing),+ MIMGI $+ Attributed a $+ MGIBlockDecl $ f $ Compose $ Identity $ Identified s $ maybe (Left []) Right e+ ],+ Identified s [Identified s Nothing]+ )++-- | Port declaration+portDecl :: Maybe NetType -> Bool -> LABranch (NonEmpty ModuleItem, NonEmpty PortInterface)+portDecl dnt fullspec =+ [ (KWInput, ps DirIn),+ (KWInout, ps DirInOut),+ ( KWOutput,+ \a ->+ fbranch+ ( \t -> case t of+ KWReg -> Just $ signRange >>= pv a . BDReg+ KWInteger -> Just $ pv a BDInt+ KWTime -> Just $ pv a BDTime+ _ -> Nothing+ )+ <|> ps DirOut a+ )+ ]+ where+ mk p = first join . DF.unzip <$> p <* if fullspec then pure () else consume SymSemi+ ps d a = mk $ portsimple dnt fullspec d a+ pv a f = mk $ portvariable fullspec a f++-- | Port expression+portExpr :: Parser [Identified (Maybe CRangeExpr)]+portExpr = option [] $ (: []) <$> pp <|> NE.toList <$> bcsl1 pp+ where+ pp = Identified <$> ident <*> optionMaybe constRangeExpr++-- | Path declaration+trPathDecl :: SourcePos -> ModulePathCondition -> Parser (NonEmpty SpecifyBlockedItem)+trPathDecl pos cond = do+ edge <- optionMaybe $+ fproduce $ \t -> case t of+ KWPosedge -> Just True+ KWNegedge -> Just False+ _ -> Nothing+ inp <- csl1 specTerm+ po <- optionMaybe $+ fproduce $ \t -> case t of+ SymPlus -> Just True+ SymDash -> Just False+ _ -> Nothing+ pf <- fproduce $ \t -> case t of+ SymAsterGt -> Just False+ SymEqGt -> Just True+ _ -> Nothing+ (out, pol, eds) <-+ parens+ ( do+ outp <- csl1 specTerm+ po <- fbranch $ \t -> case t of+ SymPlus -> Just $ consume SymColon *> return (Just True)+ SymDash -> Just $ consume SymColon *> return (Just False)+ SymColon -> Just $ return Nothing+ SymPlusColon -> Just $ return $ Just True+ SymDashColon -> Just $ return $ Just False+ _ -> Nothing+ e <- expr+ return (outp, po, Just (e, edge))+ )+ <|> (\outp -> (outp, po, Nothing)) <$> csl1 specTerm+ co <- if pf+ then case (inp, out) of+ (i :| [], o :| []) -> return $ SPParallel i o+ _ -> hardfail "Parallel delay only accept single nets as source and destination"+ else return (SPFull inp out)+ case () of+ () | isJust po && isJust eds -> hardfail "Edge sensitive path with misplaced polarity operator"+ () | isJust edge && eds == Nothing ->+ hardfail "Mixed edge and non edge sensitive delay path elements"+ () -> return ()+ closeConsume pos SymParenL SymParenR+ consume SymEq+ vals <- try (csl1 $ mtm constExpr) <|> pcsl1 (mtm constExpr) -- cancer optional parentheses+ (:|[]) . SIPathDeclaration cond co pol eds <$> case vals of+ [e] -> return $ PDV1 e+ [e1, e2] -> return $ PDV2 e1 e2+ [e1, e2, e3] -> return $ PDV3 e1 e2 e3+ [e1, e2, e3, e4, e5, e6] -> return $ PDV6 e1 e2 e3 e4 e5 e6+ [e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12] ->+ return $ PDV12 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10 e11 e12+ _ -> hardfail "Wrong number of argument"++pathDecl :: ModulePathCondition -> Parser (NonEmpty SpecifyBlockedItem)+pathDecl mpc = getPosition >>= \p -> consume SymParenL *> trPathDecl p mpc++-- | Timing check event+edgeDesc :: Parser EdgeDesc+edgeDesc = fbranch $ \t -> case t of+ KWPosedge -> Just $ return $ V.fromList [True, True, False, False, False, True]+ KWNegedge -> Just $ return $ V.fromList [False, False, True, True, True, False]+ KWEdge ->+ Just $+ (V.replicate 6 False V.//) . NE.toList+ <$> brackets+ ( csl1 $+ fproduce $ \t -> case t of+ EdgeEdge BXZ0 BXZ1 -> Just (0, True)+ EdgeEdge BXZ0 BXZX -> Just (1, True)+ EdgeEdge BXZ0 BXZZ -> Just (1, True)+ EdgeEdge BXZ1 BXZ0 -> Just (2, True)+ EdgeEdge BXZ1 BXZX -> Just (3, True)+ EdgeEdge BXZ1 BXZZ -> Just (3, True)+ EdgeEdge BXZX BXZ0 -> Just (4, True)+ EdgeEdge BXZX BXZ1 -> Just (5, True)+ EdgeEdge BXZZ BXZ0 -> Just (4, True)+ EdgeEdge BXZZ BXZ1 -> Just (5, True)+ _ -> Nothing+ )+ _ -> Nothing++-- | Timing check condition after &&&+-- | This thing is cancer because of ambiguous parens, tilde, and comparisons+-- | Especially parens and comparison because it requires early exit in expression+-- | And that is PANTS: Pure Absurdity Nobody Truly Supports+-- | So I decided to NOT parse it correctly.+-- | If you think you have a simple parser, your parser idea is likely wrong+-- | If you think it's complicated parser, your parser idea is likely wrong+-- | If you think it's absurd and you have a parser the size of this file,+-- | you're right but your parser idea is still likely wrong+timingCheckCond :: Parser (Bool, Expr)+timingCheckCond = do+ consume SymAmpAmpAmp+ try ((consume UnTilde >> (,) True <$> expr) <|> (,) False <$> expr)+ <|> (consume UnTilde >> (,) True <$> expr)++timingCheckEvent :: Parser TimingCheckEvent+timingCheckEvent =+ TimingCheckEvent <$> optionMaybe edgeDesc <*> specTerm <*> optionMaybe timingCheckCond++controlledTimingCheckEvent :: Parser ControlledTimingCheckEvent+controlledTimingCheckEvent =+ ControlledTimingCheckEvent <$> edgeDesc <*> specTerm <*> optionMaybe timingCheckCond++-- | Standard system timing check arguments+optoptChain :: b -> Parser a -> Parser b -> Parser (Maybe a, b)+optoptChain dn px pn =+ optConsume SymComma >>= \b -> if b then mkpair (optionMaybe px) pn else return (Nothing, dn)++comStcArgs :: Parser (TimingCheckEvent, TimingCheckEvent, Expr)+comStcArgs =+ (,,) <$> timingCheckEvent <* consume SymComma <*> timingCheckEvent <* consume SymComma <*> expr++stdStcArgs :: Parser STCArgs+stdStcArgs = do+ (r, d, e) <- comStcArgs+ STCArgs d r e <$> option Nothing (consume SymComma *> optionMaybe ident)++addStcArgs :: Parser (STCArgs, STCAddArgs)+addStcArgs = do+ (r, d, ll) <- comStcArgs+ consume SymComma+ lr <- expr+ let def1 = (Nothing, Nothing)+ def2 = (Nothing, def1)+ def3 = (Nothing, def2)+ (n, (sc, (cc, (dr, dd)))) <-+ optoptChain def3 ident $+ optoptChain def2 (mtm expr) $+ optoptChain def1 (mtm expr) $+ optoptChain Nothing cmtmRef $ option Nothing $ consume SymComma *> optionMaybe cmtmRef+ return (STCArgs d r ll n, STCAddArgs lr sc cc dr dd)++skewStcArgs :: Parser (Maybe Identifier, Maybe CExpr, Maybe CExpr)+skewStcArgs = do+ (n, (eb, ra)) <-+ optoptChain (Nothing, Nothing) ident $+ optoptChain Nothing constExpr $ option Nothing $ consume SymComma *> optionMaybe constExpr+ return (n, eb, ra)++-- | System timing check functions+stcfMap :: HashMap.HashMap B.ByteString (Parser SpecifyBlockedItem)+stcfMap =+ HashMap.fromList+ [ ("setup", SISetup . (\(STCArgs d r e n) -> STCArgs r d e n) <$> stdStcArgs),+ ("hold", SIHold <$> stdStcArgs),+ ("setuphold", uncurry SISetupHold <$> addStcArgs),+ ("recovery", SIRecovery <$> stdStcArgs),+ ("removal", SIRemoval <$> stdStcArgs),+ ("recrem", uncurry SIRecrem <$> addStcArgs),+ ("skew", SISkew <$> stdStcArgs),+ ( "timeskew",+ do+ (r, d, e) <- comStcArgs+ (n, eb, ra) <- skewStcArgs+ return $ SITimeSkew (STCArgs d r e n) eb ra+ ),+ ( "fullskew",+ do+ (r, d, e) <- comStcArgs+ consume SymComma+ tcl <- expr+ (n, eb, ra) <- skewStcArgs+ return $ SIFullSkew (STCArgs d r e n) tcl eb ra+ ),+ ( "period",+ SIPeriod <$> controlledTimingCheckEvent+ <* consume SymComma+ <*> expr+ <*> option Nothing (consume SymComma *> optionMaybe ident)+ ),+ ( "width",+ do+ e <- controlledTimingCheckEvent+ consume SymComma+ tcl <- expr+ (t, n) <- option (Nothing, Nothing) $ do+ consume SymComma+ mkpair (Just <$> constExpr) $ option Nothing $ do+ consume SymComma+ pos <- getPosition+ mid <- optionMaybe ident+ if mid == Nothing+ then warn pos "Optional $width notifier is a SystemVerilog feature"+ else pure ()+ return mid+ return $ SIWidth e tcl t n+ ),+ ( "nochange",+ SINoChange <$> timingCheckEvent+ <* consume SymComma+ <*> timingCheckEvent+ <* consume SymComma+ <*> mtm expr+ <* consume SymComma+ <*> mtm expr+ <*> option Nothing (consume SymComma *> optionMaybe ident)+ )+ ]++-- | Specify block item+specifyItem :: Parser (NonEmpty SpecifyBlockedItem)+specifyItem = fpbranch $ \p t -> case t of+ KWSpecparam -> Just $ (\(rng, l) -> SISpecParam rng . Identity <$> l) <$> specParam+ KWPulsestyleonevent -> Just $ psi SIPulsestyleOnevent+ KWPulsestyleondetect -> Just $ psi SIPulsestyleOndetect+ KWShowcancelled -> Just $ psi SIShowcancelled+ KWNoshowcancelled -> Just $ psi SINoshowcancelled+ KWIf -> Just $ do+ c <- parens $+ genExpr (pure . Identifier) (pure ()) attributes Just $ maybe (Just ()) $ const Nothing+ pathDecl $ MPCCond c+ KWIfnone -> Just $ pathDecl MPCNone+ SymParenL -> Just $ trPathDecl p MPCAlways+ IdSystem s -> fmap (:| []) . parens <$> HashMap.lookup s stcfMap+ _ -> Nothing+ where+ psi f = csl1 (f . Identity <$> specTerm)++-- | Non port declaration module item+npmodItem :: LAPBranch (NonEmpty ModuleItem)+npmodItem =+ (KWParameter, \a _ -> fmap (\(i, x) -> MIParameter $ AttrIded a i x) <$> paramDecl False) :+ [ (KWSpecparam, \a _ -> (\(rng, l) -> MISpecParam a rng <$> l) <$> specParam <* consume SymSemi),+ ( KWGenerate,+ \a pos -> if null a+ then (:|[]) . MIGenReg . concat <$> many (parseItem id [])+ <* closeConsume pos KWGenerate KWEndgenerate+ else hardfail "Generate region doesn't accept attributes"+ ),+ ( KWSpecify,+ \a pos -> if null a+ then (:|[]) . MISpecBlock . concat <$> many (NE.toList <$> specifyItem <* consume SymSemi)+ <* closeConsume pos KWSpecify KWEndspecify+ else hardfail "Specify region doesn't accept attributes"+ )+ ]++-- | Module+parseModule :: LocalCompDir -> Attributes -> Parser Verilog2005+parseModule (LocalCompDir ts cl pull dnt) a = do+ s <- lenientIdent+ params <- option [] $ do+ consume SymPound+ parens (wxcsl "parameter declaration" $ consume KWParameter *> trParamDecl True)+ -- if there is nothing the standard says the module cannot contain port declaration+ -- if there is empty parenthesis `()` the standard says it can or cannot, so it can+ (pd, pi) <- option (Just [], []) $ parens $ fullPort <|> (,) Nothing <$> csl partialPort+ consume SymSemi+ mi <- case pd of+ Nothing ->+ many $ parseItem MIMGI $ maplaproduce (const . fmap fst) (portDecl dnt False) ++ npmodItem+ Just pd -> (pd :) <$> many (parseItem MIMGI npmodItem)+ return mempty {_vModule = [ModuleBlock a s pi (concat mi) ts cl pull dnt]}+ where+ -- Fully specified port declaration list+ fullPort =+ bimap (Just . NE.toList . join) (NE.toList . join) . DF.unzip+ <$> xcsl1 "port declaration" (labranch $ portDecl dnt True)+ -- Partially specified port declaration list+ partialPort =+ (consume SymDot >> Identified <$> ident <*> parens portExpr)+ <|> (\l -> case l of [Identified s _] -> Identified s l; _ -> Identified "" l) <$> portExpr++-- | Primitive output port+udpOutput :: Parser (PrimPort, Identifier)+udpOutput = do+ reg <- optConsume KWReg+ s <- ident+ pp <- if reg+ then PPOutReg <$> optionMaybe (consume SymEq *> constExpr)+ else return PPOutput+ return (pp, s)++-- | Udp port declaration+udpHead :: Parser (Identifier, NonEmpty Identifier, Maybe (NonEmpty (AttrIded PrimPort)))+udpHead =+ (,,) <$> ident <* consume SymComma <*> csl1 ident <*> pure Nothing <|> do+ attr <- attributes+ consume KWOutput+ (od, o) <- udpOutput+ consume SymComma+ ins <- csl1 $ do+ attr <- attributes+ consume KWInput+ l <- scsl1 True ident $ return . flip (AttrIded attr) PPInput+ return l+ let inl = join ins+ return (o, _aiIdent <$> inl, Just $ AttrIded attr o od <| inl)++-- | Parse a udp port declaration list+udpPort :: Parser (NonEmpty (AttrIded PrimPort))+udpPort = do+ a <- attributes+ l <- fbranch $ \t -> case t of+ KWReg -> Just $ (:|[]) . (,) PPReg <$> ident+ KWOutput -> Just $ (:|[]) <$> udpOutput+ KWInput -> Just $ csl1 $ (,) PPInput <$> ident+ _ -> Nothing+ consume SymSemi+ return $ uncurry (flip $ AttrIded a) <$> l++-- | Sequential primitive output initial value+initVal :: Parser ZOX+initVal = fbranch $ \t -> case t of+ LitDecimal 0 -> Just $ return ZOXZ+ LitDecimal 1 -> Just $+ option ZOXO $ do+ consume $ NumberBase False BBin+ fproduce $ \t -> case t of+ LitBinary [BXZ0] -> Just ZOXZ+ LitBinary [BXZ1] -> Just ZOXO+ LitBinary [BXZX] -> Just ZOXX+ _ -> Nothing+ _ -> Nothing++-- | Signal level+level :: Parser SigLevel+level = fproduce $ \t -> case t of+ TableOut ZOXZ -> Just L0+ TableOut ZOXO -> Just L1+ TableOut ZOXX -> Just LX+ TableIn False -> Just LQ+ TableIn True -> Just LB+ _ -> Nothing++-- | Sequential primitive nest state+nextState :: Parser (Maybe ZOX)+nextState =+ fproduce (\t -> case t of TableOut zox -> Just $ Just zox; SymDash -> Just Nothing; _ -> Nothing)+ <* consume SymSemi++-- | Sequential primitive input row+seqRow :: Parser SeqIn+seqRow = do+ comb <- many level+ res <- (if null comb then id else option $ SIComb $ NE.fromList comb) $ do+ e <- fpbranch $ \sp t -> case t of+ TableEdge AFRNPA -> Just $ return $ EdgeDesc LQ LQ+ TableEdge AFRNPF -> Just $ return $ EdgeDesc L1 L0+ TableEdge AFRNPR -> Just $ return $ EdgeDesc L0 L1+ TableEdge AFRNPN -> Just $ return (EdgePos_neg False)+ TableEdge AFRNPP -> Just $ return (EdgePos_neg True)+ SymParenL -> Just $ EdgeDesc <$> level <*> level <* closeConsume sp SymParenL SymParenR+ _ -> Nothing+ SISeq comb e <$> many level+ consume SymColon+ return res++-- | Parses a primitive block+udp :: Attributes -> Parser Verilog2005+udp attr = do+ udpid <- ident+ (out, ins, mpd) <- parens udpHead+ consume SymSemi+ pd <- maybe (join <$> manyNE udpPort) pure mpd+ init <- optionMaybe $ do+ consume KWInitial+ s <- ident+ if s /= out+ then hardfail "Initial value can only be assigned to output port"+ else consume SymEq *> initVal <* consume SymSemi+ consume KWTable+ -- parse a seqRow to know the table kind, if it's not an allowed kind we can error later+ hdi <- seqRow+ sl <- level+ hdd <- fbranch $ \t -> case t of+ SymSemi -> Just $ return Nothing+ SymColon -> Just $ Just <$> nextState+ _ -> Nothing+ let hdu = case sl of L0 -> Just ZOXZ; L1 -> Just ZOXO; LX -> Just ZOXX; _ -> Nothing+ -- use all the information to decide if the primitive is sequential or combinational+ body <- case (hdd, hdi, hdu) of+ (Nothing, SIComb comb, Just zox) | init == Nothing ->+ CombTable . (CombRow comb zox :|) <$> many combRow+ (Just ns, _, _) ->+ SeqTable init . (SeqRow hdi sl ns :|)+ <$> many (SeqRow <$> seqRow <*> level <* consume SymColon <*> nextState)+ _ -> hardfail "Got mixed information between sequential and combinatorial UDP"+ consume KWEndtable+ return mempty {_vPrimitive = [PrimitiveBlock attr udpid out ins pd body]}+ where+ -- Combinational primitive input row+ combRow = do+ l <- manyNE level+ consume SymColon+ o <- fproduce $ \t -> case t of TableOut zox -> Just zox; _ -> Nothing+ consume SymSemi+ return $ CombRow l o++-- | Parses an element of config blocks body+configItem :: Parser ConfigItem+configItem = do+ ci <- fbranch $ \t -> case t of+ KWCell -> Just $ CICell <$> dot1Ident+ KWInstance -> Just $ CIInst . NE.fromList <$> sepBy1 ident (consume SymDot)+ _ -> Nothing+ llu <- fbranch $ \t -> case t of+ KWLiblist -> Just $ LLULiblist <$> many parseBS+ KWUse ->+ Just $+ LLUUse <$> dot1Ident+ <*> option False (consume SymColon *> consume KWConfig *> return True)+ _ -> Nothing+ consume SymSemi+ return $ ConfigItem ci llu++-- | Parses a config block+config :: Parser Verilog2005+config = do+ s <- ident+ consume SymSemi+ consume KWDesign+ design <- many dot1Ident+ consume SymSemi+ b <- many configItem+ (b', d) <- option ([], []) $ do+ consume KWDefault+ consume KWLiblist+ d <- many parseBS+ consume SymSemi+ body <- many configItem+ return (body, d)+ return mempty {_vConfig = [ConfigBlock s design (b <> b') d]}++-- | Parses compiler directives+compDir :: Parser ()+compDir = fbranch $ \t -> case t of+ CDUnconnecteddrive ->+ Just $+ fbranch $+ \t -> case t of+ KWPull0 -> Just $ modifyState $ lcdPull .~ Just False+ KWPull1 -> Just $ modifyState $ lcdPull .~ Just True+ _ -> Nothing+ CDNounconnecteddrive -> Just $ modifyState $ lcdPull .~ Nothing+ CDDefaultnettype -> Just $ do+ nt <-+ Just <$> fproduce (\t -> IntMap.lookup (getConsIndex t) $ mkActionMap netType)+ <|> fproduce (\t -> if t == IdSimple "none" then Just Nothing else Nothing)+ modifyState $ lcdDefNetType .~ nt+ CDResetall -> Just $ putState lcdDefault+ CDTimescale -> Just $ do+ uoff <- fproduce $ \t -> case t of CDTSInt i -> Just i; _ -> Nothing+ ubase <- fproduce $ \t -> case t of CDTSUnit i -> Just i; _ -> Nothing+ poff <- fproduce $ \t -> case t of CDTSInt i -> Just i; _ -> Nothing+ pbase <- fproduce $ \t -> case t of CDTSUnit i -> Just i; _ -> Nothing+ modifyState $ lcdTimescale .~ Just (ubase + uoff, pbase + poff)+ CDBeginKeywords -> Just $ pure () -- handled at lexing, this makes sure it is used outside modules+ CDEndKeywords -> Just $ pure () -- same as above+ _ -> Nothing++-- | Parses a top-level declaration: config, module or primitive block+topDecl :: Parser Verilog2005+topDecl =+ skipMany1 compDir *> return mempty <|> do+ -- I'm not sure whether these compiler directives are allowed here+ a <- many (attributeOne <* skipMany compDir)+ st <- getState+ fpbranch $ \p t -> case t of+ KWPrimitive -> Just $ udp a <* closeConsume p KWPrimitive KWEndprimitive+ KWModule -> Just $ parseModule st a <* closeConsume p KWModule KWEndmodule+ KWMacromodule -> Just $ parseModule st a <* closeConsume p KWMacromodule KWEndmodule+ KWConfig | null a -> Just $ config <* closeConsume p KWConfig KWEndconfig+ _ -> Nothing++-- | Parses a verilog file by accumulating top-level declarations+verilog2005Parser :: Parser Verilog2005+verilog2005Parser = anywherecompdir *> monoAccum topDecl <* eof++-- | Parse a file containing Verilog 2005 code, also return non Verilog2005 conformity warnings+-- The lists in the Verilog2005 structure are in reverse order from source+parseVerilog2005 :: FilePath -> IO (Verilog2005, [String])+parseVerilog2005 file = do+ stres <- scanTokens file+ case stres of+ Left s -> error s+ Right strm ->+ let (x, w) = runWriter $ runParserT verilog2005Parser lcdDefault file strm+ in case x of+ Left s -> error $ show s+ Right ast -> return (ast, w)
+ src/Verismith/Verilog2005/PrettyPrinter.hs view
@@ -0,0 +1,1369 @@+-- Module : Verismith.Verilog2005.PrettyPrinter+-- Description : Pretty printer for the Verilog 2005 AST.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RankNTypes #-}++module Verismith.Verilog2005.PrettyPrinter+ ( genSource,+ LocalCompDir (..),+ lcdDefault,+ lcdTimescale,+ lcdCell,+ lcdPull,+ lcdDefNetType,+ PrintingOpts (..)+ )+where++import Control.Lens.TH+import Data.Bifunctor (first)+import Data.Functor.Compose+import Data.Functor.Identity+import Control.Monad.Reader+import qualified Data.ByteString as B+import Data.ByteString.Internal+import qualified Data.ByteString.Lazy as LB+import Data.Foldable+import Control.Applicative (liftA2)+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromJust, fromMaybe)+import Data.String+import qualified Data.Vector.Unboxed as V+import Verismith.Utils hiding (comma)+import Verismith.Verilog2005.Lexer+import Verismith.Verilog2005.AST+import Verismith.Verilog2005.LibPretty+import Verismith.Verilog2005.Utils++-- | All locally applicable properties controlled by compiler directives+data LocalCompDir = LocalCompDir+ { _lcdTimescale :: !(Maybe (Int, Int)),+ _lcdCell :: !Bool,+ _lcdPull :: !(Maybe Bool),+ _lcdDefNetType :: !(Maybe NetType)+ }++$(makeLenses ''LocalCompDir)++lcdDefault :: LocalCompDir+lcdDefault = LocalCompDir Nothing False Nothing $ Just NTWire++-- | Pretty-printer options+data PrintingOpts = PrintingOpts+ { _poEscapedSpace :: !Bool,+ _poTableSpace :: !Bool,+ _poEdgeControlZ_X :: !Bool+ }++type Print = Reader PrintingOpts Doc++-- | Generates a string from a line length limit and a Verilog AST+genSource :: Maybe Word -> PrintingOpts -> Verilog2005 -> LB.ByteString+genSource mw opts ast = layout mw $ runReader (prettyVerilog2005 ast) opts++-- | Comma separated concatenation+(<.>) :: Doc -> Doc -> Doc+(<.>) a b = a <> comma <+> b++-- | [] {} ()+brk :: Doc -> Doc+brk = encl lbracket rbracket++brc :: Doc -> Doc+brc = encl lbrace rbrace++par :: Doc -> Doc+par = encl lparen rparen++gpar :: Doc -> Doc+gpar = group . par++-- | Print only if boolean is false+piff :: Doc -> Bool -> Doc+piff d c = if c then mempty else d++-- | Print only if boolean is true+pift :: Doc -> Bool -> Doc+pift d c = if c then d else mempty++-- | Print maybe+pm :: (x -> Print) -> Maybe x -> Print+pm = maybe $ pure mempty++-- | Print Foldable with stuff arround when not empty+pf :: Foldable f => (Doc -> Doc -> Doc) -> Doc -> Doc -> (a -> Print) -> f a -> Print+pf g l r f = nonEmpty (pure mempty) (fmap (\d -> l <> d <> r) . foldrMap1 f (liftA2 g . f)) . toList++-- | Print Foldable+pl :: Foldable f => (Doc -> Doc -> Doc) -> (a -> Print) -> f a -> Print+pl g f = foldrMap1' (pure mempty) f (liftA2 g . f) . toList++-- | Regroup and prettyprint+prettyregroup ::+ (Doc -> Doc -> Doc) ->+ (y -> Print) ->+ (x -> y) ->+ (x -> y -> Maybe y) ->+ NonEmpty x ->+ Print+prettyregroup g p mk add = foldrMap1 p (liftA2 g . p) . regroup mk add++-- | The core difficulty of this pretty printer:+-- | Identifier can be escaped, escaped identifiers require a space or newline after them+-- | but I want to avoid double [spaces/line breaks] and spaces at the end of a line+-- | And this problem creeps in every AST node with possible identifier printed at the end+-- | like expressions+-- | So a prettyprinter that takes an AST node of type `a` has this type+-- | The second element of the result pair is the type of space that follows the first element+-- | unless what is next is a space or a newline, in which case it can be ignored and replaced+type PrettyIdent a = a -> Reader PrintingOpts (Doc, Doc)++-- | The `pure/return` of prettyIdent+mkid :: PrettyIdent Doc+mkid = pure . flip (,) softline++-- | Evaluates a PrettyIdent and collapse the last character+padj :: PrettyIdent a -> a -> Print+padj p = fmap (uncurry (<>)) . p++-- | Applies a function to the stuff before the last character+fpadj :: (Doc -> Doc) -> PrettyIdent a -> a -> Print+fpadj f p x = uncurry (<>) . first f <$> p x++gpadj :: PrettyIdent a -> a -> Print+gpadj = fpadj group++ngpadj :: PrettyIdent a -> a -> Print+ngpadj = fpadj ng++-- | Just inserts a group before the last space of a PrettyIdent+-- | Useful to separate the break priority of the inside and outside space+mkg :: PrettyIdent x -> PrettyIdent x+mkg f = fmap (first group) . f++-- | In this version the group asks for raising the indentation level+mkng :: PrettyIdent x -> PrettyIdent x+mkng f = fmap (first ng) . f++-- | Print a comma separated list, haskell style: `a, b, c` or+-- | ```+-- | a+-- | , b+-- | , c+-- | ```+csl :: Foldable f => Doc -> Doc -> (a -> Print) -> f a -> Print+csl = pf $ \a b -> a </> comma <+> b++csl1 :: (a -> Print) -> NonEmpty a -> Print+csl1 f = foldrMap1 f $ liftA2 (\a b -> a </> comma <+> b) . f++cslid1 :: PrettyIdent a -> PrettyIdent (NonEmpty a)+cslid1 f = foldrMap1 f $ liftA2 (\x -> first (x <.>)) . padj f++cslid :: Foldable f => Doc -> Doc -> PrettyIdent a -> f a -> Print+cslid a b f = nonEmpty (pure mempty) (fmap (\x -> a <> x <> b) . padj (cslid1 f)) . toList++bcslid1 :: PrettyIdent a -> NonEmpty a -> Print+bcslid1 f l = brc . nest <$> padj (cslid1 $ mkg f) l++pcslid :: Foldable f => PrettyIdent a -> f a -> Print+pcslid f = cslid (lparen <> softspace) rparen $ mkg f++prettyBS :: PrettyIdent B.ByteString+prettyBS i = do+ bs <- asks _poEscapedSpace+ let si = isIdentSimple i+ return+ ( if si then raw i else "\\" <> if bs then raw i <> space else raw i,+ if si || bs then softline else newline+ )++prettyIdent :: PrettyIdent Identifier+prettyIdent (Identifier i) = prettyBS i++rawId :: Identifier -> Print+rawId (Identifier i) = do+ bs <- asks _poEscapedSpace+ let si = isIdentSimple i+ return $ if si then raw i else "\\" <> if bs then raw i <> space else raw i++-- | Somehow the next eight function are very common patterns+pspWith :: PrettyIdent a -> Doc -> PrettyIdent a+pspWith f d i = if nullDoc d then f i else (\x -> fst x <=> d) <$> f i >>= mkid++padjWith :: PrettyIdent a -> Doc -> PrettyIdent a+padjWith f d i = if nullDoc d then f i else (<> d) <$> padj f i >>= mkid++prettyEq :: Doc -> (Doc, Doc) -> (Doc, Doc)+prettyEq i = first $ \x -> ng $ group i <=> equals <+> group x++prettyAttrng :: Attributes -> Doc -> Print+prettyAttrng a x = (<?=> ng x) <$> prettyAttr a++prettyItem :: Attributes -> Doc -> Print+prettyItem a x = (<> semi) <$> prettyAttrng a x++prettyItems :: Doc -> (a -> Print) -> NonEmpty a -> Print+prettyItems h f b = (\x -> group h <=> group x <> semi) <$> csl1 (fmap ng . f) b++prettyItemsid :: Doc -> PrettyIdent a -> NonEmpty a -> Print+prettyItemsid h f b = (\x -> group h <=> x <> semi) <$> gpadj (cslid1 $ mkng f) b++prettyAttrThen :: Attributes -> Print -> Print+prettyAttrThen = liftA2 (<?=>) . prettyAttr++prettyAttr :: Attributes -> Print+prettyAttr = pl (<=>) $ nonEmpty (pure mempty) $ fmap (\x -> group $ "(* " <> fst x <=> "*)") . cslid1 pa+ where+ pa (Attribute i e) = maybe (prettyBS i) (liftA2 prettyEq (rawId $ Identifier i) . pca) e+ pca = prettyGExpr prettyIdent (pm prettyCRangeExpr) (const $ pure mempty) 12++prettyHierIdent :: PrettyIdent HierIdent+prettyHierIdent (HierIdent p i) = do+ (ii, s) <- prettyIdent i+ iii <- foldrM (\x acc -> (\d -> d <> dot <> acc) <$> phId x) ii p+ return (nest iii, s)+ where+ phId (s, r) =+ pm (fmap (group . brk) . padj prettyCExpr) r >>= \dr -> ngpadj (padjWith prettyIdent dr) s++prettyDot1Ident :: PrettyIdent Dot1Ident+prettyDot1Ident (Dot1Ident mh t) = do+ (i, s) <- prettyIdent t+ case mh of Nothing -> return (i, s); Just h -> (\ft -> (ft <> dot <> i, s)) <$> padj prettyBS h++prettySpecTerm :: PrettyIdent SpecTerm+prettySpecTerm (SpecTerm i r) = pm prettyCRangeExpr r >>= \d -> padjWith prettyIdent d i++prettyNumber :: Number -> Doc+prettyNumber x = case x of+ NBinary l -> "b" </> fromString (concatMap show l)+ NOctal l -> "o" </> fromString (concatMap show l)+ NDecimal i -> "d" </> viaShow i+ NHex l -> "h" </> fromString (concatMap show l)+ NXZ b -> if b then "dx" else "dz"++prettyNumIdent :: PrettyIdent NumIdent+prettyNumIdent x = case x of+ NIIdent i -> prettyIdent i+ NIReal r -> mkid $ raw r+ NINumber n -> mkid $ viaShow n++prettyPrim :: PrettyIdent i -> (r -> Print) -> (a -> Print) -> PrettyIdent (GenPrim i r a)+prettyPrim ppid ppr ppa x = case x of+ PrimNumber Nothing True (NDecimal i) -> mkid $ viaShow i+ PrimNumber w b n ->+ mkid $+ nest $+ (case w of Nothing -> mempty; Just ww -> viaShow ww <> softline)+ <> group ((if b then "'s" else squote) <> prettyNumber n)+ PrimReal r -> mkid $ raw r+ PrimIdent i r -> ppr r >>= \rng -> first nest <$> padjWith ppid (group rng) i+ PrimConcat l -> bcslid1 pexpr l >>= mkid+ PrimMultConcat e l ->+ liftA2 (<>) (gpadj (prettyGExpr prettyIdent (pm prettyCRangeExpr) ppa 12) e) (bcslid1 pexpr l)+ >>= mkid . brc . nest+ PrimFun i a l -> do+ dat <- ppa a+ darg <- pcslid pexpr l+ (if nullDoc dat then padjWith else pspWith) ppid (dat <?=> darg) i+ PrimSysFun i l -> pcslid pexpr l >>= mkid . \x -> nest $ "$" <> raw i <> x+ PrimMinTypMax m -> padj (prettyGMTM pexpr) m >>= mkid . par+ PrimString x -> mkid $ "\"" <> raw x <> "\""+ where pexpr = prettyGExpr ppid ppr ppa 12++preclevel :: BinaryOperator -> Int+preclevel b = case b of+ BinPower -> 1+ BinTimes -> 2+ BinDiv -> 2+ BinMod -> 2+ BinPlus -> 3+ BinMinus -> 3+ BinLSL -> 4+ BinLSR -> 4+ BinASL -> 4+ BinASR -> 4+ BinLT -> 5+ BinLEq -> 5+ BinGT -> 5+ BinGEq -> 5+ BinEq -> 6+ BinNEq -> 6+ BinCEq -> 6+ BinCNEq -> 6+ BinAnd -> 7+ BinXor -> 8+ BinXNor -> 8+ BinOr -> 9+ BinLAnd -> 10+ BinLOr -> 11++prettyGExpr :: PrettyIdent i -> (r -> Print) -> (a -> Print) -> Int -> PrettyIdent (GenExpr i r a)+prettyGExpr ppid ppr ppa l e = case e of+ ExprPrim e -> first group <$> prettyPrim ppid ppr ppa e+ ExprUnOp op a e -> do+ da <- ppa a+ (x, s) <- prettyPrim ppid ppr ppa e+ return (ng $ viaShow op <> piff (space <> da <> newline) (nullDoc da) <> x, s)+ ExprBinOp el op a r -> do+ let+ p = preclevel op+ pp = pexpr $ p - 1+ ll <- (<=> viaShow op) <$> psexpr p el+ da <- ppa a+ case compare l p of+ LT -> padj pp r >>= \rr -> mkid $ ng $ par $ ll <+> (da <?=> rr)+ EQ -> first (\rr -> ll <+> (da <?=> rr)) <$> pp r+ GT -> first (\rr -> ng $ ll <+> (da <?=> rr)) <$> pp r+ ExprCond ec a et ef -> do+ dc <- psexpr 11 ec+ dt <- psexpr 12 et+ df <- pexpr 12 ef+ da <- ppa a+ let+ pp = first (\x -> nest $ group (dc <=> nest ("?" <?+> da)) <=> group (dt <=> colon <+> x)) df+ if l < 12 then mkid $ gpar $ uncurry (<>) pp else return pp+ where+ pexpr = prettyGExpr ppid ppr ppa+ psexpr n e = fst <$> pexpr n e++prettyExpr :: PrettyIdent Expr+prettyExpr (Expr e) = prettyGExpr prettyHierIdent (pm prettyDimRange) prettyAttr 12 e++prettyCExpr :: PrettyIdent CExpr+prettyCExpr (CExpr e) = prettyGExpr prettyIdent (pm prettyCRangeExpr) prettyAttr 12 e++prettyGMTM :: PrettyIdent et -> PrettyIdent (GenMinTypMax et)+prettyGMTM pp x = case x of+ MTMSingle e -> pp e+ MTMFull l t h -> do+ mn <- gpadj pp l+ mt <- gpadj pp t+ first (\mx -> mn <> colon <-> mt <> colon <-> group mx) <$> pp h++prettyMTM :: PrettyIdent MinTypMax+prettyMTM = prettyGMTM prettyExpr++prettyCMTM :: PrettyIdent CMinTypMax+prettyCMTM = prettyGMTM prettyCExpr++prettyRange2 :: Range2 -> Print+prettyRange2 (Range2 m l) = do+ mx <- gpadj prettyCExpr m+ mn <- gpadj prettyCExpr l+ return $ brk $ mx <> colon <-> mn++prettyR2s :: [Range2] -> Print+prettyR2s = pl (</>) $ fmap group . prettyRange2++prettyRangeExpr :: PrettyIdent e -> GenRangeExpr e -> Print+prettyRangeExpr pp x = case x of+ GRESingle r -> brk <$> padj pp r+ GREPair r2 -> prettyRange2 r2+ GREBaseOff b mp o -> do+ base <- gpadj pp b+ off <- gpadj prettyCExpr o+ return $ brk $ base <> (if mp then "-" else "+") <> colon <-> off++prettyCRangeExpr :: CRangeExpr -> Print+prettyCRangeExpr = prettyRangeExpr prettyCExpr++prettyGDR :: PrettyIdent e -> GenDimRange e -> Print+prettyGDR pp (GenDimRange d r) =+ foldr (liftA2 ((</>) . group . brk) . padj pp) (group <$> prettyRangeExpr pp r) d++prettyDimRange :: DimRange -> Print+prettyDimRange = prettyGDR prettyExpr++prettyCDimRange :: CDimRange -> Print+prettyCDimRange = prettyGDR prettyCExpr++prettySignRange :: SignRange -> Print+prettySignRange (SignRange s r) = (pift "signed" s <?=>) <$> pm (fmap group . prettyRange2) r++prettyComType :: (d -> Doc) -> ComType d -> Print+prettyComType f x = case x of+ CTAbstract t -> pure $ viaShow t+ CTConcrete e sr -> group . (f e <?=>) <$> prettySignRange sr++prettyDriveStrength :: DriveStrength -> Doc+prettyDriveStrength x = case x of+ DSNormal StrStrong StrStrong -> mempty+ DSNormal s0 s1 -> par $ viaShow s0 <> "0" </> comma <+> viaShow s1 <> "1"+ DSHighZ False s -> par $ "highz0" </> comma <+> viaShow s <> "1"+ DSHighZ True s -> par $ viaShow s <> "0" </> comma <+> "highz1"++prettyDelay3 :: PrettyIdent Delay3+prettyDelay3 x =+ first ("#" <>) <$> case x of+ D3Base ni -> prettyNumIdent ni+ D31 m -> padj prettyMTM m >>= mkid . par+ D32 m1 m2 -> do+ d1 <- ngpadj prettyMTM m1+ d2 <- ngpadj prettyMTM m2+ mkid $ par $ d1 <.> d2+ D33 m1 m2 m3 -> do+ d1 <- ngpadj prettyMTM m1+ d2 <- ngpadj prettyMTM m2+ d3 <- ngpadj prettyMTM m3+ mkid $ par $ d1 <.> d2 <.> d3++prettyDelay2 :: PrettyIdent Delay2+prettyDelay2 x =+ first ("#" <>) <$> case x of+ D2Base ni -> prettyNumIdent ni+ D21 m -> padj prettyMTM m >>= mkid . par+ D22 m1 m2 -> do+ d1 <- ngpadj prettyMTM m1+ d2 <- ngpadj prettyMTM m2+ mkid $ par $ d1 <.> d2++prettyDelay1 :: PrettyIdent Delay1+prettyDelay1 x =+ first ("#" <>) <$> case x of+ D1Base ni -> prettyNumIdent ni+ D11 m -> padj prettyMTM m >>= mkid . par++prettyLValue :: (dr -> Print) -> PrettyIdent (LValue dr)+prettyLValue f x = case x of+ LVSingle hi r -> pm (fmap group . f) r >>= \rng -> first nest <$> padjWith prettyHierIdent rng hi+ LVConcat l -> bcslid1 (prettyLValue f) l >>= mkid ++prettyNetLV :: PrettyIdent NetLValue+prettyNetLV = prettyLValue prettyCDimRange++prettyVarLV :: PrettyIdent VarLValue+prettyVarLV = prettyLValue prettyDimRange++prettyAssign :: (dr -> Print) -> PrettyIdent (Assign dr)+prettyAssign f (Assign l e) = liftA2 (prettyEq . fst) (prettyLValue f l) (prettyExpr e)++prettyNetAssign :: PrettyIdent NetAssign+prettyNetAssign = prettyAssign prettyCDimRange++prettyVarAssign :: PrettyIdent VarAssign+prettyVarAssign = prettyAssign prettyDimRange++prettyEventControl :: PrettyIdent EventControl+prettyEventControl x =+ first ("@" <>) <$> case x of+ ECDeps -> pure ("*", newline)+ ECIdent hi -> first ng <$> prettyHierIdent hi+ ECExpr l -> (\e -> (gpar e, newline)) <$> padj (cslid1 pEP) l+ where+ pEP (EventPrim p e) =+ first (ng . ((case p of EPAny -> mempty; EPPos -> "posedge"; EPNeg -> "negedge") <?=>))+ <$> prettyExpr e++prettyEdgeDesc :: EdgeDesc -> Print+prettyEdgeDesc x = do+ zx <- asks _poEdgeControlZ_X+ if x == V.fromList [True, True, False, False, False, True]+ then pure "posedge"+ else+ if x == V.fromList [False, False, True, True, True, False]+ then pure "negedge"+ else+ (\x -> group $ "edge" <=> brk x)+ <$> csl mempty mempty (pure . raw) (V.ifoldr (pED zx) [] x)+ where+ pED zx i b =+ if b+ then (:) $ case i of+ 0 -> "01"+ 1 -> if zx then "0z" else "0x"+ 2 -> "10"+ 3 -> if zx then "1z" else "1x"+ 4 -> if zx then "z0" else "x0"+ 5 -> if zx then "z1" else "x1"+ else id++prettyXparam :: B.ByteString -> ComType () -> NonEmpty (Identified CMinTypMax) -> Print+prettyXparam pre t l = do+ dt <- prettyComType (const mempty) t+ prettyItemsid+ (raw pre <?=> dt)+ (\(Identified i v) -> liftA2 prettyEq (rawId i) (prettyCMTM v))+ l++type EDI = Either [Range2] CExpr++data AllBlockDecl+ = ABDReg SignRange (NonEmpty (Identified EDI))+ | ABDInt (NonEmpty (Identified EDI))+ | ABDReal (NonEmpty (Identified EDI))+ | ABDTime (NonEmpty (Identified EDI))+ | ABDRealTime (NonEmpty (Identified EDI))+ | ABDEvent (NonEmpty (Identified [Range2]))+ | ABDLocalParam (ComType ()) (NonEmpty (Identified CMinTypMax))+ | ABDParameter (ComType ()) (NonEmpty (Identified CMinTypMax))+ | ABDPort Dir (ComType Bool) (NonEmpty Identifier)++fromBlockDecl ::+ (forall x. f x -> NonEmpty (Identified x)) -> (t -> EDI) -> BlockDecl f t -> AllBlockDecl+fromBlockDecl ff ft bd = case bd of+ BDReg sr x -> convt (ABDReg sr) x+ BDInt x -> convt ABDInt x+ BDReal x -> convt ABDReal x+ BDTime x -> convt ABDTime x+ BDRealTime x -> convt ABDRealTime x+ BDEvent r2 -> conv ABDEvent r2+ BDLocalParam t v -> conv (ABDLocalParam t) v+ where+ conv c = c . ff+ convt c = c . NE.map (\(Identified i x) -> Identified i $ ft x) . ff++fromStdBlockDecl :: AttrIded StdBlockDecl -> Attributed AllBlockDecl+fromStdBlockDecl (AttrIded a i sbd) =+ Attributed a $ case sbd of+ SBDParameter (Parameter t v) -> ABDParameter t [Identified i v]+ SBDBlockDecl bd -> fromBlockDecl ((:|[]) . Identified i . runIdentity) Left bd+ +prettyAllBlockDecl :: AllBlockDecl -> Print+prettyAllBlockDecl x = case x of+ ABDReg sr l -> prettySignRange sr >>= \dsr -> mkedi ("reg" <?=> dsr) l+ ABDInt l -> mkedi "integer" l+ ABDReal l -> mkedi "real" l+ ABDTime l -> mkedi "time" l+ ABDRealTime l -> mkedi "realtime" l+ ABDEvent l ->+ prettyItemsid "event" (\(Identified i r) -> prettyR2s r >>= \dr -> padjWith prettyIdent dr i) l+ ABDLocalParam t l -> prettyXparam "localparam" t l+ ABDParameter t l -> prettyXparam "parameter" t l+ ABDPort d t l ->+ prettyComType (pift "reg") t >>= \dt -> prettyItemsid (viaShow d <?=> dt) prettyIdent l+ where+ mkedi h =+ prettyItemsid h $+ \(Identified i edi) -> case edi of+ Left r2 -> prettyR2s r2 >>= \dim -> padjWith prettyIdent (group dim) i+ Right ce -> liftA2 prettyEq (rawId i) (prettyCExpr ce)++prettyAllBlockDecls :: [Attributed AllBlockDecl] -> Print+prettyAllBlockDecls =+ nonEmpty (pure mempty) $+ prettyregroup+ (<#>)+ (\(Attributed a abd) -> prettyAllBlockDecl abd >>= prettyAttrng a)+ id+ (addAttributed $ \x y -> case (x, y) of+ (ABDReg nsr nl, ABDReg sr l) | nsr == sr -> Just $ ABDReg sr $ nl <> l+ (ABDInt nl, ABDInt l) -> Just $ ABDInt $ nl <> l+ (ABDReal nl, ABDReal l) -> Just $ ABDReal $ nl <> l+ (ABDTime nl, ABDTime l) -> Just $ ABDTime $ nl <> l+ (ABDRealTime nl, ABDRealTime l) -> Just $ ABDRealTime $ nl <> l+ (ABDEvent nl, ABDEvent l) -> Just $ ABDEvent $ nl <> l+ (ABDLocalParam nt nl, ABDLocalParam t l) | nt == t -> Just $ ABDLocalParam t $ nl <> l+ (ABDParameter nt nl, ABDParameter t l) | nt == t -> Just $ ABDParameter t $ nl <> l+ (ABDPort nd nt nl, ABDPort d t l) | nd == d && nt == t -> Just $ ABDPort d t $ nl <> l+ _ -> Nothing+ )++prettyStdBlockDecls :: [AttrIded StdBlockDecl] -> Print+prettyStdBlockDecls = prettyAllBlockDecls . map fromStdBlockDecl++prettyTFBlockDecls :: (d -> Dir) -> [AttrIded (TFBlockDecl d)] -> Print+prettyTFBlockDecls f =+ prettyAllBlockDecls+ . map+ ( \(AttrIded a i x) -> case x of+ TFBDPort d t -> Attributed a $ ABDPort (f d) t [i]+ TFBDStd sbd -> fromStdBlockDecl (AttrIded a i sbd)+ )++prettyStatement :: Bool -> Statement -> Print+prettyStatement protect x = case x of+ SBlockAssign b (Assign lv v) dec -> do+ delev <- case dec of+ Nothing -> pure mempty+ Just (DECRepeat e ev) -> do+ ex <- padj prettyExpr e+ evc <- prettyEventControl ev+ return $ group ("repeat" <=> gpar ex) <=> fst evc+ Just (DECDelay d) -> fst <$> prettyDelay1 d+ Just (DECEvent e) -> fst <$> prettyEventControl e+ ll <- prettyVarLV lv+ rr <- gpadj prettyExpr v+ return $ ng $ group (fst ll) <=> group (piff langle b <> equals <+> delev <?=> rr) <> semi+ SCase zox e b s -> do+ ex <- padj prettyExpr e+ dft <- case s of+ Attributed [] Nothing -> pure mempty+ _ -> nest . ("default:" <=>) <$> prettyMybStmt False s+ let+ pci (CaseItem p v) = do+ pat <- gpadj (cslid1 prettyExpr) p+ branch <- prettyMybStmt False v+ return $ pat <> colon <+> ng branch+ body <- pl (<#>) pci b+ return $+ block+ (nest $ "case" <> case zox of {ZOXZ -> "z"; ZOXO -> mempty; ZOXX -> "x"} <=> gpar ex)+ "endcase"+ (body <?#> dft)+ SIf c t f -> do+ head <- ("if" <=>) . gpar <$> padj prettyExpr c+ case f of+ Attributed [] Nothing | protect == False -> (ng head <>) <$> prettyRMybStmt False t+ Attributed [] (Just x@(SBlock _ _ _)) -> do+ -- `else` and `begin`/`fork` at same indentation level+ tb <- prettyRMybStmt True t+ fb <- prettyStatement False x+ return $ ng (group head <> tb) <#> "else" <=> fb+ Attributed [] (Just x@(SIf _ _ _)) -> do+ -- `if` and `else if` at same indentation level+ tb <- prettyRMybStmt True t+ fb <- prettyStatement protect x+ return $ ng (group head <> tb) <#> "else" <=> fb+ _ -> do+ tb <- prettyRMybStmt True t+ fb <- prettyRMybStmt protect f+ return $ ng (group head <> tb) <#> nest ("else" <> fb)+ SDisable hi -> (\x -> group $ "disable" <=> x <> semi) <$> padj prettyHierIdent hi+ SEventTrigger hi e -> do+ dhi <- padj prettyHierIdent hi+ dim <- pl (</>) (fmap (group . brk) . padj prettyExpr) e+ return $ group $ "->" <+> dhi <> dim <> semi+ SLoop ls s -> do+ head <- case ls of+ LSForever -> pure "forever"+ LSRepeat e -> ("repeat" <=>) . gpar <$> padj prettyExpr e+ LSWhile e -> ("while" <=>) . gpar <$> padj prettyExpr e+ LSFor i c u -> do+ di <- gpadj prettyVarAssign i+ dc <- gpadj prettyExpr c + du <- gpadj prettyVarAssign u+ return $ "for" <=> gpar (di <> semi <+> dc <> semi <+> du)+ nest . (ng head <=>) <$> prettyAttrStmt protect s+ SProcContAssign pca ->+ (<> semi) . group <$> case pca of+ PCAAssign va -> ("assign" <=>) <$> padj prettyVarAssign va+ PCADeassign lv -> ("deassign" <=>) <$> padj prettyVarLV lv+ PCAForce lv -> ("force" <=>) <$> either (padj prettyVarAssign) (padj prettyNetAssign) lv+ PCARelease lv -> ("release" <=>) <$> either (padj prettyVarLV) (padj prettyNetLV) lv+ SProcTimingControl dec s -> do+ ddec <- either prettyDelay1 prettyEventControl dec+ (group (fst ddec) <=>) <$> prettyMybStmt protect s+ SBlock h ps s -> do+ head <- pm (\(s, _) -> (colon <+>) <$> rawId s) h+ block+ (nest $ (if ps then "fork" else "begin") <?/> head)+ (if ps then "join" else "end")+ <$> liftA2 (<?#>) (pm (prettyStdBlockDecls . snd) h) (pl (<#>) (prettyAttrStmt False) s)+ SSysTaskEnable s a ->+ (\x -> ng ("$" <> raw s <> x) <> semi) <$> pcslid (maybe (mkid mempty) prettyExpr) a+ STaskEnable hi a -> do+ dhi <- padj prettyHierIdent hi+ args <- pcslid prettyExpr a+ return $ group (dhi <> args) <> semi+ SWait e s -> padj prettyExpr e >>= \x -> (ng ("wait" <=> gpar x) <>) <$> prettyRMybStmt protect s++prettyAttrStmt :: Bool -> AttrStmt -> Print+prettyAttrStmt protect (Attributed a s) = prettyAttrThen a $ nest <$> prettyStatement protect s++prettyMybStmt :: Bool -> MybStmt -> Print+prettyMybStmt protect (Attributed a s) = case s of+ Nothing -> (<> semi) <$> prettyAttr a+ Just s -> prettyAttrThen a $ prettyStatement protect s++prettyRMybStmt :: Bool -> MybStmt -> Print+prettyRMybStmt protect (Attributed a s) = do+ da <- case a of {[] -> pure mempty; _ -> (newline <>) <$> prettyAttr a}+ ds <- maybe (pure semi) (fmap (newline <>) . prettyStatement protect) s+ return $ da <> ds++prettyPortAssign :: PortAssign -> Print+prettyPortAssign x = case x of+ PortPositional l ->+ cslid+ mempty+ mempty+ ( \(Attributed a e) -> case e of+ Nothing -> prettyAttr a >>= mkid+ Just e -> do+ (i, s) <- prettyExpr e+ d <- prettyAttrng a i+ return (group d, s)+ )+ l+ PortNamed l ->+ csl+ mempty+ softline+ ( \(AttrIded a i e) -> do+ s <- padj prettyIdent i+ ex <- pm (padj prettyExpr) e+ group <$> prettyAttrng a (dot <> s <> gpar ex)+ )+ l++prettyModGenSingleItem :: ModGenSingleItem -> Bool -> Print+prettyModGenSingleItem x protect = case x of+ MGINetInit nt ds np l ->+ com np >>= \d -> prettyItemsid (viaShow nt <?=> prettyDriveStrength ds <?=> d) pide l+ MGINetDecl nt np l -> com np >>= \d -> prettyItemsid (viaShow nt <?=> d) pidd l+ MGITriD ds np l ->+ com np >>= \d -> prettyItemsid ("trireg" <?=> prettyDriveStrength ds <?=> d) pide l+ MGITriC cs np l ->+ com np >>= \d -> prettyItemsid ("trireg" <?=> piff (viaShow cs) (cs == CSMedium) <?=> d) pidd l+ MGIBlockDecl bd -> prettyAllBlockDecl $ fromBlockDecl getCompose id bd+ MGIGenVar l -> prettyItemsid "genvar" prettyIdent l+ MGITask aut s d b -> do+ i <- padj prettyIdent s+ decls <- prettyTFBlockDecls id d+ body <- prettyMybStmt False b+ return $+ block (ng $ group ("task" <?=> mauto aut) <=> i <> semi) "endtask" (decls <?#> nest body)+ MGIFunc aut t s d b -> do+ dt <- pm (prettyComType $ const mempty) t+ i <- padj prettyIdent s+ decls <- prettyTFBlockDecls (const DirIn) d+ body <- prettyStatement False $ toStatement b+ return $+ block+ (ng $ group ("function" <?=> mauto aut <?=> dt) <=> i <> semi)+ "endfunction"+ (decls <?#> nest body)+ MGIDefParam l ->+ prettyItemsid+ "defparam"+ (\(ParamOver hi v) -> liftA2 (prettyEq . fst) (prettyHierIdent hi) (prettyCMTM v))+ l+ MGIContAss ds d3 l -> do+ d <- pm (fmap fst . prettyDelay3) d3+ prettyItemsid ("assign" <?=> prettyDriveStrength ds <?=> d) prettyNetAssign l+ MGICMos r d3 l -> do+ d <- pm (fmap fst . prettyDelay3) d3+ prettyItems+ (pift "r" r <> "cmos" <?=> d)+ ( \(GICMos n lv inp nc pc) -> do+ i <- pm pname n+ dlv <- ngpadj prettyNetLV lv+ di <- ngpadj prettyExpr inp+ dn <- ngpadj prettyExpr nc+ dp <- ngpadj prettyExpr pc+ return $ i <> gpar (dlv <.> di <.> dn <.> dp)+ )+ l+ MGIEnable r oz ds d3 l -> do+ d <- pm (fmap fst . prettyDelay3) d3+ prettyItems+ ( (if r then "not" else "buf") <> "if" <> (if oz then "1" else "0")+ <?=> prettyDriveStrength ds+ <?=> d+ )+ ( \(GIEnable n lv inp e) -> do+ i <- pm pname n+ dlv <- ngpadj prettyNetLV lv+ di <- ngpadj prettyExpr inp+ de <- ngpadj prettyExpr e+ return $ i <> gpar (dlv <.> di <.> de)+ )+ l+ MGIMos r np d3 l -> do+ d <- pm (fmap fst . prettyDelay3) d3+ prettyItems+ (pift "r" r <> (if np then "n" else "p") <> "mos" <?=> d)+ ( \(GIMos n lv inp e) -> do+ i <- pm pname n+ dlv <- ngpadj prettyNetLV lv+ di <- ngpadj prettyExpr inp+ de <- ngpadj prettyExpr e+ return $ i <> gpar (dlv <.> di <.> de)+ )+ l+ MGINIn nin n ds d2 l -> do+ d <- pm (fmap fst . prettyDelay2) d2+ prettyItems+ ( (if nin == NITXor then "x" <> pift "n" n <> "or" else pift "n" n <> viaShow nin)+ <?=> prettyDriveStrength ds+ <?=> d+ )+ ( \(GINIn n lv inp) -> do+ i <- pm pname n+ dlv <- ngpadj prettyNetLV lv+ di <- padj (cslid1 $ mkng prettyExpr) inp+ return $ i <> gpar (dlv <.> di)+ )+ l+ MGINOut r ds d2 l -> do+ d <- pm (fmap fst . prettyDelay2) d2+ prettyItems+ ((if r then "not" else "buf") <?=> prettyDriveStrength ds <?=> d)+ ( \(GINOut n lv inp) -> do+ i <- pm pname n+ dlv <- padj (cslid1 $ mkng prettyNetLV) lv+ di <- ngpadj prettyExpr inp+ return $ i <> gpar (dlv <.> di)+ )+ l+ MGIPassEn r oz d2 l -> do+ d <- pm (fmap fst . prettyDelay2) d2+ prettyItems+ (pift "r" r <> "tranif" <> (if oz then "1" else "0") <?=> d)+ ( \(GIPassEn n ll rl e) -> do+ i <- pm pname n+ dll <- ngpadj prettyNetLV ll+ drl <- ngpadj prettyNetLV rl+ de <- ngpadj prettyExpr e+ return $ i <> gpar (dll <.> drl <.> de)+ )+ l+ MGIPass r l ->+ prettyItems+ (pift "r" r <> "tran")+ ( \(GIPass n ll rl) -> do+ i <- pm pname n+ dll <- ngpadj prettyNetLV ll+ drl <- ngpadj prettyNetLV rl+ return $ i <> gpar (dll <.> drl))+ l+ MGIPull ud ds l ->+ prettyItems+ ("pull" <> (if ud then "up" else "down") <?=> prettyDriveStrength ds)+ (\(GIPull n lv) -> pm pname n >>= \i -> (i <>) . gpar <$> gpadj prettyNetLV lv)+ l+ MGIUDPInst kind ds d2 l -> do+ d <- pm (fmap fst . prettyDelay2) d2+ dk <- rawId kind+ prettyItems+ (dk <?=> prettyDriveStrength ds <?=> d)+ ( \(UDPInst n lv args) -> do+ i <- pm pname n+ dlv <- gpadj prettyNetLV lv+ da <- padj (cslid1 $ mkg prettyExpr) args+ return $ i <> gpar (dlv <.> da)+ )+ l+ MGIModInst kind param l -> do+ dp <- case param of+ ParamPositional l -> cslid ("#(" <> softspace) rparen (mkng prettyExpr) l+ ParamNamed l ->+ csl+ ("#(" <> softspace)+ (softline <> rparen)+ ( \(Identified i e) -> do+ s <- padj prettyIdent i+ d <- pm (padj prettyMTM) e+ return $ ng $ dot <> s <> gpar d+ )+ l+ dk <- rawId kind+ prettyItems+ (dk <?=> dp)+ (\(ModInst n args) -> pname n >>= \i -> (i <>) . gpar <$> prettyPortAssign args)+ l+ MGIUnknownInst kind param l -> do+ dp <- case param of+ Nothing -> pure mempty+ Just (Left e) -> ("#" <>) . par <$> padj prettyExpr e+ Just (Right (e0, e1)) ->+ ("#" <>) . par <$> liftA2 (<.>) (gpadj prettyExpr e0) (gpadj prettyExpr e1)+ dk <- rawId kind+ prettyItems+ (dk <?=> dp)+ ( \(UknInst n lv args) -> do+ i <- pname n+ dlv <- gpadj prettyNetLV lv+ da <- padj (cslid1 $ mkg prettyExpr) args+ return $ i <> gpar (dlv <.> da)+ )+ l+ MGIInitial s -> ("initial" <=>) <$> prettyAttrStmt protect s+ MGIAlways s -> ("always" <=>) <$> prettyAttrStmt protect s+ MGILoopGen si vi cond su vu (Identified (Identifier s) i) -> do+ di <- gpadj (liftA2 prettyEq (rawId si) . prettyCExpr) vi+ dc <- ngpadj prettyCExpr cond+ du <- gpadj (liftA2 prettyEq (rawId su) . prettyCExpr) vu+ let head = "for" <=> gpar (di <> semi <+> dc <> semi <+> du)+ case fromMGBlockedItem i of+ [Attributed a x] | B.null s ->+ ng . (group head <=>) <$> prettyAttrThen a (prettyModGenSingleItem x protect)+ r -> (ng head <=>) <$> prettyGBlock (Identifier s) r+ MGICondItem ci -> prettyModGenCondItem ci protect -- protect should never be True in practice+ where+ pname (InstanceName i r) = pm prettyRange2 r >>= \rng -> gpadj (padjWith prettyIdent rng) i+ mauto b = pift "automatic" b+ pidd (NetDecl i d) = prettyR2s d >>= \dim -> padjWith prettyIdent dim i+ pide (NetInit i e) = liftA2 prettyEq (rawId i) (prettyExpr e)+ com (NetProp b vs d3) = do+ let s = pift "signed" b+ dvs <- maybe+ (pure s)+ ( \(vs, r2) ->+ (\x -> maybe mempty (\b -> if b then "vectored" else "scalared") vs <?=> s <?=> x)+ <$> prettyRange2 r2+ )+ vs+ (dvs <?=>) <$> pm (fmap fst . prettyDelay3) d3++-- | Nested conditionals with dangling else support+prettyModGenCondItem :: ModGenCondItem -> Bool -> Print+prettyModGenCondItem ci protect = case ci of+ MGCIIf c t f -> do+ head <- ("if" <=>) . gpar <$> padj prettyCExpr c+ case f of+ GCBEmpty -> (<?#> pift "else;" protect) <$> pGCB head protect t+ _ -> liftA2 (<#>) (pGCB head True t) (pGCB "else" protect f)+ MGCICase c b md -> do+ dc <- padj prettyCExpr c+ body <-+ pl+ (<#>)+ (\(GenCaseItem p v) -> gpadj (cslid1 prettyCExpr) p >>= \pat -> pGCB (pat <> colon) False v)+ b+ dd <- case md of GCBEmpty -> pure mempty; _ -> nest <$> pGCB "default:" False md+ return $ block (ng $ "case" <=> gpar dc) "endcase" (body <?#> dd)+ where+ isNotCond x = case x of MGICondItem _ -> False; _ -> True+ pGCB head p b = case b of+ GCBEmpty -> pure $ head <> semi+ GCBConditional (Attributed a ci) ->+ ng . (group head <=>) <$> prettyAttrThen a (prettyModGenCondItem ci p)+ GCBBlock (Identified (Identifier s) r) -> case fromMGBlockedItem r of+ [Attributed a x] | B.null s && isNotCond x ->+ ng . (group head <=>) <$> prettyAttrThen a (prettyModGenSingleItem x protect)+ r -> (ng head <=>) <$> prettyGBlock (Identifier s) r++-- | Generate block+prettyGBlock :: Identifier -> [Attributed ModGenSingleItem] -> Print+prettyGBlock i l = do+ bn <- rawId i+ block ("begin" <> piff (colon <=> bn) (nullDoc bn)) "end"+ <$> pl+ (<#>)+ (\(Attributed a x) -> prettyAttrThen a $ prettyModGenSingleItem x False)+ l++prettyGenerateBlock :: GenerateBlock -> Print+prettyGenerateBlock (Identified s x) = prettyGBlock s $ fromMGBlockedItem x++prettySpecParams :: Maybe Range2 -> NonEmpty SpecParamDecl -> Print+prettySpecParams rng l = do+ dr <- pm prettyRange2 rng+ prettyItemsid+ ("specparam" <?=> dr)+ ( \d -> case d of+ SPDAssign i v -> liftA2 prettyEq (rawId i) (prettyCMTM v)+ SPDPathPulse io r e -> do+ dpp <- pm pPP io+ dr <- ngpadj prettyCMTM r+ de <- if r == e then pure mempty else (comma <+>) <$> ngpadj prettyCMTM e+ prettyEq ("PATHPULSE$" <> dpp) <$> mkid (par $ dr <> de)+ )+ l+ where+ -- Change to a spaced layout if tools allow it+ pPP (i, o) = do+ din <- ngpadj prettySpecTerm i+ dout <- prettySpecTerm o+ return $ din <> "$" <> fst dout++prettyPathDecl :: SpecPath -> Maybe Bool -> Maybe (Expr, Maybe Bool) -> Print+prettyPathDecl p pol eds = do+ -- parallel or full, source(s), destination(s)+ (pf, (cin, _), cout) <- case p of+ SPParallel i o -> do+ sti <- prettySpecTerm i+ sto <- prettySpecTerm o+ return (True, sti, fne sto)+ SPFull i o -> do+ sti <- ppSTs i+ sto <- ppSTs o+ return (False, sti, fne sto)+ (de, ed) <- case eds of+ Nothing -> pure (cout, mempty)+ Just (dst, me) -> do+ d <- padj prettyExpr dst+ return+ ( par $ cout <> po <> colon <+> d,+ maybe mempty (\e -> if e then "posedge" else "negedge") me+ )+ return $ gpar $ ng (ed <?=> group cin) <=> pift po noedge <> (if pf then "=>" else "*>") <+> ng de+ where+ ppSTs = cslid1 $ mkng prettySpecTerm+ -- polarity+ po = maybe mempty (\p -> if p then "+" else "-") pol+ -- edge sensitive path polarity isn't at the same place as non edge sensitive+ noedge = eds == Nothing+ fne = if noedge then uncurry (<>) else \x -> fst x <> newline++prettySpecifyItem :: SpecifySingleItem -> Print+prettySpecifyItem x =+ nest <$> case x of+ SISpecParam r l -> prettySpecParams r l+ SIPulsestyleOnevent o -> prettyItemsid "pulsestyle_onevent" prettySpecTerm o+ SIPulsestyleOndetect o -> prettyItemsid "pulsestyle_ondetect" prettySpecTerm o+ SIShowcancelled o -> prettyItemsid "showcancelled" prettySpecTerm o+ SINoshowcancelled o -> prettyItemsid "noshowcancelled" prettySpecTerm o+ SIPathDeclaration mpc p pol eds l -> do+ dmpc <- case mpc of+ MPCCond e ->+ group . ("if" <=>) . gpar+ <$> padj (prettyGExpr prettyIdent (const $ pure mempty) prettyAttr 12) e+ MPCAlways -> pure mempty+ MPCNone -> pure "ifnone"+ dpd <- prettyPathDecl p pol eds+ d <- padj (fmap (prettyEq dpd) . cslid1 prettyCMTM . cPDV) l+ return $ dmpc <?=> d <> semi+ SISetup (STCArgs d r e n) -> (\x -> "$setup" </> x <> semi) <$> ppA (STCArgs r d e n)+ SIHold a -> (\x -> "$hold" </> x <> semi) <$> ppA a+ SISetupHold a aa -> (\x -> "$setuphold" </> x <> semi) <$> ppAA a aa+ SIRecovery a -> (\x -> "$recovery" </> x <> semi) <$> ppA a+ SIRemoval a -> (\x -> "$removal" </> x <> semi) <$> ppA a+ SIRecrem a aa -> (\x -> "$recrem" </> x <> semi) <$> ppAA a aa+ SISkew a -> (\x -> "$skew" </> x <> semi) <$> ppA a+ SITimeSkew (STCArgs de re tcl n) meb mra -> do+ dre <- pTCE re+ dde <- pTCE de+ dtcl <- pexpr tcl+ dn <- pid n+ dmeb <- pm (gpadj prettyCExpr) meb+ dmra <- pm (gpadj prettyCExpr) mra+ return $ "$timeskew" </> gpar (dre <.> dde <.> toc [dtcl, dn, dmeb, dmra]) <> semi+ SIFullSkew (STCArgs de re tcl0 n) tcl1 meb mra -> do+ dre <- pTCE re+ dde <- pTCE de+ dtcl0 <- pexpr tcl0+ dtcl1 <- pexpr tcl1+ dn <- pid n+ dmeb <- pm (gpadj prettyCExpr) meb+ dmra <- pm (gpadj prettyCExpr) mra+ return $ "$fullskew" </> gpar (dre <.> dde <.> dtcl0 <.> toc [dtcl1, dn, dmeb, dmra]) <> semi+ SIPeriod re tcl n -> do+ dre <- pCTCE re+ dtcl <- pexpr tcl+ dn <- prid n+ return $ "$period" </> par (dre <.> dtcl <> dn) <> semi+ SIWidth re tcl mt n -> do+ dre <- pCTCE re+ dtcl <- pexpr tcl+ dmt <- pm (gpadj prettyCExpr) mt+ dn <- pid n+ return $ "$width" </> gpar (dre <.> toc [dtcl, dmt, dn]) <> semi+ SINoChange re de so eo n -> do+ dre <- pTCE re+ dde <- pTCE de+ dso <- ngpadj prettyMTM so+ deo <- ngpadj prettyMTM eo+ dn <- prid n+ return $ "$nochange" </> gpar (dre <.> dde <.> dso <.> deo <> dn) <> semi+ where+ toc :: [Doc] -> Doc+ toc = trailoptcat (<.>)+ prid = pm $ fmap (comma <+>) . padj prettyIdent+ pid = pm $ padj prettyIdent+ pexpr = gpadj prettyExpr+ pTCC st mbe = case mbe of+ Nothing -> gpadj prettySpecTerm st+ Just (b, e) -> do+ dst <- prettySpecTerm st+ de <- gpadj prettyExpr e+ return $ group $ group (fst dst) <=> "&&&" <+> pift "~" b <?+> de+ pTCE (TimingCheckEvent ev st tc) = ng <$> liftA2 (<?=>) (pm prettyEdgeDesc ev) (pTCC st tc)+ pCTCE (ControlledTimingCheckEvent ev st tc) =+ ng <$> liftA2 (<?=>) (prettyEdgeDesc ev) (pTCC st tc)+ ppA (STCArgs de re tcl n) = do+ dre <- pTCE re+ dde <- pTCE de+ dtcl <- pexpr tcl+ dn <- prid n+ return $ gpar $ dre <.> dde <.> dtcl <> dn+ pIMTM = pm $ \(Identified i mr) ->+ pm (fmap (group . brk) . padj prettyCMTM) mr >>= \d -> ngpadj (padjWith prettyIdent d) i+ ppAA (STCArgs de re tcl0 n) (STCAddArgs tcl1 msc mtc mdr mdd) = do+ dre <- pTCE re+ dde <- pTCE de+ dtcl0 <- pexpr tcl0+ dtcl1 <- pexpr tcl1+ dn <- pid n+ dmsc <- pm (ngpadj prettyMTM) msc+ dmtc <- pm (ngpadj prettyMTM) mtc+ dmdr <- pIMTM mdr+ dmdd <- pIMTM mdd+ return $ gpar $ dre <.> dde <.> dtcl0 <.> toc [dtcl1, dn, dmsc, dmtc, dmdr, dmdd]+ cPDV x = case x of+ PDV1 e -> e :|[]+ PDV2 e1 e2 -> [e1, e2]+ PDV3 e1 e2 e3 -> [e1, e2, e3]+ PDV6 e1 e2 e3 e4 e5 e6 -> [e1, e2, e3, e4, e5, e6]+ PDV12 e1 e2 e3 e4 e5 e6 e7 e8 e9 e10 e11 e12 ->+ [e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12]++data ModuleItem'+ = MI'MGI (Attributed ModGenSingleItem)+ | MI'Port Attributes Dir SignRange (NonEmpty Identifier)+ | MI'Parameter Attributes (ComType ()) (NonEmpty (Identified CMinTypMax))+ | MI'GenReg [Attributed ModGenSingleItem]+ | MI'SpecParam Attributes (Maybe Range2) (NonEmpty SpecParamDecl)+ | MI'SpecBlock [SpecifySingleItem]++prettyModuleItems :: [ModuleItem] -> Print+prettyModuleItems =+ nonEmpty (pure mempty) $+ prettyregroup+ (<#>)+ ( \x -> case x of+ MI'MGI (Attributed a i) -> prettyAttrThen a $ prettyModGenSingleItem i False+ MI'Port a d sr l -> do+ dsr <- prettySignRange sr+ it <- prettyItemsid (viaShow d <?=> dsr) prettyIdent l+ prettyAttrng a it+ MI'Parameter a t l -> prettyXparam "parameter" t l >>= prettyAttrng a+ MI'GenReg l ->+ block "generate" "endgenerate" <$>+ pl (<#>) (\(Attributed a i) -> prettyAttrThen a $ prettyModGenSingleItem i False) l+ MI'SpecParam a r l -> prettySpecParams r l >>= prettyAttrng a+ MI'SpecBlock l -> block "specify" "endspecify" <$> pl (<#>) prettySpecifyItem l+ )+ ( \x -> case x of+ MIMGI i -> MI'MGI $ fromMGBlockedItem1 <$> i+ MIPort (AttrIded a i (d, sr)) -> MI'Port a d sr [i]+ MIParameter (AttrIded a i (Parameter t v)) -> MI'Parameter a t [Identified i v]+ MIGenReg l -> MI'GenReg $ fromMGBlockedItem l+ MISpecParam a r spd -> MI'SpecParam a r [spd]+ MISpecBlock l -> MI'SpecBlock $ fromSpecBlockedItem l+ )+ ( \mi mi' -> case (mi, mi') of+ (MIMGI mgi, MI'MGI l) -> MI'MGI <$> (addAttributed fromMGBlockedItem_add) mgi l+ (MIPort (AttrIded na i (nd, nsr)), MI'Port a d sr l) | na == a && nd == d && nsr == sr ->+ Just $ MI'Port a d sr $ i <| l+ (MIParameter (AttrIded na i (Parameter nt v)), MI'Parameter a t l) | na == a && nt == t ->+ Just $ MI'Parameter a t $ Identified i v <| l+ (MISpecParam na nr spd, MI'SpecParam a r l) | na == a && nr == r ->+ Just $ MI'SpecParam a r $ spd <| l+ _ -> Nothing+ )++prettyPortInter :: [Identified [Identified (Maybe CRangeExpr)]] -> Print+prettyPortInter =+ cslid mempty mempty $+ \(Identified i@(Identifier ii) l) -> case l of+ [Identified i' x] | i == i' -> first group <$> prettySpecTerm (SpecTerm i x)+ _ ->+ if B.null ii+ then portexpr l+ else do+ di <- padj prettyIdent i+ de <- padj portexpr l+ mkid $ ng $ dot <> di <> gpar de+ where+ pst (Identified i x) = prettySpecTerm $ SpecTerm i x+ portexpr :: PrettyIdent [Identified (Maybe CRangeExpr)]+ portexpr l = case l of+ [] -> pure (mempty, mempty)+ [x] -> pst x+ _ -> cslid (lbrace <> softspace) rbrace pst l >>= mkid++prettyModuleBlock :: LocalCompDir -> ModuleBlock -> Reader PrintingOpts (Doc, LocalCompDir)+prettyModuleBlock (LocalCompDir ts c p dn) (ModuleBlock a i pi b mts mc mp mdn) = do+ head <- fpadj (group . ("module" <=>)) prettyIdent i+ ports <- prettyPortInter pi+ header <- prettyItem a $ head <> gpar ports+ body <- prettyModuleItems b+ let+ dts =+ piff (let (a, b) = fromJust mts in "`timescale" <+> tsval a <+> "/" <+> tsval b) (ts == mts)+ dcd = piff (if mc then "`celldefine" else "`endcelldefine") (c == mc)+ dud =+ piff+ ( case mp of+ Nothing -> "`nounconnected_drive"+ Just b -> "`unconnected_drive pull" <> if b then "1" else "0"+ )+ (p == mp)+ ddn = piff ("`default_nettype" <+> maybe "none" viaShow mdn) (dn == mdn)+ return+ (dts <?#> dcd <?#> dud <?#> ddn <?#> block header "endmodule" body, LocalCompDir mts mc mp mdn)+ where+ tsval i =+ let (u, v) = divMod i 3+ in case v of 0 -> "1"; 1 -> "10"; 2 -> "100"+ <> case u of 0 -> "s"; -1 -> "ms"; -2 -> "us"; -3 -> "ns"; -4 -> "ps"; -5 -> "fs"++prettyPrimPorts :: (Attributes, PrimPort, NonEmpty Identifier) -> Print+prettyPrimPorts (a, d, l) = do+ (ids, s) <- cslid1 prettyIdent l+ ports <- case d of+ PPOutReg (Just e) -> (\x -> ids <=> equals <+> x) <$> gpadj prettyCExpr e+ _ -> pure $ ids <> s+ prettyItem a $+ (case d of PPInput -> "input"; PPOutput -> "output"; PPReg -> "reg"; PPOutReg _ -> "output reg")+ <=> ports++-- | Analyses the column size of all lines and returns a list of either+-- | number of successive non-edge columns or the width of a column that contain edges+seqrowAlignment :: NonEmpty SeqRow -> [Either Int Int]+seqrowAlignment =+ maybe [] fst . foldrMapM1+ ( \sr@(SeqRow sri _ _) -> Just (case sri of+ SISeq l0 e l1 -> [Left $ length l0, Right $ edgeprintsize e, Left $ length l1]+ SIComb l -> [Left $ length l],+ totallength sr)+ )+ ( \sr@(SeqRow sri _ _) (sl, tl) ->+ if totallength sr /= tl+ then Nothing+ else case sri of+ SISeq l0 e l1 -> (,) <$> spliceputat (edgeprintsize e) (length l0) sl <*> pure tl+ SIComb l -> Just (sl, tl)+ )+ where+ totallength sr =+ case _srowInput sr of SIComb l -> length l; SISeq l0 e l1 -> 1 + length l0 + length l1+ edgeprintsize x = case x of EdgePos_neg _ -> 1; EdgeDesc _ _ -> 4+ -- Searches and splices a streak of non edge columns and puts an edge column+ spliceputat w n l = case l of+ [] -> Nothing+ Right w' : t ->+ if 0 < n+ then (Right w' :) <$> spliceputat w (n - 1) t+ else Just $ Right (max w w') : t+ Left m : t -> case compare m (n + 1) of+ LT -> (Left m :) <$> spliceputat w (n - m) t+ EQ -> Just $ Left n : Right w : t+ GT -> Just $ Left n : Right w : Left (m - n - 1) : t++-- | Prints levels or edges in an aligned way using analysis results+-- | the second part of the accumulation is Right if there is an edge, Left otherwise+prettySeqIn :: SeqIn -> [Either Int Int] -> Print+prettySeqIn si l = do+ ts <- asks _poTableSpace+ let pcat f = foldrMap1' mempty f ((if ts then (<+>) else (<>)) . f)+ return $+ fst $+ foldl'+ ( \(d, si) e -> case (e, si) of+ (Left n, Left l') ->+ let (l0, l1) = splitAt n l'+ in (d <> pcat viaShow l0, Left l1)+ (Right w, Left (h : t)) -> (d <> prettylevelwithwidth h w, Left t)+ (Left n, Right (l0, e, l1)) ->+ let (l00, l01) = splitAt n l0+ in (d <> pcat viaShow l00, Right (l01, e, l1))+ (Right w, Right ([], e, l1)) ->+ (d <> viaShow e <> pift sp3 (edgeprintsize e < w), Left l1)+ (Right w, Right (h : t, e, l')) -> (d <> prettylevelwithwidth h w, Right (t, e, l'))+ )+ (mempty, case si of SIComb l -> Left $ NE.toList l; SISeq a b c -> Right (a, b, c))+ l+ where+ edgeprintsize x = case x of EdgePos_neg _ -> 1; EdgeDesc _ _ -> 4+ sp3 = raw " "+ prettylevelwithwidth l w = viaShow l <> pift sp3 (w == 4)+ ++-- | Prints a table in a singular block with aligned columns, or just prints it if not possible+prettySeqRows :: NonEmpty SeqRow -> Print+prettySeqRows l = do+ ts <- asks _poTableSpace+ let+ pp :: (Foldable t, Show x) => t x -> Doc+ pp l =+ raw $+ fromString $+ if ts then intercalate " " $ map show $ toList l+ else concatMap show l+ psi x = case x of+ SIComb l -> pp l+ SISeq l0 e l1 -> pp l0 <+> viaShow e <+> pp l1+ pl+ (<#>)+ ( case seqrowAlignment l of+ -- fallback prettyprinting because aligned is better but not always possible+ [] -> \(SeqRow si s ns) -> pure $ nest $ psi si <=> prettyend s ns+ -- aligned prettyprinting+ colws -> \(SeqRow si s ns) -> nest . (<=> prettyend s ns) <$> prettySeqIn si colws+ )+ l+ where+ prettyend s ns = group (colon <+> viaShow s <=> colon <+> maybe "-" viaShow ns) <> semi++prettyPrimTable :: Doc -> PrimTable -> Print+prettyPrimTable od b = case b of+ CombTable l -> do+ ts <- asks _poTableSpace+ let+ pp l =+ if ts then intercalate " " $ map show $ toList l+ else concatMap show l+ return $+ block "table" "endtable" $+ (\f -> foldrMap1 f ((<#>) . f))+ (\(CombRow i o) -> nest $ raw (fromString $ pp i) <=> colon <+> viaShow o <> semi)+ l+ SeqTable mi l -> do+ table <- prettySeqRows l+ let pinit iv = case iv of ZOXX -> "1'bx"; ZOXZ -> "0"; ZOXO -> "1"+ return $+ maybe mempty (\iv -> nest $ group ("initial" <=> od) <=> equals <+> pinit iv <> semi) mi+ <?#> block "table" "endtable" table++prettyPrimitiveBlock :: PrimitiveBlock -> Print+prettyPrimitiveBlock (PrimitiveBlock a s o i pd b) = do+ (od, ol) <- prettyIdent o+ head <- fpadj (group . ("primitive" <=>)) prettyIdent s+ ports <- padj (cslid1 prettyIdent) i+ header <- prettyItem a $ head <> gpar (od <> ol <.> ports)+ table <- prettyPrimTable od b+ block header "endprimitive" . (<#> table)+ <$> prettyregroup+ (<#>)+ prettyPrimPorts+ (\(AttrIded a i p) -> (a, p, [i]))+ ( \(AttrIded na i np) (a, p, l) -> case (np, p) of+ (PPInput, PPInput) | na == a -> Just (a, p, i <| l)+ _ -> Nothing+ )+ pd++prettyConfigItem :: ConfigItem -> Print+prettyConfigItem (ConfigItem ci llu) = do+ dci <- case ci of+ CICell c -> ("cell" <=>) . fst <$> prettyDot1Ident c+ CIInst i ->+ ("instance" <=>)+ <$> foldrMap1 (fmap fst . prettyIdent) (liftA2 (\a b -> a <> dot <> b) . padj prettyIdent) i+ dllu <- case llu of+ LLULiblist ls -> ("liblist" <?=>) <$> catid prettyBS ls+ LLUUse s c -> (\x -> "use" <=> x <> pift ":config" c) <$> padj prettyDot1Ident s+ return $ nest $ ng dci <=> ng dllu <> semi+ where+ catid f = foldrMap1' (pure mempty) (gpadj f) $ liftA2 ((<=>) . fst) . f++prettyConfigBlock :: ConfigBlock -> Print+prettyConfigBlock (ConfigBlock i des b def) = do+ di <- padj prettyIdent i+ design <- catid prettyDot1Ident des+ body <- pl (<#>) prettyConfigItem b+ dft <- catid prettyBS def+ return $+ block (nest $ "config" <=> di <> semi) "endconfig" $+ nest ("design" <?=> design) <> semi <#> body <?#> nest ("default liblist" <?=> dft) <> semi+ where+ catid f = foldrMap1' (pure mempty) (gpadj f) $ liftA2 ((<=>) . fst) . f++prettyVerilog2005 :: Verilog2005 -> Print+prettyVerilog2005 (Verilog2005 mb pb cb) = do+ mods <-+ foldl'+ ( \macc m -> do+ (d, lcd) <- macc+ first (d <##>) <$> prettyModuleBlock lcd m+ )+ (pure (mempty, lcdDefault))+ mb+ prims <- pl (<##>) prettyPrimitiveBlock pb+ confs <- pl (<##>) prettyConfigBlock cb+ return $ fst mods <##> prims <##> confs+ where+ (<##>) = mkopt $ \a b -> a <#> mempty <#> b
+ src/Verismith/Verilog2005/Randomness.hs view
@@ -0,0 +1,209 @@+-- Module : Verismith.Verilog2005.Randomness+-- Description : Random sources+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : stable+-- Portability : POSIX+{-# LANGUAGE ScopedTypeVariables #-}++module Verismith.Verilog2005.Randomness+ ( sampleCategoricalProbability,+ sampleNumberProbability,+ sampleIn,+ sampleInString,+ sampleBernoulli,+ choice,+ sampleMaybe,+ sampleEither,+ sampleSegment,+ sampleEnum,+ sampleMaybeEnum,+ sampleWeighted,+ sampleFrom,+ sampleFromString,+ sampleBranch,+ sampleNum,+ sampleN,+ sampleNE,+ sampleString,+ sampleNEString,+ sampleFiltered,+ GenM,+ )+where++import Control.Applicative (liftA2)+import Control.Monad (join, replicateM)+import Control.Monad.Reader+import qualified Data.ByteString as B+import Data.List+import Data.List.NonEmpty (NonEmpty (..), toList)+import qualified Data.List.NonEmpty as NE+import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)+import Data.Word+import System.Random.MWC.Probability+import Verismith.Config (CategoricalProbability (..), NumberProbability (..), uniformCP)+import Verismith.Utils (nonEmpty, foldrMap1)++infixl 4 <.>++(<.>) :: (Monad m, Applicative m) => m (a -> m b) -> m a -> m b+(<.>) mf mx = join $ mf <*> mx++avoid :: [Int] -> Int -> Int+avoid l x = case l of+ h : t | h <= x -> avoid t $ x + 1+ _ -> x++uniq :: Ord b => (a -> b) -> (a -> a -> a) -> [a] -> [a]+uniq f m =+ nonEmpty [] $ toList+ . foldrMap1 (:|[]) (\e (x :| a) -> if f x == f e then (m x e) :| a else e :| x : a)+ . NE.sortWith f+ ++clean :: Int -> [(Double, Int)] -> [(Double, Int)]+clean t =+ map (\(x, y) -> (max 0 x, y))+ . uniq snd (\(x1, y1) (x2, y2) -> (x1 + x2, y1))+ . filter ((<= t) . snd)++sampleCategoricalProbability ::+ PrimMonad m => Int -> Gen (PrimState m) -> CategoricalProbability -> m Int+sampleCategoricalProbability t gen d = case d of+ CPDiscrete l ->+ let ll = NE.take (t + 1) l+ in case ll of+ [] -> error "Probability vector cannot be empty"+ [x] -> pure 0+ _ -> sample (categorical ll) gen+ CPBiasedUniform l b ->+ let ll = clean t l+ uw = fromIntegral (t + 1 - length ll) * b+ in nonEmpty+ (pure Nothing)+ (flip sample gen . discrete . ((uw, Nothing) :) . map (\(x, y) -> (x, Just y)) . toList)+ ll+ >>= maybe (avoid (map snd ll) <$> sample (uniformR (0, t - length ll)) gen) pure++sampleNumberProbability :: PrimMonad m => Gen (PrimState m) -> NumberProbability -> m Int+sampleNumberProbability gen d = case d of+ NPUniform l h -> sample (uniformR (l, h)) gen+ NPBinomial o t f -> (o +) <$> sample (binomial t f) gen+ NPNegativeBinomial o r f -> (o +) <$> sample (negativeBinomial f r) gen+ NPPoisson o p -> (o +) <$> sample (poisson p) gen+ NPDiscrete l -> sample (discrete l) gen+ NPLinearComb l -> sample (discrete l) gen >>= sampleNumberProbability gen++sampleIn :: (Functor m, PrimMonad m) => [a] -> Gen (PrimState m) -> CategoricalProbability -> m a+sampleIn l gen d = (l !!) <$> sampleCategoricalProbability (length l - 1) gen d++sampleInString ::+ (Functor m, PrimMonad m) =>+ B.ByteString ->+ Gen (PrimState m) ->+ CategoricalProbability ->+ m Word8+sampleInString s gen d = (B.index s) <$> sampleCategoricalProbability (B.length s - 1) gen d++type GenM p = ReaderT (p, Gen RealWorld) IO++sampleWrapper :: (p -> d) -> (Gen RealWorld -> d -> GenM p x) -> GenM p x+sampleWrapper p f = f <$> asks snd <.> asks (p . fst)++sampleBernoulli :: (p -> Double) -> GenM p Bool+sampleBernoulli p = sample <$> (bernoulli <$> asks (p . fst)) <.> asks snd++choice :: (p -> Double) -> GenM p a -> GenM p a -> GenM p a+choice c t f = sampleBernoulli c >>= \b -> if b then t else f++sampleMaybe :: (p -> Double) -> GenM p a -> GenM p (Maybe a)+sampleMaybe c x = choice c (Just <$> x) (pure Nothing)++sampleEither :: (p -> Double) -> GenM p a -> GenM p b -> GenM p (Either a b)+sampleEither c t f = choice c (Left <$> t) (Right <$> f)++sampleSegment :: (p -> CategoricalProbability) -> Int -> Int -> GenM p Int+sampleSegment p l h = (l +) <$> (sampleWrapper p $ sampleCategoricalProbability $ h - l)++sampleEnum :: forall a p. (Bounded a, Enum a) => (p -> CategoricalProbability) -> GenM p a+sampleEnum p = toEnum <$> sampleSegment p (fromEnum (minBound :: a)) (fromEnum (maxBound :: a))++sampleMaybeEnum ::+ forall a p. (Bounded a, Enum a) => (p -> CategoricalProbability) -> GenM p (Maybe a)+sampleMaybeEnum p =+ (\n -> if n == 0 then Nothing else Just $ toEnum $ mib + n - 1)+ <$> (sampleWrapper p $ sampleCategoricalProbability $ mab - mib + 1)+ where+ mib = fromEnum (minBound :: a)+ mab = fromEnum (maxBound :: a)++sampleWeighted :: [(Double, a)] -> GenM p a+sampleWeighted l = case l of+ [] -> error "Probability vector cannot be empty"+ [(_, x)] -> pure x+ _ -> asks snd >>= sample (discrete l)++sampleFrom :: (p -> CategoricalProbability) -> [a] -> GenM p a+sampleFrom p l = sampleWrapper p $ sampleIn l++sampleFromString :: (p -> CategoricalProbability) -> B.ByteString -> GenM p Word8+sampleFromString p s = sampleWrapper p $ sampleInString s++sampleBranch :: (p -> CategoricalProbability) -> [GenM p a] -> GenM p a+sampleBranch p l = join $ sampleFrom p l++sampleNum :: (p -> NumberProbability) -> GenM p Int+sampleNum p = sampleWrapper p sampleNumberProbability++sampleN :: (p -> NumberProbability) -> GenM p b -> GenM p [b]+sampleN p x = sampleNum p >>= flip replicateM x++sampleNE :: (p -> NumberProbability) -> GenM p b -> GenM p (NonEmpty b)+sampleNE p x = liftA2 (:|) x $ sampleN p x++sampleString ::+ (p -> NumberProbability) -> (p -> CategoricalProbability) -> B.ByteString -> GenM p B.ByteString+sampleString np cp s = B.pack <$> sampleN np (sampleFromString cp s)++sampleNEString ::+ (p -> NumberProbability) -> (p -> CategoricalProbability) -> B.ByteString -> GenM p B.ByteString+sampleNEString np cp s = B.pack . toList <$> sampleNE np (sampleFromString cp s)++deleteFirstOrdered :: Ord c => (a -> c) -> (b -> c) -> [a] -> [b] -> [a]+deleteFirstOrdered pa pb la lb = case (la, lb) of+ (ha : ta, hb : tb) -> case compare (pa ha) (pb hb) of+ LT -> ha : deleteFirstOrdered pa pb ta lb+ EQ -> deleteFirstOrdered pa pb ta tb+ GT -> deleteFirstOrdered pa pb la tb+ _ -> la++merge :: Ord a => [a] -> [a] -> [a]+merge la lb = case (la, lb) of+ (ha : ta, hb : tb) -> case compare ha hb of+ LT -> ha : merge ta lb+ EQ -> ha : hb : merge ta tb+ GT -> hb : merge la tb+ (_, []) -> la+ _ -> lb++sampleFiltered :: (p -> CategoricalProbability) -> Int -> [Int] -> GenM p Int+sampleFiltered p t l = do+ gen <- asks snd+ d <- asks $ p . fst+ case d of+ CPDiscrete l ->+ avoid ll+ <$> sample (discrete $ deleteFirstOrdered snd id (zip (NE.take (t + 1) l) [0 .. t]) ll) gen+ CPBiasedUniform l' b ->+ let ll' = deleteFirstOrdered snd id (clean t l') ll+ uw = fromIntegral (t - length ll - length ll') * b+ in sample (discrete $ (uw, Nothing) : map (\(x, y) -> (x, Just y)) ll') gen+ >>= maybe+ ( avoid (merge ll $ map snd ll')+ <$> sample (uniformR (0, t - length ll - length ll')) gen+ )+ pure+ where+ ll = sort $ filter (<= t) l
+ src/Verismith/Verilog2005/Token.hs view
@@ -0,0 +1,583 @@+-- Module : Verismith.Verilog2005.Token+-- Description : Tokens for Verilog 2005 lexing and parsing.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX+{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DeriveGeneric #-}++module Verismith.Verilog2005.Token+ ( PosToken (..),+ Position (..),+ PSource (..),+ helperShowPositions,+ showWithPosition,+ Token (..),+ AFRNP (..),+ BXZ (..),+ OXZ (..),+ HXZ (..),+ ZOX (..),+ Base (..),+ )+where++import Control.DeepSeq (NFData)+import qualified Data.ByteString as B+import Data.ByteString.Internal+import qualified Data.ByteString.Lazy as LBS+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Generics (Generic)+import Numeric.Natural+import Text.Printf (printf)+import Verismith.Utils++data PosToken = PosToken+ { _ptPos :: !(NonEmpty Position),+ _ptToken :: !Token+ }+ deriving (Eq)++instance Show PosToken where+ show (PosToken _ t) = show t++data Position = Position+ { _posLine :: !Word,+ _posColumn :: !Word,+ _posSource :: !PSource+ }+ deriving (Eq)++data PSource+ = PSFile !String+ | PSDefine !LBS.ByteString+ | PSLine+ { _pslFile :: !String,+ _pslEntering :: !Bool+ }+ deriving (Eq)++instance Show PSource where+ show x = case x of+ PSFile f -> "file " ++ f+ PSDefine t -> "macro replacement \"" ++ map w2c (LBS.unpack t) ++ "\""+ PSLine f _ -> "file " ++ f++instance Show Position where+ show (Position l c s) = printf "line %d, column %d of " l c ++ show s++helperShowPositions :: NonEmpty Position -> String+helperShowPositions =+ foldrMap1+ show+ $ \a@(Position _ _ s) b -> show a+ ++ case s of {PSFile _ -> " included"; PSDefine _ -> ""; PSLine _ _ -> " set"}+ ++ " from "+ ++ b++showWithPosition :: PosToken -> String+showWithPosition (PosToken p t) = show t ++ " at " ++ helperShowPositions p++data AFRNP = AFRNPA | AFRNPF | AFRNPR | AFRNPN | AFRNPP+ deriving (Eq, Ord, Data, Generic, NFData)++data BXZ = BXZ0 | BXZ1 | BXZX | BXZZ+ deriving (Eq, Ord, Bounded, Enum, Data, Generic, NFData)++data OXZ = OXZ0 | OXZ1 | OXZ2 | OXZ3 | OXZ4 | OXZ5 | OXZ6 | OXZ7 | OXZX | OXZZ+ deriving (Eq, Ord, Bounded, Enum, Data, Generic, NFData)++data HXZ+ = HXZ0+ | HXZ1+ | HXZ2+ | HXZ3+ | HXZ4+ | HXZ5+ | HXZ6+ | HXZ7+ | HXZ8+ | HXZ9+ | HXZA+ | HXZB+ | HXZC+ | HXZD+ | HXZE+ | HXZF+ | HXZX+ | HXZZ+ deriving (Eq, Ord, Bounded, Enum, Data, Generic, NFData)++data ZOX = ZOXZ | ZOXO | ZOXX+ deriving (Eq, Ord, Bounded, Enum, Data, Generic, NFData)++data Base = BBin | BOct | BDec | BHex+ deriving (Eq, Ord, Data, Generic, NFData)++instance Show AFRNP where+ show x =+ case x of AFRNPA -> "*"; AFRNPF -> "f"; AFRNPR -> "r"; AFRNPN -> "n"; AFRNPP -> "p"++instance Show ZOX where+ show x = case x of ZOXZ -> "0"; ZOXO -> "1"; ZOXX -> "x"++instance Show BXZ where+ show x = case x of BXZ0 -> "0"; BXZ1 -> "1"; BXZX -> "x"; BXZZ -> "z"++instance Show OXZ where+ show x = case x of+ OXZ0 -> "0"+ OXZ1 -> "1"+ OXZ2 -> "2"+ OXZ3 -> "3"+ OXZ4 -> "4"+ OXZ5 -> "5"+ OXZ6 -> "6"+ OXZ7 -> "7"+ OXZX -> "x"+ OXZZ -> "z"++instance Show HXZ where+ show x = case x of+ HXZ0 -> "0"+ HXZ1 -> "1"+ HXZ2 -> "2"+ HXZ3 -> "3"+ HXZ4 -> "4"+ HXZ5 -> "5"+ HXZ6 -> "6"+ HXZ7 -> "7"+ HXZ8 -> "8"+ HXZ9 -> "9"+ HXZA -> "A"+ HXZB -> "B"+ HXZC -> "C"+ HXZD -> "D"+ HXZE -> "E"+ HXZF -> "F"+ HXZX -> "x"+ HXZZ -> "z"++instance Show Base where+ show x = case x of BBin -> "b"; BOct -> "o"; BDec -> "d"; BHex -> "h"++data Token+ = IdSimple !B.ByteString+ | IdEscaped !B.ByteString+ | IdSystem !B.ByteString+ | LitReal !B.ByteString+ | LitString !B.ByteString+ | NumberBase !Bool !Base+ | LitXZ !Bool+ | LitBinary ![BXZ]+ | LitDecimal !Natural+ | LitOctal ![OXZ]+ | LitHex ![HXZ]+ | TableOut !ZOX+ | TableIn !Bool+ | TableEdge !AFRNP+ | EdgeEdge !BXZ !BXZ+ | TknPP !B.ByteString+ | AmBar+ | AmHat+ | AmAmp+ | AmTildeHat+ | UnTilde+ | UnBang+ | UnTildeAmp+ | UnTildeBar+ | BinSlash+ | BinPercent+ | BinLt+ | BinGt+ | BinEqEq+ | BinBangEq+ | BinEqEqEq+ | BinBangEqEq+ | BinAmpAmp+ | BinBarBar+ | BinAsterAster+ | BinGtEq+ | BinLtLt+ | BinGtGt+ | BinLtLtLt+ | BinGtGtGt+ | SymParenL+ | SymParenR+ | SymBrackL+ | SymBrackR+ | SymBraceL+ | SymBraceR+ | SymAt+ | SymPound+ | SymDollar+ | SymAster+ | SymDot+ | SymComma+ | SymColon+ | SymSemi+ | SymEq+ | SymDash+ | SymPlus+ | SymParenAster+ | SymAsterParen+ | SymQuestion+ | SymLtEq+ | SymPlusColon+ | SymDashColon+ | SymDashGt+ | SymEqGt+ | SymAsterGt+ | SymAmpAmpAmp+ | CDCelldefine+ | CDDefaultnettype+ | CDEndcelldefine+ | CDInclude+ | CDNounconnecteddrive+ | CDResetall+ | CDTimescale+ | CDTSInt !Int+ | CDTSUnit !Int+ | CDUnconnecteddrive+ | CDBeginKeywords+ | CDEndKeywords+-- | CDPragma+-- | CDEndPragma+ | KWAlways+ | KWAnd+ | KWAssign+ | KWAutomatic+ | KWBegin+ | KWBuf+ | KWBufif0+ | KWBufif1+ | KWCase+ | KWCasex+ | KWCasez+ | KWCell+ | KWCmos+ | KWConfig+ | KWDeassign+ | KWDefault+ | KWDefparam+ | KWDesign+ | KWDisable+ | KWEdge+ | KWElse+ | KWEnd+ | KWEndcase+ | KWEndconfig+ | KWEndfunction+ | KWEndgenerate+ | KWEndmodule+ | KWEndprimitive+ | KWEndspecify+ | KWEndtable+ | KWEndtask+ | KWEvent+ | KWFor+ | KWForce+ | KWForever+ | KWFork+ | KWFunction+ | KWGenerate+ | KWGenvar+ | KWHighz0+ | KWHighz1+ | KWIf+ | KWIfnone+ | KWIncdir+ | KWInclude+ | KWInitial+ | KWInout+ | KWInput+ | KWInstance+ | KWInteger+ | KWJoin+ | KWLarge+ | KWLiblist+ | KWLibrary+ | KWLocalparam+ | KWMacromodule+ | KWMedium+ | KWModule+ | KWNand+ | KWNegedge+ | KWNmos+ | KWNor+ | KWNoshowcancelled+ | KWNot+ | KWNotif0+ | KWNotif1+ | KWOr+ | KWOutput+ | KWParameter+ | KWPmos+ | KWPosedge+ | KWPrimitive+ | KWPull0+ | KWPull1+ | KWPulldown+ | KWPullup+ | KWPulsestyleonevent+ | KWPulsestyleondetect+ | KWRcmos+ | KWReal+ | KWRealtime+ | KWReg+ | KWRelease+ | KWRepeat+ | KWRnmos+ | KWRpmos+ | KWRtran+ | KWRtranif0+ | KWRtranif1+ | KWScalared+ | KWShowcancelled+ | KWSigned+ | KWSmall+ | KWSpecify+ | KWSpecparam+ | KWStrong0+ | KWStrong1+ | KWSupply0+ | KWSupply1+ | KWTable+ | KWTask+ | KWTime+ | KWTran+ | KWTranif0+ | KWTranif1+ | KWTri+ | KWTri0+ | KWTri1+ | KWTriand+ | KWTrior+ | KWTrireg+ | KWUnsigned+ | KWUse+ | KWUwire+ | KWVectored+ | KWWait+ | KWWand+ | KWWeak0+ | KWWeak1+ | KWWhile+ | KWWire+ | KWWor+ | KWXnor+ | KWXor+ | TokSVKeyword !B.ByteString+ deriving (Eq, Data)++instance Show Token where+ show x = case x of+ IdSimple s -> unpackChars s+ IdEscaped s -> unpackChars s+ IdSystem s -> '$' : unpackChars s+ LitReal s -> unpackChars s+ LitString s -> '"' : unpackChars s ++ "\""+ NumberBase s b -> '\'' : if s then 's' : show b else show b+ LitXZ b -> if b then "x" else "z"+ LitBinary l -> concatMap show l+ LitDecimal i -> show i+ LitOctal l -> concatMap show l+ LitHex l -> concatMap show l+ TableOut x -> show x+ TableIn b -> if b then "b" else "?"+ TableEdge x -> show x+ EdgeEdge e0 e1 -> show e0 ++ show e1+ TknPP s -> "PATHPULSE$" ++ unpackChars s+ AmBar -> "|"+ AmHat -> "^"+ AmAmp -> "&"+ AmTildeHat -> "~^ or ^~"+ UnTilde -> "~"+ UnBang -> "!"+ UnTildeAmp -> "~&"+ UnTildeBar -> "~|"+ BinSlash -> "/"+ BinPercent -> "%"+ BinLt -> "<"+ BinGt -> ">"+ BinEqEq -> "=="+ BinBangEq -> "!="+ BinEqEqEq -> "==="+ BinBangEqEq -> "!=="+ BinAmpAmp -> "&&"+ BinBarBar -> "||"+ BinAsterAster -> "**"+ BinGtEq -> ">="+ BinLtLt -> "<<"+ BinGtGt -> ">>"+ BinLtLtLt -> "<<<"+ BinGtGtGt -> ">>>"+ SymParenL -> "'('"+ SymParenR -> "')'"+ SymBrackL -> "'['"+ SymBrackR -> "']'"+ SymBraceL -> "'{'"+ SymBraceR -> "'}'"+ SymAt -> "@"+ SymPound -> "#"+ SymDollar -> "$"+ SymAster -> "*"+ SymDot -> "'.'"+ SymComma -> "','"+ SymColon -> "':'"+ SymSemi -> "';'"+ SymEq -> "="+ SymDash -> "-"+ SymPlus -> "+"+ SymParenAster -> "'(*'"+ SymAsterParen -> "'*)'"+ SymQuestion -> "?"+ SymLtEq -> "<="+ SymPlusColon -> "'+:'"+ SymDashColon -> "'-:'"+ SymDashGt -> "->"+ SymEqGt -> "=>"+ SymAsterGt -> "*>"+ SymAmpAmpAmp -> "&&&"+ CDCelldefine -> "`celldefine"+ CDDefaultnettype -> "`default_nettype"+ CDEndcelldefine -> "`endcelldefine"+ CDInclude -> "`include"+ CDNounconnecteddrive -> "`nounconnected_drive"+ CDResetall -> "`resetall"+ CDTimescale -> "`timescale"+ CDTSInt i -> '1' : case i of 0 -> ""; 1 -> "0"; 2 -> "00"+ CDTSUnit i ->+ case i of { 0 -> ""; -1 -> "m"; -2 -> "u"; -3 -> "n"; -4 -> "p"; -5 -> "f" } ++ "s"+ CDUnconnecteddrive -> "`unconnected_drive"+ CDBeginKeywords -> "`begin_keywords"+ CDEndKeywords -> "`end_keywords"+-- CDPragma+-- CDEndPragma+ KWAlways -> "always"+ KWAnd -> "and"+ KWAssign -> "assign"+ KWAutomatic -> "automatic"+ KWBegin -> "begin"+ KWBuf -> "buf"+ KWBufif0 -> "bufif0"+ KWBufif1 -> "bufif1"+ KWCase -> "case"+ KWCasex -> "casex"+ KWCasez -> "casez"+ KWCell -> "cell"+ KWCmos -> "cmos"+ KWConfig -> "config"+ KWDeassign -> "deassign"+ KWDefault -> "default"+ KWDefparam -> "defparam"+ KWDesign -> "design"+ KWDisable -> "disable"+ KWEdge -> "edge"+ KWElse -> "else"+ KWEnd -> "end"+ KWEndcase -> "endcase"+ KWEndconfig -> "endconfig"+ KWEndfunction -> "endfunction"+ KWEndgenerate -> "endgenerate"+ KWEndmodule -> "endmodule"+ KWEndprimitive -> "endprimitive"+ KWEndspecify -> "endspecify"+ KWEndtable -> "endtable"+ KWEndtask -> "endtask"+ KWEvent -> "event"+ KWFor -> "for"+ KWForce -> "force"+ KWForever -> "forever"+ KWFork -> "fork"+ KWFunction -> "function"+ KWGenerate -> "generate"+ KWGenvar -> "genvar"+ KWHighz0 -> "highz0"+ KWHighz1 -> "highz1"+ KWIf -> "if"+ KWIfnone -> "ifnone"+ KWIncdir -> "incdir"+ KWInclude -> "include"+ KWInitial -> "initial"+ KWInout -> "inout"+ KWInput -> "input"+ KWInstance -> "instance"+ KWInteger -> "integer"+ KWJoin -> "join"+ KWLarge -> "large"+ KWLiblist -> "liblist"+ KWLibrary -> "library"+ KWLocalparam -> "localparam"+ KWMacromodule -> "macromodule"+ KWMedium -> "medium"+ KWModule -> "module"+ KWNand -> "nand"+ KWNegedge -> "negedge"+ KWNmos -> "nmos"+ KWNor -> "now"+ KWNoshowcancelled -> "noshowcancelled"+ KWNot -> "not"+ KWNotif0 -> "notif0"+ KWNotif1 -> "notif1"+ KWOr -> "or"+ KWOutput -> "output"+ KWParameter -> "parameter"+ KWPmos -> "pmos"+ KWPosedge -> "posedge"+ KWPrimitive -> "primitive"+ KWPull0 -> "pull0"+ KWPull1 -> "pull1"+ KWPulldown -> "pulldown"+ KWPullup -> "pullup"+ KWPulsestyleonevent -> "pulsestyle_onevent"+ KWPulsestyleondetect -> "plusestyle_ondetect"+ KWRcmos -> "rcmos"+ KWReal -> "real"+ KWRealtime -> "realtime"+ KWReg -> "reg"+ KWRelease -> "release"+ KWRepeat -> "repeat"+ KWRnmos -> "rnmos"+ KWRpmos -> "rpmos"+ KWRtran -> "rtan"+ KWRtranif0 -> "rtranif0"+ KWRtranif1 -> "rtranif1"+ KWScalared -> "scalared"+ KWShowcancelled -> "showcancelled"+ KWSigned -> "signed"+ KWSmall -> "small"+ KWSpecify -> "specify"+ KWSpecparam -> "specparam"+ KWStrong0 -> "strong0"+ KWStrong1 -> "strong1"+ KWSupply0 -> "supply0"+ KWSupply1 -> "supply1"+ KWTable -> "table"+ KWTask -> "task"+ KWTime -> "time"+ KWTran -> "tran"+ KWTranif0 -> "tranif0"+ KWTranif1 -> "tranif1"+ KWTri -> "tri"+ KWTri0 -> "tri0"+ KWTri1 -> "tri1"+ KWTriand -> "triand"+ KWTrior -> "trior"+ KWTrireg -> "trireg"+ KWUnsigned -> "unsigned"+ KWUse -> "use"+ KWUwire -> "uwire"+ KWVectored -> "vectored"+ KWWait -> "wait"+ KWWand -> "wand"+ KWWeak0 -> "weak0"+ KWWeak1 -> "weak1"+ KWWhile -> "while"+ KWWire -> "wire"+ KWWor -> "wor"+ KWXnor -> "xnor"+ KWXor -> "xor"+ TokSVKeyword kw -> unpackChars kw
+ src/Verismith/Verilog2005/Utils.hs view
@@ -0,0 +1,452 @@+-- Module : Verismith.Verilog2005.Utils+-- Description : AST utilitary functions.+-- Copyright : (c) 2023 Quentin Corradi+-- License : GPL-3+-- Maintainer : q [dot] corradi22 [at] imperial [dot] ac [dot] uk+-- Stability : experimental+-- Portability : POSIX++{-# LANGUAGE OverloadedLists #-}++module Verismith.Verilog2005.Utils+ ( makeIdent,+ regroup,+ addAttributed,+ genexprnumber,+ constifyIdent,+ constifyMaybeRange,+ trConstifyGenExpr,+ constifyExpr,+ constifyLV,+ expr2netlv,+ netlv2expr,+ toStatement,+ fromStatement,+ fromMybStmt,+ toMGIBlockDecl,+ fromMGIBlockDecl1,+ fromMGIBlockDecl_add,+ toStdBlockDecl,+ toSpecBlockedItem,+ fromSpecBlockedItem,+ toMGBlockedItem,+ fromMGBlockedItem1,+ fromMGBlockedItem_add,+ fromMGBlockedItem,+ )+where++import Numeric.Natural+import Text.Printf (printf)+import Data.Functor.Compose+import Data.Functor.Identity+import qualified Data.ByteString as BS+import Data.ByteString.Internal (c2w, packChars)+import qualified Data.HashSet as HS+import Data.List.NonEmpty (NonEmpty (..), (<|), toList)+import qualified Data.List.NonEmpty as NE+import Verismith.Verilog2005.Lexer (VerilogVersion (..), isIdentSimple)+import Verismith.Verilog2005.AST+import Verismith.Utils (nonEmpty, foldrMap1)++-- AST utils++makeIdent :: BS.ByteString -> Identifier+makeIdent =+ Identifier . BS.concatMap+ (\w -> if 33 <= w && w <= 126 then BS.pack [w] else packChars $ printf "\\%02x" w)++-- | Groups `x`s into `y`s by converting a single `x` and merging previous `x`s to the result+regroup :: (x -> y) -> (x -> y -> Maybe y) -> NonEmpty x -> NonEmpty y+regroup mk add = foldrMap1 ((:|[]) . mk) (\e (h :| t) -> maybe (mk e :| h : t) (:| t) $ add e h)++-- | Merges `Attributed x`s if we can merge `x`s+addAttributed :: (x -> y -> Maybe y) -> Attributed x -> Attributed y -> Maybe (Attributed y)+addAttributed f (Attributed na x) (Attributed a y) =+ if a /= na then Nothing else Attributed a <$> f x y++-- | Makes a Verilog2005 expression out of a number+genexprnumber :: Natural -> GenExpr i r a+genexprnumber = ExprPrim . PrimNumber Nothing False . NDecimal++-- | converts HierIdent into Identifier+constifyIdent :: HierIdent -> Maybe Identifier+constifyIdent (HierIdent p i) = case p of [] -> Just i; _ -> Nothing++-- | the other way+unconstIdent :: Identifier -> HierIdent+unconstIdent = HierIdent []++-- | converts Prim into GenPrim i r+constifyGenPrim ::+ (si -> Maybe di) ->+ (Maybe DimRange -> Maybe r) ->+ GenPrim si (Maybe DimRange) a ->+ Maybe (GenPrim di r a)+constifyGenPrim fi fr x = case x of+ PrimNumber s b n -> Just $ PrimNumber s b n+ PrimReal s -> Just $ PrimReal s+ PrimIdent s rng -> PrimIdent <$> fi s <*> fr rng+ PrimConcat e -> PrimConcat <$> mapM ce e+ PrimMultConcat m e -> PrimMultConcat m <$> mapM ce e+ PrimFun s a e -> PrimFun <$> fi s <*> pure a <*> mapM ce e+ PrimSysFun s e -> PrimSysFun s <$> mapM ce e+ PrimMinTypMax (MTMSingle e) -> PrimMinTypMax . MTMSingle <$> ce e+ PrimMinTypMax (MTMFull l t h) -> PrimMinTypMax <$> (MTMFull <$> ce l <*> ce t <*> ce h)+ PrimString s -> Just $ PrimString s+ where+ ce = trConstifyGenExpr fi fr++-- | the other way+unconstPrim :: GenPrim Identifier (Maybe CRangeExpr) a -> GenPrim HierIdent (Maybe DimRange) a+unconstPrim x = case x of+ PrimNumber s b n -> PrimNumber s b n+ PrimReal s -> PrimReal s+ PrimIdent s rng -> PrimIdent (unconstIdent s) (GenDimRange [] . unconstRange <$> rng)+ PrimConcat e -> PrimConcat (NE.map trUnconstExpr e)+ PrimMultConcat m e -> PrimMultConcat m (NE.map trUnconstExpr e)+ PrimFun s a e -> PrimFun (unconstIdent s) a (map trUnconstExpr e)+ PrimSysFun s e -> PrimSysFun s (map trUnconstExpr e)+ PrimMinTypMax (MTMSingle e) -> PrimMinTypMax (MTMSingle (trUnconstExpr e))+ PrimMinTypMax (MTMFull l t h) ->+ PrimMinTypMax $ MTMFull (trUnconstExpr l) (trUnconstExpr t) (trUnconstExpr h)+ PrimString s -> PrimString s++-- | converts `GenExpr si (MaybeDimRange) a` into `GenExpr i r a`+trConstifyGenExpr ::+ (si -> Maybe di) ->+ (Maybe DimRange -> Maybe r) ->+ GenExpr si (Maybe DimRange) a ->+ Maybe (GenExpr di r a)+trConstifyGenExpr fi fr x = case x of+ ExprPrim p -> ExprPrim <$> constifyGenPrim fi fr p+ ExprUnOp op a p -> ExprUnOp op a <$> constifyGenPrim fi fr p+ ExprBinOp lhs op a rhs -> ExprBinOp <$> ce lhs <*> pure op <*> pure a <*> ce rhs+ ExprCond c a t f -> ExprCond <$> ce c <*> pure a <*> ce t <*> ce f+ where+ ce = trConstifyGenExpr fi fr++-- | converts Expr's `DimRange` into CExpr's `CRangeExpr`+constifyMaybeRange :: Maybe DimRange -> Maybe (Maybe CRangeExpr)+constifyMaybeRange =+ maybe (Just Nothing) $ \(GenDimRange l r) -> if null l then Just <$> constifyRange r else Nothing++-- | converts Expr's `GenExpr` into CExpr `GenExpr`+trConstifyExpr ::+ GenExpr HierIdent (Maybe DimRange) a -> Maybe (GenExpr Identifier (Maybe CRangeExpr) a)+trConstifyExpr = trConstifyGenExpr constifyIdent constifyMaybeRange++-- | the other way+trUnconstExpr :: GenExpr Identifier (Maybe CRangeExpr) a -> GenExpr HierIdent (Maybe DimRange) a+trUnconstExpr x = case x of+ ExprPrim p -> ExprPrim (unconstPrim p)+ ExprUnOp op a p -> ExprUnOp op a (unconstPrim p)+ ExprBinOp lhs op a rhs -> ExprBinOp (trUnconstExpr lhs) op a (trUnconstExpr rhs)+ ExprCond c a t f -> ExprCond (trUnconstExpr c) a (trUnconstExpr t) (trUnconstExpr f)++-- | converts Expr to CExpr+constifyExpr :: Expr -> Maybe CExpr+constifyExpr (Expr e) = CExpr <$> trConstifyExpr e++-- | the other way+unconstExpr :: CExpr -> Expr+unconstExpr (CExpr e) = Expr (trUnconstExpr e)++-- | converts RangeExpr into CRangeExpr+constifyRange :: RangeExpr -> Maybe CRangeExpr+constifyRange x = case x of+ GRESingle e -> GRESingle <$> constifyExpr e+ GREPair r2 -> Just $ GREPair r2+ GREBaseOff b mp o -> (\cb -> GREBaseOff cb mp o) <$> constifyExpr b++-- | the other way+unconstRange :: CRangeExpr -> RangeExpr+unconstRange x = case x of+ GRESingle e -> GRESingle (unconstExpr e)+ GREPair r2 -> GREPair r2+ GREBaseOff b mp o -> GREBaseOff (unconstExpr b) mp o++-- | converts DimRange into CDimRange+constifyDR :: GenDimRange Expr -> Maybe (GenDimRange CExpr)+constifyDR (GenDimRange dim rng) = GenDimRange <$> mapM constifyExpr dim <*> constifyRange rng++-- | the other way+unconstDR :: GenDimRange CExpr -> GenDimRange Expr+unconstDR (GenDimRange dim rng) = GenDimRange (map unconstExpr dim) (unconstRange rng)++-- | converts variable lvalue into net lvalue+constifyLV :: VarLValue -> Maybe NetLValue+constifyLV v = case v of+ LVSingle hi mdr -> LVSingle hi <$> maybe (Just Nothing) (fmap Just . constifyDR) mdr+ LVConcat l -> LVConcat <$> mapM constifyLV l++-- | the other way+unconstLV :: NetLValue -> VarLValue+unconstLV n = case n of+ LVSingle hi dr -> LVSingle hi (unconstDR <$> dr)+ LVConcat l -> LVConcat (NE.map unconstLV l)++-- | converts expression into net lvalue+expr2netlv :: Expr -> Maybe NetLValue+expr2netlv (Expr x) = aux x+ where+ aux x = case x of+ ExprPrim (PrimConcat c) -> LVConcat <$> mapM aux c+ ExprPrim (PrimIdent s sub) -> LVSingle s <$> maybe (Just Nothing) (Just . constifyDR) sub+ _ -> Nothing++-- | the other way+netlv2expr :: NetLValue -> Expr+netlv2expr = Expr . aux+ where+ aux x = case x of+ LVConcat e -> ExprPrim $ PrimConcat $ NE.map aux e+ LVSingle s dr -> ExprPrim $ PrimIdent s $ unconstDR <$> dr++-- | Converts Function statements to statements+toStatement :: FunctionStatement -> Statement+toStatement x = case x of+ FSBlockAssign va -> SBlockAssign True va Nothing+ FSCase zox e l d -> SCase zox e (map (\(FCaseItem p v) -> CaseItem p $ mybf v) l) (mybf d)+ FSIf e t f -> SIf e (mybf t) (mybf f)+ FSDisable hi -> SDisable hi+ FSLoop ls b -> SLoop ls $ toStatement <$> b+ FSBlock h ps b -> SBlock h ps $ fmap toStatement <$> b+ where mybf = fmap $ fmap toStatement++-- | the other way+fromStatement :: Statement -> Maybe FunctionStatement+fromStatement x = case x of+ SBlockAssign True va Nothing -> Just $ FSBlockAssign va+ SCase zox e l d -> FSCase zox e <$> traverse (\(CaseItem p v) -> FCaseItem p <$> mybf v) l <*> mybf d+ SIf e t f -> FSIf e <$> mybf t <*> mybf f+ SDisable hi -> Just $ FSDisable hi+ SLoop ls b -> FSLoop ls <$> traverse fromStatement b+ SBlock h ps b -> FSBlock h ps <$> traverse (traverse fromStatement) b+ _ -> Nothing+ where mybf s = traverse (traverse fromStatement) s++-- | Converts MybStmt to AttrStmt+fromMybStmt :: MybStmt -> AttrStmt+fromMybStmt x = case x of+ Attributed _ Nothing -> Attributed [] $ SIf (Expr $ genexprnumber 1) x $ Attributed [] Nothing+ Attributed a (Just s) -> Attributed a s++type BD f t = BlockDecl (Compose f Identified) t++-- | Converts ModGenSingleItem's `BlockDecl` into ModGenBlockedItem's `BlockDecl`+toMGIBlockDecl :: BD NonEmpty t -> NonEmpty (BD Identity t)+toMGIBlockDecl x = case x of+ BDReg sr d -> conv (BDReg sr) d+ BDInt d -> conv BDInt d+ BDReal d -> conv BDReal d+ BDTime d -> conv BDTime d+ BDRealTime d -> conv BDRealTime d+ BDEvent d -> conv BDEvent d+ BDLocalParam t d -> conv (BDLocalParam t) d+ where+ conv f = fmap (f . Compose . Identity) . getCompose++-- | Converts one ModGenBlockedItem's `BlockDecl` into ModGenSingleItem's `BlockDecl`+fromMGIBlockDecl1 :: BD Identity t -> BD NonEmpty t+fromMGIBlockDecl1 x = case x of+ BDReg sr d -> conv (BDReg sr) d+ BDInt d -> conv BDInt d+ BDReal d -> conv BDReal d+ BDTime d -> conv BDTime d+ BDRealTime d -> conv BDRealTime d+ BDEvent d -> conv BDEvent d+ BDLocalParam t d -> conv (BDLocalParam t) d+ where+ conv f = f . Compose . (:|[]) . runIdentity . getCompose++-- | Merges one ModGenBlockedItem's `BlockDecl` with one ModGenSingleItem's `BlockDecl`+fromMGIBlockDecl_add :: BD Identity t -> BD NonEmpty t -> Maybe (BD NonEmpty t)+fromMGIBlockDecl_add x y = case (x, y) of+ (BDReg nsr d, BDReg sr l) | nsr == sr -> add (BDReg sr) d l+ (BDInt d, BDInt l) -> add BDInt d l+ (BDReal d, BDReal l) -> add BDReal d l+ (BDTime d, BDTime l) -> add BDTime d l+ (BDRealTime d, BDRealTime l) -> add BDRealTime d l+ (BDEvent d, BDEvent l) -> add BDEvent d l+ (BDLocalParam nt d, BDLocalParam t l) | nt == t -> add (BDLocalParam t) d l+ _ -> Nothing+ where+ add f x l = Just $ f $ Compose $ runIdentity (getCompose x) <| getCompose l++-- | Converts ModGenSingleItem like `BlockDecl` into StdBlockDecl `BlockDecl`+toStdBlockDecl :: BD NonEmpty t -> NonEmpty (Identified (BlockDecl Identity t))+toStdBlockDecl x = case x of+ BDReg sr d -> conv (BDReg sr) d+ BDInt d -> conv BDInt d+ BDReal d -> conv BDReal d+ BDTime d -> conv BDTime d+ BDRealTime d -> conv BDRealTime d+ BDEvent d -> conv BDEvent d+ BDLocalParam t d -> conv (BDLocalParam t) d+ where+ conv f = fmap (fmap $ f . Identity) . getCompose++-- | Converts `SpecifySingleItem` into `SpecifyBlockedItem`s+toSpecBlockedItem :: SpecifySingleItem -> NonEmpty SpecifyBlockedItem+toSpecBlockedItem x = case x of+ SISpecParam rng d -> conv (SISpecParam rng) d+ SIPulsestyleOnevent st -> conv SIPulsestyleOnevent st+ SIPulsestyleOndetect st -> conv SIPulsestyleOndetect st+ SIShowcancelled st -> conv SIShowcancelled st+ SINoshowcancelled st -> conv SINoshowcancelled st+ SIPathDeclaration mpc con pol eds v -> [SIPathDeclaration mpc con pol eds v]+ SISetup a -> [SISetup a]+ SIHold a -> [SIHold a]+ SISetupHold a aa -> [SISetupHold a aa]+ SIRecovery a -> [SIRecovery a]+ SIRemoval a -> [SIRemoval a]+ SIRecrem a aa -> [SIRecrem a aa]+ SISkew a -> [SISkew a]+ SITimeSkew a ev rem -> [SITimeSkew a ev rem]+ SIFullSkew a tcl ev rem -> [SIFullSkew a tcl ev rem]+ SIPeriod ref tcl s -> [SIPeriod ref tcl s]+ SIWidth ref tcl t s -> [SIWidth ref tcl t s]+ SINoChange ref dat st en s -> [SINoChange ref dat st en s]+ where+ conv f = fmap (f . Identity)++fromSpecBlockedItem1 :: SpecifyBlockedItem -> SpecifySingleItem+fromSpecBlockedItem1 x = case x of+ SISpecParam rng d -> conv (SISpecParam rng) d+ SIPulsestyleOnevent st -> conv SIPulsestyleOnevent st+ SIPulsestyleOndetect st -> conv SIPulsestyleOndetect st+ SIShowcancelled st -> conv SIShowcancelled st+ SINoshowcancelled st -> conv SINoshowcancelled st+ SIPathDeclaration mpc con pol eds v -> SIPathDeclaration mpc con pol eds v+ SISetup a -> SISetup a+ SIHold a -> SIHold a+ SISetupHold a aa -> SISetupHold a aa+ SIRecovery a -> SIRecovery a+ SIRemoval a -> SIRemoval a+ SIRecrem a aa -> SIRecrem a aa+ SISkew a -> SISkew a+ SITimeSkew a ev rem -> SITimeSkew a ev rem+ SIFullSkew a tcl ev rem -> SIFullSkew a tcl ev rem+ SIPeriod ref tcl s -> SIPeriod ref tcl s+ SIWidth ref tcl t s -> SIWidth ref tcl t s+ SINoChange ref dat st en s -> SINoChange ref dat st en s+ where+ conv f = f . (:|[]) . runIdentity++fromSpecBlockedItem_add :: SpecifyBlockedItem -> SpecifySingleItem -> Maybe SpecifySingleItem+fromSpecBlockedItem_add x y = case (x, y) of+ (SISpecParam nrng d, SISpecParam rng l) | nrng == rng-> add (SISpecParam rng) d l+ (SIPulsestyleOnevent st, SIPulsestyleOnevent l) -> add SIPulsestyleOnevent st l+ (SIPulsestyleOndetect st, SIPulsestyleOndetect l) -> add SIPulsestyleOndetect st l+ (SIShowcancelled st, SIShowcancelled l) -> add SIShowcancelled st l+ (SINoshowcancelled st, SINoshowcancelled l) -> add SINoshowcancelled st l+ _ -> Nothing+ where+ add f x y = Just $ f $ runIdentity x <| y++-- | Converts `SpecifyBlockedItem`s into `SpecifySingleItem`s+fromSpecBlockedItem :: [SpecifyBlockedItem] -> [SpecifySingleItem]+fromSpecBlockedItem = nonEmpty [] $ toList . regroup fromSpecBlockedItem1 fromSpecBlockedItem_add++-- | Converts `ModGenSingleItem` into `ModGenBlockedItem`s+toMGBlockedItem :: ModGenSingleItem -> NonEmpty ModGenBlockedItem+toMGBlockedItem x = case x of+ MGINetInit nt ds np ni -> conv (MGINetInit nt ds np) ni+ MGINetDecl nt np nd -> conv (MGINetDecl nt np) nd+ MGITriD ds np ni -> conv (MGITriD ds np) ni+ MGITriC cs np nd -> conv (MGITriC cs np) nd+ MGIBlockDecl d -> fmap MGIBlockDecl $ toMGIBlockDecl d+ MGIGenVar i -> conv MGIGenVar i+ MGITask b i d s -> [MGITask b i d s]+ MGIFunc b t i d s -> [MGIFunc b t i d s]+ MGIDefParam po -> conv MGIDefParam po+ MGIContAss ds d3 na -> conv (MGIContAss ds d3) na+ MGICMos r d3 l -> conv (MGICMos r d3) l+ MGIEnable r b ds d3 l -> conv (MGIEnable r b ds d3) l+ MGIMos r np d3 l -> conv (MGIMos r np d3) l+ MGINIn nt n ds d2 l -> conv (MGINIn nt n ds d2) l+ MGINOut r ds d2 l -> conv (MGINOut r ds d2) l+ MGIPassEn r b d2 l -> conv (MGIPassEn r b d2) l+ MGIPass r l -> conv (MGIPass r) l+ MGIPull b ds l -> conv (MGIPull b ds) l+ MGIUDPInst udp ds d2 i -> conv (MGIUDPInst udp ds d2) i+ MGIModInst mod pa i -> conv (MGIModInst mod pa) i+ MGIUnknownInst t p i -> conv (MGIUnknownInst t p) i+ MGIInitial s -> [MGIInitial s]+ MGIAlways s -> [MGIAlways s]+ MGILoopGen ii iv c ui uv b -> [MGILoopGen ii iv c ui uv b]+ MGICondItem ci -> [MGICondItem ci]+ where+ conv f = fmap (f . Identity)++fromMGBlockedItem1 :: ModGenBlockedItem -> ModGenSingleItem+fromMGBlockedItem1 x = case x of+ MGINetInit nt ds np ni -> conv (MGINetInit nt ds np) ni+ MGINetDecl nt np nd -> conv (MGINetDecl nt np) nd+ MGITriD ds np ni -> conv (MGITriD ds np) ni+ MGITriC cs np nd -> conv (MGITriC cs np) nd+ MGIBlockDecl d -> MGIBlockDecl $ fromMGIBlockDecl1 d+ MGIGenVar i -> conv MGIGenVar i+ MGITask b i d s -> MGITask b i d s+ MGIFunc b t i d s -> MGIFunc b t i d s+ MGIDefParam po -> conv MGIDefParam po+ MGIContAss ds d3 na -> conv (MGIContAss ds d3) na+ MGICMos r d3 i -> conv (MGICMos r d3) i+ MGIEnable r b ds d3 i -> conv (MGIEnable r b ds d3) i+ MGIMos r np d3 i -> conv (MGIMos r np d3) i+ MGINIn nt n ds d2 i -> conv (MGINIn nt n ds d2) i+ MGINOut r ds d2 i -> conv (MGINOut r ds d2) i+ MGIPassEn r b d2 i -> conv (MGIPassEn r b d2) i+ MGIPass r i -> conv (MGIPass r) i+ MGIPull b ds i -> conv (MGIPull b ds) i+ MGIUDPInst udp ds d2 i -> conv (MGIUDPInst udp ds d2) i+ MGIModInst mod pa i -> conv (MGIModInst mod pa) i+ MGIUnknownInst t p i -> conv (MGIUnknownInst t p) i+ MGIInitial s -> MGIInitial s+ MGIAlways s -> MGIAlways s+ MGILoopGen ii iv c ui uv b -> MGILoopGen ii iv c ui uv b+ MGICondItem ci -> MGICondItem ci+ where+ conv f = f . (:|[]) . runIdentity++fromMGBlockedItem_add :: ModGenBlockedItem -> ModGenSingleItem -> Maybe ModGenSingleItem+fromMGBlockedItem_add x y = case (x, y) of+ (MGINetInit nnt nds nnp ni, MGINetInit nt ds np l) | nnt == nt && nds == ds && nnp == np ->+ add (MGINetInit nt ds np) ni l+ (MGINetDecl nnt nnp nd, MGINetDecl nt np l) | nnt == nt && nnp == np ->+ add (MGINetDecl nt np) nd l+ (MGITriD nds nnp ni, MGITriD ds np l) | nds == ds && nnp == np -> add (MGITriD ds np) ni l+ (MGITriC ncs nnp nd, MGITriC cs np l) | ncs == cs && nnp == np -> add (MGITriC cs np) nd l+ (MGIBlockDecl d, MGIBlockDecl l) -> MGIBlockDecl <$> fromMGIBlockDecl_add d l+ (MGIGenVar i, MGIGenVar l) -> add MGIGenVar i l+ (MGIDefParam po, MGIDefParam l) -> add MGIDefParam po l+ (MGIContAss nds nd3 na, MGIContAss ds d3 l) | nds == ds && nd3 == d3 ->+ add (MGIContAss ds d3) na l+ (MGICMos nr nd3 i, MGICMos r d3 l) | nr == r && nd3 == d3 -> add (MGICMos r d3) i l+ (MGIEnable nr nb nds nd3 i, MGIEnable r b ds d3 l)+ | nr == r && nb == b && nds == ds && nd3 == d3 -> add (MGIEnable r b ds d3) i l+ (MGIMos nr nnp nd3 i, MGIMos r np d3 l) | nr == r && nnp == np && nd3 == d3 ->+ add (MGIMos r np d3) i l+ (MGINIn nnt nn nds nd2 i, MGINIn nt n ds d2 l)+ | nnt == nt && nn == n && nds == ds && nd2 == d2 -> add (MGINIn nt n ds d2) i l+ (MGINOut nr nds nd2 i, MGINOut r ds d2 l) | nr == r && nds == ds && nd2 == d2 ->+ add (MGINOut r ds d2) i l+ (MGIPassEn nr nb nd2 i, MGIPassEn r b d2 l) | nr == r && nb == b && nd2 == d2 ->+ add (MGIPassEn r b d2) i l+ (MGIPass nr i, MGIPass r l) | nr == r -> add (MGIPass r) i l+ (MGIPull nb nds i, MGIPull b ds l) | nb == b && nds == ds -> add (MGIPull b ds) i l+ (MGIUDPInst nudp nds nd2 i, MGIUDPInst udp ds d2 l)+ | nudp == udp && nds == ds && nd2 == d2 -> add (MGIUDPInst udp ds d2) i l+ (MGIModInst nmod npa i, MGIModInst mod pa l) | nmod == mod && npa == pa ->+ add (MGIModInst mod pa) i l+ (MGIUnknownInst nt np i, MGIUnknownInst t p l) | nt == t && np == p ->+ add (MGIUnknownInst t p) i l+ _ -> Nothing+ where+ add f x y = Just $ f $ runIdentity x <| y++-- | Converts `ModGenBlockedItem`s into `ModGenSingleItem`s+fromMGBlockedItem :: [Attributed ModGenBlockedItem] -> [Attributed ModGenSingleItem]+fromMGBlockedItem =+ nonEmpty [] $ toList . regroup (fmap fromMGBlockedItem1) (addAttributed fromMGBlockedItem_add)
test/Benchmark.hs view
@@ -1,15 +1,24 @@+{-# LANGUAGE TypeApplications #-}+ module Main where -import Control.Lens ((&), (.~))-import Criterion.Main (bench, bgroup, defaultMain, nfAppIO)-import Verismith (configProperty, defaultConfig, proceduralIO,- propSize, propStmntDepth)+import Control.Lens ((&), (.~))+import Criterion.Main (bench, bgroup, defaultMain, nfAppIO)+import Verismith+ ( configProperty,+ defaultConfig,+ proceduralIO,+ propSize,+ propStmntDepth,+ ) main :: IO ()-main = defaultMain- [ bgroup "generation"- [ bench "default" $ nfAppIO (proceduralIO "top") defaultConfig- , bench "depth" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propStmntDepth .~ 10- , bench "size" . nfAppIO (proceduralIO "top") $ defaultConfig & configProperty . propSize .~ 40+main =+ defaultMain+ [ bgroup+ "generation"+ [ bench "default" $ nfAppIO (proceduralIO @() "top") defaultConfig,+ bench "depth" . nfAppIO (proceduralIO @() "top") $ defaultConfig & configProperty . propStmntDepth .~ 10,+ bench "size" . nfAppIO (proceduralIO @() "top") $ defaultConfig & configProperty . propSize .~ 40 ] ]
+ test/Config.hs view
@@ -0,0 +1,44 @@+-- |+-- Module : Config+-- Description : Test the configuration parsing/printing.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Test the parser.+module Config+ ( configUnitTests,+ )+where++import qualified Data.Text as T+import Test.Tasty+import Test.Tasty.HUnit+import Verismith+import Verismith.Config++testParseFailure :: String -> FilePath -> TestTree+testParseFailure name fp = testCase name $ do+ conf <- parseConfigFile fp+ case conf of+ Left _ -> return ()+ Right _ -> assertFailure "Configuration was incorrectly parsed"++testParse :: String -> FilePath -> Config -> TestTree+testParse name fp conf =+ testCase name $ do+ parsedConf <- parseConfigFile fp+ case parsedConf of+ Left err -> assertFailure $ T.unpack err+ Right parsedConf' ->+ assertEqual "Configuration different to expected" parsedConf' conf++configUnitTests :: TestTree+configUnitTests =+ testGroup+ "Config unit tests"+ [ testParse "Default configuration parsed" "test/data/default_config.toml" defaultConfig,+ testParseFailure "Additional fields not parsed" "test/data/additional.toml"+ ]
+ test/Distance.hs view
@@ -0,0 +1,32 @@+module Distance+ ( distanceTests,+ )+where++import Hedgehog (Property, (===))+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as Hog+import Test.Tasty+import Test.Tasty.Hedgehog+import Verismith.Verilog.Distance++distanceLess :: Property+distanceLess = Hog.property $ do+ x <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)+ y <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)+ Hog.assert $ udistance x y <= distance x y++distanceEq :: Property+distanceEq = Hog.property $ do+ x <- Hog.forAll (Hog.list (Hog.linear 0 15) Hog.alpha)+ distance x x === 0+ udistance x x === 0++distanceTests :: TestTree+distanceTests =+ testGroup+ "Distance tests"+ [ testProperty "Unordered distance <= distance" distanceLess,+ testProperty "distance x x === 0" distanceEq+ ]
test/Parser.hs view
@@ -1,129 +1,137 @@-{-|-Module : Parser-Description : Test the parser.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Test the parser.--}-+-- |+-- Module : Parser+-- Description : Test the parser.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Test the parser. module Parser- ( parserTests- , parseUnitTests- )+ ( parserTests,+ parseUnitTests,+ ) where -import Control.Lens-import Data.Either (either, isRight)-import Hedgehog (Gen, Property, (===))-import qualified Hedgehog as Hog-import qualified Hedgehog.Gen as Hog-import Test.Tasty-import Test.Tasty.Hedgehog-import Test.Tasty.HUnit-import Text.Parsec-import Verismith-import Verismith.Internal-import Verismith.Verilog.Lex-import Verismith.Verilog.Parser-import Verismith.Verilog.Preprocess (uncomment)+import Control.Lens+import Data.Either (either, isRight)+import Hedgehog (Gen, Property, (===))+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Hedgehog+import Text.Parsec+import Verismith+import Verismith.Utils (showT)+import Verismith.Verilog.Lex+import Verismith.Verilog.Parser+import Verismith.Verilog.Preprocess (uncomment) smallConfig :: Config smallConfig = defaultConfig & configProperty . propSize .~ 5 -randomMod' :: Gen ModDecl+randomMod' :: Gen (ModDecl ann) randomMod' = Hog.resize 20 (randomMod 3 10) parserInputMod :: Property parserInputMod = Hog.property $ do- v <- GenVerilog <$> Hog.forAll randomMod'- Hog.assert . isRight $ parse parseModDecl- "input_test_mod"- (alexScanTokens . uncomment "test" $ show v)+ v <- GenVerilog <$> Hog.forAll randomMod' :: Hog.PropertyT IO (GenVerilog (ModDecl ()))+ Hog.assert . isRight $+ parse+ parseModDecl+ "input_test_mod"+ (alexScanTokens . uncomment "test" $ show v) parserIdempotentMod :: Property parserIdempotentMod = Hog.property $ do- v <- Hog.forAll randomMod'- let sv = vshow v- p sv === (p . p) sv+ v <- Hog.forAll randomMod' :: Hog.PropertyT IO (ModDecl ())+ let sv = vshow v+ p sv === (p . p) sv where vshow = show . GenVerilog p sv =- either (\x -> show x <> "\n" <> sv) vshow- . parse parseModDecl "idempotent_test_mod"- $ alexScanTokens sv+ either (\x -> show x <> "\n" <> sv) vshow+ . parse parseModDecl "idempotent_test_mod"+ $ alexScanTokens sv parserInput :: Property parserInput = Hog.property $ do- v <- Hog.forAll (GenVerilog <$> procedural "top" smallConfig)- Hog.assert . isRight $ parse parseModDecl- "input_test"- (alexScanTokens . uncomment "test" $ show v)+ v <- Hog.forAll (GenVerilog <$> (procedural "top" smallConfig :: Gen (Verilog ())))+ Hog.assert . isRight $+ parse+ parseModDecl+ "input_test"+ (alexScanTokens . uncomment "test" $ show v) parserIdempotent :: Property parserIdempotent = Hog.property $ do- v <- Hog.forAll (procedural "top" smallConfig)- let sv = vshow v- p sv === (p . p) sv+ v <- Hog.forAll (procedural "top" smallConfig) :: Hog.PropertyT IO (Verilog ())+ let sv = vshow v+ p sv === (p . p) sv where vshow = showT . GenVerilog- p sv = either (\x -> showT x <> "\n" <> sv) vshow- $ parseVerilog "idempotent_test" sv+ p sv =+ either (\x -> showT x <> "\n" <> sv) vshow $+ parseVerilog "idempotent_test" sv parserTests :: TestTree-parserTests = testGroup+parserTests =+ testGroup "Parser properties"- [ testProperty "Input Mod" parserInputMod- , testProperty "Input" parserInput- , testProperty "Idempotence Mod" parserIdempotentMod- , testProperty "Idempotence" parserIdempotent+ [ testProperty "Input Mod" parserInputMod,+ testProperty "Input" parserInput,+ testProperty "Idempotence Mod" parserIdempotentMod,+ testProperty "Idempotence" parserIdempotent ] testParse :: (Eq a, Show a) => Parser a -> String -> String -> a -> TestTree testParse p name input golden =- testCase name $ case parse p "testcase" (alexScanTokens input) of- Left e -> assertFailure $ show e- Right result -> golden @=? result+ testCase name $ case parse p "testcase" (alexScanTokens input) of+ Left e -> assertFailure $ show e+ Right result -> golden @=? result testParseFail :: (Eq a, Show a) => Parser a -> String -> String -> TestTree testParseFail p name input =- testCase name $ case parse p "testcase" (alexScanTokens input) of- Left _ -> return ()- Right _ -> assertFailure "Parse incorrectly succeeded"+ testCase name $ case parse p "testcase" (alexScanTokens input) of+ Left _ -> return ()+ Right _ -> assertFailure "Parse incorrectly succeeded" parseEventUnit :: TestTree-parseEventUnit = testGroup+parseEventUnit =+ testGroup "Event"- [ testFailure "No empty event" "@()"- , test "@*" EAll- , test "@(*)" EAll- , test "@(posedge clk)" $ EPosEdge "clk"- , test "@(negedge clk)" $ ENegEdge "clk"- , test "@(wire1)" $ EId "wire1"- , test "@(a or b or c or d)"- $ EOr (EId "a") (EOr (EId "b") (EOr (EId "c") (EId "d")))- , test "@(a, b, c, d)"- $ EComb (EId "a") (EComb (EId "b") (EComb (EId "c") (EId "d")))- , test "@(posedge a or negedge b or c or d)"- $ EOr (EPosEdge "a") (EOr (ENegEdge "b") (EOr (EId "c") (EId "d")))+ [ testFailure "No empty event" "@()",+ test "@*" EAll,+ test "@(*)" EAll,+ test "@(posedge clk)" $ EPosEdge "clk",+ test "@(negedge clk)" $ ENegEdge "clk",+ test "@(wire1)" $ EId "wire1",+ test "@(a or b or c or d)" $+ EOr (EId "a") (EOr (EId "b") (EOr (EId "c") (EId "d"))),+ test "@(a, b, c, d)" $+ EComb (EId "a") (EComb (EId "b") (EComb (EId "c") (EId "d"))),+ test "@(posedge a or negedge b or c or d)" $+ EOr (EPosEdge "a") (EOr (ENegEdge "b") (EOr (EId "c") (EId "d"))) ] where test a = testParse parseEvent ("Test " <> a) a testFailure = testParseFail parseEvent parseAlwaysUnit :: TestTree-parseAlwaysUnit = testGroup+parseAlwaysUnit =+ testGroup "Always"- [ test "Empty" "always begin end" $ Always (SeqBlock [])- , test "Empty with event @*" "always @* begin end"- $ Always (EventCtrl EAll (Just (SeqBlock [])))- , test "Empty with event @(posedge clk)" "always @(posedge clk) begin end"- $ Always (EventCtrl (EPosEdge "clk") (Just (SeqBlock [])))+ [ test "Empty" "always begin end" $ Always (SeqBlock []),+ test "Empty with event @*" "always @* begin end" $+ Always (EventCtrl EAll (Just (SeqBlock []))),+ test "Empty with event @(posedge clk)" "always @(posedge clk) begin end" $+ Always (EventCtrl (EPosEdge "clk") (Just (SeqBlock []))) ]- where test = testParse parseModItem+ where+ test :: String -> String -> ModItem () -> TestTree+ test = testParse parseModItem parseUnitTests :: TestTree parseUnitTests = testGroup "Parser unit" [parseEventUnit, parseAlwaysUnit]
test/Property.hs view
@@ -1,51 +1,53 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Property- ( propertyTests- )+ ( propertyTests,+ ) where -import Data.Either (either, isRight)-import qualified Data.Graph.Inductive as G-import Data.Text (Text)-import Hedgehog (Gen, Property, (===))-import qualified Hedgehog as Hog-import qualified Hedgehog.Gen as Hog-import qualified Hedgehog.Range as Hog-import Parser (parserTests)-import Test.Tasty-import Test.Tasty.Hedgehog-import Text.Parsec-import Verismith-import Verismith.Result-import Verismith.Verilog.Lex-import Verismith.Verilog.Parser+import Data.Either (either, isRight)+import qualified Data.Graph.Inductive as G+import Data.Text (Text)+import Distance (distanceTests)+import Hedgehog (Gen, Property, (===))+import qualified Hedgehog as Hog+import qualified Hedgehog.Gen as Hog+import qualified Hedgehog.Range as Hog+import Parser (parserTests)+import Test.Tasty+import Test.Tasty.Hedgehog+import Text.Parsec+import Verismith+import Verismith.Result+import Verismith.Verilog.Lex+import Verismith.Verilog.Parser randomDAG' :: Gen Circuit randomDAG' = Hog.resize 30 randomDAG acyclicGraph :: Property acyclicGraph = Hog.property $ do- xs <- Hog.forAllWith (const "") randomDAG'- Hog.assert $ simp xs+ xs <- Hog.forAllWith (const "") randomDAG'+ Hog.assert $ simp xs where simp g =- (== G.noNodes (getCircuit g))- . sum- . fmap length- . G.scc- . getCircuit- $ g+ (== G.noNodes (getCircuit g))+ . sum+ . fmap length+ . G.scc+ . getCircuit+ $ g propertyTests :: TestTree-propertyTests = testGroup+propertyTests =+ testGroup "Property Tests"- [ testProperty "acyclic graph generation check" acyclicGraph- , parserTests+ [ testProperty "acyclic graph generation check" acyclicGraph,+ parserTests,+ distanceTests ]
test/Reduce.hs view
@@ -1,46 +1,52 @@-{-|-Module : Reduce-Description : Test reduction.-Copyright : (c) 2019, Yann Herklotz Grave-License : GPL-3-Maintainer : yann [at] yannherklotz [dot] com-Stability : experimental-Portability : POSIX--Test reduction.--}- {-# LANGUAGE QuasiQuotes #-} +-- |+-- Module : Reduce+-- Description : Test reduction.+-- Copyright : (c) 2019, Yann Herklotz Grave+-- License : GPL-3+-- Maintainer : yann [at] yannherklotz [dot] com+-- Stability : experimental+-- Portability : POSIX+--+-- Test reduction. module Reduce- ( reduceUnitTests- )+ ( reduceUnitTests,+ ) where -import Data.List ((\\))-import Test.Tasty-import Test.Tasty.HUnit-import Verismith-import Verismith.Reduce+import Data.List ((\\))+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit+import Verismith+import Verismith.Reduce +sourceInfo :: Text -> Verilog ReduceAnn -> SourceInfo ReduceAnn+sourceInfo = SourceInfo+ reduceUnitTests :: TestTree-reduceUnitTests = testGroup+reduceUnitTests =+ testGroup "Reducer tests"- [ moduleReducerTest- , modItemReduceTest- , halveStatementsTest- , statementReducerTest- , activeWireTest- , cleanTest- , cleanAllTest- , removeDeclTest+ [ moduleReducerTest,+ modItemReduceTest,+ halveStatementsTest,+ statementReducerTest,+ activeWireTest,+ cleanTest,+ cleanAllTest,+ removeDeclTest ] removeConstInConcatTest :: TestTree removeConstInConcatTest = testCase "Remove const in concat" $ do- GenVerilog (removeDecl srcInfo1) @?= golden1+ GenVerilog (removeDecl srcInfo1) @?= golden1 where- srcInfo1 = SourceInfo "top" [verilog|+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top; wire a; reg b;@@ -53,7 +59,11 @@ end endmodule |]- golden1 = GenVerilog $ SourceInfo "top" [verilog|+ golden1 =+ GenVerilog $+ sourceInfo+ "top"+ [verilog| module top; wire a; reg b;@@ -69,9 +79,12 @@ removeDeclTest :: TestTree removeDeclTest = testCase "Remove declarations" $ do- GenVerilog (removeDecl srcInfo1) @?= golden1- where- srcInfo1 = SourceInfo "top" [verilog|+ GenVerilog (removeDecl srcInfo1) @?= golden1+ where+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top; wire a; wire b;@@ -99,7 +112,11 @@ assign b = g; endmodule |]- golden1 = GenVerilog $ SourceInfo "top" [verilog|+ golden1 =+ GenVerilog $+ sourceInfo+ "top"+ [verilog| module top; wire a; wire b;@@ -125,11 +142,13 @@ endmodule |] -cleanAllTest :: TestTree cleanAllTest = testCase "Clean all" $ do- GenVerilog (cleanSourceInfoAll srcInfo1) @?= golden1- where- srcInfo1 = SourceInfo "top" [verilog|+ GenVerilog (cleanSourceInfoAll srcInfo1) @?= golden1+ where+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top; wire a; wire b;@@ -157,7 +176,11 @@ assign b = c + d; endmodule |]- golden1 = GenVerilog $ SourceInfo "top" [verilog|+ golden1 =+ GenVerilog $+ sourceInfo+ "top"+ [verilog| module top; wire a; wire b;@@ -188,10 +211,12 @@ cleanTest :: TestTree cleanTest = testCase "Clean expression" $ do- clean ["wire1", "wire2"] srcInfo1 @?= golden1- clean ["wire1", "wire3"] srcInfo2 @?= golden2- where- srcInfo1 = GenVerilog . SourceInfo "top" $ [verilog|+ clean ["wire1", "wire2"] srcInfo1 @?= golden1+ clean ["wire1", "wire3"] srcInfo2 @?= golden2+ where+ srcInfo1 =+ GenVerilog . sourceInfo "top" $+ [verilog| module top; wire wire1; wire wire2;@@ -199,7 +224,9 @@ assign wire1 = wire2[wire3]; endmodule |]- golden1 = GenVerilog . SourceInfo "top" $ [verilog|+ golden1 =+ GenVerilog . sourceInfo "top" $+ [verilog| module top; wire wire1; wire wire2;@@ -207,7 +234,9 @@ assign wire1 = wire2[1'b0]; endmodule |]- srcInfo2 = GenVerilog . SourceInfo "top" $ [verilog|+ srcInfo2 =+ GenVerilog . sourceInfo "top" $+ [verilog| module top; wire wire1; wire wire2;@@ -215,7 +244,9 @@ assign wire1 = wire2[wire3:wire1]; endmodule |]- golden2 = GenVerilog . SourceInfo "top" $ [verilog|+ golden2 =+ GenVerilog . sourceInfo "top" $+ [verilog| module top; wire wire1; wire wire2;@@ -224,15 +255,18 @@ endmodule |] - activeWireTest :: TestTree activeWireTest = testCase "Active wires" $ do- findActiveWires "top" verilog1 \\ ["x", "y", "z", "w"] @?= []- findActiveWires "top" verilog2 \\ ["x", "y", "z"] @?= []- findActiveWires "top" verilog3 \\ ["x", "y", "clk", "r1", "r2"] @?= []- findActiveWires "top" verilog4 \\ ["x", "y", "w", "a", "b"] @?= []- where- verilog1 = SourceInfo "top" [verilog|+ findActiveWires "top" verilog1 \\ ["x", "y", "z", "w"] @?= []+ findActiveWires "top" verilog2 \\ ["x", "y", "z"] @?= []+ findActiveWires "top" verilog3 \\ ["x", "y", "clk", "r1", "r2"] @?= []+ findActiveWires "top" verilog4 \\ ["x", "y", "w", "a", "b"] @?= []+ findActiveWires "top" verilog5 \\ ["r2", "r1", "x", "y"] @?= []+ where+ verilog1 =+ sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -243,7 +277,10 @@ assign y = w + z; endmodule |]- verilog2 = SourceInfo "top" [verilog|+ verilog2 =+ sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -252,7 +289,10 @@ assign z = 0; endmodule |]- verilog3 = SourceInfo "top" [verilog|+ verilog3 =+ sourceInfo+ "top"+ [verilog| module top(clk, y, x); input clk; input x;@@ -273,7 +313,10 @@ assign y = {r1, r2, r3}; endmodule |]- verilog4 = SourceInfo "top" [verilog|+ verilog4 =+ sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -297,12 +340,32 @@ output z; endmodule |]+ verilog5 =+ sourceInfo+ "top"+ [verilog|+module top(y, x);+ input x;+ output y;+ reg r1;+ reg r2;+ reg r3;+ always @* begin+ for (r1 = 1; r1 < 2; r1 = r1 + 1) begin+ r2 <= 1'b0;+ end+ end+endmodule+|] halveStatementsTest :: TestTree halveStatementsTest = testCase "Statements" $ do- GenVerilog <$> halveStatements "top" srcInfo1 @?= golden1- where- srcInfo1 = SourceInfo "top" [verilog|+ GenVerilog <$> halveStatements "top" (tagAlways "top" srcInfo1) @?= golden1+ where+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top(clk, y, x); input clk; input x;@@ -324,7 +387,13 @@ assign y = {r1, r2, r3}; endmodule |]- golden1 = GenVerilog <$> Dual (SourceInfo "top" [verilog|+ golden1 =+ GenVerilog+ <$> Dual+ ( tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(clk, y, x); input clk; input x;@@ -333,15 +402,22 @@ reg r2; reg r3; always @(posedge clk) begin- r1 <= 1'b0;+ r1 <= r3; end always @(posedge clk) begin- r1 <= 1'b0;+ r1 <= r2;+ r2 <= r3;+ r3 <= r1; end- assign y = {r1, 1'b0, 1'b0};+ assign y = {r1, r2, r3}; endmodule-|]) (SourceInfo "top" [verilog|+|]+ )+ ( tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(clk, y, x); input clk; input x;@@ -350,23 +426,28 @@ reg r2; reg r3; always @(posedge clk) begin- r2 <= 1'b0;+ r2 <= r1; r3 <= r2; end always @(posedge clk) begin+ r1 <= r2; r2 <= r3;- r3 <= 1'b0;+ r3 <= r1; end- assign y = {1'b0, r2, r3};+ assign y = {r1, r2, r3}; endmodule-|])+|]+ ) modItemReduceTest :: TestTree modItemReduceTest = testCase "Module items" $ do- GenVerilog <$> halveModItems "top" srcInfo1 @?= golden1- where- srcInfo1 = SourceInfo "top" [verilog|+ GenVerilog <$> halveModItems "top" srcInfo1 @?= golden1+ where+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -377,7 +458,12 @@ assign y = w; endmodule |]- golden1 = GenVerilog <$> Dual (SourceInfo "top" [verilog|+ golden1 =+ GenVerilog+ <$> Dual+ ( sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -386,7 +472,11 @@ assign y = 1'b0; assign z = x; endmodule-|]) (SourceInfo "top" [verilog|+|]+ )+ ( sourceInfo+ "top"+ [verilog| module top(y, x); input x; output y;@@ -395,14 +485,19 @@ assign y = w; assign w = 1'b0; endmodule-|])+|]+ ) statementReducerTest :: TestTree statementReducerTest = testCase "Statement reducer" $ do- GenVerilog <$> halveStatements "top" srcInfo1 @?= fmap GenVerilog golden1- GenVerilog <$> halveStatements "top" srcInfo2 @?= fmap GenVerilog golden2- where- srcInfo1 = SourceInfo "top" [verilog|+ GenVerilog <$> halveStatements "top" srcInfo1 @?= fmap GenVerilog golden1+ GenVerilog <$> halveStatements "top" srcInfo2 @?= fmap GenVerilog golden2+ where+ srcInfo1 =+ tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -422,7 +517,12 @@ end endmodule |]- golden1 = Dual (SourceInfo "top" [verilog|+ golden1 =+ Dual+ ( tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -435,9 +535,16 @@ always @(posedge clk) begin a <= 1; b <= 2;+ c <= 3;+ d <= 4; end endmodule-|]) $ SourceInfo "top" [verilog|+|]+ )+ . tagAlways "top"+ $ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -448,12 +555,18 @@ end always @(posedge clk) begin+ a <= 1;+ b <= 2; c <= 3; d <= 4; end endmodule |]- srcInfo2 = SourceInfo "top" [verilog|+ srcInfo2 =+ tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -466,7 +579,12 @@ end endmodule |]- golden2 = Dual (SourceInfo "top" [verilog|+ golden2 =+ Dual+ ( tagAlways "top" $+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -474,7 +592,12 @@ always @(posedge clk) y <= 2; endmodule-|]) $ SourceInfo "top" [verilog|+|]+ )+ . tagAlways "top"+ $ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -486,10 +609,13 @@ moduleReducerTest :: TestTree moduleReducerTest = testCase "Module reducer" $ do- halveModules srcInfo1 @?= golden1- halveModules srcInfo2 @?= golden2- where- srcInfo1 = SourceInfo "top" [verilog|+ halveModules srcInfo1 @?= golden1+ halveModules srcInfo2 @?= golden2+ where+ srcInfo1 =+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -501,13 +627,20 @@ input wire [4:0] x; endmodule |]- golden1 = Single $ SourceInfo "top" [verilog|+ golden1 =+ Single $+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x; endmodule |]- srcInfo2 = SourceInfo "top" [verilog|+ srcInfo2 =+ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -525,7 +658,11 @@ input wire [4:0] x; endmodule |]- golden2 = Dual (SourceInfo "top" [verilog|+ golden2 =+ Dual+ ( sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;@@ -536,7 +673,11 @@ output wire [4:0] y; input wire [4:0] x; endmodule-|]) $ SourceInfo "top" [verilog|+|]+ )+ $ sourceInfo+ "top"+ [verilog| module top(y, x); output wire [4:0] y; input wire [4:0] x;
test/Test.hs view
@@ -1,8 +1,8 @@ module Main where -import Property-import Test.Tasty-import Unit+import Property+import Test.Tasty+import Unit tests :: TestTree tests = testGroup "Tests" [unitTests, propertyTests]
test/Unit.hs view
@@ -1,101 +1,111 @@ module Unit- ( unitTests- )+ ( unitTests,+ ) where -import Control.Lens-import Data.List.NonEmpty (NonEmpty (..))-import Parser (parseUnitTests)-import Reduce (reduceUnitTests)-import Test.Tasty-import Test.Tasty.HUnit-import Verismith+import Config (configUnitTests)+import Control.Lens+import Data.List.NonEmpty (NonEmpty (..))+import Parser (parseUnitTests)+import Reduce (reduceUnitTests)+import Test.Tasty+import Test.Tasty.HUnit+import Verismith unitTests :: TestTree-unitTests = testGroup+unitTests =+ testGroup "Unit tests"- [ testCase "Transformation of AST" $ assertEqual- "Successful transformation"- transformExpectedResult- (transform trans transformTestData)- , parseUnitTests- , reduceUnitTests+ [ testCase "Transformation of AST" $+ assertEqual+ "Successful transformation"+ transformExpectedResult+ (transform trans transformTestData),+ parseUnitTests,+ reduceUnitTests,+ configUnitTests ] transformTestData :: Expr-transformTestData = BinOp- (BinOp (BinOp (Id "id1") BinAnd (Id "id2"))- BinAnd- (BinOp (Id "id1") BinAnd (Id "id2"))+transformTestData =+ BinOp+ ( BinOp+ (BinOp (Id "id1") BinAnd (Id "id2"))+ BinAnd+ (BinOp (Id "id1") BinAnd (Id "id2")) ) BinAnd- (BinOp- (BinOp+ ( BinOp+ ( BinOp (BinOp (Id "id1") BinAnd (Id "id2")) BinAnd- (BinOp+ ( BinOp (Id "id1") BinAnd- (BinOp (BinOp (Id "id1") BinAnd (Id "id2"))- BinAnd- (BinOp (Id "id1") BinAnd (Id "id2"))+ ( BinOp+ (BinOp (Id "id1") BinAnd (Id "id2"))+ BinAnd+ (BinOp (Id "id1") BinAnd (Id "id2")) ) ) ) BinOr- ( Concat- $ ( Concat- $ (Concat $ (Id "id1") :| [Id "id2", Id "id2"])- :| [ Id "id2"- , Id "id2"- , ( Concat- $ (Id "id2")- :| [Id "id2", (Concat $ Id "id1" :| [Id "id2"])]- )- , Id "id2"- ]- )- :| [Id "id1", Id "id2"]+ ( Concat $+ ( Concat $+ (Concat $ (Id "id1") :| [Id "id2", Id "id2"])+ :| [ Id "id2",+ Id "id2",+ ( Concat $+ (Id "id2")+ :| [Id "id2", (Concat $ Id "id1" :| [Id "id2"])]+ ),+ Id "id2"+ ]+ )+ :| [Id "id1", Id "id2"] ) ) transformExpectedResult :: Expr-transformExpectedResult = BinOp- (BinOp (BinOp (Id "id1") BinAnd (Id "Replaced"))- BinAnd- (BinOp (Id "id1") BinAnd (Id "Replaced"))+transformExpectedResult =+ BinOp+ ( BinOp+ (BinOp (Id "id1") BinAnd (Id "Replaced"))+ BinAnd+ (BinOp (Id "id1") BinAnd (Id "Replaced")) ) BinAnd- (BinOp- (BinOp+ ( BinOp+ ( BinOp (BinOp (Id "id1") BinAnd (Id "Replaced")) BinAnd- (BinOp+ ( BinOp (Id "id1") BinAnd- (BinOp (BinOp (Id "id1") BinAnd (Id "Replaced"))- BinAnd- (BinOp (Id "id1") BinAnd (Id "Replaced"))+ ( BinOp+ (BinOp (Id "id1") BinAnd (Id "Replaced"))+ BinAnd+ (BinOp (Id "id1") BinAnd (Id "Replaced")) ) ) ) BinOr- ( Concat- $ ( Concat- $ (Concat $ (Id "id1") :| [Id "Replaced", Id "Replaced"])- :| [ Id "Replaced"- , Id "Replaced"- , Concat- $ Id "Replaced"- :| [Id "Replaced", Concat $ Id "id1" :| [Id "Replaced"]]- , Id "Replaced"- ]- )- :| [Id "id1", Id "Replaced"]+ ( Concat $+ ( Concat $+ (Concat $ (Id "id1") :| [Id "Replaced", Id "Replaced"])+ :| [ Id "Replaced",+ Id "Replaced",+ Concat $+ Id "Replaced"+ :| [Id "Replaced", Concat $ Id "id1" :| [Id "Replaced"]],+ Id "Replaced"+ ]+ )+ :| [Id "id1", Id "Replaced"] ) ) trans :: Expr -> Expr trans e = case e of- Id i -> if i == Identifier "id2" then Id $ Identifier "Replaced" else Id i- _ -> e+ Id i -> if i == Identifier "id2" then Id $ Identifier "Replaced" else Id i+ _ -> e
verismith.cabal view
@@ -1,5 +1,5 @@ name: verismith-version: 1.0.0.2+version: 1.1.0 synopsis: Random verilog generation and simulator testing. description: Verismith provides random verilog generation modules@@ -9,7 +9,7 @@ license-file: LICENSE author: Yann Herklotz maintainer: yann [at] yannherklotz [dot] com-copyright: 2018-2020 Yann Herklotz+copyright: 2018-2025 Yann Herklotz category: Hardware build-type: Simple cabal-version: >=1.10@@ -27,13 +27,15 @@ source-repository this type: git location: https://github.com/ymherklotz/verismith- tag: v1.0.0.0+ tag: v1.1.0 library hs-source-dirs: src default-language: Haskell2010 build-tools: alex >=3 && <4 other-modules: Paths_verismith+-- ghc-options: -ddump-simpl -ddump-to-file+ ghc-options: -Wno-x-partial -Wno-unrecognised-warning-flags exposed-modules: Verismith , Verismith.Circuit , Verismith.Circuit.Base@@ -42,13 +44,14 @@ , Verismith.Circuit.Random , Verismith.Config , Verismith.CounterEg+ , Verismith.EMI , Verismith.Fuzz , Verismith.Generate- , Verismith.Internal , Verismith.OptParser , Verismith.Reduce , Verismith.Report , Verismith.Result+ , Verismith.Shuffle , Verismith.Tool , Verismith.Tool.Icarus , Verismith.Tool.Identity@@ -59,10 +62,12 @@ , Verismith.Tool.Vivado , Verismith.Tool.XST , Verismith.Tool.Yosys+ , Verismith.Utils , Verismith.Verilog , Verismith.Verilog.AST , Verismith.Verilog.BitVec , Verismith.Verilog.CodeGen+ , Verismith.Verilog.Distance , Verismith.Verilog.Eval , Verismith.Verilog.Internal , Verismith.Verilog.Lex@@ -71,41 +76,51 @@ , Verismith.Verilog.Preprocess , Verismith.Verilog.Quote , Verismith.Verilog.Token- build-depends: DRBG >=0.5 && <0.6- , array >=0.5 && <0.6+ , Verismith.Verilog2005+ , Verismith.Verilog2005.Token+ , Verismith.Verilog2005.Lexer+ , Verismith.Verilog2005.AST+ , Verismith.Verilog2005.Utils+ , Verismith.Verilog2005.LibPretty+ , Verismith.Verilog2005.PrettyPrinter+ , Verismith.Verilog2005.Parser+ , Verismith.Verilog2005.Randomness+ , Verismith.Verilog2005.Generator+ build-depends: 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.27- , deepseq >= 1.4.3.0 && <1.5+ , bytestring >=0.10 && <0.12+ , cryptonite >=0.25 && <0.31+ , deepseq >= 1.4.3.0 && <1.6 , exceptions >=0.10.0 && <0.11- , fgl >=5.6 && <5.8+ , fgl >=5.6 && <5.9 , 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.19+ , hedgehog >=1.0 && <1.6+ , lens >=4.16.1 && <5.4 , lifted-base >=0.2.3 && <0.3- , memory >=0.14 && <0.16+ , memory >=0.14 && <0.20 , monad-control >=1.0.2 && <1.1- , mtl >=2.2.2 && <2.3- , optparse-applicative >=0.14 && <0.16+ , mtl >=2.2.2 && <2.4+ , optparse-applicative >=0.14 && <0.19 , parsec >=3.1 && <3.2- , prettyprinter >=1.2.0.1 && <1.7- , random >=1.1 && <1.2- , recursion-schemes >=5.0.2 && <5.2- , shakespeare >=2 && <2.1- , shelly >=1.8.0 && <1.10- , statistics >=0.14.0.2 && <0.16- , template-haskell >=2.13.0 && <2.16- , text >=1.2 && <1.3- , time >= 1.8.0.2 && <1.10- , tomland >=1.0 && <1.3- , transformers >=0.5 && <0.6+ , prettyprinter >=1.2.0.1 && <1.8+ , random >=1.1 && <1.3+ , recursion-schemes >=5.0.2 && <5.3+ , shelly >=1.8.0 && <1.13+ , template-haskell >=2.13.0 && <2.24+ , text >=1.2 && <2.2+ , time >= 1.8.0.2 && <1.13+ , tomland >=1.3.2 && <1.4+ , transformers >=0.5 && <0.7 , transformers-base >=0.4.5 && <0.5- , unordered-containers >=0.2.10 && <0.3- , vector >=0.12.0.1 && <0.13+ , containers >=0.6.0.1 && <0.9+ , unordered-containers >=0.2.9.0 && <0.2.21+ , mwc-probability >=2.0.0 && <2.4+ , primitive >=0.6.4.0 && <0.10+ , vector >=0.12.0.3 && <0.14 default-extensions: OverloadedStrings executable verismith@@ -124,8 +139,8 @@ main-is: Benchmark.hs build-depends: base >=4 && <5 , verismith- , criterion >=1.5.5 && <1.6- , lens >=4.16.1 && <4.19+ , criterion >=1.5.5 && <1.7+ , lens >=4.16.1 && <5.4 default-extensions: OverloadedStrings test-suite test@@ -134,20 +149,21 @@ hs-source-dirs: test main-is: Test.hs other-modules: Unit+ , Config , Property , Reduce , Parser+ , Distance build-depends: base >=4 && <5 , verismith- , fgl >=5.6 && <5.8- , hedgehog >=1.0 && <1.2- , lens >=4.16.1 && <4.19+ , fgl >=5.6 && <5.9+ , hedgehog >=1.0 && <1.6+ , lens >=4.16.1 && <5.4 , parsec >= 3.1 && < 3.2- , shakespeare >=2 && <2.1- , tasty >=1.0.1.1 && <1.3- , tasty-hedgehog >=1.0 && <1.1+ , tasty >=1.0.1.1 && <1.5+ , tasty-hedgehog >=1.0 && <1.6 , tasty-hunit >=0.10 && <0.11- , text >=1.2 && <1.3+ , text >=1.2 && <2.2 default-extensions: OverloadedStrings --test-suite doctest