diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,147 @@ # Changelog for the Clash project + +## 1.8.0 + +Release highlights: + +* Support for GHC 9.2, 9.4, 9.6 and 9.8. While GHC 9.2 is supported, we recommend users to skip this version as there is a severe degradation of error message quality. With this change, Clash now supports GHC versions 8.6 through 9.8. +* Major overhaul of the clocking functionality in `Clash.Xilinx.ClockGen` and `Clash.Intel.ClockGen`, see their respective entries below +* `mealyS` function (and several variations) to make writing state machines using the strict `State` monad easier +* Overhaul of `resetGlitchFilter`, see its respective entries below. + +Added: + +* `altpllSync` and `alteraPllSync` in `Clash.Intel.ClockGen`. These replace the deprecated functions without the `Sync` suffix. Unlike the old functions, these functions are safe to use and have a reset signal for each output domain that can be used to keep the domain in reset while the clock output stabilizes. All PLL functions now also support multiple clock outputs like the old `alteraPll` did. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* A new clock type `DiffClock` is introduced to signify a differential clock signal that is passed to the design on two ports in antiphase. This is used by the differential Xilinx clock wizards in `Clash.Xilinx.ClockGen`. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* `Clash.Explicit.Testbench.clockToDiffClock`, to create a differential clock signal in a test bench. It is not suitable for synthesizing a differential output in hardware. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* `resetGlitchFilterWithReset`, which accomplishes the same task as `resetGlitchFilter` in domains with unknown initial values by adding a power-on reset input to reset the glitch filter itself. [#2544](https://github.com/clash-lang/clash-compiler/pull/2544) +* Convenience functions: `noReset`, `andReset`, `orReset` plus their unsafe counterparts [#2539](https://github.com/clash-lang/clash-compiler/pull/2539) +* Convenience constraint aliases: `HasSynchronousReset`, `HasAsynchronousReset`, and `HasDefinedInitialValues` [#2539](https://github.com/clash-lang/clash-compiler/pull/2539) +* `Clash.Prelude.Mealy.mealyS` and `Clash.Explicit.Mealy.mealyS` and their bundled equivalents `mealySB` which make writing state machines using the strict `State` monad easier. The tutorial has also been simplified by using this change. [#2484](https://github.com/clash-lang/clash-compiler/pull/2484) +* An experimental feature allowing clocks to vary their periods over time, called "dynamic clocks". Given that this is an experimental feature, it is not part of the public API. [#2295](https://github.com/clash-lang/clash-compiler/pull/2295) +* The prelude now exports `+>>.` and `.<<+`, which can be used to shift in a bit into a `BitVector` from the left or right respectively - similar to `+>>` and `<<+` for `Vec`s. [#2307](https://github.com/clash-lang/clash-compiler/pull/2307) +* `Clash.DataFiles.tclConnector` and the executable `static-files` in `clash-lib`. They provide the Tcl Connector, a Tcl script that allows Vivado to interact with the metadata generated by Clash (Quartus support will be added later). See `Clash.DataFiles.tclConnector` for further information. More documentation about the Tcl Connector and the Clash<->Tcl API will be made available later. [#2335](https://github.com/clash-lang/clash-compiler/pull/2335) +* Add `BitPack`, `NFDataX` and `ShowX` instances for `Ordering` [#2366](https://github.com/clash-lang/clash-compiler/pull/2366) +* Verilog users can now influence the "precision" part of the generated `timescale` pragma using `-fclash-timescale-precision`. [#2353](https://github.com/clash-lang/clash-compiler/pull/2353) +* Clash now includes blackboxes for `integerToFloat#`, `integerToDouble#` [#2342](https://github.com/clash-lang/clash-compiler/issues/2342) +* Instances `Arbitrary (Erroring a)`, `Arbitrary (Saturating a)`, `Arbitrary (Saturating a)`, and `Arbitrary (Zeroing a)` [#2356](https://github.com/clash-lang/clash-compiler/pull/2356) +* `Clash.Magic.clashSimulation`, a way to differentiate between Clash simulation and generating HDL. [#2473](https://github.com/clash-lang/clash-compiler/pull/2473) +* `Clash.Magic.clashCompileError`: make HDL generation error out with a custom error message. Simulation in Clash will also error when the function is evaluated, including a call stack. HDL generation unfortunately does not include a call stack. [#2399](https://github.com/clash-lang/clash-compiler/pull/2399) +* Added `Clash.XException.MaybeX`, a data structure with smart constructors that can help programmers deal with `XException` values in their blackbox model implementations [#2442](https://github.com/clash-lang/clash-compiler/pull/2442) +* `Clash.Magic.SimOnly`, A container for data you only want to have around during simulation and is ignored during synthesis. Useful for carrying around things such as: a map of simulation/vcd traces, co-simulation state or meta-data, etc. [#2464](https://github.com/clash-lang/clash-compiler/pull/2464) +* `KnownNat (DomainPeriod dom)` as an implied constraint to `KnownDomain dom`. This reduces the amount of code needed to write - for example - clock speed dependent code. [#2541](https://github.com/clash-lang/clash-compiler/pull/2541) +* `Clash.Annotations.SynthesisAttributes.annotate`: a term level way of annotating signals with synthesis attributes [#2547](https://github.com/clash-lang/clash-compiler/pull/2547) +* `Clash.Annotations.SynthesisAttributes.markDebug`: a way of marking a signals "debug", instructing synthesizers to leave the signal alone and offer debug features [#2547](https://github.com/clash-lang/clash-compiler/pull/2547) +* Add hex and octal BitVector parsing. [#1772](https://github.com/clash-lang/clash-compiler/pull/2505) +* `1 <= n => Foldable1 (Vec n)` instance (`base-4.18+` only) [#2563](https://github.com/clash-lang/clash-compiler/pull/2563) +* You can now use `~PERIOD`, `~ISSYNC`, `~ISINITDEFINED` and `~ACTIVEEDGE` on arguments of type `Clock`, `Reset`, `Enable`,`ClockN` and `DiffClock`. [#2590](https://github.com/clash-lang/clash-compiler/pull/2590) + +Removed: + +* Deprecated module `Clash.Prelude.BitIndex`: functions have been moved to `Clash.Class.BitPack` [#2555](https://github.com/clash-lang/clash-compiler/pull/2555) +* Deprecated module `Clash.Prelude.BitReduction`: functions have been moved to `Clash.Class.BitPack` [#2555](https://github.com/clash-lang/clash-compiler/pull/2555) +* Deprecated function `Clash.Explicit.Signal.enable`: function has been renamed to `andEnable` [#2555](https://github.com/clash-lang/clash-compiler/pull/2555) +* The module `Clash.Clocks.Deriving` has been removed. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) + +Deprecated: + +* `unsafeFromLowPolarity`, `unsafeFromHighPolarity`, `unsafeToLowPolarity`, `unsafeToHighPolarity` have been replaced by `unsafeFromActiveLow`, `unsafeFromActiveHigh`, `unsafeToActiveLow`, `unsafeToActiveHigh`. While former ones will continue to exist, a deprecation warning has been added pointing to the latter ones. [#2540](https://github.com/clash-lang/clash-compiler/pull/2540) +* The functions `altpll` and `alteraPll` in `Clash.Intel.ClockGen` have been deprecated because they are unsafe to use while this is not apparent from the name. The `locked` output signal of these functions is an asynchronous signal which needs to be synchronized before it can be used (something the examples did in fact demonstrate). For the common use case, new functions are available, named `altpllSync` and `alteraPllSync`. These functions are safe. For advanced use cases, the old functionality can be obtained through `unsafeAltpll` and `unsafeAlteraPll`. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) + +Changed: + +* The wizards in `Clash.Xilinx.ClockGen` have been completely overhauled. The original functions were unsafe and broken in several ways. See the documentation in `Clash.Xilinx.ClockGen` for how to use the new functions. Significant changes are: + * `clockWizard` and `clockWizardDifferential` now output a `Clock` and a `Reset` which can be directly used by logic. Previously, it outputted a clock and an asynchronous `locked` signal which first needed to be synchronized before it could be used (hence the old function being unsafe). Additionally, the original `locked` signal was strange: it mistakenly was an `Enable` instead of a `Signal dom Bool` and there was a polarity mismatch between Clash simulation and HDL. The `locked` signal was also not resampled to the output domain in Clash simulation. + * There are new functions `unsafeClockWizard` and `unsafeClockWizardDifferential` for advanced use cases which directly expose the `locked` output of the wizard. + * All clock generators now have the option to output multiple clocks from a single instance. + * `clockWizardDifferential` now gets its input clock as a `DiffClock` type; use `clockToDiffClock` to generate this in your test bench if needed. Previously, the function received two clock inputs, but this generated `create_clock` statements in the top-level SDC file for both phases which is incorrect. + * A constraint was removed: The _output_ clock domain no longer requires asynchronous resets. This was originally intended to signal that the outgoing lock signal is an asynchronous signal. The constraint does not convey this information at all and is wrong; it also prevents using synchronous resets in the circuit as recommended by Xilinx. Note that if you use the `unsafe` functions, it is still necessary to synchronize the `locked` output in your design. + * The port names of the primitives in HDL are now correctly lower case. + * Add Tcl generation. This moves the responsibility of MMCM component generation from the user to `clashConnector.tcl`, which can be found in [`clash-lib:Clash.DataFiles`](https://hackage.haskell.org/package/clash-lib-1.8.0/docs/Clash-DataFiles.html). + * The wizards now use the user-provided name as the name of the _instance_ rather than the name of the _IP core_. This change was also done for `Clash.Intel.ClockGen` in Clash v1.2.0 in March 2020, when Clash started generating Intel Qsys files. Before that, the user needed to generate a Qsys component manually. Now, in Clash v1.8.0, we also generate the Tcl for Xilinx wizards. When the user is responsible for creating the IP core, it makes sense to always set the component name to the user-provided value. But when that is also generated by Clash, that is no longer needed. Allowing users to set the instance name instead makes it possible to match on the instance in SDC files and such. + [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* The IP core generators in `Clash.Intel.ClockGen` now declare that their input domain needs to have asynchronous resets (`HasAsynchronousReset`), as the functions react asynchronously to their reset input and thus need to be glitch-free. The functions marked `unsafe` do not have this constraint; instead, the function documentation calls attention to the requirement. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* `resetGlitchFilter` now uses a counter instead of shift register, allowing glitch filtering over much larger periods. [#2374](https://github.com/clash-lang/clash-compiler/pull/2374) +* `resetGlitchFilter` now filters glitches symmetrically, only deasserting the reset after the incoming reset has stabilized. For more information, read [#2374](https://github.com/clash-lang/clash-compiler/pull/2374). +* `resetGlitchFilter` does not support domains with unknown initial values anymore. Its previous behavior could lead to unstable circuits. Domains not supporting initial values should consider using `resetGlitchFilterWithReset` or `holdReset`. The previous behavior can still be attained through the new `unsafeResetGlitchFilter`. [#2544](https://github.com/clash-lang/clash-compiler/pull/2544) +* `fromJustX` now uses `deepErrorX` instead of `errorX`. This adds `NFDataX` constraints to `blockRam` like functions, `asyncRam` and `writeToBiSignal`. [#2113](https://github.com/clash-lang/clash-compiler/pull/2113) +* All memory functions now use `deepErrorX` for `XException`s. This adds `NFDataX` constraints to `asyncRom`, `asyncRomPow2` and `asyncRom#`. [#2113](https://github.com/clash-lang/clash-compiler/pull/2113) +* Before this release, `scanl1` was re-exported from the Haskell Prelude. Clash's Prelude now exports a `Vec` specialized version. [#2172](https://github.com/clash-lang/clash-compiler/pull/2172) +* When generating (System)Verilog, Clash now sets the default net type to `none`. This means any implicitly declared signal in the design will trigger an error when elaborating the design. [#2174](https://github.com/clash-lang/clash-compiler/pull/2174) +* Blackbox templates no longer have the `outputReg` key, it has been replaced with the more general `outputUsage` which specifies how signals are used in terms of whether writes are + + * continuous (i.e. a concurrent context) + * procedural non-blocking (i.e. `signal` in a VHDL process) + * procedural blocking (i.e. `variable` in a VHDL process) + + The `~OUTPUTWIREREG` tag continues to work for backwards compatibility, but there is also a new `~OUTPUTUSAGE` tag which is recommended. In the future, the `~OUTPUTWIREREG` tag may be removed. [#2230](https://github.com/clash-lang/clash-compiler/pull/2230) +* `Clash.Explicit.Testbench.outputVerifier` now takes an additional clock as an argument: the clock used by the circuit under test. If your tests use the same domain for the test circuit and design under test, consider using `Clash.Explicit.Testbench.outputVerifier'`. [#2295](https://github.com/clash-lang/clash-compiler/pull/2295) +* `Clash.Explicit.Signal.veryUnsafeSynchronizer` now accepts either a static clock period or a dynamic one. If you don't use dynamic clocks, convert your calls to use `Left`. [#2295](https://github.com/clash-lang/clash-compiler/pull/2295) +* `SDomainConfiguration` is now a record, easing field access. [#2349](https://github.com/clash-lang/clash-compiler/pull/2349) +* Generalized the return types of `periodToHz` and `hzToPeriod`. Use a type application (`periodToHz @(Ratio Natural)`, `hzToPeriod @Natural`) to get the old behavior back, in case type errors arise. [#2436](https://github.com/clash-lang/clash-compiler/pull/2436) +* `periodToHz` and `hzToPeriod` now throw an `ErrorCall` with call stack when called with the argument 0 (zero), instead of a `RatioZeroDenominator :: ArithException`. [#2436](https://github.com/clash-lang/clash-compiler/pull/2436) +* `hasX` now needs an `NFDataX` constraint, in addition to an `NFData` one. This API change was made to fix an issue where `hasX` would hide error calls in certain situations, see [#2450](https://github.com/clash-lang/clash-compiler/issues/2450). +* Clock generators now wait at least 100 ns before producing their first tick. This change has been implemented to account for Xilinx's GSR in clock synchronization primitives. This change does not affect Clash simulation. See [#2455](https://github.com/clash-lang/clash-compiler/issues/2455). +* From GHC 9.4.1 onwards the following types: `BiSignalOut`, `Index`, `Signed`, `Unsigned`, `File`, `Ref`, and `SimIO` are all encoded as `newtype` instead of `data` now that [#2511](https://github.com/clash-lang/clash-compiler/pull/2511) is merged. This means you can once again use `Data.Coerce.coerce` to coerce between these types and their underlying representation. [#2535](https://github.com/clash-lang/clash-compiler/pull/2535) +* The `Foldable (Vec n)` instance and `Traversable (Vec n)` instance no longer have the `1 <= n` constraint. `Foldable.{foldr1,foldl1,maximum,minimum}` functions now throw an error at run-/simulation-time, and also at HDL-generation time, for vectors of length zero. [#2563](https://github.com/clash-lang/clash-compiler/pull/2563) +* The `maximum` and `minimum` functions exported by `Clash.Prelude` work on non-empty vectors, instead of the more generic version from `Data.Foldable`. [#2563](https://github.com/clash-lang/clash-compiler/pull/2563) +* `unsafeToReset` and `invertReset` now have a KnownDomain constraint This was done in preparation for [Remove KnownDomain #2589](https://github.com/clash-lang/clash-compiler/pull/2589) + +Fixed: + +* `altpll` and `alteraPll` in `Clash.Intel.ClockGen` now account for the input domain's `ResetPolarity`. Before this fix, the reset was always interpreted as an active-high signal. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) +* Fix `alteraPll` `qsys` generation. PR [#2417](https://github.com/clash-lang/clash-compiler/pull/2417) (included in Clash v1.6.5) caused a bug in the generation of the `qsys` file: it generated a spurious extra output clock which was completely unused otherwise. [#2587](https://github.com/clash-lang/clash-compiler/pull/2587) +* Files in `clash-manifest.json` are now (correctly) listed in reverse topological order [#2334](https://github.com/clash-lang/clash-compiler/issues/2334) +* Dependencies in `clash-manifest.json` are now listed in reverse topological ordering [#2325](https://github.com/clash-lang/clash-compiler/issues/2325) +* Clash now renders undefined bits set via `-fclash-force-undefined` correctly [#2360](https://github.com/clash-lang/clash-compiler/issues/2360) +* `resetGen`'s documentation now mentions it is non-synthesizable ([#2375](https://github.com/clash-lang/clash-compiler/issues/2375)) +* `trueDualPortBlockRam` now handles undefined values in its input correctly [#2350](https://github.com/clash-lang/clash-compiler/issues/2350) +* `trueDualPortBlockRam` now correctly handles port enables when clock edges coincide [#2351](https://github.com/clash-lang/clash-compiler/issues/2351) +* `Clash.Primitives.DSL.deconstructProduct` now projects fields out of a product [#2469](https://github.com/clash-lang/clash-compiler/issues/2469) +* BiSignal test does not look through `Annotate` [#2472](https://github.com/clash-lang/clash-compiler/issues/2472) +* Port size not rendered when type has more than one `Annotate` [#2475](https://github.com/clash-lang/clash-compiler/pull/2475) +* Clash now preserves `NOINLINE` of functions being specialized [#2502](https://github.com/clash-lang/clash-compiler/issues/2502) +* When `convertReset` was used with two domains that had a different reset polarity, the polarity of the signal was not changed. +* Functional arguments of primitives cannot have 0-bit results [#2549](https://github.com/clash-lang/clash-compiler/issues/2549) +* If the source reset of `convertReset` is synchronous, a flip-flop in the source domain is inserted to filter glitches from the source reset. [#2573](https://github.com/clash-lang/clash-compiler/pull/2573) +* SystemVerilog backend: Assignment patterns for unpacked arrays now have an index for every element; improves QuestaSim compatibility. [#2595](https://github.com/clash-lang/clash-compiler/pull/2595) +* Name duplication in generated Verilog involving reset synchronizer [#2598](https://github.com/clash-lang/clash-compiler/issues/2598) + +Internal added: + +* `Clash.Primitives.DSL.instDecl` now accepts `TExpr`s instead of `LitHDL`s as generics/parameters. This allows for VHDL black boxes to use all possible generic types. To ease transition, `litTExpr` has been added to `Clash.Primitives.DSL`. [#2471](https://github.com/clash-lang/clash-compiler/issues/2471) +* `Clash.Core.TermLiteral.deriveTermToData` now works on records [#2270](https://github.com/clash-lang/clash-compiler/pull/2270) +* `Clash.Primitives.getVec` tries to get all elements in a Vector from an expression [#2483](https://github.com/clash-lang/clash-compiler/pull/2483) +* Added `Clash.Primitives.DSL.deconstructMaybe`. This DSL function makes it easy to deconstruct a `Maybe` into its constructor bit and data. This is often useful for primitives taking 'enable' and 'data' signals. [#2202](https://github.com/clash-lang/clash-compiler/pull/2202) +* Added `unsafeToActiveHigh` and `unsafeToActiveLow` to `Clash.Primitives.DSL`. [#2270](https://github.com/clash-lang/clash-compiler/pull/2270) +* Added `TermLiteral` instance for `Either` [#2329](https://github.com/clash-lang/clash-compiler/pull/2329) +* `Clash.Primitives.DSL.declareN`, a companion to `declare` which declares multiple signals in one go. [#2592](https://github.com/clash-lang/clash-compiler/pull/2592) + +Internal changes: + +* `Clash.Primitives.DSL.boolFromBit` is now polymorphic in its HDL backend. [#2202](https://github.com/clash-lang/clash-compiler/pull/2202) +* `Clash.Primitives.DSL.unsignedFromBitVector` is now polymorphic in its HDL backend. [#2202](https://github.com/clash-lang/clash-compiler/pull/2202) +* `Clash.Primitives.DSL.fromBV` now converts some `BitVector` expression into some type. [#2202](https://github.com/clash-lang/clash-compiler/pull/2202) +* Add `CompDecl` to `Clash.Netlist.Types.Declaration` to accomodate VHDL's `component` declarations. +* Black box functions declare their usage, necessary for implicit netlist usage analysis implemented in [#2230](https://github.com/clash-lang/clash-compiler/pull/2230) +* Added `showsTypePrec` to `TermLiteral` to make `TermLiteral SNat` work as expected. Deriving an instance is now a bit simpler. Instances which previously had to be defined as: + + ```haskell + instance TermLiteral Bool where + termToData = $(deriveTermToData ''Bool) + ``` + + can now be defined using: + + ```haskell + deriveTermLiteral ''Bool + ``` + [#2329](https://github.com/clash-lang/clash-compiler/pull/2329) + ## 1.6.6 *Oct 2nd 2023* -* Support Aeson 2.2 [#2578](https://github.com/clash-lang/clash-compiler/pull/2578) -* Drop the snap package [#2439](https://github.com/clash-lang/clash-compiler/pull/2439) +* Support Aeson 2.2 +* Dropped the snap package The Clash snap package has not been a recommended way to use Clash for quite some time, and it is a hassle to support. @@ -63,7 +202,6 @@ Internal change: * Clash now always generates non-extended identifiers for port names, so that generated names play nicer with different vendor tools. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142) * Top entity name available in netlist context. Top entity name used in generated name for include files. [#2146](https://github.com/clash-lang/clash-compiler/pull/2146) - ## 1.6.2 *Feb 25th 2022* Fixed: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,9 +10,8 @@ Features of Clash: - * Strongly typed (like VHDL), yet with a very high degree of type inference, - enabling both safe and fast prototying using consise descriptions (like - Verilog). + * Strongly typed, but with a very high degree of type inference, enabling both + safe and fast prototyping using concise descriptions. * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.6.6 +Version: 1.8.0 Synopsis: Clash: a functional hardware description language - As a library Description: Clash is a functional hardware description language that borrows both its @@ -51,7 +51,7 @@ Maintainer: QBayLogic B.V. Copyright: Copyright © 2012-2016, University of Twente, 2016-2019, Myrtle Software Ltd, - 2017-2019, QBayLogic B.V., Google Inc. + 2017-2023, QBayLogic B.V., Google Inc. Category: Hardware Build-type: Simple @@ -61,6 +61,7 @@ src/ClashDebug.h Data-files: + data-files/tcl/clashConnector.tcl prims/common/*.primitives.yaml, prims/commonverilog/*.primitives.yaml, prims/verilog/*.primitives.yaml, @@ -84,6 +85,18 @@ default: True manual: True +flag doctests + description: + You can disable testing with doctests using `-f-doctests`. + default: True + manual: True + +flag workaround-ghc-mmap-crash + description: + Only use this flag when hit by GHC bug #19421. See clash-compiler PR #2444. + default: False + manual: True + common common-options default-language: Haskell2010 default-extensions: BangPatterns @@ -100,6 +113,7 @@ InstanceSigs KindSignatures NoStarIsType + PostfixOperators ScopedTypeVariables StandaloneDeriving TupleSections @@ -129,7 +143,7 @@ Build-depends: aeson >= 0.6.2.0 && < 2.3, attoparsec-aeson >= 2.1 && < 2.3, aeson-pretty >= 0.8 && < 0.9, - ansi-terminal >= 0.8.0.0 && < 0.12, + ansi-terminal >= 0.8.0.0 && < 1.1, array, async >= 2.2.0 && < 2.3, attoparsec >= 0.10.4.0 && < 0.15, @@ -137,31 +151,33 @@ base16-bytestring >= 0.1.1 && < 1.1, binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.12, - clash-prelude == 1.6.6, + clash-prelude == 1.8.0, concurrent-supply >= 0.1.7 && < 0.2, containers >= 0.5.0.0 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.7 && < 0.8, - deepseq >= 1.3.0.2 && < 1.5, + deepseq >= 1.3.0.2 && < 1.6, dlist >= 0.8 && < 1.1, directory >= 1.2.0.1 && < 1.4, exceptions >= 0.8.3 && < 0.11.0, extra >= 1.6.17 && < 1.8, filepath >= 1.3.0.1 && < 1.5, - ghc >= 8.6.0 && < 9.1, + ghc >= 8.6.0 && < 9.9, ghc-boot-th, hashable >= 1.2.1.0 && < 1.5, haskell-src-meta >= 0.8 && < 0.9, hint >= 0.7 && < 0.10, - interpolate >= 0.2.0 && < 1.0, + infinite-list ^>= 0.1, lens >= 4.10 && < 5.3, - mtl >= 2.1.2 && < 2.3, + mtl >= 2.1.2 && < 2.4, ordered-containers >= 0.2 && < 0.3, prettyprinter >= 1.2.0.1 && < 1.8, + prettyprinter-interp ^>= 0.2, pretty-show >= 1.9 && < 2.0, primitive >= 0.5.0.1 && < 1.0, - template-haskell >= 2.8.0.0 && < 2.18, + string-interpolate ^>= 0.3, + template-haskell >= 2.8.0.0 && < 2.22, temporary >= 1.2.1 && < 1.4, terminal-size >= 0.3 && < 0.4, text >= 1.2.2 && < 2.1, @@ -173,8 +189,11 @@ unordered-containers >= 0.2.3.3 && < 0.3, yaml >= 0.11 && < 0.12, + if impl(ghc < 9.4.0) + build-depends: + if impl(ghc >= 9.0.0) - build-depends: ghc-bignum >=1.0 && <1.3 + build-depends: ghc-bignum >=1.0 && <1.4 else build-depends: integer-gmp >=1.0 && <1.1 @@ -185,6 +204,7 @@ Clash.Backend Clash.Backend.SystemVerilog Clash.Backend.Verilog + Clash.Backend.Verilog.Time Clash.Backend.VHDL Clash.Core.DataCon @@ -212,6 +232,10 @@ Clash.Core.Var Clash.Core.VarEnv + Clash.Data.UniqMap + + Clash.DataFiles + Clash.Debug Clash.Driver @@ -225,6 +249,7 @@ Clash.Netlist.BlackBox.Parser Clash.Netlist.BlackBox.Types Clash.Netlist.BlackBox.Util + Clash.Netlist.Expr Clash.Netlist.Id Clash.Netlist.Id.Common Clash.Netlist.Id.Internal @@ -258,14 +283,17 @@ Clash.Primitives.Types Clash.Primitives.Util + Clash.Primitives.Annotations.SynthesisAttributes Clash.Primitives.GHC.Int Clash.Primitives.GHC.Literal Clash.Primitives.GHC.Word Clash.Primitives.Intel.ClockGen + Clash.Primitives.Magic Clash.Primitives.Sized.ToInteger Clash.Primitives.Sized.Signed Clash.Primitives.Sized.Vector Clash.Primitives.Verification + Clash.Primitives.Xilinx.ClockGen Clash.Rewrite.Combinators Clash.Rewrite.Types @@ -288,6 +316,9 @@ -- Used in clash-cores Data.Text.Prettyprint.Doc.Extra + -- Used in clash-ghc + GHC.BasicTypes.Extra + Other-Modules: Clash.Annotations.TopEntity.Extra Data.IntMap.Extra Data.List.Extra @@ -296,7 +327,6 @@ Data.Primitive.ByteArray.Extra Data.Set.Ordered.Extra Data.Text.Extra - GHC.BasicTypes.Extra GHC.SrcLoc.Extra Paths_clash_lib @@ -320,12 +350,49 @@ GHC-Options: -Wall -Wcompat default-language: Haskell2010 +executable static-files + Main-Is: tools/static-files.hs + Build-Depends: + base, + clash-lib, + directory, + docopt ^>= 0.7, + extra, + filepath + GHC-Options: -Wall -Wcompat + default-language: Haskell2010 + if impl(ghc >= 9.2.0) + buildable: False + + +test-suite doctests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: doctests.hs + ghc-options: -Wall -Wcompat -threaded + hs-source-dirs: tests + + if !flag(doctests) + buildable: False + else + build-depends: + base, + clash-lib, + doctest-parallel >= 0.2 && < 0.4, + filepath + test-suite unittests import: common-options type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: unittests.hs - ghc-options: -Wall -Wcompat -threaded -with-rtsopts=-N + ghc-options: -Wall -Wcompat -threaded + -- Note that multiple -with-rtsopts are not cumulative, so we can't add the + -- common RTS options in the unconditional GHC-Options + if flag(workaround-ghc-mmap-crash) + GHC-Options: "-with-rtsopts=-N -xm20000000" + else + GHC-Options: -with-rtsopts=-N hs-source-dirs: tests if !flag(unittests) @@ -352,9 +419,10 @@ lens, pretty-show, quickcheck-text, - tasty >= 1.2 && < 1.5, + tasty >= 1.2 && < 1.6, tasty-hunit, tasty-quickcheck, + tasty-th, template-haskell, text, transformers, @@ -362,6 +430,8 @@ Other-Modules: Clash.Tests.Core.FreeVars Clash.Tests.Core.Subst + Clash.Tests.Core.TermLiteral + Clash.Tests.Core.TermLiteral.Types Clash.Tests.Driver.Manifest Clash.Tests.Netlist.Id Clash.Tests.Util.Interpolate diff --git a/data-files/tcl/clashConnector.tcl b/data-files/tcl/clashConnector.tcl new file mode 100644 --- /dev/null +++ b/data-files/tcl/clashConnector.tcl @@ -0,0 +1,606 @@ +# Copyright : (C) 2021-2022, QBayLogic B.V., +# 2022 , Google Inc., +# License : BSD2 (see the file LICENSE) +# Maintainer : QBayLogic B.V. +# +# Script to parse output generated by Clash to use in the synthesis tool. +# +# TODO: More user documentation + +package require json + +namespace eval clash { + variable metadata {} + variable topEntity + + # Set verbosity level. Range is 0-4, where 0 means "silent". Example: + # set clash::verbosity 3 + variable verbosity 1 + + # Dry run can be enabled by + # set clash::dryRun true + variable dryRun false + + # Invoke with $topEntityDir set to the path where the manifest file of + # your top entity is. Read all the metadata generated by Tcl: manifests + # and Tcl interface scripts, for the top entity and its dependencies. + proc readMetadata topEntityDir { + variable metadata + variable topEntity + + # If we are called multiple times, we will remove the results of + # earlier invocations. + set metadata [dict create] + if {[namespace exists tclIface]} { + namespace delete tclIface + } + + set topEntity [ParseManifest $topEntityDir true] + Log 1 "Top entity is $topEntity" + return + } + + # Issue "read_vhdl" / "read_verilog" for all HDL files generated by Clash + proc readHdl {} { + variable metadata + variable topEntity + + CheckMetadataExists + set libs [dict get $metadata $topEntity dependencies] + lappend libs $topEntity + foreach lib $libs { + foreach hdlFile [dict get $metadata $lib hdlFiles] { + if {[string match {*.vhdl} $hdlFile]} { + PerformAction { + read_vhdl -library } -var lib { } -var hdlFile + } elseif {[string match {*.v} $hdlFile]} { + PerformAction { + read_verilog } -var hdlFile + } elseif {[string match {*.sv} $hdlFile]} { + PerformAction { + read_verilog -sv } -var hdlFile + } else { + error "Error: Unknown extension on HDL file $hdlFile" + } + } + } + return + } + + # Issue "read_xdc" for all constraint files generated by Clash for the top + # entity, and all constraint files managed by the Clash<->Tcl API (not just + # for the top entity, but for all libraries). + proc readXdc orders { + variable metadata + variable topEntity + + CheckMetadataExists + foreach order $orders { + if {$order ni {early normal late}} { + error "Error: readXdc: Invalid order $order" + } + } + unset order + + set early {} + set normal {} + set late {} + foreach tclIface [GetAllTclIfaces {purposes readXdc}] { + namespace upvar ${tclIface} order order + lappend $order $tclIface + } + + if {{early} in $orders} { + foreach tclIface $early { + ReadManagedXdc $tclIface + } + } + if {{normal} in $orders} { + ReadUnmanagedXdc + foreach tclIface $normal { + ReadManagedXdc $tclIface + } + } + if {{late} in $orders} { + foreach tclIface $late { + ReadManagedXdc $tclIface + } + } + return + } + + # Invoke all Clash-generated Tcl interfaces that specify a "createIp" + # purpose, which will call Vivado's "create_ip" with any additional + # arguments passed to this function (hint: "createIp -dir yourdir" will + # create the IP in the subdirectory named "yourdir"). Following that, the + # IP is configured. + # + # Also see "createAndReadIp" below; call it or use its code as + # inspiration. It is suggested to call it like "createAndReadIp -dir ip" + # so you keep the files in a separate directory named "ip". The directory + # will need to exist already. + proc createIp args { + CheckMetadataExists + # Identical names means identical IP, only one run needed even if it + # occurs in multiple HDL directories. + set seen {} + foreach tclIface [GetAllTclIfaces {purposes createIp}] { + namespace upvar ${tclIface} ipName ipName + if {$ipName in $seen} { + continue + } + PerformAction -var tclIface {::createIp } -var ipName { } \ + -varexpand args + LogProc 3 { } ${tclIface}::createIp + lappend seen $ipName + } + return $seen + } + + # Convenience method to create the IP in a temporary in-memory project and + # then read in the results in non-project mode. Finally, targets are + # created for the IP. + # + # NOTE WELL: since this switches into and out of project mode, it should + # probably be the very first thing you call in setting up the design. + proc createAndReadIp args { + CheckMetadataExists + if {![llength [GetAllTclIfaces {purposes createIp}]]} { + return + } + PerformAction { + create_project -in_memory + } + set ips [createIp {*}$args] + PerformAction { + set ipFiles [get_property IP_FILE [get_ips } -var ips {]] + close_project + read_ip $ipFiles + set_property GENERATE_SYNTH_CHECKPOINT false [get_files $ipFiles] + generate_target {synthesis simulation} [get_ips } -var ips {] + } + return + } + + #--------------------------------------------------------------------------- + # Private definitions + #--------------------------------------------------------------------------- + + proc Log {level msg} { + variable verbosity + + if {$verbosity >= $level} { + puts "Clash \[$level\]: $msg" + } + return + } + + proc LogDry {level msg} { + variable dryRun + + if {$dryRun} { + puts "Clash \[$level\]: \[DRY-RUN\] $msg" + } else { + Log $level $msg + } + return + } + + # Remove leading and trailing lines with just spaces + proc TrimLines msg { + return [regsub {^( *\n)*(.*?)\n?( *\n?)*$} $msg {\2}] + } + + proc GetCommonIndent msg { + set indent -1 + foreach line [split $msg \n] { + regexp -indices {^ *} $line blanks + if {[lindex $blanks 1] == [string length $line] - 1} { + # Empty line or line of all blanks; ignore + continue + } + set leader [expr {[lindex $blanks 1] - [lindex $blanks 0] + 1}] + if {$indent < 0 || $leader < $indent} { + set indent $leader + } + } + if {$indent < 0} { + return 0 + } + return $indent + } + + proc LogProc {level leader procName} { + Log $level "${leader}proc [namespace tail $procName]\ + {[info args $procName]} \{" + set body [TrimLines [info body $procName]] + set outdent [GetCommonIndent $body] + foreach line [split $body \n] { + Log $level "$leader [string range $line $outdent end]" + } + Log $level $leader\} + return + } + + proc PerformAction args { + variable dryRun + + set action {} + set trace {} + set argsLen [llength $args] + for {set i 0} {$i < $argsLen} {incr i} { + set fragment [lindex $args $i] + if {$fragment ni {-var -varexpand}} { + set action $action$fragment + set trace $trace$fragment + continue + } + incr i + if {$i == $argsLen} { + error "Error: $fragment requires an argument" + } + set varName [lindex $args $i] + upvar $varName var + switch $fragment { + -var { + set action "$action\${$varName}" + set trace $trace$var + } + -varexpand { + set action "$action{*}\${$varName}" + set trace $trace$var + } + } + } + set trace [TrimLines $trace] + set outdent [GetCommonIndent $trace] + foreach line [split $trace \n] { + LogDry 2 [string range $line $outdent end] + } + if {$dryRun} { + return + } + catch { + uplevel 1 $action + } msg opts + dict incr opts -level + return {*}$opts $msg + } + + proc WriteIntVar {def gname name1 _name2 _op} { + upvar $name1 var + if {![string is integer -strict $var]} { + set var $def + error "Error: $gname: Only integer values are accepted;\ + reset to default: $def" + } + return + } + + proc WriteBoolVar {def gname name1 _name2 _op} { + upvar $name1 var + if {![string is boolean -strict $var]} { + set var $def + error "Error: $gname: Only {0 1 false true no yes off on} are\ + accepted; reset to default: $def" + } + return + } + + proc TraceWrite {varName cmd args} { + set ns [namespace current] + set commandPrefix [linsert $args 0 ${ns}::$cmd] + lappend commandPrefix ${ns}::$varName + uplevel 1 [list trace remove variable $varName write $commandPrefix] + uplevel 1 [list trace add variable $varName write $commandPrefix] + return + } + + proc CheckMetadataExists {} { + variable metadata + if {![dict size $metadata]} { + error "Error: Please invoke clash::readMetadata first." + } + return + } + + proc GetNsVar {ns varName} { + if {![llength [uplevel 1 [list info vars ${ns}::$varName]]]} { + error "Error: $ns doesn't provide \"$varName\"\ + variable." + } + return [uplevel 1 [list set ${ns}::$varName]] + } + + proc ParseManifest {entityDir withDeps} { + variable metadata + + set manC [open [file join $entityDir clash-manifest.json] r] + set manifest [json::json2dict [read $manC]] + close $manC + set lib [dict get $manifest top_component name] + Log 1 "New top component: $lib" + # Clash sometimes lists files multiple times, process them only once + set seen {} + set topConstraintName [file join $entityDir "${lib}.sdc"] + dict set metadata $lib hdlFiles {} + dict set metadata $lib constraintFiles {} + foreach fileEntry [dict get $manifest files] { + set name [file join $entityDir [dict get $fileEntry name]] + if {$name in $seen} { + continue + } + lappend seen $name + if {$name eq $topConstraintName} { + dict set metadata $lib topConstraintFile $name + } elseif { + [string match {*.vhdl} $name] + || [string match {*.v} $name] + || [string match {*.sv} $name] + } then { + Log 3 "Adding HDL file: $name" + dict with metadata $lib { + lappend hdlFiles $name + } + } elseif { + [string match {*.sdc} $name] + || [string match {*.xdc} $name] + } then { + Log 3 "Adding constraint file: $name" + dict with metadata $lib { + lappend constraintFiles $name + } + } elseif {[string match {*.clash.tcl} $name]} { + Log 3 "Adding Clash<->Tcl API file: $name" + LoadTclIface $lib $name + } + } + RemoveManagedFiles $lib + + if {!$withDeps} { + return $lib + } + + set dependencies {} + foreach dependency [dict get $manifest dependencies transitive] { + set dependencyDir [file join [file dirname $entityDir] $dependency] + lappend dependencies [ParseManifest $dependencyDir false] + } + dict set metadata $lib dependencies $dependencies + return $lib + } + + # Populate a namespace with a Clash-generated Tcl interface. + # Namespace is clash::tclIface::${lib}::$baseName + proc LoadTclIface {lib tclIfaceFile} { + set fileName [file tail $tclIfaceFile] + # Strip all extensions + set baseName [string range $fileName 0 [string first . $fileName]-1] + set tclIface [namespace current]::tclIface::${lib}::$baseName + # Evaluate script code inside temporary throwaway namespace to + # separate its code from ours and reduce the chance of accidentally + # corrupting our code. + namespace eval tmp {} + set tmp::tclIfaceFile $tclIfaceFile + set tmp::tclIface $tclIface + namespace eval tmp { + # -notrace is a Vivado specific option inhibiting the printing of + # the script to stdout + source -notrace $tclIfaceFile + } + if {![namespace exists $tclIface]} { + error "Error: $tclIfaceFile did not create the requested namespace\ + specified by the \$tclIface variable. The Tcl script does\ + not conform to the defined Clash<->Tcl API." + } + namespace delete tmp + VerifyTclIface $tclIface $tclIfaceFile true + return + } + + # Verify that the read interface file is strictly something we support. + proc VerifyTclIface {tclIface tclIfaceFile isRoot} { + set api [GetNsVar $tclIface api] + if {$api ne {1}} { + error "Error: $tclIface doesn't implement an API we support:\ + api = \"$api\"." + } + set purpose [GetNsVar $tclIface scriptPurpose] + Log 3 " API level / purpose: $api/$purpose" + if {$purpose eq {multipleScripts}} { + if {!$isRoot} { + error "Error: ${tclIface}::scriptPurpose = \"multipleScripts\",\ + nested use not allowed." + } + if {![namespace exists ${tclIface}::multipleScripts]} { + error "Error: ${tclIface}::multipleScripts does not exist." + } + set children [namespace children ${tclIface}::multipleScripts] + if {![llength $children]} { + error "Error: ${tclIface}::multipleScripts doesn't provide any\ + scripts." + } + foreach child $children { + if {[llength [info vars ${child}::api]]} { + error "Error: $child cannot specify api: it is specified by\ + parent script." + } + set ${child}::api $api + VerifyTclIface $child $tclIfaceFile false + } + + } elseif {$purpose eq {createIp}} { + Log 3 " IP name: [GetNsVar $tclIface ipName]" + # In Tcl, you can call procedures with a partial name. So an + # invocation of "createIp" could call "createIpAlt" if + # "createIp" did not exist. Let's be strict here to prevent + # confusion: only accept the exact name "createIp". + if {![llength [info procs ${tclIface}::createIp]]} { + error "Error: $tclIface doesn't provide \"createIp\"\ + procedure." + } + LogProc 4 { } ${tclIface}::createIp + + } elseif {$purpose eq {readXdc}} { + set order [GetNsVar $tclIface order] + if {$order ni {early normal late}} { + error "Error: ${tclIface}::order bogus value \"$order\"." + } + set usedIn [GetNsVar $tclIface usedIn] + foreach stage $usedIn { + if {$stage ni {synthesis implementation}} { + error "Error: ${tclIface}::usedIn bogus value \"$stage\"." + } + } + set xdcFile [GetNsVar $tclIface xdcFile] + # "file join" also correctly handles an absolute $xdcFile + set resolvedFile [file join [file dirname $tclIfaceFile] $xdcFile] + # "file isfile" also positively matches a symlink to a regular + # file + if {![file isfile $resolvedFile]} { + error "Error: ${tclIface}::xdcFile = \"$xdcFile\" does not\ + refer to an existing file." + } + set ${tclIface}::xdcFile $resolvedFile + Log 3 " Constraint file: $resolvedFile" + Log 4 " Order: $order" + if {[llength [info vars ${tclIface}::scopeRef]]} { + namespace upvar ${tclIface} scopeRef scopeRef + Log 4 " Scoped to ref: $scopeRef" + } + Log 4 " Used in: $usedIn" + + } else { + error "Error: ${tclIface}::scriptPurpose bogus value \"$purpose\"." + } + return + } + + # Remove constraint files that are managed by a Tcl interface script from + # the list of constraint files for the library. + proc RemoveManagedFiles lib { + variable metadata + + foreach tclIface [GetAllTclIfaces {libs $lib purposes readXdc}] { + namespace upvar ${tclIface} xdcFile xdcFile + set constraintFiles [dict get $metadata $lib constraintFiles] + if {[lsearch -exact $constraintFiles $xdcFile] >= 0} { + Log 3 "Marking as managed by the Clash<->Tcl API: $xdcFile" + set filtered [lsearch -all -inline -exact -not \ + $constraintFiles $xdcFile] + dict set metadata $lib constraintFiles $filtered + } + } + return + } + + # Return all the Tcl interface namespaces + # + # They can optionally be filtered by specifying a list of libraries to + # consider, a list of interface names to consider, or a list of script + # purposes to consider. The sole argument of the function is a dictionary of + # options, with the possible keys "libs", "ifaces" and "purposes". + # + # For example, if these two interfaces exist: + # - ::clash::tclIface::libA::ifaceX + # - ::clash::tclIface::libB::ifaceX + # + # Then "GetAllTclIfaces {libs libA}" would only return the first, but + # "GetAllTclIfaces {ifaces ifaceX}" would return both since the interface + # names both match. + proc GetAllTclIfaces {{opts {}}} { + if {![namespace exists tclIface]} { + # There are no scripts + return + } + + if {[dict exists $opts libs]} { + set walkLibs {} + foreach lib [dict get $opts libs] { + if {[namespace exists tclIface::$lib]} { + lappend walkLibs tclIface::$lib + } + } + } else { + set walkLibs [namespace children tclIface] + } + set tclIfaces {} + set hasIfaces [dict exists $opts ifaces] + if {$hasIfaces} { + set ifaces [dict get $opts ifaces] + } + set hasPurposes [dict exists $opts purposes] + if {$hasPurposes} { + set purposes [dict get $opts purposes] + } + foreach libNs $walkLibs { + foreach tclIface [namespace children $libNs] { + if {$hasIfaces && [namespace tail $tclIface] ni $ifaces} { + continue + } + namespace upvar ${tclIface} scriptPurpose purpose + if {$purpose ne {multipleScripts}} { + if {(!$hasPurposes) || $purpose in $purposes} { + lappend tclIfaces $tclIface + } + continue + } + set childIfaces \ + [namespace children ${tclIface}::multipleScripts] + foreach childIface $childIfaces { + namespace upvar ${childIface} scriptPurpose purpose + if {(!$hasPurposes) || $purpose in $purposes} { + lappend tclIfaces $childIface + } + } + } + } + return $tclIfaces + } + + # If Clash generates constraint files without an accompanying tclIface, they + # fall into two categories. Given $lib as the name of the top component in a + # library, ${lib}.sdc contains the "create_clock" statements. We only read + # that for the top entity. All other constraint files are passed to Vivado + # as-is and should match on unique identifiers in the HDL, such that they + # can be read for all libraries without worrying about `current_instance` or + # similar scoping mechanisms. + proc ReadUnmanagedXdc {} { + variable metadata + variable topEntity + + if {[dict exists $metadata $topEntity topConstraintFile]} { + set topConstraintFile \ + [dict get $metadata $topEntity topConstraintFile] + PerformAction { + read_xdc } -var topConstraintFile + } + set libs [dict get $metadata $topEntity dependencies] + lappend libs $topEntity + foreach lib $libs { + set constraintFiles [dict get $metadata $lib constraintFiles] + foreach constraintFile $constraintFiles { + PerformAction { + read_xdc } -var constraintFile + } + } + } + + proc ReadManagedXdc tclIface { + namespace upvar $tclIface xdcFile xdcFile usedIn usedIn + if {[llength [info vars ${tclIface}::scopeRef]]} { + namespace upvar ${tclIface} scopeRef scopeRef + set scopeRefArg [list -ref $scopeRef] + } else { + set scopeRefArg {} + } + PerformAction { + read_xdc } -varexpand scopeRefArg { } -var xdcFile { + set_property USED_IN } -var usedIn { [get_files } -var xdcFile {] + } + return + } + + TraceWrite verbosity WriteIntVar 1 + TraceWrite dryRun WriteBoolVar false +} diff --git a/prims/common/Clash_Explicit_Signal.primitives.yaml b/prims/common/Clash_Explicit_Signal.primitives.yaml --- a/prims/common/Clash_Explicit_Signal.primitives.yaml +++ b/prims/common/Clash_Explicit_Signal.primitives.yaml @@ -3,9 +3,22 @@ kind: Expression type: |- veryUnsafeSynchronizer - :: Int -- ARG[0] - -> Int -- ARG[1] - -> Signal dom1 a -- ARG[2] + :: Either Int (Signal dom1 Int) -- ARG[0] + -> Either Int (Signal dom2 Int) -- ARG[1] + -> Signal dom1 a -- ARG[2] -> Signal dom2 a template: ~ARG[2] + workInfo: Never +- BlackBox: + name: Clash.Explicit.Signal.unsafeSynchronizer + kind: Expression + type: |- + unsafeSynchronizer + :: ( KnownDomain dom1 -- ARG[0] + , KnownDomain dom2 ) -- ARG[1] + => Clock dom1 -- ARG[2] + -> Clock dom2 -- ARG[3] + -> Signal dom1 a -- ARG[4] + -> Signal dom2 a + template: ~ARG[4] workInfo: Never diff --git a/prims/common/Clash_Intel_ClockGen.primitives.yaml b/prims/common/Clash_Intel_ClockGen.primitives.yaml --- a/prims/common/Clash_Intel_ClockGen.primitives.yaml +++ b/prims/common/Clash_Intel_ClockGen.primitives.yaml @@ -1,5 +1,5 @@ - BlackBox: - name: Clash.Intel.ClockGen.altpll + name: Clash.Intel.ClockGen.unsafeAltpll format: Haskell includes: - name: altpll @@ -10,7 +10,7 @@ templateFunction: Clash.Primitives.Intel.ClockGen.altpllTF workInfo: Always - BlackBox: - name: Clash.Intel.ClockGen.alteraPll + name: Clash.Intel.ClockGen.unsafeAlteraPll format: Haskell includes: - name: altera_pll diff --git a/prims/common/Clash_Magic.primitives.yaml b/prims/common/Clash_Magic.primitives.yaml --- a/prims/common/Clash_Magic.primitives.yaml +++ b/prims/common/Clash_Magic.primitives.yaml @@ -16,3 +16,9 @@ - Primitive: name: Clash.Magic.setName primType: Function +- BlackBox: + name: Clash.Magic.SimOnly + kind: Expression + type: 'SimOnly :: a -> SimOnly a' + template: ~ERRORO + workInfo: Constant diff --git a/prims/common/Clash_XException.primitives.yaml b/prims/common/Clash_XException.primitives.yaml --- a/prims/common/Clash_XException.primitives.yaml +++ b/prims/common/Clash_XException.primitives.yaml @@ -22,8 +22,7 @@ - BlackBox: name: Clash.XException.deepseqX kind: Expression - type: 'deepseqX :: Undefined - a => a -> b -> b' + type: 'deepseqX :: NFDataX a => a -> b -> b' template: ~ARG[2] workInfo: Never - BlackBox: diff --git a/prims/common/Clash_Xilinx_ClockGen.primitives.yaml b/prims/common/Clash_Xilinx_ClockGen.primitives.yaml new file mode 100644 --- /dev/null +++ b/prims/common/Clash_Xilinx_ClockGen.primitives.yaml @@ -0,0 +1,22 @@ +- BlackBox: + name: Clash.Xilinx.ClockGen.unsafeClockWizard + kind: Declaration + format: Haskell + templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardTF + includes: + - name: clk_wiz + extension: clash.tcl + format: Haskell + templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardTclTF + workInfo: Always +- BlackBox: + name: Clash.Xilinx.ClockGen.unsafeClockWizardDifferential + kind: Declaration + format: Haskell + templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardDifferentialTF + includes: + - name: clk_wiz + extension: clash.tcl + format: Haskell + templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardDifferentialTclTF + workInfo: Always diff --git a/prims/common/GHC_Prim.primitives.yaml b/prims/common/GHC_Prim.primitives.yaml --- a/prims/common/GHC_Prim.primitives.yaml +++ b/prims/common/GHC_Prim.primitives.yaml @@ -18,20 +18,84 @@ Int# -> Int#' template: ~ARG[0] + ~ARG[1] - BlackBox: + name: GHC.Prim.plusInt8# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusInt16# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusInt32# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusInt64# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: name: GHC.Prim.-# kind: Expression type: '(-#) :: Int# -> Int# -> Int#' template: ~ARG[0] - ~ARG[1] - BlackBox: + name: GHC.Prim.subInt8# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subInt16# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subInt32# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subInt64# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: name: GHC.Prim.plusWord# kind: Expression type: 'plusWord# :: Word# -> Word# -> Word#' template: ~ARG[0] + ~ARG[1] - BlackBox: + name: GHC.Prim.plusWord8# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusWord16# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusWord32# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: + name: GHC.Prim.plusWord64# + kind: Expression + template: ~ARG[0] + ~ARG[1] +- BlackBox: name: GHC.Prim.minusWord# kind: Expression type: 'minusWord# :: Word# -> Word# -> Word#' + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subWord8# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subWord16# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subWord32# + kind: Expression + template: ~ARG[0] - ~ARG[1] +- BlackBox: + name: GHC.Prim.subWord64# + kind: Expression template: ~ARG[0] - ~ARG[1] diff --git a/prims/common/GHC_Prim_Panic.primitives.yaml b/prims/common/GHC_Prim_Panic.primitives.yaml new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Prim_Panic.primitives.yaml @@ -0,0 +1,7 @@ +- BlackBox: + name: GHC.Prim.Panic.absentError + kind: Expression + type: 'absentError :: + Addr# -> a' + template: ~ERRORO + workInfo: Constant diff --git a/prims/common/GHC_TypeNats.primitives.yaml b/prims/common/GHC_TypeNats.primitives.yaml --- a/prims/common/GHC_TypeNats.primitives.yaml +++ b/prims/common/GHC_TypeNats.primitives.yaml @@ -7,6 +7,11 @@ workInfo: Never - Primitive: name: GHC.TypeNats.someNatVal - primType: Functions + primType: Function type: 'someNatVal :: Natural -> SomeNat' + workInfo: Never +- Primitive: + name: GHC.TypeNates.withSomeSNat + primType: Function + type: 'withSomeSNat :: forall rep (r :: TYPE rep). Natural -> (forall n. SNat n -> r) -> r' workInfo: Never diff --git a/prims/common/GHC_Types.primitives.yaml b/prims/common/GHC_Types.primitives.yaml --- a/prims/common/GHC_Types.primitives.yaml +++ b/prims/common/GHC_Types.primitives.yaml @@ -2,3 +2,17 @@ name: GHC.Types.MkCoercible primType: Constructor workInfo: Never +- BlackBox: + name: GHC.Types.I# + kind: Expression + comment: Needed to make the evaluator handle this constructor strictly + type: 'I# :: Int# -> Int' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: GHC.Types.W# + kind: Expression + comment: Needed to make the evaluator handle this constructor strictly + type: 'W# :: Word# -> Word' + template: ~ARG[0] + workInfo: Never diff --git a/prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml b/prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml --- a/prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml +++ b/prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml @@ -29,6 +29,7 @@ name: Clash.Explicit.SimIO.writeReg kind: Declaration renderVoid: RenderVoid + outputUsage: Blocking template: ~ARG[0] = ~ARG[1]; - BlackBox: name: Clash.Explicit.SimIO.openFile @@ -51,6 +52,7 @@ - BlackBox: name: Clash.Explicit.SimIO.getLine kind: Declaration + outputUsage: Blocking template: ~RESULT = $fgets(~ARG[2],~ARG[1]); - BlackBox: name: Clash.Explicit.SimIO.isEOF @@ -64,10 +66,12 @@ - BlackBox: name: Clash.Explicit.SimIO.seek kind: Declaration + outputUsage: Blocking template: ~RESULT = $fseek(~ARG[0],~ARG[1],~ARG[2]); - BlackBox: name: Clash.Explicit.SimIO.rewind kind: Declaration + outputUsage: Blocking template: ~RESULT = $rewind(~ARG[0]); - BlackBox: name: Clash.Explicit.SimIO.tell diff --git a/prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml b/prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml --- a/prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml +++ b/prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml @@ -5,3 +5,7 @@ Enable dom' template: assign ~RESULT = 1'b1; workInfo: Always +- BlackBox: + name: Clash.Explicit.Testbench.clockToDiffClock + kind: Expression + template: '{~ARG[1], ~ ~ARG[1]}' diff --git a/prims/commonverilog/Clash_Signal_Internal.primitives.yaml b/prims/commonverilog/Clash_Signal_Internal.primitives.yaml --- a/prims/commonverilog/Clash_Signal_Internal.primitives.yaml +++ b/prims/commonverilog/Clash_Signal_Internal.primitives.yaml @@ -9,6 +9,6 @@ name: Clash.Signal.Internal.unsafeToReset kind: Expression type: 'unsafeToReset :: - Signal dom Bool -> Reset dom' - template: ~ARG[0] + KnownDomain dom => Signal dom Bool -> Reset dom' + template: ~ARG[1] workInfo: Never diff --git a/prims/commonverilog/Clash_Xilinx_ClockGen.primitives.yaml b/prims/commonverilog/Clash_Xilinx_ClockGen.primitives.yaml deleted file mode 100644 --- a/prims/commonverilog/Clash_Xilinx_ClockGen.primitives.yaml +++ /dev/null @@ -1,42 +0,0 @@ -- BlackBox: - name: Clash.Xilinx.ClockGen.clockWizard - kind: Declaration - type: |- - clockWizard - :: ( KnownDomain domIn confIn -- ARG[0] - , KnownDomain domOut confOut ) -- ARG[1] - => SSymbol name -- ARG[2] - -> Clock pllIn -- ARG[3] - -> Reset pllIn -- ARG[4] - -> (Clock pllOut, Enable pllOut) - template: |- - // clockWizard begin - ~NAME[2] ~GENSYM[clockWizard_inst][2] - (.CLK_IN1 (~ARG[3]) - ,.RESET (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI ~ARG[4]) - ,.CLK_OUT1 (~RESULT[1]) - ,.LOCKED (~RESULT[0])); - // clockWizard end - workInfo: Always -- BlackBox: - name: Clash.Xilinx.ClockGen.clockWizardDifferential - kind: Declaration - type: |- - clockWizardDifferential - :: ( KnownDomain domIn confIn -- ARG[0] - , KnownDomain domOut confOut ) -- ARG[1] - :: SSymbol name -- ARG[2] - -> Clock pllIn -- ARG[3] - -> Clock pllIn -- ARG[4] - -> Reset pllIn -- ARG[5] - -> (Clock pllOut, Enable pllOut) - template: |- - // clockWizardDifferential begin - ~NAME[2] ~GENSYM[clockWizardDifferential_inst][2] - (.CLK_IN1_D_clk_n (~ARG[3]) - ,.CLK_IN1_D_clk_n (~ARG[4]) - ,.RESET (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI ~ARG[5]) - ,.CLK_OUT1 (~RESULT[1]) - ,.LOCKED (~RESULT[0])); - // clockWizardDifferential end - workInfo: Always diff --git a/prims/commonverilog/GHC_Num_Integer.primitives.yaml b/prims/commonverilog/GHC_Num_Integer.primitives.yaml --- a/prims/commonverilog/GHC_Num_Integer.primitives.yaml +++ b/prims/commonverilog/GHC_Num_Integer.primitives.yaml @@ -173,6 +173,14 @@ but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: + name: GHC.Num.Integer.integerToInt64# + kind: Expression + type: 'integerToInt64#:: Integer -> Int64#' + template: ~ARG[0] + warning: 'GHC.Num.Integer.integerToInt64#: Integers are dynamically sized in + simulation, but fixed-length after synthesis. Use carefully.' + workInfo: Never +- BlackBox: name: GHC.Num.Integer.integerToWord64# comment: only used by 32 bit GHC kind: Declaration @@ -183,6 +191,14 @@ simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: + name: GHC.Num.Integer.integerFromWord64# + kind: Declaration + type: 'integerFromWord64# :: Word64# -> Integer' + template: assign ~RESULT = $signed(~ARG[0]); + warning: 'GHC.Num.Integer.integerFromWord64#: Integers are dynamically sized in + simulation, but fixed-length after synthesis. Use carefully.' + workInfo: Never +- BlackBox: name: GHC.Num.Integer.integerBit# kind: Expression type: 'integerBit# :: @@ -279,3 +295,12 @@ template: ~ARG[0] / ~ARG[1] warning: 'GHC.Num.Integer.integerQuot: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' +- BlackBox: + name: GHC.Num.Integer.$wintegerFromInt64# + kind: Declaration + type: '$wintegerFromInt64# :: Int64# -> Int#' + template: |- + // wintegerFromInt64 begin + assign ~RESULT = ~ARG[0]; + // wintegerFromInt64 end + workInfo: Never diff --git a/prims/commonverilog/GHC_Prim.primitives.yaml b/prims/commonverilog/GHC_Prim.primitives.yaml --- a/prims/commonverilog/GHC_Prim.primitives.yaml +++ b/prims/commonverilog/GHC_Prim.primitives.yaml @@ -432,3 +432,619 @@ type: 'quotWord# :: Word# -> Word# -> Word#' template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.int8ToInt# + kind: Declaration + template: |- + // int8ToInt begin + assign ~RESULT = ~ARG[0]; + // int8ToInt end + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt8# + kind: Declaration + template: |- + // intToInt8 begin + assign ~RESULT = ~ARG[0]; + // intToInt8 end + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt8# + kind: Expression + template: -(~ARG[0]) +- BlackBox: + name: GHC.Prim.timesInt8# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotInt8# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remInt8# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt8# + kind: Expression + template: ~ARG[0] <<< ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt8# + kind: Expression + template: ~ARG[0] >>> ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt8# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.int8ToWord8# + kind: Expression + template: $unsigned(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt8# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geInt8# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtInt8# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leInt8# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltInt8# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neInt8# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.word8ToWord# + kind: Declaration + template: |- + // word8ToWord begin + assign ~RESULT = ~ARG[0]; + // word8ToWord end + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord8# + kind: Declaration + template: |- + // wordToWord8 begin + assign ~RESULT = ~ARG[0]; + // wordToWord8 end + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord8# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotWord8# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remWord8# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.andWord8# + kind: Expression + template: ~ARG[0] & ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord8# + kind: Expression + template: ~ARG[0] | ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord8# + kind: Expression + template: ~ARG[0] ^ ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord8# + kind: Expression + template: ~ ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord8# + kind: Expression + template: ~ARG[0] << ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord8# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.word8ToInt8# + kind: Expression + template: $signed(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord8# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geWord8# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtWord8# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leWord8# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltWord8# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neWord8# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.int16ToInt# + kind: Declaration + template: |- + // int16ToInt begin + assign ~RESULT = ~ARG[0]; + // int16ToInt end + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt16# + kind: Declaration + template: |- + // intToInt16 begin + assign ~RESULT = ~ARG[0]; + // intToInt16 end + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt16# + kind: Expression + template: -(~ARG[0]) +- BlackBox: + name: GHC.Prim.timesInt16# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotInt16# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remInt16# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt16# + kind: Expression + template: ~ARG[0] <<< ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt16# + kind: Expression + template: ~ARG[0] >>> ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt16# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.int16ToWord16# + kind: Expression + template: $unsigned(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt16# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geInt16# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtInt16# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leInt16# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltInt16# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neInt16# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.word16ToWord# + kind: Declaration + template: |- + // word16ToWord begin + assign ~RESULT = ~ARG[0]; + // word16ToWord end + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord16# + kind: Declaration + template: |- + // wordToWord16 begin + assign ~RESULT = ~ARG[0]; + // wordToWord16 end + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord16# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotWord16# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remWord16# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.andWord16# + kind: Expression + template: ~ARG[0] & ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord16# + kind: Expression + template: ~ARG[0] | ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord16# + kind: Expression + template: ~ARG[0] ^ ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord16# + kind: Expression + template: ~ ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord16# + kind: Expression + template: ~ARG[0] << ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord16# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.word16ToInt16# + kind: Expression + template: $signed(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord16# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geWord16# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtWord16# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leWord16# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltWord16# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neWord16# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.int32ToInt# + kind: Declaration + template: |- + // int32ToInt begin + assign ~RESULT = ~ARG[0]; + // int32ToInt end + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt32# + kind: Declaration + template: |- + // intToInt32 begin + assign ~RESULT = ~ARG[0]; + // intToInt32 end + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt32# + kind: Expression + template: -(~ARG[0]) +- BlackBox: + name: GHC.Prim.timesInt32# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotInt32# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remInt32# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt32# + kind: Expression + template: ~ARG[0] <<< ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt32# + kind: Expression + template: ~ARG[0] >>> ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt32# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.int32ToWord32# + kind: Expression + template: $unsigned(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt32# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geInt32# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtInt32# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leInt32# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltInt32# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neInt32# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.word32ToWord# + kind: Declaration + template: |- + // word32ToWord begin + assign ~RESULT = ~ARG[0]; + // word32ToWord end + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord32# + kind: Declaration + template: |- + // wordToWord32 begin + assign ~RESULT = ~ARG[0]; + // wordToWord32 end + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord32# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotWord32# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remWord32# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.andWord32# + kind: Expression + template: ~ARG[0] & ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord32# + kind: Expression + template: ~ARG[0] | ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord32# + kind: Expression + template: ~ARG[0] ^ ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord32# + kind: Expression + template: ~ ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord32# + kind: Expression + template: ~ARG[0] << ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord32# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.word32ToInt32# + kind: Expression + template: $signed(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord32# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geWord32# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtWord32# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leWord32# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltWord32# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neWord32# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.int64ToInt# + kind: Declaration + template: |- + // int64ToInt begin + assign ~RESULT = ~ARG[0]; + // int64ToInt end + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt64# + kind: Declaration + template: |- + // intToInt64 begin + assign ~RESULT = ~ARG[0]; + // intToInt64 end + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt64# + kind: Expression + template: -(~ARG[0]) +- BlackBox: + name: GHC.Prim.timesInt64# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotInt64# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remInt64# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedIShiftL64# + kind: Expression + template: ~ARG[0] <<< ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedIShiftRA64# + kind: Expression + template: ~ARG[0] >>> ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedIShiftRL64# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.int64ToWord64# + kind: Expression + template: $unsigned(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt64# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geInt64# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtInt64# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leInt64# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltInt64# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neInt64# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.word64ToWord# + kind: Declaration + template: |- + // word64ToWord begin + assign ~RESULT = ~ARG[0]; + // word64ToWord end + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord64# + kind: Declaration + template: |- + // wordToWord64 begin + assign ~RESULT = ~ARG[0]; + // wordToWord64 end + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord64# + kind: Expression + template: ~ARG[0] * ~ARG[1] +- BlackBox: + name: GHC.Prim.quotWord64# + kind: Expression + template: ~ARG[0] / ~ARG[1] +- BlackBox: + name: GHC.Prim.remWord64# + kind: Expression + template: ~ARG[0] % ~ARG[1] +- BlackBox: + name: GHC.Prim.and64# + kind: Expression + template: ~ARG[0] & ~ARG[1] +- BlackBox: + name: GHC.Prim.or64# + kind: Expression + template: ~ARG[0] | ~ARG[1] +- BlackBox: + name: GHC.Prim.xor64# + kind: Expression + template: ~ARG[0] ^ ~ARG[1] +- BlackBox: + name: GHC.Prim.not64# + kind: Expression + template: ~ ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftL64# + kind: Expression + template: ~ARG[0] << ~ARG[1] +- BlackBox: + name: GHC.Prim.uncheckedShiftRL64# + kind: Expression + template: ~ARG[0] >> ~ARG[1] +- BlackBox: + name: GHC.Prim.word64ToInt64# + kind: Expression + template: $signed(~ARG[0]) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord64# + kind: Expression + template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.geWord64# + kind: Expression + template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.gtWord64# + kind: Expression + template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.leWord64# + kind: Expression + template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.ltWord64# + kind: Expression + template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" +- BlackBox: + name: GHC.Prim.neWord64# + kind: Expression + template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0" diff --git a/prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml b/prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml --- a/prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml +++ b/prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml @@ -5,7 +5,7 @@ blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] @@ -50,7 +50,7 @@ blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -92,7 +92,7 @@ blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -131,60 +131,3 @@ end~FI assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[10]]; // blockRam1 end -- BlackBox: - name: Clash.Explicit.BlockRam.trueDualPortBlockRam# - kind: Declaration - type: |- - trueDualPortBlockRam# :: - forall nAddrs domA domB a . - ( HasCallStack ~ARG[0] - , KnownNat nAddrs ~ARG[1] - , KnownDomain domA ~ARG[2] - , KnownDomain domB ~ARG[3] - , NFDataX a ~ARG[4] - ) => - - Clock domA -> ~ARG[5] - Signal domA Bool -> ~ARG[6] - Signal domA Bool -> ~ARG[7] - Signal domA (Index nAddrs) -> ~ARG[8] - Signal domA a -> ~ARG[9] - - Clock domB -> ~ARG[10] - Signal domB Bool -> ~ARG[11] - Signal domB Bool -> ~ARG[12] - Signal domB (Index nAddrs) -> ~ARG[13] - Signal domB a -> ~ARG[14] - (Signal domA a, Signal domB a) - template: |- - // trueDualPortBlockRam begin - // Shared memory - logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[mem][0] [~LIT[1]-1:0]; - - ~SIGD[~GENSYM[data_slow][1]][9]; - ~SIGD[~GENSYM[data_fast][2]][14]; - - // Port A - always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]) begin - if(~ARG[6]) begin - ~SYM[1] <= ~SYM[0][~IF~SIZE[~TYP[8]]~THEN~ARG[8]~ELSE0~FI]; - if(~ARG[7]) begin - ~SYM[1] <= ~ARG[9]; - ~SYM[0][~IF~SIZE[~TYP[8]]~THEN~ARG[8]~ELSE0~FI] <= ~ARG[9]; - end - end - end - - // Port B - always @(~IF~ACTIVEEDGE[Rising][3]~THENposedge~ELSEnegedge~FI ~ARG[10]) begin - if(~ARG[11]) begin - ~SYM[2] <= ~SYM[0][~IF~SIZE[~TYP[13]]~THEN~ARG[13]~ELSE0~FI]; - if(~ARG[12]) begin - ~SYM[2] <= ~ARG[14]; - ~SYM[0][~IF~SIZE[~TYP[13]]~THEN~ARG[13]~ELSE0~FI] <= ~ARG[14]; - end - end - end - - assign ~RESULT = {~SYM[1], ~SYM[2]}; - // end trueDualPortBlockRam diff --git a/prims/systemverilog/Clash_Explicit_DDR.primitives.yaml b/prims/systemverilog/Clash_Explicit_DDR.primitives.yaml --- a/prims/systemverilog/Clash_Explicit_DDR.primitives.yaml +++ b/prims/systemverilog/Clash_Explicit_DDR.primitives.yaml @@ -4,7 +4,7 @@ type: |- ddrIn# :: forall a slow fast n pFast gated synchronous. ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4], clk @@ -47,9 +47,10 @@ - BlackBox: name: Clash.Explicit.DDR.ddrOut# kind: Declaration + outputUsage: Blocking type: |- - ddrOut# :: ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + ddrOut# :: ( HasCallStack -- ARG[0] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] diff --git a/prims/systemverilog/Clash_Explicit_ROM.primitives.yaml b/prims/systemverilog/Clash_Explicit_ROM.primitives.yaml --- a/prims/systemverilog/Clash_Explicit_ROM.primitives.yaml +++ b/prims/systemverilog/Clash_Explicit_ROM.primitives.yaml @@ -4,7 +4,7 @@ type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] diff --git a/prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml b/prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml --- a/prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml +++ b/prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml @@ -53,66 +53,4 @@ // pragma translate_on assign ~RESULT = ~ARG[7]; // assertBitVector end -- BlackBox: - name: Clash.Explicit.Testbench.tbClockGen - kind: Declaration - type: |- - tbClockGen - :: KnownDomain dom -- ARG[0] - => Signal dom Bool -- ARG[1] - -> Clock dom - template: |- - // tbClockGen begin - // pragma translate_off - // 1 = 0.1ps - localparam ~GENSYM[half_period][0] = (~PERIOD[0]0 / 2); - always begin - ~RESULT = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; - `ifndef VERILATOR - #~LONGESTPERIOD0 forever begin - if (~ ~ARG[1]) begin - $finish; - end - ~RESULT = ~ ~RESULT; - #~SYM[0]; - ~RESULT = ~ ~RESULT; - #~SYM[0]; - end - `else - ~RESULT = $c("this->~GENSYM[tb_clock_gen][1](",~SYM[0],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI,",(~ ~ARG[1]),")"); - `endif - end - `ifdef VERILATOR - `systemc_interface - CData ~SYM[1](vluint32_t half_period, bool active_rising, bool result_rec) { - static vluint32_t init_wait = ~LONGESTPERIOD0; - static vluint32_t to_wait = 0; - static CData clock = active_rising ? 0 : 1; - - if(init_wait == 0) { - if(result_rec) { - std::exit(0); - } - else { - if(to_wait == 0) { - to_wait = half_period - 1; - clock = clock == 0 ? 1 : 0; - } - else { - to_wait = to_wait - 1; - } - } - } - else { - init_wait = init_wait - 1; - } - - return clock; - } - `verilog - `endif - // pragma translate_on - // tbClockGen end - warning: Clash.Signal.Internal.tbClockGen is not synthesizable! - workInfo: Always diff --git a/prims/systemverilog/Clash_Prelude_ROM.primitives.yaml b/prims/systemverilog/Clash_Prelude_ROM.primitives.yaml --- a/prims/systemverilog/Clash_Prelude_ROM.primitives.yaml +++ b/prims/systemverilog/Clash_Prelude_ROM.primitives.yaml @@ -2,14 +2,16 @@ name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- - asyncRom# :: KnownNat n -- ^ ARG[0] - => Vec n a -- ^ ARG[1] - -> Int -- ^ ARG[2] - -> a + asyncRom# + :: ( KnownNat n -- ARG[0] + , NFDataX a) -- ARG[1] + => Vec n a -- ARG[2] + -> Int -- ARG[3] + -> a template: |- // asyncRom begin - ~SIGD[~GENSYM[ROM][0]][1]; - assign ~SYM[0] = ~CONST[1]; + ~SIGD[~GENSYM[ROM][0]][2]; + assign ~SYM[0] = ~CONST[2]; - assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[2]\]][~TYPO]; + assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[3]\]][~TYPO]; // asyncRom end diff --git a/prims/systemverilog/Clash_Signal_Internal.primitives.yaml b/prims/systemverilog/Clash_Signal_Internal.primitives.yaml --- a/prims/systemverilog/Clash_Signal_Internal.primitives.yaml +++ b/prims/systemverilog/Clash_Signal_Internal.primitives.yaml @@ -1,10 +1,11 @@ - BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration + outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] - , Undefined a ) -- ARG[1] + , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] @@ -28,6 +29,7 @@ - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration + outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] @@ -56,10 +58,11 @@ - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration + outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] - , Undefined a ) -- ARG[1] + , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] @@ -82,14 +85,16 @@ end // register end - BlackBox: - name: Clash.Signal.Internal.clockGen + name: Clash.Signal.Internal.tbClockGen kind: Declaration + outputUsage: Blocking type: |- - clockGen + tbClockGen :: KnownDomain dom -- ARG[0] - => Clock dom + => Signal dom Bool -- ARG[1] + -> Clock dom template: |- - // clockGen begin + // tbClockGen begin // pragma translate_off // 1 = 0.1ps localparam ~GENSYM[half_period][0] = (~PERIOD[0]0 / 2); @@ -97,30 +102,40 @@ ~RESULT = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; `ifndef VERILATOR #~LONGESTPERIOD0 forever begin + ~IF~ISACTIVEENABLE[1]~THEN + if (~ ~ARG[1]) begin + $finish; + end + ~ELSE~FI ~RESULT = ~ ~RESULT; #~SYM[0]; ~RESULT = ~ ~RESULT; #~SYM[0]; end `else - ~RESULT = $c("this->~GENSYM[tb_clock_gen][1](",~SYM[0],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI)"); + ~RESULT = $c("this->~GENSYM[tb_clock_gen][1](",~SYM[0],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI,",(~ ~ARG[1]),")"); `endif end `ifdef VERILATOR `systemc_interface - CData ~SYM[1](vluint32_t half_period, bool active_rising) { + CData ~SYM[1](vluint32_t half_period, bool active_rising, bool result_rec) { static vluint32_t init_wait = ~LONGESTPERIOD0; static vluint32_t to_wait = 0; static CData clock = active_rising ? 0 : 1; if(init_wait == 0) { - if(to_wait == 0) { - to_wait = half_period - 1; - clock = clock == 0 ? 1 : 0; + if(result_rec) { + std::exit(0); } else { - to_wait = to_wait - 1; + if(to_wait == 0) { + to_wait = half_period - 1; + clock = clock == 0 ? 1 : 0; + } + else { + to_wait = to_wait - 1; + } } } else { @@ -131,14 +146,50 @@ } `verilog `endif + // pragma translate_on + // tbClockGen end + warning: Clash.Signal.Internal.tbClockGen is not synthesizable! + workInfo: Always +- BlackBox: + name: Clash.Signal.Internal.tbDynamicClockGen + kind: Declaration + outputUsage: Blocking + type: |- + tbDynamicClockGen + :: KnownDomain dom -- ARG[0] + -> Signal dom Natural -- ARG[1] + -> Signal dom Bool -- ARG[2] + => Clock dom + template: |- + // tbDynamicClockGen begin + // pragma translate_off + // 1 = 0.1ps + time ~GENSYM[half_period][0]; + always begin + ~RESULT = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; + #~LONGESTPERIOD0 forever begin + ~IF~ISACTIVEENABLE[2]~THEN + if (~ ~ARG[2]) begin + $finish; + end + ~ELSE~FI + // 1 = 0.1ps + ~SYM[0] = (~VAR[periods][1] / 2); + ~RESULT = ~ ~RESULT; + #(~SYM[0] * 0.01); + ~RESULT = ~ ~RESULT; + #(~SYM[0] * 0.01); + end + end // pragma translate_on - // clockGen end - warning: Clash.Signal.Internal.clockGen is not synthesizable! + // tbDynamicClockGen end + warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable! workInfo: Always - BlackBox: name: Clash.Signal.Internal.resetGenN kind: Declaration + outputUsage: Blocking type: 'resetGenN :: (KnownDomain dom, 1 <= n) => SNat n -> Reset dom' template: |- @@ -180,4 +231,5 @@ `endif // pragma translate_on // resetGen end + warning: Clash.Signal.Internal.resetGenN can not be synthesized to hardware! workInfo: Always diff --git a/prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml b/prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml --- a/prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml +++ b/prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml @@ -1,6 +1,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration + outputUsage: Blocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] @@ -17,6 +18,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration + outputUsage: Blocking type: |- setSlice# :: SNat (m + 1 + i) -> BitVector (m + 1 + i) -- ARG[1] diff --git a/prims/systemverilog/Clash_Sized_Vector.primitives.yaml b/prims/systemverilog/Clash_Sized_Vector.primitives.yaml --- a/prims/systemverilog/Clash_Sized_Vector.primitives.yaml +++ b/prims/systemverilog/Clash_Sized_Vector.primitives.yaml @@ -241,6 +241,7 @@ - BlackBox: name: Clash.Sized.Vector.replace_int kind: Declaration + outputUsage: Blocking type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a' template: |- diff --git a/prims/systemverilog/GHC_Base.primitives.yaml b/prims/systemverilog/GHC_Base.primitives.yaml --- a/prims/systemverilog/GHC_Base.primitives.yaml +++ b/prims/systemverilog/GHC_Base.primitives.yaml @@ -5,12 +5,24 @@ Int -> Int' template: |- // divInt begin - // divide (rounds towards zero) - ~SIGD[~GENSYM[quot_res][0]][0]; - assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + logic ~GENSYM[resultPos][1]; + logic ~GENSYM[dividerNeg][2]; + logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3]; + logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4]; + logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5]; + logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; - // round toward minus infinity - assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; + assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]; + assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1; + assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]}); // sign extension + assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} ); // sign extension + + assign ~SYM[3] = ~SYM[1] ? ~SYM[4] + : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1) + : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1)); + + assign ~SYM[6] = ~SYM[3] / ~SYM[5]; + assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInt end - BlackBox: name: GHC.Base.modInt diff --git a/prims/systemverilog/GHC_Prim.primitives.yaml b/prims/systemverilog/GHC_Prim.primitives.yaml --- a/prims/systemverilog/GHC_Prim.primitives.yaml +++ b/prims/systemverilog/GHC_Prim.primitives.yaml @@ -1424,3 +1424,87 @@ ~FI assign ~RESULT = $unsigned(~SYM[7]); // ctz end +- BlackBox: + name: GHC.Prim.quotRemInt8# + kind: Declaration + type: 'quotRemInt8# :: + Int8# -> Int8# -> (#Int8#, Int8##)' + template: |- + // quotRemInt8 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt8 end +- BlackBox: + name: GHC.Prim.quotRemWord8# + kind: Declaration + type: 'quotRemWord8# :: + Word8# -> Word8# -> (#Word8#, Word8##)' + template: |- + // quotRemWord8 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord8 end +- BlackBox: + name: GHC.Prim.quotRemInt16# + kind: Declaration + type: 'quotRemInt16# :: + Int16# -> Int16# -> (#Int16#, Int16##)' + template: |- + // quotRemInt16 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt16 end +- BlackBox: + name: GHC.Prim.quotRemWord16# + kind: Declaration + type: 'quotRemWord16# :: + Word16# -> Word16# -> (#Word16#, Word16##)' + template: |- + // quotRemWord16 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord16 end +- BlackBox: + name: GHC.Prim.quotRemInt32# + kind: Declaration + type: 'quotRemInt32# :: + Int32# -> Int32# -> (#Int32#, Int32##)' + template: |- + // quotRemInt32 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt32 end +- BlackBox: + name: GHC.Prim.quotRemWord32# + kind: Declaration + type: 'quotRemWord32# :: + Word32# -> Word32# -> (#Word32#, Word32##)' + template: |- + // quotRemWord32 begin + ~SIGD[~GENSYM[quot_res][0]][0]; + ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord32 end diff --git a/prims/verilog/Clash_Explicit_BlockRam.primitives.yaml b/prims/verilog/Clash_Explicit_BlockRam.primitives.yaml --- a/prims/verilog/Clash_Explicit_BlockRam.primitives.yaml +++ b/prims/verilog/Clash_Explicit_BlockRam.primitives.yaml @@ -1,12 +1,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRam# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] @@ -52,12 +52,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRamU# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -95,12 +95,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRam1# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -142,61 +142,3 @@ ~RESULT <= ~SYM[0][~ARG[7]]; end~FI // blockRam1 end -- BlackBox: - name: Clash.Explicit.BlockRam.trueDualPortBlockRam# - kind: Declaration - type: |- - trueDualPortBlockRam# :: - forall nAddrs domA domB a . - ( HasCallStack ~ARG[0] - , KnownNat nAddrs ~ARG[1] - , KnownDomain domA ~ARG[2] - , KnownDomain domB ~ARG[3] - , NFDataX a ~ARG[4] - ) => - - Clock domA -> ~ARG[5] - Signal domA Bool -> ~ARG[6] - Signal domA Bool -> ~ARG[7] - Signal domA (Index nAddrs) -> ~ARG[8] - Signal domA a -> ~ARG[9] - - Clock domB -> ~ARG[10] - Signal domB Bool -> ~ARG[11] - Signal domB Bool -> ~ARG[12] - Signal domB (Index nAddrs) -> ~ARG[13] - Signal domB a -> ~ARG[14] - (Signal domA a, Signal domB a) - template: |- - // trueDualPortBlockRam begin - // Shared memory - reg [~SIZE[~TYP[9]]-1:0] ~GENSYM[mem][0] [~LIT[1]-1:0]; - - reg ~SIGD[~GENSYM[data_slow][1]][9]; - reg ~SIGD[~GENSYM[data_fast][2]][14]; - - // Port A - always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]) begin - if(~ARG[6]) begin - ~SYM[1] <= ~SYM[0][~IF~SIZE[~TYP[8]]~THEN~ARG[8]~ELSE0~FI]; - if(~ARG[7]) begin - ~SYM[1] <= ~ARG[9]; - ~SYM[0][~IF~SIZE[~TYP[8]]~THEN~ARG[8]~ELSE0~FI] <= ~ARG[9]; - end - end - end - - // Port B - always @(~IF~ACTIVEEDGE[Rising][3]~THENposedge~ELSEnegedge~FI ~ARG[10]) begin - if(~ARG[11]) begin - ~SYM[2] <= ~SYM[0][~IF~SIZE[~TYP[13]]~THEN~ARG[13]~ELSE0~FI]; - if(~ARG[12]) begin - ~SYM[2] <= ~ARG[14]; - ~SYM[0][~IF~SIZE[~TYP[13]]~THEN~ARG[13]~ELSE0~FI] <= ~ARG[14]; - end - end - end - - assign ~RESULT = {~SYM[1], ~SYM[2]}; - - // end trueDualPortBlockRam diff --git a/prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml b/prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml --- a/prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml +++ b/prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml @@ -1,7 +1,7 @@ - BlackBox: name: Clash.Explicit.BlockRam.Blob.blockRamBlob# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- blockRamBlob# :: KnownDomain dom -- ARG[0] diff --git a/prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml b/prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml --- a/prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml +++ b/prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml @@ -1,7 +1,7 @@ - BlackBox: name: Clash.Explicit.BlockRam.File.blockRamFile# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- blockRamFile# :: ( KnownDomain dom -- ARG[0] diff --git a/prims/verilog/Clash_Explicit_DDR.primitives.yaml b/prims/verilog/Clash_Explicit_DDR.primitives.yaml --- a/prims/verilog/Clash_Explicit_DDR.primitives.yaml +++ b/prims/verilog/Clash_Explicit_DDR.primitives.yaml @@ -4,7 +4,7 @@ type: |- ddrIn# :: forall a slow fast n pFast gated synchronous. ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] @@ -48,8 +48,8 @@ name: Clash.Explicit.DDR.ddrOut# kind: Declaration type: |- - ddrOut# :: ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + ddrOut# :: ( HasCallStack -- ARG[0] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] @@ -63,6 +63,7 @@ // ddrOut begin reg ~SIGD[~GENSYM[data_Pos][1]][7]; reg ~SIGD[~GENSYM[data_Neg][2]][7]; + ~IF ~VIVADO ~THENreg ~SIGDO[~GENSYM[ddrOut][3]];~ELSE~FI always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[4]~IF~ISSYNC[3]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[5])~FI begin : ~GENSYM[~COMPNAME_ddrOut_pos][5] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[1] <= ~ARG[7]; @@ -78,6 +79,14 @@ end end - assign ~RESULT = ~ARG[4] ? ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1] : ~SYM[2]~ELSE~SYM[2] : ~SYM[1]~FI; + ~IF ~VIVADO ~THENalways @(*) begin + if (~ARG[4]) begin + ~SYM[3] = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI; + end else begin + ~SYM[3] = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI; + end + end + assign ~RESULT = ~SYM[3];~ELSE + assign ~RESULT = ~ARG[4] ? ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1] : ~SYM[2]~ELSE~SYM[2] : ~SYM[1]~FI;~FI // ddrOut end diff --git a/prims/verilog/Clash_Explicit_ROM.primitives.yaml b/prims/verilog/Clash_Explicit_ROM.primitives.yaml --- a/prims/verilog/Clash_Explicit_ROM.primitives.yaml +++ b/prims/verilog/Clash_Explicit_ROM.primitives.yaml @@ -1,11 +1,11 @@ - BlackBox: name: Clash.Explicit.ROM.rom# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] diff --git a/prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml b/prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml --- a/prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml +++ b/prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml @@ -1,7 +1,7 @@ - BlackBox: name: Clash.Explicit.ROM.Blob.romBlob# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- romBlob# :: KnownDomain dom -- ARG[0] diff --git a/prims/verilog/Clash_Explicit_ROM_File.primitives.yaml b/prims/verilog/Clash_Explicit_ROM_File.primitives.yaml --- a/prims/verilog/Clash_Explicit_ROM_File.primitives.yaml +++ b/prims/verilog/Clash_Explicit_ROM_File.primitives.yaml @@ -1,7 +1,7 @@ - BlackBox: name: Clash.Explicit.ROM.File.romFile# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- romFile# :: ( KnownNat m -- ARG[0] , KnownDomain dom ) -- ARG[1] diff --git a/prims/verilog/Clash_Explicit_Testbench.primitives.yaml b/prims/verilog/Clash_Explicit_Testbench.primitives.yaml --- a/prims/verilog/Clash_Explicit_Testbench.primitives.yaml +++ b/prims/verilog/Clash_Explicit_Testbench.primitives.yaml @@ -53,70 +53,3 @@ // pragma translate_on assign ~RESULT = ~ARG[7]; // assertBitVector end -- BlackBox: - name: Clash.Explicit.Testbench.tbClockGen - kind: Declaration - type: |- - tbClockGen - :: KnownDomain dom -- ARG[0] - => Signal dom Bool -- ARG[1] - -> Clock dom - template: |- - // tbClockGen begin - // pragma translate_off - reg ~TYPO ~GENSYM[clk][0]; - // 1 = 0.1ps - localparam ~GENSYM[half_period][1] = (~PERIOD[0]0 / 2); - always begin - // Delay of 1 mitigates race conditions (https://github.com/steveicarus/iverilog/issues/160) - #1 ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; - `ifndef VERILATOR - #~LONGESTPERIOD0 forever begin - if (~ ~ARG[1]) begin - $finish(0); - end - ~SYM[0] = ~ ~SYM[0]; - #~SYM[1]; - ~SYM[0] = ~ ~SYM[0]; - #~SYM[1]; - end - `else - ~SYM[0] = $c("this->~GENSYM[tb_clock_gen][2](",~SYM[1],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI,",(~ ~ARG[1]),")"); - `endif - end - - `ifdef VERILATOR - `systemc_interface - CData ~SYM[2](vluint32_t half_period, bool active_rising, bool result_rec) { - static vluint32_t init_wait = ~LONGESTPERIOD0; - static vluint32_t to_wait = 0; - static CData clock = active_rising ? 0 : 1; - - if(init_wait == 0) { - if(result_rec) { - std::exit(0); - } - else { - if(to_wait == 0) { - to_wait = half_period - 1; - clock = clock == 0 ? 1 : 0; - } - else { - to_wait = to_wait - 1; - } - } - } - else { - init_wait = init_wait - 1; - } - - return clock; - } - `verilog - `endif - - assign ~RESULT = ~SYM[0]; - // pragma translate_on - // tbClockGen end - warning: Clash.Signal.Internal.tbClockGen is not synthesizable! - workInfo: Always diff --git a/prims/verilog/Clash_Prelude_ROM.primitives.yaml b/prims/verilog/Clash_Prelude_ROM.primitives.yaml --- a/prims/verilog/Clash_Prelude_ROM.primitives.yaml +++ b/prims/verilog/Clash_Prelude_ROM.primitives.yaml @@ -2,16 +2,18 @@ name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- - asyncRom# :: KnownNat n -- ^ ARG[0] - => Vec n a -- ^ ARG[1] - -> Int -- ^ ARG[2] - -> a + asyncRom# + :: ( KnownNat n -- ARG[0] + , NFDataX a) -- ARG[1] + => Vec n a -- ARG[2] + -> Int -- ARG[3] + -> a template: |- // asyncRom begin wire ~TYPO ~GENSYM[ROM][0] [0:~LIT[0]-1]; - wire ~TYP[1] ~GENSYM[romflat][1]; - assign ~SYM[1] = ~CONST[1]; + wire ~TYP[2] ~GENSYM[romflat][1]; + assign ~SYM[1] = ~CONST[2]; genvar ~GENSYM[i][2]; ~GENERATE for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] @@ -19,5 +21,5 @@ end ~ENDGENERATE - assign ~RESULT = ~SYM[0][~ARG[2]]; + assign ~RESULT = ~SYM[0][~ARG[3]]; // asyncRom end diff --git a/prims/verilog/Clash_Signal_Internal.primitives.yaml b/prims/verilog/Clash_Signal_Internal.primitives.yaml --- a/prims/verilog/Clash_Signal_Internal.primitives.yaml +++ b/prims/verilog/Clash_Signal_Internal.primitives.yaml @@ -1,11 +1,11 @@ - BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] - , Undefined a ) -- ARG[1] + , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] @@ -29,7 +29,7 @@ - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] @@ -58,11 +58,11 @@ - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration - outputReg: true + outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] - , Undefined a ) -- ARG[1] + , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] @@ -85,14 +85,15 @@ end // register end - BlackBox: - name: Clash.Signal.Internal.clockGen + name: Clash.Signal.Internal.tbClockGen kind: Declaration type: |- - clockGen + tbClockGen :: KnownDomain dom -- ARG[0] - => Clock dom + => Signal dom Bool -- ARG[1] + -> Clock dom template: |- - // clockGen begin + // tbClockGen begin // pragma translate_off reg ~TYPO ~GENSYM[clk][0]; // 1 = 0.1ps @@ -102,30 +103,40 @@ #1 ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; `ifndef VERILATOR #~LONGESTPERIOD0 forever begin + ~IF~ISACTIVEENABLE[1]~THEN + if (~ ~ARG[1]) begin + $finish(0); + end + ~ELSE~FI ~SYM[0] = ~ ~SYM[0]; #~SYM[1]; ~SYM[0] = ~ ~SYM[0]; #~SYM[1]; end `else - ~SYM[0] = $c("this->~GENSYM[tb_clock_gen][2](",~SYM[1],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI)"); + ~SYM[0] = $c("this->~GENSYM[tb_clock_gen][2](",~SYM[1],",~IF~ACTIVEEDGE[Rising][0]~THENtrue~ELSEfalse~FI,",(~ ~ARG[1]),")"); `endif end `ifdef VERILATOR `systemc_interface - CData ~SYM[2](vluint32_t half_period, bool active_rising) { + CData ~SYM[2](vluint32_t half_period, bool active_rising, bool result_rec) { static vluint32_t init_wait = ~LONGESTPERIOD0; static vluint32_t to_wait = 0; static CData clock = active_rising ? 0 : 1; if(init_wait == 0) { - if(to_wait == 0) { - to_wait = half_period - 1; - clock = clock == 0 ? 1 : 0; + if(result_rec) { + std::exit(0); } else { - to_wait = to_wait - 1; + if(to_wait == 0) { + to_wait = half_period - 1; + clock = clock == 0 ? 1 : 0; + } + else { + to_wait = to_wait - 1; + } } } else { @@ -139,8 +150,46 @@ assign ~RESULT = ~SYM[0]; // pragma translate_on - // clockGen end - warning: Clash.Signal.Internal.clockGen is not synthesizable! + // tbClockGen end + warning: Clash.Signal.Internal.tbClockGen is not synthesizable! + workInfo: Always +- BlackBox: + name: Clash.Signal.Internal.tbDynamicClockGen + kind: Declaration + type: |- + clockGen + :: KnownDomain dom -- ARG[0] + -> Signal dom Int64 -- ARG[1] + -> Signal dom Bool -- ARG[2] + => Clock dom + template: |- + // tbDynamicClockGen begin + // pragma translate_off + reg ~TYPO ~GENSYM[clk][0]; + time ~GENSYM[half_period][1]; + always begin + // Delay of 1 mitigates race conditions (https://github.com/steveicarus/iverilog/issues/160) + #1 ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI; + #~LONGESTPERIOD0 forever begin + ~IF~ISACTIVEENABLE[2]~THEN + if (~ ~ARG[2]) begin + $finish(0); + end + ~ELSE~FI + // 1 = 0.1ps + ~SYM[1] = (~VAR[periods][1] / 2); + + ~SYM[0] = ~ ~SYM[0]; + #(~SYM[1] * 0.01); + ~SYM[0] = ~ ~SYM[0]; + #(~SYM[1] * 0.01); + end + end + + assign ~RESULT = ~SYM[0]; + // pragma translate_on + // tbDynamicClockGen end + warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable! workInfo: Always - BlackBox: name: Clash.Signal.Internal.resetGenN diff --git a/prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml b/prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml --- a/prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml +++ b/prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml @@ -1,7 +1,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration - outputReg: true + outputUsage: Blocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] @@ -18,7 +18,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration - outputReg: true + outputUsage: Blocking type: |- setSlice# :: SNat (m + 1 + i) -> BitVector (m + 1 + i) -- ARG[1] diff --git a/prims/verilog/Clash_Sized_Vector.primitives.yaml b/prims/verilog/Clash_Sized_Vector.primitives.yaml --- a/prims/verilog/Clash_Sized_Vector.primitives.yaml +++ b/prims/verilog/Clash_Sized_Vector.primitives.yaml @@ -97,7 +97,7 @@ for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]~IF~SIZE[~TYP[1]]~THEN wire ~TYPEL[~TYP[1]] ~GENSYM[map_in][3]; assign ~SYM[3] = ~VAR[vec][1][~SYM[1]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI - ~OUTPUTWIREREG[0] ~TYPEL[~TYPO] ~GENSYM[map_out][4]; + ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~GENSYM[map_out][4]; ~INST 0 ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ @@ -120,7 +120,7 @@ wire [~SIZE[~INDEXTYPE[~LIT[0]]]-1:0] ~GENSYM[map_index][3];~IF~SIZE[~TYP[2]]~THEN wire ~TYPEL[~TYP[2]] ~GENSYM[map_in][4]; assign ~SYM[4] = ~VAR[vec][2][~SYM[1]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI - ~OUTPUTWIREREG[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; + ~OUTPUTUSAGE[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; assign ~SYM[3] = ~SIZE[~INDEXTYPE[~LIT[0]]]'d~MAXINDEX[~TYPO] - ~SYM[1][0+:~SIZE[~INDEXTYPE[~LIT[0]]]]; ~INST 1 @@ -146,7 +146,7 @@ wire ~TYP[0] ~GENSYM[map_index][3];~IF~SIZE[~TYP[2]]~THEN wire ~TYPEL[~TYP[2]] ~GENSYM[map_in][4]; assign ~SYM[4] = ~VAR[vec][2][~SYM[1]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI - ~OUTPUTWIREREG[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; + ~OUTPUTUSAGE[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5]; assign ~SYM[3] = ~SIZE[~TYP[0]]'d~MAXINDEX[~TYPO] - ~SYM[1][0+:~SIZE[~TYP[0]]] + ~ARG[0]; ~INST 1 @@ -173,7 +173,7 @@ assign ~SYM[3] = ~VAR[vec1][1][~SYM[2]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN wire ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][4]; assign ~SYM[4] = ~VAR[vec2][2][~SYM[2]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI - ~OUTPUTWIREREG[0] ~TYPEL[~TYPO] ~SYM[5]; + ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~SYM[5]; ~INST 0 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ @@ -200,7 +200,7 @@ wire ~TYPEL[~TYP[2]] ~GENSYM[foldr_in1][5]; assign ~SYM[5] = ~VAR[xs][2][(~LENGTH[~TYP[2]]-1-~SYM[3])*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI wire ~TYPO ~GENSYM[foldr_in2][6]; - ~OUTPUTWIREREG[0] ~TYPO ~GENSYM[foldr_out][7]; + ~OUTPUTUSAGE[0] ~TYPO ~GENSYM[foldr_out][7]; assign ~SYM[6] = ~SYM[0][~SYM[3]+1]; ~INST 0 diff --git a/prims/verilog/GHC_Base.primitives.yaml b/prims/verilog/GHC_Base.primitives.yaml --- a/prims/verilog/GHC_Base.primitives.yaml +++ b/prims/verilog/GHC_Base.primitives.yaml @@ -5,12 +5,24 @@ Int -> Int' template: |- // divInt begin - // divide (rounds towards zero) - wire ~SIGD[~GENSYM[quot_res][0]][0]; - assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1]; + wire ~GENSYM[resultPos][1]; + wire ~GENSYM[dividerNeg][2]; + wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3]; + wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4]; + wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5]; + wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; - // round toward minus infinity - assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1; + assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]; + assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1; + assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]}); // sign extension + assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} ); // sign extension + + assign ~SYM[3] = ~SYM[1] ? ~SYM[4] + : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1) + : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1)); + + assign ~SYM[6] = ~SYM[3] / ~SYM[5]; + assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInt end - BlackBox: name: GHC.Base.modInt diff --git a/prims/verilog/GHC_Prim.primitives.yaml b/prims/verilog/GHC_Prim.primitives.yaml --- a/prims/verilog/GHC_Prim.primitives.yaml +++ b/prims/verilog/GHC_Prim.primitives.yaml @@ -1472,3 +1472,87 @@ ~FI assign ~RESULT = $unsigned(~SYM[7]); // ctz end +- BlackBox: + name: GHC.Prim.quotRemInt8# + kind: Declaration + type: 'quotRemInt8# :: + Int8# -> Int8# -> (#Int8#, Int8##)' + template: |- + // quotRemInt8 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt8 end +- BlackBox: + name: GHC.Prim.quotRemWord8# + kind: Declaration + type: 'quotRemWord8# :: + Word8# -> Word8# -> (#Word8#, Word8##)' + template: |- + // quotRemWord8 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord8 end +- BlackBox: + name: GHC.Prim.quotRemInt16# + kind: Declaration + type: 'quotRemInt16# :: + Int16# -> Int16# -> (#Int16#, Int16##)' + template: |- + // quotRemInt16 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt16 end +- BlackBox: + name: GHC.Prim.quotRemWord16# + kind: Declaration + type: 'quotRemWord16# :: + Word16# -> Word16# -> (#Word16#, Word16##)' + template: |- + // quotRemWord16 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord16 end +- BlackBox: + name: GHC.Prim.quotRemInt32# + kind: Declaration + type: 'quotRemInt32# :: + Int32# -> Int32# -> (#Int32#, Int32##)' + template: |- + // quotRemInt32 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemInt32 end +- BlackBox: + name: GHC.Prim.quotRemWord32# + kind: Declaration + type: 'quotRemWord32# :: + Word32# -> Word32# -> (#Word32#, Word32##)' + template: |- + // quotRemWord32 begin + wire ~SIGD[~GENSYM[quot_res][0]][0]; + wire ~SIGD[~GENSYM[rem_res][1]][0]; + assign ~SYM[0] = ~ARG[0] / ~ARG[1]; + assign ~SYM[1] = ~ARG[0] % ~ARG[1]; + + assign ~RESULT = {~SYM[0],~SYM[1]}; + // quotRemWord32 end diff --git a/prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml b/prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml --- a/prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml @@ -1,11 +1,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRam# kind: Declaration + outputUsage: NonBlocking type: |- blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] @@ -56,11 +57,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRamU# kind: Declaration + outputUsage: NonBlocking type: |- blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -113,11 +115,12 @@ - BlackBox: name: Clash.Explicit.BlockRam.blockRam1# kind: Declaration + outputUsage: NonBlocking type: |- blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] @@ -168,67 +171,3 @@ end process; ~FI end block; --end blockRam1 -- BlackBox: - name: Clash.Explicit.BlockRam.trueDualPortBlockRam# - kind: Declaration - type: |- - trueDualPortBlockRam# :: - forall nAddrs domA domB a . - ( HasCallStack ~ARG[0] - , KnownNat nAddrs ~ARG[1] - , KnownDomain domA ~ARG[2] - , KnownDomain domB ~ARG[3] - , NFDataX a ~ARG[4] - ) => - - Clock domA -> ~ARG[5] - Signal domA Bool -> ~ARG[6] - Signal domA Bool -> ~ARG[7] - Signal domA (Index nAddrs) -> ~ARG[8] - Signal domA a -> ~ARG[9] - - Clock domB -> ~ARG[10] - Signal domB Bool -> ~ARG[11] - Signal domB Bool -> ~ARG[12] - Signal domB (Index nAddrs) -> ~ARG[13] - Signal domB a -> ~ARG[14] - (Signal domA a, Signal domB a) - template: |- - -- trueDualPortBlockRam begin - ~GENSYM[~RESULT_trueDualPortBlockRam][1] : block - -- Shared memory - type mem_type is array ( ~LIT[1]-1 downto 0 ) of ~TYP[9]; - shared variable mem : mem_type; - signal ~GENSYM[a_dout][2] : ~TYP[9]; - signal ~GENSYM[b_dout][3] : ~TYP[14]; - begin - - -- Port A - process(~ARG[5]) - begin - if(rising_edge(~ARG[5])) then - if(~ARG[6]) then - if(~ARG[7]) then - mem(~IF~SIZE[~TYP[8]]~THENto_integer(~ARG[8])~ELSE0~FI) := ~ARG[9]; - end if; - ~SYM[2] <= mem(~IF~SIZE[~TYP[8]]~THENto_integer(~ARG[8])~ELSE0~FI); - end if; - end if; - end process; - - -- Port B - process(~ARG[10]) - begin - if(rising_edge(~ARG[10])) then - if(~ARG[11]) then - if(~ARG[12]) then - mem(~IF~SIZE[~TYP[13]]~THENto_integer(~ARG[13])~ELSE0~FI) := ~ARG[14]; - end if; - ~SYM[3] <= mem(~IF~SIZE[~TYP[13]]~THENto_integer(~ARG[13])~ELSE0~FI); - end if; - end if; - end process; - - ~RESULT <= (~SYM[2], ~SYM[3]); - end block; - -- end trueDualPortBlockRam diff --git a/prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml b/prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml --- a/prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml @@ -1,6 +1,7 @@ - BlackBox: name: Clash.Explicit.BlockRam.Blob.blockRamBlob# kind: Declaration + outputUsage: NonBlocking type: |- blockRamBlob# :: KnownDomain dom -- ARG[0] diff --git a/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml b/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml --- a/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml @@ -1,6 +1,7 @@ - BlackBox: name: Clash.Explicit.BlockRam.File.blockRamFile# kind: Declaration + outputUsage: NonBlocking type: |- blockRamFile# :: ( KnownDomain dom -- ARG[0] diff --git a/prims/vhdl/Clash_Explicit_DDR.primitives.yaml b/prims/vhdl/Clash_Explicit_DDR.primitives.yaml --- a/prims/vhdl/Clash_Explicit_DDR.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_DDR.primitives.yaml @@ -4,7 +4,7 @@ type: |- ddrIn# :: forall a slow fast n pFast enabled synchronous. ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] @@ -94,8 +94,8 @@ name: Clash.Explicit.DDR.ddrOut# kind: Declaration type: |- - ddrOut# :: ( HasCallStack -- ARG[0] - , Undefined a -- ARG[1] + ddrOut# :: ( HasCallStack -- ARG[0] + , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] diff --git a/prims/vhdl/Clash_Explicit_ROM.primitives.yaml b/prims/vhdl/Clash_Explicit_ROM.primitives.yaml --- a/prims/vhdl/Clash_Explicit_ROM.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_ROM.primitives.yaml @@ -1,10 +1,11 @@ - BlackBox: name: Clash.Explicit.ROM.rom# kind: Declaration + outputUsage: NonBlocking type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] - , Undefined a ) -- ARG[2] + , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] diff --git a/prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml b/prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml --- a/prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml @@ -1,6 +1,7 @@ - BlackBox: name: Clash.Explicit.ROM.Blob.romBlob# kind: Declaration + outputUsage: NonBlocking type: |- romBlob# :: KnownDomain dom -- ARG[0] diff --git a/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml b/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml --- a/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml @@ -1,6 +1,7 @@ - BlackBox: name: Clash.Explicit.ROM.File.romFile# kind: Declaration + outputUsage: NonBlocking type: |- romFile# :: ( KnownNat m -- ARG[0] , KnownDomain dom -- ARG[1] diff --git a/prims/vhdl/Clash_Explicit_Testbench.primitives.yaml b/prims/vhdl/Clash_Explicit_Testbench.primitives.yaml --- a/prims/vhdl/Clash_Explicit_Testbench.primitives.yaml +++ b/prims/vhdl/Clash_Explicit_Testbench.primitives.yaml @@ -149,41 +149,13 @@ end block; -- assertBitVector end - BlackBox: - name: Clash.Explicit.Testbench.tbClockGen - comment: |- - ModelSim and Vivado seem to round time values to an integer number of picoseconds. - Use two half periods to prevent rounding errors from affecting the full period. - kind: Declaration - type: |- - tbClockGen - :: KnownDomain dom -- ARG[0] - => Signal dom Bool -- ARG[1] - -> Clock dom - template: |- - -- tbClockGen begin - -- pragma translate_off - ~GENSYM[clkGen][0] : process is - constant ~GENSYM[half_periodH][1] : time := ~PERIOD[0]000 fs / 2; - constant ~GENSYM[half_periodL][2] : time := ~PERIOD[0]000 fs - ~SYM[1]; - begin - ~RESULT <= ~IF~ACTIVEEDGE[Rising][0]~THEN'0'~ELSE'1'~FI; - wait for ~LONGESTPERIOD ps; - while ~ARG[1] loop - ~RESULT <= not ~RESULT; - wait for ~SYM[1]; - ~RESULT <= not ~RESULT; - wait for ~SYM[2]; - end loop; - wait; - end process; - -- pragma translate_on - -- tbClockGen end - warning: Clash.Signal.Internal.tbClockGen is not synthesizable! - workInfo: Always -- BlackBox: name: Clash.Explicit.Testbench.tbEnableGen kind: Declaration type: 'tbEnableGen :: Enable dom' template: ~RESULT <= true; workInfo: Always +- BlackBox: + name: Clash.Explicit.Testbench.clockToDiffClock + kind: Expression + template: (~ARG[1], not ~ARG[1]) diff --git a/prims/vhdl/Clash_Prelude_ROM.primitives.yaml b/prims/vhdl/Clash_Prelude_ROM.primitives.yaml --- a/prims/vhdl/Clash_Prelude_ROM.primitives.yaml +++ b/prims/vhdl/Clash_Prelude_ROM.primitives.yaml @@ -2,19 +2,21 @@ name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- - asyncRom# :: KnownNat n -- ^ ARG[0] - => Vec n a -- ^ ARG[1] - -> Int -- ^ ARG[2] - -> a + asyncRom# + :: ( KnownNat n -- ARG[0] + , NFDataX a) -- ARG[1] + => Vec n a -- ARG[2] + -> Int -- ARG[3] + -> a template: |- -- asyncRom begin ~GENSYM[asyncRom][0] : block - signal ~GENSYM[ROM][1] : ~TYP[1]; + signal ~GENSYM[ROM][1] : ~TYP[2]; signal ~GENSYM[rd][2] : integer range 0 to ~LIT[0]-1; begin - ~SYM[1] <= ~CONST[1]; + ~SYM[1] <= ~CONST[2]; - ~SYM[2] <= to_integer(~VAR[rdI][2](31 downto 0)) + ~SYM[2] <= to_integer(~VAR[rdI][3](31 downto 0)) -- pragma translate_off mod ~LIT[0] -- pragma translate_on diff --git a/prims/vhdl/Clash_Signal_Internal.primitives.yaml b/prims/vhdl/Clash_Signal_Internal.primitives.yaml --- a/prims/vhdl/Clash_Signal_Internal.primitives.yaml +++ b/prims/vhdl/Clash_Signal_Internal.primitives.yaml @@ -1,10 +1,11 @@ - BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration + outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] - , Undefined a ) -- ARG[1] + , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] @@ -34,6 +35,7 @@ - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration + outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] @@ -69,6 +71,7 @@ - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration + outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] @@ -126,17 +129,19 @@ end process;~FI~FI -- register end - BlackBox: - name: Clash.Signal.Internal.clockGen + name: Clash.Signal.Internal.tbClockGen comment: |- ModelSim and Vivado seem to round time values to an integer number of picoseconds. Use two half periods to prevent rounding errors from affecting the full period. kind: Declaration + outputUsage: NonBlocking type: |- - clockGen + tbClockGen :: KnownDomain dom -- ARG[0] - => Clock dom + => Signal dom Bool -- ARG[1] + -> Clock dom template: |- - -- clockGen begin + -- tbClockGen begin -- pragma translate_off ~GENSYM[clkGen][0] : process is constant ~GENSYM[half_periodH][1] : time := ~PERIOD[0]000 fs / 2; @@ -144,7 +149,7 @@ begin ~RESULT <= ~IF~ACTIVEEDGE[Rising][0]~THEN'0'~ELSE'1'~FI; wait for ~LONGESTPERIOD ps; - loop + ~IF~ISACTIVEENABLE[1]~THENwhile ~ARG[1] ~ELSE~FIloop ~RESULT <= not ~RESULT; wait for ~SYM[1]; ~RESULT <= not ~RESULT; @@ -153,10 +158,50 @@ wait; end process; -- pragma translate_on - -- clockGen end - warning: Clash.Signal.Internal.clockGen is not synthesizable! + -- tbClockGen end + warning: Clash.Signal.Internal.tbClockGen is not synthesizable! workInfo: Always - BlackBox: + name: Clash.Signal.Internal.tbDynamicClockGen + comment: |- + ModelSim and Vivado seem to round time values to an integer number of picoseconds. + Use two half periods to prevent rounding errors from affecting the full period. + kind: Declaration + outputUsage: NonBlocking + type: |- + tbDynamicClockGen + :: KnownDomain dom -- ARG[0] + => Signal dom Int64 -- ARG[1] + -> Signal dom Bool -- ARG[2] + -> Clock dom + template: |- + -- tbDynamicClockGen begin + -- pragma translate_off + ~GENSYM[dynClkGen][0] : process is + variable ~GENSYM[whole_period][1] : time; + variable ~GENSYM[half_periodH][2] : time; + variable ~GENSYM[half_periodL][3] : time; + begin + ~RESULT <= ~IF~ACTIVEEDGE[Rising][0]~THEN'0'~ELSE'1'~FI; + wait for ~LONGESTPERIOD ps; + + ~IF~ISACTIVEENABLE[2]~THENwhile ~ARG[2] ~ELSE~FIloop + ~SYM[1] := to_integer(~VAR[periods][1]) * 1 fs; + ~SYM[2] := ~SYM[1] / 2; + ~SYM[3] := ~SYM[1] - ~SYM[2]; + + ~RESULT <= not ~RESULT; + wait for ~SYM[2]; + ~RESULT <= not ~RESULT; + wait for ~SYM[3]; + end loop; + wait; + end process; + -- pragma translate_on + -- tbDynamicClockGen end + warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable! + workInfo: Always +- BlackBox: name: Clash.Signal.Internal.resetGenN kind: Declaration type: 'resetGenN :: (KnownDomain @@ -185,6 +230,6 @@ name: Clash.Signal.Internal.unsafeToReset kind: Declaration type: 'unsafeToReset :: - Signal dom Bool -> Reset dom' - template: ~RESULT <= '1' when ~ARG[0] = true else '0'; + KnownDomain dom => Signal dom Bool -> Reset dom' + template: ~RESULT <= '1' when ~ARG[1] = true else '0'; workInfo: Never diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml --- a/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml @@ -252,6 +252,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration + outputUsage: NonBlocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] @@ -282,6 +283,7 @@ - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration + outputUsage: NonBlocking type: |- setSlice# :: SNat (m + 1 + i) => BitVector (m + 1 + i) -- ARG[1] diff --git a/prims/vhdl/Clash_Sized_Vector.primitives.yaml b/prims/vhdl/Clash_Sized_Vector.primitives.yaml --- a/prims/vhdl/Clash_Sized_Vector.primitives.yaml +++ b/prims/vhdl/Clash_Sized_Vector.primitives.yaml @@ -274,6 +274,7 @@ - BlackBox: name: Clash.Sized.Vector.replace_int kind: Declaration + outputUsage: NonBlocking type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a' template: |- diff --git a/prims/vhdl/Clash_Xilinx_ClockGen.primitives.yaml b/prims/vhdl/Clash_Xilinx_ClockGen.primitives.yaml deleted file mode 100644 --- a/prims/vhdl/Clash_Xilinx_ClockGen.primitives.yaml +++ /dev/null @@ -1,65 +0,0 @@ -- BlackBox: - name: Clash.Xilinx.ClockGen.clockWizard - kind: Declaration - type: |- - clockWizard - :: ( KnownDomain domIn confIn -- ARG[0] - , KnownDomain domOut confOut ) -- ARG[1] - => SSymbol name -- ARG[2] - -> Clock pllIn -- ARG[3] - -> Reset pllIn -- ARG[4] - -> (Clock pllOut, Enable pllOut) - template: |- - -- clockWizard begin - ~GENSYM[clockWizard][0] : block - signal ~GENSYM[pllOut][1] : std_logic; - signal ~GENSYM[locked][2] : std_logic; - signal ~GENSYM[pllLock][3] : boolean; - - component ~NAME[2] - port (CLK_IN1 : in std_logic; - RESET : in std_logic; - CLK_OUT1 : out std_logic; - LOCKED : out std_logic); - end component; - begin - ~GENSYM[clockWizard_inst][4] : component ~NAME[2] port map (~ARG[3],~IF ~ISACTIVEHIGH[0] ~THEN ~ARG[4] ~ELSE NOT(~ARG[4]) ~FI,~SYM[1],~SYM[2]); - ~SYM[3] <= true when ~SYM[2] = '1' else false; - ~RESULT <= (~SYM[1],~SYM[3]); - end block; - -- clockWizard end - workInfo: Always -- BlackBox: - name: Clash.Xilinx.ClockGen.clockWizardDifferential - kind: Declaration - type: |- - clockWizardDifferential - :: ( KnownDomain domIn confIn -- ARG[0] - , KnownDomain domOut confOut ) -- ARG[1] - => SSymbol name -- ARG[2] - -> Clock pllIn -- ARG[3] - -> Clock pllIn -- ARG[4] - -> Reset pllIn -- ARG[5] - -> (Clock pllOut, Enable pllOut) - template: |- - -- clockWizardDifferential begin - ~GENSYM[clockWizardDifferential][0] : block - signal ~GENSYM[pllOut][1] : std_logic; - signal ~GENSYM[locked][2] : std_logic; - signal ~GENSYM[pllLock][3] : boolean; - - component ~NAME[2] - port (CLK_IN1_D_clk_n : in std_logic; - CLK_IN1_D_clk_p : in std_logic; - RESET : in std_logic; - CLK_OUT1 : out std_logic; - LOCKED : out std_logic); - end component; - begin - ~GENSYM[clockWizardDifferential_inst][4] : component ~NAME[2] - port map (~ARG[3],~ARG[4],~IF ~ISACTIVEHIGH[0] ~THEN ~ARG[5] ~ELSE NOT(~ARG[5]) ~FI,~SYM[1],~SYM[2]); - ~SYM[3] <= true when ~SYM[2] = '1' else false; - ~RESULT <= (~SYM[1],~SYM[3]); - end block; - -- clockWizardDifferential end - workInfo: Always diff --git a/prims/vhdl/GHC_Base.primitives.yaml b/prims/vhdl/GHC_Base.primitives.yaml --- a/prims/vhdl/GHC_Base.primitives.yaml +++ b/prims/vhdl/GHC_Base.primitives.yaml @@ -17,15 +17,22 @@ template: |- -- divInt begin ~GENSYM[divInt][0] : block - signal ~GENSYM[quot_res][1] : ~TYP[1]; + signal ~GENSYM[resultPos][1] : boolean; + signal ~GENSYM[dividerNeg][2] : boolean; + signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0); + signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0); begin - ~SYM[1] <= ~ARG[0] / ~ARG[1] + ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high); + ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1'; + ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1) when ~SYM[1] else + (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1) when ~SYM[2] else + (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1); + ~SYM[4] <= ~SYM[3] / ~VAR[divider][1] -- pragma translate_off - when (ARG[1] /= 0) else (others => 'X') + when (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; - ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else - ~SYM[1]; + ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divInt end - BlackBox: diff --git a/prims/vhdl/GHC_Num_Integer.primitives.yaml b/prims/vhdl/GHC_Num_Integer.primitives.yaml --- a/prims/vhdl/GHC_Num_Integer.primitives.yaml +++ b/prims/vhdl/GHC_Num_Integer.primitives.yaml @@ -291,6 +291,14 @@ but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: + name: GHC.Num.Integer.integerToInt64# + kind: Expression + type: 'integerToInt64# :: Integer -> Int64#' + template: ~ARG[0] + warning: 'GHC.Num.Integer.integerToInt64#: Integers are dynamically sized in + simulation, but fixed-length after synthesis. Use carefully.' + workInfo: Never +- BlackBox: name: GHC.Num.Integer.integerToWord64# comment: only used by 32 bit GHC kind: Expression @@ -301,6 +309,14 @@ simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: + name: GHC.Num.Integer.integerFromWord64# + kind: Expression + type: 'integerFromWord64# :: Word64# -> Integer' + template: signed(std_logic_vector(~ARG[0])) + warning: 'GHC.Num.Integer.integerFromWord64#: Integers are dynamically sized in + simulation, but fixed-length after synthesis. Use carefully.' + workInfo: Never +- BlackBox: name: GHC.Num.Integer.integerBit# kind: Expression type: 'integerBit :: Word# @@ -341,17 +357,17 @@ warning: 'GHC.Num.Integer.integerAnd: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: - name: GHC.Num.Integer.integerSigmum + name: GHC.Num.Integer.integerSignum kind: Declaration - type: 'integerSigmum :: + type: 'integerSignum :: Integer -> Integer' template: |2 - -- begin integerSigmum + -- begin integerSignum ~RESULT <= to_signed(-1, ~SIZE[~TYPO]) when ~ARG[0] < 0 else to_signed(0, ~SIZE[~TYPO]) when ~ARG[0] = 0 else to_signed(1, ~SIZE[~TYPO]); - -- end integerSigmum + -- end integerSignum warning: 'GHC.Num.Integer.integerSignum: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: @@ -403,3 +419,9 @@ ; warning: 'GHC.Num.Integer.integerQuot: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' +- BlackBox: + name: GHC.Num.Integer.$wintegerFromInt64# + kind: Expression + type: '$wintegerFromInt64# :: Int64# -> Int#' + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never diff --git a/prims/vhdl/GHC_Prim.primitives.yaml b/prims/vhdl/GHC_Prim.primitives.yaml --- a/prims/vhdl/GHC_Prim.primitives.yaml +++ b/prims/vhdl/GHC_Prim.primitives.yaml @@ -1257,3 +1257,1003 @@ when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; +- BlackBox: + name: GHC.Prim.int8ToInt# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt8# + kind: Expression + template: ~VAR[i][0](7 downto 0) + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt8# + kind: Expression + template: -~ARG[0] +- BlackBox: + name: GHC.Prim.timesInt8# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotInt8# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remInt8# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemInt8# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt8# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt8# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftR][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_right(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt8# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.int8ToWord8# + kind: Expression + template: unsigned(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neInt8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.word8ToWord# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord8# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord8# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotWord8# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remWord8# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemWord8# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.andWord8# + kind: Expression + template: ~ARG[0] and ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord8# + kind: Expression + template: ~ARG[0] or ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord8# + kind: Expression + template: ~ARG[0] xor ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord8# + kind: Expression + template: not ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord8# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord8# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.word8ToInt8# + kind: Expression + template: signed(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neWord8# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.int16ToInt# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt16# + kind: Expression + template: ~VAR[i][0](15 downto 0) + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt16# + kind: Expression + template: -~ARG[0] +- BlackBox: + name: GHC.Prim.timesInt16# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotInt16# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remInt16# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemInt16# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt16# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt16# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftR][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_right(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt16# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.int16ToWord16# + kind: Expression + template: unsigned(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neInt16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.word16ToWord# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord16# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord16# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotWord16# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remWord16# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemWord16# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.andWord16# + kind: Expression + template: ~ARG[0] and ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord16# + kind: Expression + template: ~ARG[0] or ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord16# + kind: Expression + template: ~ARG[0] xor ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord16# + kind: Expression + template: not ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord16# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord16# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.word16ToInt16# + kind: Expression + template: signed(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neWord16# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.int32ToInt# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt32# + kind: Expression + template: ~VAR[i][0](31 downto 0) + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt32# + kind: Expression + template: -~ARG[0] +- BlackBox: + name: GHC.Prim.timesInt32# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotInt32# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remInt32# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemInt32# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.uncheckedShiftLInt32# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRAInt32# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftR][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_right(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLInt32# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.int32ToWord32# + kind: Expression + template: unsigned(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neInt32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.word32ToWord# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord32# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord32# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotWord32# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remWord32# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemWord32# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.andWord32# + kind: Expression + template: ~ARG[0] and ~ARG[1] +- BlackBox: + name: GHC.Prim.orWord32# + kind: Expression + template: ~ARG[0] or ~ARG[1] +- BlackBox: + name: GHC.Prim.xorWord32# + kind: Expression + template: ~ARG[0] xor ~ARG[1] +- BlackBox: + name: GHC.Prim.notWord32# + kind: Expression + template: not ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftLWord32# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRLWord32# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.word32ToInt32# + kind: Expression + template: signed(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neWord32# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.int64ToInt# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.intToInt64# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.negateInt64# + kind: Expression + template: -~ARG[0] +- BlackBox: + name: GHC.Prim.timesInt64# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotInt64# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remInt64# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemInt64# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.uncheckedIShiftL64# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedIShiftRA64# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftR][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_right(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedIShiftRL64# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.int64ToWord64# + kind: Expression + template: unsigned(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neInt64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.word64ToWord# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.wordToWord64# + kind: Expression + template: resize(~ARG[0],~SIZE[~TYPO]) + workInfo: Never +- BlackBox: + name: GHC.Prim.timesWord64# + kind: Expression + template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) +- BlackBox: + name: GHC.Prim.quotWord64# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] / ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.remWord64# + kind: Declaration + template: |- + ~RESULT <= ~ARG[0] rem ~ARG[1] + -- pragma translate_off + when (~ARG[1] /= 0) else (others => 'X') + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.quotRemWord64# + kind: Declaration + template: |- + ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1]) + -- pragma translate_off + when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X')) + -- pragma translate_on + ; +- BlackBox: + name: GHC.Prim.and64# + kind: Expression + template: ~ARG[0] and ~ARG[1] +- BlackBox: + name: GHC.Prim.or64# + kind: Expression + template: ~ARG[0] or ~ARG[1] +- BlackBox: + name: GHC.Prim.xor64# + kind: Expression + template: ~ARG[0] xor ~ARG[1] +- BlackBox: + name: GHC.Prim.not64# + kind: Expression + template: not ~ARG[0] +- BlackBox: + name: GHC.Prim.uncheckedShiftL64# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= shift_left(~ARG[0],~SYM[1]) + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.uncheckedShiftRL64# + kind: Declaration + template: |- + ~GENSYM[~RESULT_shiftRL][0] : block + signal ~GENSYM[sh][1] : natural; + begin + ~SYM[1] <= + -- pragma translate_off + natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else + -- pragma translate_on + to_integer(~VAR[shI][1]); + ~RESULT <= ~ARG[0] srl ~SYM[1] + -- pragma translate_off + when (~ARG[1] >= 0) else (others => 'X') + -- pragma translate_on + ; + end block; +- BlackBox: + name: GHC.Prim.word64ToInt64# + kind: Expression + template: signed(std_logic_vector(~ARG[0])) + workInfo: Never +- BlackBox: + name: GHC.Prim.eqWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.geWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.gtWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.leWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.ltWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); +- BlackBox: + name: GHC.Prim.neWord64# + kind: Declaration + template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); diff --git a/src/Clash/Backend.hs b/src/Clash/Backend.hs --- a/src/Clash/Backend.hs +++ b/src/Clash/Backend.hs @@ -2,6 +2,7 @@ Copyright : (C) 2015-2016, University of Twente, 2017 , Myrtle Software Ltd, Google Inc., 2021-2022, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -13,6 +14,7 @@ import Data.HashMap.Strict (HashMap, empty) import Data.HashSet (HashSet) +import Control.Lens (Lens') import Data.Monoid (Ap) import Data.Text (Text) import qualified Data.Text.Lazy as LT @@ -27,7 +29,7 @@ import Clash.Driver.Types (ClashOpts) import {-# SOURCE #-} Clash.Netlist.Types - (Component, Declaration, Expr, HWType, Identifier, IdentifierSet, HasIdentifierSet) + (Component, Declaration, Expr, HWType, Identifier, IdentifierSet, HasIdentifierSet, UsageMap) import Clash.Netlist.BlackBox.Types import Clash.Signal.Internal (VDomainConfiguration) @@ -87,7 +89,10 @@ emptyDomainMap :: DomainMap emptyDomainMap = empty -class HasIdentifierSet state => Backend state where +class HasUsageMap s where + usageMap :: Lens' s UsageMap + +class (HasUsageMap state, HasIdentifierSet state) => Backend state where -- | Initial state for state monad initBackend :: ClashOpts -> state @@ -108,7 +113,7 @@ extractTypes :: state -> HashSet HWType -- | Generate HDL for a Netlist component - genHDL :: ModName -> SrcSpan -> IdentifierSet -> Component -> Ap (State state) ((String, Doc),[(String,Doc)]) + genHDL :: ClashOpts -> ModName -> SrcSpan -> IdentifierSet -> UsageMap -> Component -> Ap (State state) ((String, Doc),[(String,Doc)]) -- | Generate a HDL package containing type definitions for the given HWTypes mkTyPackage :: ModName -> [HWType] -> Ap (State state) [(String, Doc)] -- | Convert a Netlist HWType to a target HDL type diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -1,7 +1,8 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V., + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -48,18 +49,19 @@ (bitsToBits) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) -import Clash.Core.Var (Attr'(..)) +import Clash.Annotations.SynthesisAttributes (Attr(..)) import Clash.Debug (traceIf) import Clash.Backend import Clash.Backend.Verilog (bits, bit_char, encodingNote, exprLit, include, noEmptyInit, uselibs) +import Clash.Backend.Verilog.Time (periodToString) import Clash.Driver.Types (ClashOpts(..)) import Clash.Explicit.BlockRam.Internal (unpackNats) import Clash.Netlist.BlackBox.Types (HdlSyn (..)) import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox, renderFilePath) import qualified Clash.Netlist.Id as Id -import Clash.Netlist.Types hiding (intWidth) +import Clash.Netlist.Types hiding (intWidth, usages, _usages) import Clash.Netlist.Util import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Util @@ -93,6 +95,7 @@ , _aggressiveXOptBB_ :: AggressiveXOptBB , _renderEnums_ :: RenderEnums , _domainConfigurations_ :: DomainMap + , _usages :: UsageMap } makeLenses ''SystemVerilogState @@ -100,6 +103,9 @@ instance HasIdentifierSet SystemVerilogState where identifierSet = idSeen +instance HasUsageMap SystemVerilogState where + usageMap = usages + instance Backend SystemVerilogState where initBackend opts = SystemVerilogState { _tyCache=HashSet.empty @@ -122,6 +128,7 @@ , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _renderEnums_=coerce (opt_renderEnums opts) , _domainConfigurations_=emptyDomainMap + , _usages=mempty } hdlKind = const SystemVerilog primDirs = const $ do root <- primsRoot @@ -197,33 +204,40 @@ -- | Generate SystemVerilog for a Netlist component genSystemVerilog - :: ModName + :: ClashOpts + -> ModName -> SrcSpan -> IdentifierSet + -> UsageMap -> Component -> SystemVerilogM ((String, Doc), [(String, Doc)]) -genSystemVerilog _ sp seen c = do +genSystemVerilog opts _ sp seen us c = do -- Don't have type names conflict with module names or with previously -- generated type names. -- -- TODO: Collect all type names up front, to prevent relatively costly union. -- TODO: Investigate whether type names / signal names collide in the first place - Ap $ idSeen %= Id.union seen + Ap $ do + idSeen %= Id.union seen + usages .= us + setSrcSpan sp - Ap $ setSrcSpan sp v <- verilog incs <- Ap $ use includes return ((TextS.unpack (Id.toText cName), v), incs) where cName = componentName c verilog = commentHeader <> line <> + nettype <> line <> timescale <> line <> module_ c commentHeader = "/* AUTOMATICALLY GENERATED SYSTEMVERILOG-2005 SOURCE CODE." <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY." <> line <> "*/" - timescale = "`timescale 100fs/100fs" + nettype = "`default_nettype none" + timescale = "`timescale 100fs/" <> string (Text.pack precision) + precision = periodToString (opt_timescalePrecision opts) -- | Generate a SystemVerilog package containing type definitions for the given HWTypes mkTyPackage_ :: TextS.Text -> [HWType] -> SystemVerilogM [(String,Doc)] @@ -316,6 +330,7 @@ normaliseType ty@(Sum _ _) = return (BitVector (typeSize ty)) normaliseType ty@(CustomSum _ _ _ _) = return (BitVector (typeSize ty)) normaliseType (Clock _) = return Bit +normaliseType (ClockN _) = return Bit normaliseType (Reset _) = return Bit normaliseType (Enable _) = return Bool normaliseType (BiDirectional dir ty) = BiDirectional dir <$> normaliseType ty @@ -380,6 +395,7 @@ Product {} -> (ns, verilogType t) Vector {} -> error $ $(curLoc) ++ "impossible" Clock {} -> (ns, verilogType t) + ClockN {} -> (ns, verilogType t) Reset {} -> (ns, "logic") Enable {} -> (ns, "logic") Bool -> (ns, "logic") @@ -522,13 +538,21 @@ modEnding = "endmodule" inPorts = sequence [ sigPort (Nothing,isBiSignalIn ty) (i,ty) Nothing | (i,ty) <- inputs c ] - outPorts = sequence [ sigPort (Just wr,False) p iEM | (wr, p, iEM) <- outputs c ] + outPorts = sequence [ sigPort (Just u,False) p iEM | (u, p, iEM) <- outputs c ] + -- NOTE [net types and data types] + -- + -- SystemVerilog makes a distinction between the type of a net and the data + -- type of a signal. For output ports / inout ports this is fine, as there + -- is only one possible type. For input ports when using `default_nettype none + -- we have to specify the net type as wire explicitly (or vendor tools will + -- claim the net from the port declaration is implicitly defined). + wr2ty (Nothing,isBidirectional) | isBidirectional - = "inout" + = "inout" -- no net type here, it gets added by verilogType. | otherwise - = "input" + = "input wire" -- See NOTE [net types and data types] wr2ty (Just _,_) = "output" @@ -574,6 +598,7 @@ RTree {} -> pvrType Signed n -> logicOrWire <+> "signed" <+> brackets (int (n-1) <> colon <> int 0) Clock _ -> "logic" + ClockN _ -> "logic" Reset _ -> "logic" Enable _ -> "logic" Bit -> "logic" @@ -623,6 +648,7 @@ tyName t@(SP _ _) = "logic_vector_" <> int (typeSize t) tyName (Clock _) = "logic" +tyName (ClockN _) = "logic" tyName (Reset _) = "logic" tyName (Enable _) = "logic" tyName t = error $ $(curLoc) ++ "tyName: " ++ show t @@ -665,35 +691,34 @@ _ -> punctuate' semi (A.pure dsDoc) decl :: Declaration -> SystemVerilogM (Maybe Doc) -decl (NetDecl' noteM _ id_ tyE iEM) = +decl (NetDecl' noteM id_ tyE iEM) = Just A.<$> maybe id addNote noteM (addAttrs attrs (typ tyE)) where - typ (Left ty) = stringS ty <+> pretty id_ <> iE - typ (Right ty) = sigDecl (pretty id_) ty <> iE + typ ty = sigDecl (pretty id_) ty <> iE addNote n = mappend ("//" <+> stringS n <> line) - attrs = fromMaybe [] (hwTypeAttrs A.<$> either (const Nothing) Just tyE) + attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM decl _ = return Nothing -- | Convert single attribute to systemverilog syntax -renderAttr :: Attr' -> Text.Text -renderAttr (StringAttr' key value) = Text.pack $ concat [key, " = ", show value] -renderAttr (IntegerAttr' key value) = Text.pack $ concat [key, " = ", show value] -renderAttr (BoolAttr' key True ) = Text.pack $ concat [key, " = ", "1"] -renderAttr (BoolAttr' key False) = Text.pack $ concat [key, " = ", "0"] -renderAttr (Attr' key ) = Text.pack $ key +renderAttr :: Attr TextS.Text -> TextS.Text +renderAttr (StringAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)] +renderAttr (IntegerAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)] +renderAttr (BoolAttr key True ) = TextS.concat [key, " = ", "1"] +renderAttr (BoolAttr key False) = TextS.concat [key, " = ", "0"] +renderAttr (Attr key ) = key -- | Add attribute notation to given declaration addAttrs - :: [Attr'] + :: [Attr TextS.Text] -> SystemVerilogM Doc -> SystemVerilogM Doc addAttrs [] t = t addAttrs attrs' t = "(*" <+> attrs'' <+> "*)" <+> t where - attrs'' = string $ Text.intercalate ", " (map renderAttr attrs') + attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs') insts :: [Declaration] -> SystemVerilogM Doc insts [] = emptyDoc @@ -777,7 +802,9 @@ inst_ :: Declaration -> SystemVerilogM (Maybe Doc) inst_ (TickDecl {}) = return Nothing -inst_ (Assignment id_ e) = fmap Just $ +inst_ (CompDecl {}) = return Nothing + +inst_ (Assignment id_ Cont e) = fmap Just $ "assign" <+> pretty id_ <+> equals <+> align (expr_ False e <> semi) inst_ (CondAssignment id_ ty scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ do @@ -868,6 +895,9 @@ inst_ (ConditionalDecl cond ds) = Just <$> "`ifdef" <+> pretty cond <> line <> indent 2 (insts ds) <> line <> "`endif" +inst_ d = + error ("inst_: " ++ show d) + -- | Render a data constructor application for data constructors having a -- custom bit representation. customReprDataCon @@ -952,8 +982,9 @@ "end") <:> conds es' seq_ (SeqDecl sd) = case sd of - Assignment id_ e -> - pretty id_ <+> equals <+> expr_ False e <> semi + Assignment id_ (Proc b) e -> + let sym = case b of { Blocking -> equals; NonBlocking -> "<=" } + in pretty id_ <+> sym <+> expr_ False e <> semi BlackBoxD {} -> fromMaybe <$> emptyDoc <*> inst_ sd @@ -1116,10 +1147,10 @@ expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty -expr_ _ (DataCon (Vector 1 elTy) _ [e]) = "'" <> braces (toSLV elTy e) +expr_ _ (DataCon (Vector 1 elTy) _ [e]) = "'" <> braces (int 0 <> colon <+> toSLV elTy e) expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = case vectorChain e of - Just es -> "'" <> listBraces (mapM (toSLV elTy) es) + Just es -> "'" <> listBraces (zipWithM (\i e3 -> int i <> colon <+> toSLV elTy e3) [0..] es) Nothing -> verilogTypeMark ty <> "_cons" <> parens (expr_ False e1 <> comma <+> expr_ False e2) expr_ _ (DataCon (MemBlob n m) _ [n0, m0, _, runs, _, ends]) @@ -1190,9 +1221,9 @@ expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" , [Literal _ m, Literal _ i] <- extractLiterals bbCtx - = let NumLit m' = m - NumLit i' = i - in exprLitSV (Just (Bit,1)) (BitLit $ toBit m' i') + , NumLit m' <- m + , NumLit i' <- i + = exprLitSV (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -1,7 +1,8 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -20,7 +21,9 @@ module Clash.Backend.VHDL (VHDLState) where import Control.Arrow (second) +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Control.Lens hiding (Indexed, Empty) import Control.Monad (forM,join,zipWithM) import Control.Monad.State (State, StateT) @@ -35,7 +38,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List - (mapAccumL, nub, nubBy, intersperse, group, sort) + (mapAccumL, nub, nubBy, partition, intersperse, group, sort) import Data.List.Extra ((<:>), equalLength, zipEqual) import Data.Maybe (catMaybes,mapMaybe) import Data.Monoid (Ap(Ap)) @@ -62,8 +65,8 @@ (bitsToBits) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) +import Clash.Annotations.SynthesisAttributes (Attr(..)) import Clash.Backend -import Clash.Core.Var (Attr'(..),attrName) import Clash.Debug (traceIf) import Clash.Driver.Types (ClashOpts(..)) import Clash.Explicit.BlockRam.Internal (unpackNats) @@ -71,7 +74,7 @@ import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox, renderFilePath) import qualified Clash.Netlist.Id as Id -import Clash.Netlist.Types hiding (intWidth) +import Clash.Netlist.Types hiding (intWidth, usages, _usages) import Clash.Netlist.Util import Clash.Util (SrcSpan, noSrcSpan, clogBase, curLoc, makeCached, indexNote) @@ -115,6 +118,7 @@ , _aggressiveXOptBB_ :: AggressiveXOptBB , _renderEnums_ :: RenderEnums , _domainConfigurations_ :: DomainMap + , _usages :: UsageMap } makeLenses ''VHDLState @@ -122,6 +126,9 @@ instance HasIdentifierSet VHDLState where identifierSet = idSeen +instance HasUsageMap VHDLState where + usageMap = usages + instance Backend VHDLState where initBackend opts = VHDLState { _tyCache=mempty @@ -144,6 +151,7 @@ , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _renderEnums_=coerce (opt_renderEnums opts) , _domainConfigurations_=emptyDomainMap + , _usages=mempty } hdlKind = const VHDL primDirs = const $ do root <- primsRoot @@ -169,6 +177,7 @@ if enums then pure UserType else pure SynonymType Clock {} -> pure SynonymType + ClockN {} -> pure SynonymType Reset {} -> pure SynonymType Enable {} -> pure SynonymType Index {} -> pure SynonymType @@ -242,20 +251,28 @@ blockDecl nm ds = do decs <- decls ds let attrs = [ (id_, attr) - | NetDecl' _ _ id_ (Right hwtype) _ <- ds + | NetDecl' _ id_ hwtype _ <- ds , attr <- hwTypeAttrs hwtype] if isEmpty decs - then insts ds + then insts ids else nest 2 (pretty nm <+> colon <+> "block" <> line <> pure decs <> - if null attrs + (if null attrs then emptyDoc - else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <> - nest 2 - ("begin" <> line <> - insts ds) <> line <> + else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> + if null cds + then emptyDoc + else line <> line <> insts cds) <> line <> "begin" <> + nest 2 (line <> insts ids) + <> line <> "end block" <> semi + where + (cds, ids) = partition isCompDecl ds + + isCompDecl (CompDecl {}) = True + isCompDecl _ = False + addIncludes inc = includes %= (inc++) addLibraries libs = libraries %= (libs ++) addImports imps = packages %= (imps ++) @@ -282,7 +299,7 @@ -- | Generate unique (partial) names for product fields. Example: -- --- >>> productFieldNames [Unsigned 6, Unsigned 6, Bit, Bool] +-- > productFieldNames Nothing [Unsigned 6, Unsigned 6, Bit, Bool] -- ["unsigned6_0", "unsigned6_1", "bit", "boolean"] productFieldNames :: HasCallStack @@ -296,7 +313,9 @@ hFields <- zipWithM hName labels1 fields let grouped = group $ sort $ hFields - counted = HashMapS.fromList (map (\(g:gs) -> (g, succ (length gs))) grouped) + countGroup [] = error "productFIeldNames.countGroup: group of zero elements" + countGroup (g:gs) = (g, succ (length gs)) + counted = HashMapS.fromList (map countGroup grouped) names = snd $ mapAccumL (name' counted) HashMapS.empty hFields return names @@ -373,20 +392,24 @@ -- | Generate VHDL for a Netlist component genVHDL - :: ModName + :: ClashOpts + -> ModName -> SrcSpan -> IdentifierSet + -> UsageMap -> Component -> VHDLM ((String, Doc), [(String, Doc)]) -genVHDL nm sp seen c = do +genVHDL _ nm sp seen us c = do -- Don't have type names conflict with module names or with previously -- generated type names. -- -- TODO: Collect all type names up front, to prevent relatively costly union. -- TODO: Investigate whether type names / signal names collide in the first place - Ap $ idSeen %= Id.union seen + Ap $ do + idSeen %= Id.union seen + usages .= us + setSrcSpan sp - Ap $ setSrcSpan sp v <- vhdl i <- Ap $ use includes Ap $ libraries .= [] @@ -579,6 +602,7 @@ -- Type aliases: Clock _ -> typAliasDec hwty + ClockN _ -> typAliasDec hwty Reset _ -> typAliasDec hwty Enable _ -> typAliasDec hwty Index _ -> typAliasDec hwty @@ -721,8 +745,9 @@ parens ("p." <> tyName t <> selectProductField labels elTys i)) argLengths = map typeSize elTys - starts = 0 : snd (mapAccumL ((join (,) .) . (+)) 0 argLengths) - ends = map (subtract 1) (tail starts) + starts1 = snd (mapAccumL ((join (,) .) . (+)) 0 argLengths) + starts = 0 : starts1 + ends = map (subtract 1) starts1 elTyFromSLV = forM (zip starts ends) (\(s,e) -> "fromSLV" <> @@ -940,7 +965,7 @@ rattrs = renderAttrs (TextS.pack "signal") attrs attrs = inputAttrs ++ outputAttrs inputAttrs = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype] - outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] + outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] architecture :: Component -> VHDLM Doc @@ -961,46 +986,52 @@ } where netdecls = filter isNetDecl (declarations c) - declAttrs = [(id_, attr) | NetDecl' _ _ id_ (Right hwtype) _ <- netdecls, attr <- hwTypeAttrs hwtype] + declAttrs = [(id_, attr) | NetDecl' _ id_ hwtype _ <- netdecls, attr <- hwTypeAttrs hwtype] inputAttrs = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype] - outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] + outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] isNetDecl :: Declaration -> Bool - isNetDecl (NetDecl' _ _ _ (Right _) _) = True - isNetDecl _ = False + isNetDecl NetDecl'{} = True + isNetDecl _ = False -attrType - :: t ~ HashMap T.Text T.Text - => t - -> Attr' - -> t +attrType :: + HashMap TextS.Text TextS.Text -> + Attr TextS.Text -> + HashMap TextS.Text TextS.Text attrType types attr = case HashMap.lookup name' types of Nothing -> HashMap.insert name' type' types Just type'' | type'' == type' -> types | otherwise -> error $ - $(curLoc) ++ unwords [ T.unpack name', "already assigned" - , T.unpack type'', "while we tried to" - , "add", T.unpack type' ] + $(curLoc) ++ unwords [ TextS.unpack name', "already assigned" + , TextS.unpack type'', "while we tried to" + , "add", TextS.unpack type' ] where - name' = T.pack $ attrName attr - type' = T.pack $ case attr of - BoolAttr' _ _ -> "boolean" - IntegerAttr' _ _ -> "integer" - StringAttr' _ _ -> "string" - Attr' _ -> "bool" + name' = attrName attr + type' = case attr of + BoolAttr _ _ -> "boolean" + IntegerAttr _ _ -> "integer" + StringAttr _ _ -> "string" + Attr _ -> "boolean" +attrName :: Attr a -> a +attrName = \case + BoolAttr a _ -> a + IntegerAttr a _ -> a + StringAttr a _ -> a + Attr a -> a + -- | Create 'attrname -> type' mapping for given attributes. Will err if multiple -- types are assigned to the same name. -attrTypes :: [Attr'] -> HashMap T.Text T.Text +attrTypes :: [Attr TextS.Text] -> HashMap TextS.Text TextS.Text attrTypes = foldl attrType HashMap.empty -- | Create a 'attrname -> (type, [(signalname, value)]). Will err if multiple -- types are assigned to the same name. attrMap :: forall t - . t ~ HashMap T.Text (T.Text, [(TextS.Text, T.Text)]) - => [(Identifier, Attr')] + . t ~ HashMap TextS.Text (TextS.Text, [(TextS.Text, TextS.Text)]) + => [(Identifier, Attr TextS.Text)] -> t attrMap attrs0 = foldl go empty' attrs1 where @@ -1010,56 +1041,57 @@ [(k, (types HashMap.! k, [])) | k <- HashMap.keys types] types = attrTypes (map snd attrs1) - go :: t -> (TextS.Text, Attr') -> t - go map' attr = HashMap.adjust - (go' attr) - (T.pack $ attrName $ snd attr) - map' + go :: t -> (TextS.Text, Attr TextS.Text) -> t + go map' attr = HashMap.adjust (go' attr) (attrName $ snd attr) map' go' - :: (TextS.Text, Attr') - -> (T.Text, [(TextS.Text, T.Text)]) - -> (T.Text, [(TextS.Text, T.Text)]) + :: (TextS.Text, Attr TextS.Text) + -> (TextS.Text, [(TextS.Text, TextS.Text)]) + -> (TextS.Text, [(TextS.Text, TextS.Text)]) go' (signalName, attr) (typ, elems) = (typ, (signalName, renderAttr attr) : elems) renderAttrs :: TextS.Text - -> [(Identifier, Attr')] + -> [(Identifier, Attr TextS.Text)] -> VHDLM Doc renderAttrs what (attrMap -> attrs) = vcat $ sequence $ intersperse " " $ map renderAttrGroup (HashMap.toList attrs) where renderAttrGroup - :: (T.Text, (T.Text, [(TextS.Text, T.Text)])) + :: (TextS.Text, (TextS.Text, [(TextS.Text, TextS.Text)])) -> VHDLM Doc renderAttrGroup (attrname, (typ, elems)) = - ("attribute" <+> string attrname <+> colon <+> string typ <> semi) + ("attribute" <+> stringS attrname <+> colon <+> stringS typ <> semi) <> line <> (vcat $ sequence $ map (renderAttrDecl attrname) elems) renderAttrDecl - :: T.Text - -> (TextS.Text, T.Text) + :: TextS.Text + -> (TextS.Text, TextS.Text) -> VHDLM Doc renderAttrDecl attrname (signalName, value) = "attribute" - <+> string attrname + <+> stringS attrname <+> "of" <+> stringS signalName -- or component name <+> colon <+> stringS what <+> "is" -- "signal is" or "component is" - <+> string value + <+> stringS value <> semi -- | Convert single attribute to VHDL syntax -renderAttr :: Attr' -> T.Text -renderAttr (StringAttr' _key value) = T.replace "\\\"" "\"\"" $ T.pack $ show value -renderAttr (IntegerAttr' _key value) = T.pack $ show value -renderAttr (BoolAttr' _key True ) = T.pack $ "true" -renderAttr (BoolAttr' _key False) = T.pack $ "false" -renderAttr (Attr' _key ) = T.pack $ "true" +renderAttr :: Attr TextS.Text -> TextS.Text +renderAttr (StringAttr _key value) = wrap '"' $ TextS.replace "\"" "\"\"" value +renderAttr (IntegerAttr _key value) = TextS.pack (show value) +renderAttr (BoolAttr _key True ) = "true" +renderAttr (BoolAttr _key False) = "false" +renderAttr (Attr _key ) = "true" +-- | Prepend and append a character to a string +wrap :: Char -> TextS.Text -> TextS.Text +wrap c = cons c . (`snoc` c) + sigDecl :: VHDLM Doc -> HWType -> VHDLM Doc sigDecl d t = d <+> colon <+> sizedQualTyName t @@ -1173,6 +1205,9 @@ Clock nm0 -> let nm1 = "clk_" `TextS.append` nm0 in Ap $ makeCached (t, False) nameCache (userTyName "clk" nm1 t) + ClockN nm0 -> + let nm1 = "clk_n_" `TextS.append` nm0 in + Ap $ makeCached (t, False) nameCache (userTyName "clk" nm1 t) Reset nm0 -> let nm1 = "rst_" `TextS.append` nm0 in Ap $ makeCached (t, False) nameCache (userTyName "rst" nm1 t) @@ -1225,6 +1260,7 @@ -- Simple types, for which a subtype (without qualifiers) will be made in VHDL: Clock _ -> Bit + ClockN _ -> Bit Reset _ -> Bit Enable _ -> Bool Index _ -> Unsigned (typeSize hwty) @@ -1248,6 +1284,7 @@ Integer -> hwty Bit -> hwty Clock _ -> hwty + ClockN _ -> hwty Reset _ -> hwty Enable _ -> hwty Index _ -> hwty @@ -1275,8 +1312,8 @@ (map (second filterTransparent) constrs) -- Transparent types: - Annotated _ elTy -> elTy - BiDirectional _ elTy -> elTy + Annotated _ elTy -> filterTransparent elTy + BiDirectional _ elTy -> filterTransparent elTy Void {} -> hwty KnownDomain {} -> hwty @@ -1326,6 +1363,7 @@ else qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> singularErrValue) sizedQualTyNameErrValue (Clock _) = singularErrValue +sizedQualTyNameErrValue (ClockN _) = singularErrValue sizedQualTyNameErrValue (Reset _) = singularErrValue sizedQualTyNameErrValue (Enable _) = singularErrValue sizedQualTyNameErrValue (Void {}) = @@ -1360,8 +1398,8 @@ _ -> vcat (pure dsDoc) decl :: Int -> Declaration -> VHDLM (Maybe (Doc,Int)) -decl l (NetDecl' noteM _ id_ ty iEM) = Just <$> (,fromIntegral (TextS.length (Id.toText id_))) <$> - maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty sizedQualTyName ty <> iE <> semi) +decl l (NetDecl' noteM id_ ty iEM) = Just <$> (,fromIntegral (TextS.length (Id.toText id_))) <$> + maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> sizedQualTyName ty <> iE <> semi) where addNote n = mappend ("--" <+> pretty n <> line) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM @@ -1384,7 +1422,9 @@ portDir In = "in" portDir Out = "out" - attrs' = if null attrs then emptyDoc else renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs] + attrs' + | null attrs = emptyDoc + | otherwise = renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs] decl _ _ = return Nothing @@ -1479,9 +1519,16 @@ -- | Turn a Netlist Declaration to a VHDL concurrent block inst_ :: Declaration -> VHDLM (Maybe Doc) -inst_ (Assignment id_ e) = fmap Just $ +inst_ (Assignment id_ Cont e) = fmap Just $ pretty id_ <+> larrow <+> align (expr_ False e) <> semi +inst_ (CompDecl nm ps0) = + fmap Just $ "component" <+> pretty nm <+> + ("port" <> line <> indent 2 (tupledSemi ps <> semi)) + <> line <> "end component" <> semi + where ps = traverse (\(t,pd,ty) -> pretty t <+> ":" <+> ppd pd <+> sizedQualTyName ty) ps0 + ppd = \case { In -> "in"; Out -> "out"} + inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ pretty id_ <+> larrow <+> align (vsep (sequence [expr_ False t <+> "when" <+> @@ -1706,16 +1753,16 @@ expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx - = let NumLit m' = m - NumLit i' = i - in exprLit (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i') + , NumLit m' <- m + , NumLit i' <- i + = exprLit (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" , [Literal _ m, Literal _ i] <- extractLiterals bbCtx - = let NumLit m' = m - NumLit i' = i - in exprLit (Just (Bit,1)) (BitLit $ toBit m' i') + , NumLit m' <- m + , NumLit i' <- i + = exprLit (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" @@ -1890,9 +1937,9 @@ bits = dquotes . hcat . mapM bit_char toHex :: Int -> Integer -> String -toHex sz i = - let Just d = clogBase 16 (2^sz) - in printf ("%0" ++ show d ++ "X") (abs i) +toHex sz i = case clogBase 16 (2^sz) of + Just d -> printf ("%0" ++ show d ++ "X") (abs i) + _ -> error "toHex: impossible" hex :: String -> VHDLM Doc hex s = char 'x' <> dquotes (pretty (T.pack s)) @@ -1905,7 +1952,7 @@ case udf of Nothing -> char '-' Just Nothing -> char '0' - Just (Just i) -> "'" <> int i <> "'" + Just (Just i) -> int i bit_char Z = char 'Z' toSLV :: HasCallStack => HWType -> Expr -> VHDLM Doc @@ -1918,6 +1965,9 @@ toSLV (Clock {}) e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) +toSLV (ClockN {}) e = do + nm <- Ap $ use modNm + pretty nm <> "_types.toSLV" <> parens (expr_ False e) toSLV (Reset {}) e = do nm <- Ap $ use modNm pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e) @@ -2004,6 +2054,7 @@ encodingNote :: HWType -> VHDLM Doc encodingNote (Clock _) = "-- clock" <> line +encodingNote (ClockN _) = "-- clock (neg phase)" <> line encodingNote (Reset _) = "-- reset" <> line encodingNote (Enable _) = "-- enable" <> line encodingNote (Annotated _ t) = encodingNote t diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs --- a/src/Clash/Backend/Verilog.hs +++ b/src/Clash/Backend/Verilog.hs @@ -1,7 +1,8 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -64,8 +65,9 @@ (ConstrRepr'(..), DataRepr'(..), ConstrRepr'(..)) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) -import Clash.Core.Var (Attr'(..)) +import Clash.Annotations.SynthesisAttributes (Attr(..)) import Clash.Backend +import Clash.Backend.Verilog.Time (periodToString) import Clash.Debug (traceIf) import Clash.Driver.Types (ClashOpts(..)) import Clash.Explicit.BlockRam.Internal (unpackNats) @@ -73,7 +75,7 @@ import Clash.Netlist.BlackBox.Util (extractLiterals, renderBlackBox, renderFilePath) import qualified Clash.Netlist.Id as Id -import Clash.Netlist.Types hiding (intWidth) +import Clash.Netlist.Types as N hiding (intWidth, usages, _usages) import Clash.Netlist.Util import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Util @@ -101,6 +103,7 @@ , _undefValue :: Maybe (Maybe Int) , _aggressiveXOptBB_ :: AggressiveXOptBB , _domainConfigurations_ :: DomainMap + , _usages :: UsageMap } makeLenses ''VerilogState @@ -108,6 +111,9 @@ instance HasIdentifierSet VerilogState where identifierSet = idSeen +instance HasUsageMap VerilogState where + usageMap = usages + instance Backend VerilogState where initBackend opts = VerilogState { _genDepth=0 @@ -125,6 +131,7 @@ , _undefValue=opt_forceUndefined opts , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _domainConfigurations_=emptyDomainMap + , _usages=mempty } hdlKind = const Verilog primDirs = const $ do root <- primsRoot @@ -136,7 +143,7 @@ name = const "verilog" extension = const ".v" - genHDL = const genVerilog + genHDL = genVerilog mkTyPackage _ _ = return [] hdlType _ = verilogType hdlHWTypeKind _ = pure PrimitiveType -- Everything is a bitvector! @@ -197,20 +204,25 @@ -- | Generate Verilog for a Netlist component genVerilog - :: SrcSpan + :: ClashOpts + -> ModName + -> SrcSpan -> IdentifierSet + -> UsageMap -> Component -> VerilogM ((String, Doc), [(String, Doc)]) -genVerilog sp seen c = do +genVerilog opts _ sp seen usage c = do -- Don't have type names conflict with module names or with previously -- generated type names. -- -- TODO: Collect all type names up front, to prevent relatively costly union. -- TODO: Investigate whether type names / signal names collide in the first place - Ap $ idSeen %= Id.union seen + Ap $ do + idSeen %= Id.union seen + usages .= usage + setSrcSpan sp - Ap (setSrcSpan sp) - v <- commentHeader <> line <> timescale <> line <> module_ c + v <- commentHeader <> line <> nettype <> line <> timescale <> line <> module_ c incs <- Ap $ use includes return ((TextS.unpack (Id.toText cName), v), incs) where @@ -219,25 +231,76 @@ = "/* AUTOMATICALLY GENERATED VERILOG-2001 SOURCE CODE." <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY." <> line <> "*/" - timescale = "`timescale 100fs/100fs" + nettype = "`default_nettype none" + timescale = "`timescale 100fs/" <> string (Text.pack precision) + precision = periodToString (opt_timescalePrecision opts) sigPort - :: Maybe WireOrReg + :: VerilogM Doc + -> Maybe N.Usage -> Identifier -> HWType -> Maybe Expr -> VerilogM Doc -sigPort wor (Id.toText -> pName) hwType iEM = +sigPort def mu (Id.toText -> pName) hwType iEM = do addAttrs (hwTypeAttrs hwType) (portType <+> verilogType hwType <+> stringS pName <> iE <> encodingNote hwType) where - portType = case wor of - Nothing -> if isBiSignalIn hwType then "inout" else "input" - Just Wire -> "output" <+> "wire" - Just Reg -> "output" <+> "reg" + portType = + -- See NOTE [net and variable ports] + case mu of + Just Cont -> + "output wire" + Just Proc{} -> + "output reg" + + Nothing -> + if isBiSignalIn hwType then "inout wire" else def <+> "wire" + iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM +{- +NOTE [net and variable ports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Verilog, ports are typically seen written with the default implicit net type +of wire, i.e. + + input foo, + output bar, + +which is really a shorthand for + + input wire foo, + output wire bar, + +When we use `default_nettype none however, this is no longer allowed as all +nets must be explicitly given their type. When generating code we must include +the additional word wire (the net type). + +What is the benefit of this? When we have a default net type, any variable +generated which is not declared is given an implicit declaration of this +default type. This can obscure clash errors, i.e. if Clash generated + + wire foo; + fo <= ...; + +Then simulators would act as though this was written: + + wire foo; + wire fo; + fo <= ...; + +Which should never be the desired behaviour for code generated by Clash. + +One final point, Verilog allows output to also be a variable type, i.e. + + output reg foo; + +If a port is an input or an inout then it can only be a net and not a variable +according to the standard, so input reg and inout reg are impossible. +-} + module_ :: Component -> VerilogM Doc module_ c = modVerilog <* Ap (imports .= HashSet.empty >> libraries .= HashSet.empty) @@ -256,8 +319,11 @@ modBody = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c)) modEnding = "endmodule" - inPorts = sequence [ sigPort Nothing id_ hwType Nothing | (id_, hwType) <- inputs c ] - outPorts = sequence [ sigPort (Just wireOrReg) id_ hwType iEM | (wireOrReg, (id_, hwType), iEM) <- outputs c ] + inPorts = sequence [ sigPort "input" Nothing id_ hwType Nothing | (id_, hwType) <- inputs c ] + outPorts = do + us <- use usages + let useOf i u = lookupUsage i us <> Just u + sequence [ sigPort "output" (useOf id_ u) id_ hwType iEM | (u,(id_, hwType), iEM) <- outputs c ] -- slightly more readable than 'tupled', makes the output Haskell-y-er commafy v = (comma <> space) <> pure v @@ -291,21 +357,23 @@ indent 2 (string "`uselib" <+> (hsep (mapM (\l -> ("lib=" <> string l)) xs))) <> line <> line -wireRegFileDoc :: WireOrReg -> (Either a HWType) -> VerilogM Doc -wireRegFileDoc _ (Right FileType) = "integer" -wireRegFileDoc Wire _ = "wire" -wireRegFileDoc Reg _ = "reg" +usageFileDoc :: Maybe N.Usage -> HWType -> VerilogM Doc +usageFileDoc _ FileType = "integer" +usageFileDoc (Just Proc{}) _ = "reg" +usageFileDoc _ _ = "wire" verilogType :: HWType -> VerilogM Doc verilogType t = case t of Signed n -> "signed" <+> brackets (int (n-1) <> colon <> int 0) Clock {} -> emptyDoc + ClockN {} -> emptyDoc Reset {} -> emptyDoc Enable {} -> emptyDoc Bit -> emptyDoc Bool -> emptyDoc FileType -> emptyDoc Annotated _ ty -> verilogType ty + BiDirectional _ ty -> verilogType ty _ -> brackets (int (typeSize t -1) <> colon <> int 0) sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc @@ -342,31 +410,32 @@ -- | Add attribute notation to given declaration addAttrs - :: [Attr'] + :: [Attr TextS.Text] -> VerilogM Doc -> VerilogM Doc addAttrs [] t = t addAttrs attrs' t = "(*" <+> attrs'' <+> "*)" <+> t where - attrs'' = string $ Text.intercalate ", " (map renderAttr attrs') + attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs') -- | Convert single attribute to verilog syntax -renderAttr :: Attr' -> Text.Text -renderAttr (StringAttr' key value) = pack $ concat [key, " = ", show value] -renderAttr (IntegerAttr' key value) = pack $ concat [key, " = ", show value] -renderAttr (BoolAttr' key True ) = pack $ concat [key, " = ", "1"] -renderAttr (BoolAttr' key False) = pack $ concat [key, " = ", "0"] -renderAttr (Attr' key ) = pack $ key +renderAttr :: Attr TextS.Text -> TextS.Text +renderAttr (StringAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)] +renderAttr (IntegerAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)] +renderAttr (BoolAttr key True ) = TextS.concat [key, " = ", "1"] +renderAttr (BoolAttr key False) = TextS.concat [key, " = ", "0"] +renderAttr (Attr key ) = key decl :: Declaration -> VerilogM (Maybe Doc) -decl (NetDecl' noteM wr id_ tyE iEM) = - Just A.<$> maybe id addNote noteM (addAttrs attrs (wireRegFileDoc wr tyE <+> tyDec tyE)) +decl (NetDecl' noteM id_ tyE iEM) = do + us <- use usages + let u = lookupUsage id_ us + Just A.<$> maybe id addNote noteM (addAttrs attrs (usageFileDoc u tyE <+> tyDec tyE)) where - tyDec (Left ty) = stringS ty <+> pretty id_ <> iE - tyDec (Right ty) = sigDecl (pretty id_) ty <> iE + tyDec ty = sigDecl (pretty id_) ty <> iE addNote n = mappend ("//" <+> stringS n <> line) - attrs = fromMaybe [] (hwTypeAttrs A.<$> either (const Nothing) Just tyE) + attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM decl _ = return Nothing @@ -471,7 +540,8 @@ -- | Turn a Netlist Declaration to a Verilog concurrent block inst_ :: Declaration -> VerilogM (Maybe Doc) inst_ (TickDecl {}) = return Nothing -inst_ (Assignment id_ e) = fmap Just $ +inst_ (CompDecl {}) = return Nothing +inst_ (Assignment id_ Cont e) = fmap Just $ "assign" <+> pretty id_ <+> equals <+> expr_ False e <> semi inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ @@ -535,6 +605,9 @@ inst_ (ConditionalDecl cond ds) = Just <$> "`ifdef" <+> pretty cond <> line <> indent 2 (insts ds) <> line <> "`endif" +inst_ d = + error ("inst_: " ++ show d) + seq_ :: Seq -> VerilogM Doc seq_ (AlwaysClocked edge clk ds) = "always @" <> @@ -575,8 +648,9 @@ "end") <:> conds es' seq_ (SeqDecl sd) = case sd of - Assignment id_ e -> - pretty id_ <+> equals <+> expr_ False e <> semi + Assignment id_ (Proc b) e -> + let op = case b of { Blocking -> equals; NonBlocking -> "<=" } + in pretty id_ <+> op <+> expr_ False e <> semi BlackBoxD {} -> fromMaybe <$> emptyDoc <*> inst_ sd @@ -1060,16 +1134,16 @@ expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx - = let NumLit m' = m - NumLit i' = i - in exprLitV (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i') + , NumLit m' <- m + , NumLit i' <- i + = exprLitV (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger##" , [Literal _ m, Literal _ i] <- extractLiterals bbCtx - = let NumLit m' = m - NumLit i' = i - in exprLitV (Just (Bit,1)) (BitLit $ toBit m' i') + , NumLit m' <- m + , NumLit i' <- i + = exprLitV (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" @@ -1192,10 +1266,9 @@ udf <- Ap (use k) case (udf,b) of (Just Nothing,U) -> char '0' - (Just (Just i),U) -> "'" <> int i <> "'" + (Just (Just i),U) -> int i _ -> char (bit_char' b) - dcToExpr :: HWType -> Int -> Expr dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) @@ -1211,6 +1284,7 @@ encodingNote :: Applicative m => HWType -> m Doc encodingNote (Clock _) = string " // clock" +encodingNote (ClockN _) = string " // clock (neg phase)" encodingNote (Reset _) = string " // reset" encodingNote (Enable _) = string " // enable" encodingNote (Annotated _ t) = encodingNote t diff --git a/src/Clash/Backend/Verilog/Time.hs b/src/Clash/Backend/Verilog/Time.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Backend/Verilog/Time.hs @@ -0,0 +1,127 @@ +{-| +Copyright : (C) 2022, Google Inc., +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +Utilities and definitions to deal with Verilog's time unit. These definitions +are here mostly to deal with varying @`timescale@ defintions, see: + + https://www.chipverify.com/verilog/verilog-timescale + +-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +module Clash.Backend.Verilog.Time where + +import Clash.Class.HasDomain.HasSingleDomain + (TryDomain, TryDomainResult(NotFound)) + +import Control.DeepSeq (NFData) +import Data.Char (toLower, isDigit) +import Data.Hashable (Hashable) +import Data.List (find) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Text.Read (readMaybe) + +-- | Verilog time units +data Unit = Fs | Ps | Ns | Us | Ms | S + deriving (Show, Enum, Bounded, Eq, Ord, Generic, Hashable, NFData) + +type instance TryDomain t Unit = 'NotFound + +-- | Verilog time period. A combination of a length and a unit. +data Period = Period Word64 Unit + deriving (Show, Generic, Hashable, Eq, NFData) + +-- | Verilog timescale. Influences simulation precision. +data Scale = Scale + { -- | Time step in wait statements, e.g. `#1`. + step :: Period + + -- | Simulator precision - all units will get rounded to this period. + , precision :: Period + } + deriving (Show, Generic, Hashable, Eq, NFData) + +-- | Pretty print 'Scale' to Verilog `timescale +-- +-- >>> scaleToString (Scale (Period 100 Ps) (Period 10 Fs)) +-- "`timescale 100ps/10fs" +-- +scaleToString :: Scale -> String +scaleToString (Scale{step, precision}) = + "`timescale " <> periodToString step <> "/" <> periodToString precision + +-- | Convert 'Unit' to Verilog time unit +-- +-- >>> periodToString (Period 100 Fs) +-- "100fs" +-- +periodToString :: Period -> String +periodToString (Period len unit) = show len <> unitToString unit + +-- | Convert 'Unit' to Verilog time unit +-- +-- >>> unitToString Ms +-- "ms" +-- +unitToString :: Unit -> String +unitToString = map toLower . show + +-- | Parse string representing a Verilog time unit to 'Unit'. +-- +-- >>> parseUnit "ms" +-- Just Ms +-- >>> parseUnit "xs" +-- Nothing +-- +parseUnit :: String -> Maybe Unit +parseUnit s = find tryUnit [minBound..] + where + tryUnit :: Unit -> Bool + tryUnit u = unitToString u == s + +-- | Parse a Verilog +-- +-- >>> parsePeriod "100ms" +-- Just (Period 100 Ms) +-- >>> parsePeriod "100xs" +-- Nothing +-- >>> parsePeriod "100" +-- Nothing +-- >>> parsePeriod "ms" +-- Nothing +-- +parsePeriod :: String -> Maybe Period +parsePeriod s = + case span isDigit s of + (len0, unit0) -> do + len1 <- readMaybe len0 + unit1 <- parseUnit unit0 + pure (Period len1 unit1) + +-- | Convert a period to a specific time unit. Will always output a minimum +-- of 1, even if the given 'Period' is already of the right 'Unit'. +-- +-- >>> convertUnit Ps (Period 100 Ps) +-- 100 +-- >>> convertUnit Fs (Period 100 Ps) +-- 100000 +-- >>> convertUnit Ns (Period 100 Ps) +-- 1 +-- >>> convertUnit Ms (Period 0 Ms) +-- 1 +-- +convertUnit :: Unit -> Period -> Word64 +convertUnit targetUnit = go + where + go (Period len unit) = + case compare unit targetUnit of + LT -> go (Period (len `div` 1000) (succ unit)) + EQ -> max 1 len + GT -> go (Period (len * 1000) (pred unit)) diff --git a/src/Clash/Core/Evaluator/Types.hs b/src/Clash/Core/Evaluator/Types.hs --- a/src/Clash/Core/Evaluator/Types.hs +++ b/src/Clash/Core/Evaluator/Types.hs @@ -38,6 +38,7 @@ whnf' :: Evaluator -> BindingMap + -> VarEnv Term -> TyConMap -> PrimHeap -> Supply @@ -45,12 +46,12 @@ -> Bool -> Term -> (PrimHeap, PureHeap, Term) -whnf' eval bm tcm ph ids is isSubj e = +whnf' eval bm lh tcm ph ids is isSubj e = toResult $ whnf eval tcm isSubj m where toResult x = (mHeapPrim x, mHeapLocal x, mTerm x) - m = Machine ph gh emptyVarEnv [] ids is e + m = Machine ph gh lh [] ids is e gh = mapVarEnv bindingTerm bm -- | Evaluate to WHNF given an existing Heap and Stack @@ -314,9 +315,19 @@ forcePrims :: Machine -> Bool forcePrims = go . mStack where + -- When do we need to force the compile-time evaluation of a primitive? + -- + -- 1. When they are the subject of a case-expression go (Scrutinise{}:_) = True + -- 2. When they are in the argument position of another primitive: + -- primitives are assumed to be strict in their arguments go (PrimApply{}:_) = True + -- We look through ticks go (Tickish{}:xs) = go xs + -- We are in a context where we dereferenced a heap-binding, hence the + -- update fram on the stack. So now we need to check whether that variable + -- reference was in a position where the result must be evaluated to WHNF + go (Update{}:xs) = go xs go _ = False primCount :: Machine -> Int diff --git a/src/Clash/Core/HasType.hs b/src/Clash/Core/HasType.hs --- a/src/Clash/Core/HasType.hs +++ b/src/Clash/Core/HasType.hs @@ -22,8 +22,6 @@ , piResultTys ) where -import qualified Data.Text as Text (isInfixOf) - #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (line) #else @@ -35,17 +33,16 @@ import Clash.Core.DataCon (DataCon(dcType)) import Clash.Core.HasFreeVars import Clash.Core.Literal (Literal(..)) -import Clash.Core.Name (Name(nameOcc)) import Clash.Core.Pretty import Clash.Core.Subst import Clash.Core.Term (Term(..), IsMultiPrim(..), PrimInfo(..), collectArgs) -import Clash.Core.TyCon (TyCon(tyConKind), TyConMap) +import Clash.Core.TyCon (TyCon(tyConKind), TyConMap, isTupleTyConLike) import Clash.Core.Type import Clash.Core.TysPrim import Clash.Core.Var (Var(varType)) import Clash.Core.VarEnv +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn) -import Clash.Unique (lookupUniqMap') import Clash.Util (curLoc, pprPanic) import qualified Clash.Util.Interpolate as I @@ -70,6 +67,14 @@ CharLiteral _ -> charPrimTy Int64Literal _ -> int64PrimTy Word64Literal _ -> word64PrimTy +#if MIN_VERSION_ghc(8,8,0) + Int8Literal _ -> int8PrimTy + Int16Literal _ -> int16PrimTy + Int32Literal _ -> int32PrimTy + Word8Literal _ -> word8PrimTy + Word16Literal _ -> word16PrimTy + Word32Literal _ -> word32PrimTy +#endif NaturalLiteral _ -> naturalPrimTy ByteArrayLiteral _ -> byteArrayPrimTy @@ -82,7 +87,7 @@ MultiResult | let (primArgs, primResTy) = splitFunForallTy (primType pr) , TyConApp tupTcNm tupArgs <- tyView primResTy - , Text.isInfixOf "GHC.Tuple.(" (nameOcc tupTcNm) + , isTupleTyConLike tupTcNm -> mkPolyFunTy primResTy (primArgs <> fmap Right tupArgs) | otherwise @@ -111,7 +116,7 @@ liftedTypeKind TyConApp tc args -> - piResultTys tcm (tyConKind (lookupUniqMap' tcm tc)) args + piResultTys tcm (tyConKind (UniqMap.find tc tcm)) args OtherType{} -> case ty of @@ -120,6 +125,7 @@ ForAllTy _ a -> inferCoreTypeOf tcm a LitTy NumTy{} -> typeNatKind LitTy SymTy{} -> typeSymbolKind + LitTy CharTy{} -> charPrimTy AnnType _ a -> inferCoreTypeOf tcm a AppTy a b -> go a [b] where diff --git a/src/Clash/Core/Literal.hs b/src/Clash/Core/Literal.hs --- a/src/Clash/Core/Literal.hs +++ b/src/Clash/Core/Literal.hs @@ -9,6 +9,7 @@ Term Literal -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -50,6 +51,14 @@ | WordLiteral !Integer | Int64Literal !Integer | Word64Literal !Integer +#if MIN_VERSION_ghc(8,8,0) + | Int8Literal !Integer + | Int16Literal !Integer + | Int32Literal !Integer + | Word8Literal !Integer + | Word16Literal !Integer + | Word32Literal !Integer +#endif | StringLiteral !String | FloatLiteral !Word32 | DoubleLiteral !Word64 diff --git a/src/Clash/Core/PartialEval/AsTerm.hs b/src/Clash/Core/PartialEval/AsTerm.hs --- a/src/Clash/Core/PartialEval/AsTerm.hs +++ b/src/Clash/Core/PartialEval/AsTerm.hs @@ -9,7 +9,6 @@ -} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Clash.Core.PartialEval.AsTerm ( AsTerm(..) diff --git a/src/Clash/Core/PartialEval/NormalForm.hs b/src/Clash/Core/PartialEval/NormalForm.hs --- a/src/Clash/Core/PartialEval/NormalForm.hs +++ b/src/Clash/Core/PartialEval/NormalForm.hs @@ -12,9 +12,7 @@ -} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} module Clash.Core.PartialEval.NormalForm ( Arg diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs --- a/src/Clash/Core/Pretty.hs +++ b/src/Clash/Core/Pretty.hs @@ -13,7 +13,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -224,11 +223,24 @@ dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_, data_,newtype_,type_,family_,instance_ :: ClashDoc -[dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_, - data_,newtype_,type_,family_,instance_] - = annotate (AnnSyntax Keyword) <$> - ["::", "->", "λ", "Λ", "@", "▷", "~", "let", "letrec", "in", "case", "of", "forall", - "data","newtype","type","family","instance"] +dcolon = annotate (AnnSyntax Keyword) "::" +rarrow = annotate (AnnSyntax Keyword) "->" +lam = annotate (AnnSyntax Keyword) "λ" +tylam = annotate (AnnSyntax Keyword) "Λ" +at = annotate (AnnSyntax Keyword) "@" +cast = annotate (AnnSyntax Keyword) "▷" +coerce = annotate (AnnSyntax Keyword) "~" +let_ = annotate (AnnSyntax Keyword) "let" +letrec = annotate (AnnSyntax Keyword) "letrec" +in_ = annotate (AnnSyntax Keyword) "in" +case_ = annotate (AnnSyntax Keyword) "case" +of_ = annotate (AnnSyntax Keyword) "of" +forall_ = annotate (AnnSyntax Keyword) "forall" +data_ = annotate (AnnSyntax Keyword) "data" +newtype_ = annotate (AnnSyntax Keyword) "newtype" +type_ = annotate (AnnSyntax Keyword) "type" +family_ = annotate (AnnSyntax Keyword) "family" +instance_ = annotate (AnnSyntax Keyword) "instance" instance PrettyPrec Text where pprPrec _ = pure . pretty @@ -291,6 +303,7 @@ instance Pretty LitTy where pretty (NumTy i) = pretty i pretty (SymTy s) = dquotes $ pretty s + pretty (CharTy c) = squotes $ pretty c instance PrettyPrec LitTy where pprPrec _ = return . annotate (AnnSyntax LitS) . pretty @@ -352,17 +365,19 @@ instance PrettyPrec Literal where pprPrec _ l = return $ annotate (AnnSyntax LitS) $ case l of - IntegerLiteral i - | i < 0 -> parens (pretty i) - | otherwise -> pretty i - IntLiteral i - | i < 0 -> parens (pretty i <> "#") - | otherwise -> pretty i <> "#" - Int64Literal i - | i < 0 -> parens (pretty i <> "#") - | otherwise -> pretty i <> "#" + IntegerLiteral i -> parensIf (i < 0) (pretty i) + IntLiteral i -> parensIf (i < 0) (pretty i <> "#") + Int64Literal i -> parensIf (i < 0) (pretty i <> "#64") WordLiteral w -> pretty w <> "##" - Word64Literal w -> pretty w <> "##" + Word64Literal w -> pretty w <> "##64" +#if MIN_VERSION_ghc(8,8,0) + Int8Literal i -> parensIf (i < 0) (pretty i <> "#8") + Int16Literal i -> parensIf (i < 0) (pretty i <> "#16") + Int32Literal i -> parensIf (i < 0) (pretty i <> "#32") + Word8Literal w -> pretty w <> "##8" + Word16Literal w -> pretty w <> "##16" + Word32Literal w -> pretty w <> "##32" +#endif FloatLiteral w -> pretty (wordToFloat w) <> "#" DoubleLiteral w -> pretty (wordToDouble w) <> "##" CharLiteral c -> pretty c <> "#" @@ -440,7 +455,7 @@ pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc pprPrecLetrec prec isRec xes body = do let bndrs = fst <$> xes - body' <- annotate (AnnContext $ LetBody bndrs) <$> pprPrec noPrec body + body' <- annotate (AnnContext $ LetBody xes) <$> pprPrec noPrec body xes' <- mapM (\(x,e) -> do x' <- pprBndr LetBind x e' <- pprPrec noPrec e diff --git a/src/Clash/Core/Subst.hs b/src/Clash/Core/Subst.hs --- a/src/Clash/Core/Subst.hs +++ b/src/Clash/Core/Subst.hs @@ -86,8 +86,8 @@ import Clash.Core.Type (Type (..)) import Clash.Core.VarEnv import Clash.Core.Var (Id, Var (..), TyVar, isGlobalId) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn) -import Clash.Unique import Clash.Util import Clash.Pretty @@ -457,7 +457,7 @@ "needsInScope" <+> clashPretty needsInScope) a where - needsInScope = foldrWithUnique (\k _ s -> delVarSetByKey k s) + needsInScope = UniqMap.foldrWithUnique (\k _ s -> delVarSetByKey k s) (freeVarsOf tys) tenv tysFVsInSope = needsInScope `varSetInScope` inScope @@ -968,10 +968,6 @@ Case {} -> 11 Tick {} -> 12 -thenCompare :: Ordering -> Ordering -> Ordering -thenCompare EQ rel = rel -thenCompare rel _ = rel - -- | Structural equality on 'Term' eqTerm :: Term -> Term -> Bool eqTerm = go @@ -1040,5 +1036,3 @@ instance Ord Term where compare = acmpTerm - -deriving instance Ord TickInfo diff --git a/src/Clash/Core/Subst.hs-boot b/src/Clash/Core/Subst.hs-boot --- a/src/Clash/Core/Subst.hs-boot +++ b/src/Clash/Core/Subst.hs-boot @@ -19,3 +19,4 @@ -> Bool instance Eq Type +instance Ord Type diff --git a/src/Clash/Core/Term.hs b/src/Clash/Core/Term.hs --- a/src/Clash/Core/Term.hs +++ b/src/Clash/Core/Term.hs @@ -70,19 +70,19 @@ import Data.Text (Text) import GHC.Generics #if MIN_VERSION_ghc(9,0,0) -import GHC.Types.SrcLoc (SrcSpan) +import GHC.Types.SrcLoc (SrcSpan, leftmost_smallest) #else -import SrcLoc (SrcSpan) +import SrcLoc (SrcSpan, leftmost_smallest) #endif -- Internal Modules import Clash.Core.DataCon (DataCon) import Clash.Core.Literal (Literal) import Clash.Core.Name (Name (..)) -import {-# SOURCE #-} Clash.Core.Subst () -- instance Eq Type +import {-# SOURCE #-} Clash.Core.Subst () -- instance Eq/Ord Type import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (Var, Id, TyVar) -import Clash.Util (curLoc) +import Clash.Util (curLoc, thenCompare) -- | Term representation in the CoreHW language: System F + LetRec + Case data Term @@ -124,6 +124,18 @@ -- do not try to share expressions between multiple branches. deriving (Eq, Show, Generic, NFData, Binary) +instance Ord TickInfo where + compare (SrcSpan s1) (SrcSpan s2) = leftmost_smallest s1 s2 + compare (NameMod m1 t1) (NameMod m2 t2) = + compare m1 m2 `thenCompare` compare t1 t2 + compare t1 t2 = compare (getRank t1) (getRank t2) + where + getRank :: TickInfo -> Word + getRank SrcSpan{} = 0 + getRank NameMod{} = 1 + getRank DeDup = 2 + getRank NoDeDup = 3 + -- | Tag to indicate which instance/register name modifier was used data NameMod = PrefixName @@ -254,7 +266,7 @@ -- ^ Function position of a type application | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' - | LetBody [Id] + | LetBody [LetBinding] -- ^ Body of a Let-binding with the bound LHS' | LamBody Id -- ^ Body of a lambda-term with the abstracted variable @@ -291,7 +303,7 @@ -- NB: we do not see inside the argument here (TyAppC, TyAppC) -> True (LetBinding i is, LetBinding i' is') -> i == i' && is == is' - (LetBody is, LetBody is') -> is == is' + (LetBody is, LetBody is') -> map fst is == map fst is' (LamBody i, LamBody i') -> i == i' (TyLamBody tv, TyLamBody tv') -> tv == tv' (CaseAlt p, CaseAlt p') -> p == p' diff --git a/src/Clash/Core/TermInfo.hs b/src/Clash/Core/TermInfo.hs --- a/src/Clash/Core/TermInfo.hs +++ b/src/Clash/Core/TermInfo.hs @@ -6,16 +6,14 @@ module Clash.Core.TermInfo where import Data.Maybe (fromMaybe) -import Data.Text (isInfixOf) import GHC.Stack (HasCallStack) import Clash.Core.HasType -import Clash.Core.Name import Clash.Core.Term -import Clash.Core.TyCon (tyConDataCons, TyConMap) +import Clash.Core.TyCon (tyConDataCons, isTupleTyConLike, TyConMap) import Clash.Core.Type import Clash.Core.Var -import Clash.Unique (lookupUniqMap) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Util.Interpolate as I termSize :: Term -> Word @@ -70,8 +68,8 @@ | (_primArgs, primResTy) <- splitFunForallTy (primType primInfo) , TyConApp tupTcNm tupEls <- tyView primResTy -- XXX: Hardcoded for tuples - , "GHC.Tuple.(," `isInfixOf` nameOcc tupTcNm - , Just tupTc <- lookupUniqMap tupTcNm tcm + , isTupleTyConLike tupTcNm + , Just tupTc <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc = Just $ MultiPrimInfo { mpi_primInfo = primInfo diff --git a/src/Clash/Core/TermLiteral.hs b/src/Clash/Core/TermLiteral.hs --- a/src/Clash/Core/TermLiteral.hs +++ b/src/Clash/Core/TermLiteral.hs @@ -1,21 +1,29 @@ {-| Copyright : (C) 2019, Myrtle Software Ltd, 2021, QBayLogic B.V. + 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Tools to convert a 'Term' into its "real" representation -} + +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} --{-# OPTIONS_GHC -ddump-splices #-} module Clash.Core.TermLiteral ( TermLiteral + , showsTypePrec + , showType , termToData , termToDataError + , deriveTermLiteral ) where import Data.Bifunctor (bimap) @@ -23,20 +31,39 @@ import Data.Proxy (Proxy(..)) import Data.Text (Text) import qualified Data.Text as Text +import Data.Text.Extra (showt) +#if MIN_VERSION_ghc(9,4,0) +import qualified Data.Text.Internal as Text +import qualified Data.Text.Array as Text +import qualified Data.Primitive.ByteArray as BA +#endif import Data.Typeable (Typeable, typeRep) import GHC.Natural import GHC.Stack +import GHC.TypeNats (KnownNat) +import Text.Show.Pretty (ppShow) -import Clash.Core.Term (Term(Literal), collectArgs) +import Clash.Annotations.SynthesisAttributes (Attr) +import Clash.Core.DataCon (DataCon(..)) import Clash.Core.Literal +import Clash.Core.Name (Name(..)) import Clash.Core.Pretty (showPpr) +import Clash.Core.Term (Term(Literal, Data), collectArgs) +import Clash.Promoted.Nat +import Clash.Promoted.Nat.Unsafe +import Clash.Sized.Index (Index) +import Clash.Sized.Vector (Vec (Nil, Cons), fromList) import qualified Clash.Util.Interpolate as I import qualified Clash.Verification.Internal as Cv import Clash.Core.TermLiteral.TH --- | Tools to deal with literals encoded as a "Term". -class Typeable a => TermLiteral a where +-- | Pretty print type @a@ +showType :: TermLiteral a => Proxy a -> String +showType proxy = showsTypePrec 0 proxy "" + +-- | Tools to deal with literals encoded as a 'Term'. +class TermLiteral a where -- | Convert 'Term' to the constant it represents. Will return an error if -- (one of the subterms) fail to translate. termToData @@ -47,6 +74,23 @@ -- ^ 'Left' indicates a failure, containing the (sub)term that failed to -- translate. 'Right' indicates a success. + -- | Pretty print the type of a term (for error messages). Its default implementation + -- uses 'Typeable' to print the type. Note that this method is there to allow + -- an instance for 'SNat' to exist (and other GADTs imposing + -- t'GHC.TypeNats.KnownNat'). Without it, GHC would ask for a @KnownNat@ + -- constraint on the instance, which would defeat the purpose of it. + showsTypePrec :: + -- | The operator precedence of the enclosing context (a number from @0@ to + -- @11@). Function application has precedence @10@. Used to determine whether + -- the result should be wrapped in parentheses. + Int -> + -- | Proxy for a term whose type needs to be pretty printed + Proxy a -> + ShowS + + default showsTypePrec :: Typeable a => Int -> Proxy a -> ShowS + showsTypePrec n _ = showsPrec n (typeRep (Proxy @a)) + instance TermLiteral Term where termToData = pure @@ -55,8 +99,23 @@ termToData t = Left t instance TermLiteral Text where - termToData t = Text.pack <$> termToData t + termToData (collectArgs -> (_, [Left (Literal (StringLiteral s))])) = + Right (Text.pack s) +#if MIN_VERSION_ghc(9,4,0) + termToData (collectArgs -> (_, [ Left (Literal (ByteArrayLiteral (BA.ByteArray ba))) + , Left (Literal (IntLiteral off)) + , Left (Literal (IntLiteral len))])) = + Right (Text.Text (Text.ByteArray ba) (fromInteger off) (fromInteger len)) +#endif + termToData t = Left t +instance KnownNat n => TermLiteral (Index n) where + termToData t@(collectArgs -> (_, [_, _, Left (Literal (IntegerLiteral n))])) + | n < 0 = Left t + | n >= natToNum @n = Left t + | otherwise = Right (fromInteger n) + termToData t = Left t + instance TermLiteral Int where termToData (collectArgs -> (_, [Left (Literal (IntLiteral n))])) = Right (fromInteger n) @@ -68,6 +127,7 @@ termToData t = Left t instance TermLiteral Integer where + termToData (Literal (IntegerLiteral n)) = Right n termToData (collectArgs -> (_, [Left (Literal (IntegerLiteral n))])) = Right n termToData t = Left t @@ -76,10 +136,31 @@ termToData t = Left t instance TermLiteral Natural where + termToData t@(Literal (NaturalLiteral n)) + | n < 0 = Left t + | otherwise = Right (fromIntegral n) termToData (collectArgs -> (_, [Left (Literal (NaturalLiteral n))])) = Right (fromInteger n) termToData t = Left t +-- | Unsafe warning: If you use this instance in a monomorphic context (e.g., +-- @TermLiteral (SNat 5)@), you need to make very sure that the term corresponds +-- to the literal. If you don't, there will be a mismatch between type level +-- variables and the proof carried in 'SNat's 'KnownNat'. Typical usage of this +-- instance will therefore leave the /n/ polymorphic. +-- +instance TermLiteral (SNat n) where + termToData = \case + Literal (NaturalLiteral n) -> Right (unsafeSNat n) + t -> Left t + + showsTypePrec n _ + -- We don't know the literal /n/ at this point. However, we can't simply put + -- and /n/ here either, as it might collide with other type variables. To + -- prevent confusion, we put an underscore. This is obviously "wrong", but + -- good enough for error messages - the main purpose of this function. + = showParen (n > 10) $ showString "SNat _" + instance (TermLiteral a, TermLiteral b) => TermLiteral (a, b) where termToData (collectArgs -> (_, lefts -> [a, b])) = do a' <- termToData a @@ -87,38 +168,81 @@ pure (a', b') termToData t = Left t -instance TermLiteral a => TermLiteral (Maybe a) where - termToData = $(deriveTermToData ''Maybe) - -instance TermLiteral Bool where - termToData = $(deriveTermToData ''Bool) + showsTypePrec _ _ = + -- XXX: We pass in 11 here, but should really be passing in 0. We never want + -- any parentheses for fields in tuples. However, Typeable's show + -- implementation does put parentheses around tuple fields - so we + -- replicate that behavior here for ease of testing. + showChar '(' + . showsTypePrec 11 (Proxy @a) + . showString "," + . showsTypePrec 11 (Proxy @b) + . showChar ')' -instance TermLiteral Cv.RenderAs where - termToData = $(deriveTermToData ''Cv.RenderAs) +instance (TermLiteral a, KnownNat n) => TermLiteral (Vec n a) where + termToData term = do + res <- fromList <$> go term + -- Check whether length of list constructed in 'go' corresponds to the + -- @KnownNat n@ we've been given + case res of + Nothing -> Left term + Just v -> Right v + where + -- Construct a list from given term + go t@(collectArgs -> (constr, args)) = + case constr of + Data (MkData{dcName=Name{nameOcc}}) + | nameOcc == showt 'Nil -> Right [] + | nameOcc == showt 'Cons -> + case lefts args of + [_gadtProof, c0, cs0] -> do + c1 <- termToData @a c0 + cs1 <- go cs0 + Right (c1:cs1) + _ -> Left t + _ -> Left t -instance TermLiteral a => TermLiteral (Cv.Assertion' a) where - termToData = $(deriveTermToData ''Cv.Assertion') + showsTypePrec n _ = + showParen (n > 10) $ + showString "Vec" + . showChar ' ' + . showString (show (natToInteger @n)) + . showChar ' ' + . showsTypePrec 11 (Proxy @a) -instance TermLiteral a => TermLiteral (Cv.Property' a) where - termToData = $(deriveTermToData ''Cv.Property') +deriveTermLiteral ''Bool +deriveTermLiteral ''Maybe +deriveTermLiteral ''Either +deriveTermLiteral ''Cv.RenderAs +deriveTermLiteral ''Cv.Assertion' +deriveTermLiteral ''Cv.Property' +deriveTermLiteral ''Attr -- | Same as 'termToData', but returns printable error message if it couldn't -- translate a term. termToDataError :: forall a. TermLiteral a => Term -> Either String a termToDataError term = bimap err id (termToData term) where - typ = show (typeRep (Proxy @a)) + -- XXX: If we put this construct in the quasiquoted part, it yields a parse + -- error on some platforms. This is likely related to some older version + -- of dependencies. In the interested of time yours truly just moved it + -- outside of the quasiquoter. + shownType = showType (Proxy @a) err failedTerm = [I.i| Failed to translate term to literal. Term that failed to translate: #{showPpr failedTerm} + In its non-pretty-printed form: + + #{ppShow failedTerm} + In the full term: #{showPpr term} While trying to interpret something to type: - #{typ} + #{shownType} |] diff --git a/src/Clash/Core/TermLiteral/TH.hs b/src/Clash/Core/TermLiteral/TH.hs --- a/src/Clash/Core/TermLiteral/TH.hs +++ b/src/Clash/Core/TermLiteral/TH.hs @@ -1,7 +1,20 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} +{-| +Copyright : (C) 2019, Myrtle Software Ltd, + 2021, QBayLogic B.V. + 2022, Google Inc +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +Template Haskell utilities for "Clash.Core.TermLiteral". +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + module Clash.Core.TermLiteral.TH - ( deriveTermToData + ( deriveTermToData + , deriveShowsTypePrec + , deriveTermLiteral -- Stop exporting @dcName'@ once `ghcide` stops type-checking expanded -- TH splices , dcName' @@ -9,7 +22,12 @@ import Data.Either import qualified Data.Text as Text +import Data.List (intersperse) +import qualified Data.List.NonEmpty as NE +import Data.Proxy +import Data.Maybe (isNothing) import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib hiding (match) import Clash.Core.DataCon import Clash.Core.Term (collectArgs, Term(Data)) @@ -21,18 +39,136 @@ -- module Clash.Core.Subst cannot be linked; it is only available as a boot module import Clash.Core.Subst () +#if __GLASGOW_HASKELL__ >= 900 +type CompatTyVarBndr = TyVarBndr () +#else +type CompatTyVarBndr = TyVarBndr +#endif + dcName' :: DataCon -> String dcName' = Text.unpack . nameOcc . dcName termToDataName :: Name -termToDataName = mkName "Clash.Core.TermLiteral.termToData" +termToDataName = + -- Note that we can't use a fully qualified name here: GHC disallows fully + -- qualified names in instance function declarations. + mkName "termToData" +showsTypePrecName :: Name +showsTypePrecName = + -- Note that we can't use a fully qualified name here: GHC disallows fully + -- qualified names in instance function declarations. + mkName "showsTypePrec" + +termLiteralName :: Name +termLiteralName = mkName "Clash.Core.TermLiteral.TermLiteral" + +-- | Extracts variable names from a 'TyVarBndr'. +typeVarName :: CompatTyVarBndr -> Q (Name, Maybe Type) +typeVarName = \case +#if __GLASGOW_HASKELL__ >= 900 + PlainTV typVarName () -> pure (typVarName, Nothing) + KindedTV typVarName () StarT -> pure (typVarName, Nothing) + KindedTV typVarName () kind -> pure (typVarName, Just kind) +#else + PlainTV typVarName -> pure (typVarName, Nothing) + KindedTV typVarName StarT -> pure (typVarName, Nothing) + KindedTV typVarName kind -> pure (typVarName, Just kind) +#endif + +-- | Derive a t'Clash.Core.TermLiteral.TermLiteral' instance for given type +deriveTermLiteral :: Name -> Q [Dec] +deriveTermLiteral typName = do + TyConI (DataD _ _ typeVars _ _ _) <- reify typName +#if MIN_VERSION_template_haskell(2,21,0) + typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars +#else + typeVarNames <- mapM typeVarName typeVars +#endif + showsTypePrec <- deriveShowsTypePrec typName + termToDataBody <- deriveTermToData typName + let + termToData = FunD termToDataName [Clause [] (NormalB termToDataBody) []] + innerInstanceType = foldl AppT (ConT typName) (map (VarT . fst) typeVarNames) + instanceType = ConT termLiteralName `AppT` innerInstanceType + constraint typVarName = [t| $(conT termLiteralName) $(varT typVarName) |] + constraints <- mapM (constraint . fst) (filter (isNothing . snd) typeVarNames) + pure $ [InstanceD Nothing constraints instanceType [showsTypePrec, termToData]] + +-- | For 'Maybe', constructs: +-- +-- > showsTypePrec n _ +-- > = let +-- > showSpace = showChar ' ' +-- > precCalls = [showsTypePrec 11 (Proxy @a)] +-- > interspersedPrecCalls = intersperse showSpace precCalls +-- > showType = foldl (.) (showString "Maybe") (showSpace : interspersedPrecCalls) +-- > in +-- > showParen (n > 10) showType +-- +deriveShowsTypePrec :: Name -> Q Dec +deriveShowsTypePrec typName = do + TyConI (DataD _ _ typeVars _ _ _) <- reify typName +#if MIN_VERSION_template_haskell(2,21,0) + typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars +#else + typeVarNames <- mapM typeVarName typeVars +#endif + showTypeBody <- mkShowTypeBody typeVarNames + pure (FunD showsTypePrecName [Clause [VarP nName, WildP] (NormalB showTypeBody) []]) + where + showTypeName = [| showString $(litE (StringL (nameBase typName))) |] + + -- Constructs: + -- + -- > showsTypePrec 11 (Proxy @a) + -- + -- where the 'a' is given as an argument. The surrounding operator precedence + -- is set to indicate "function" application. I.e., it instructs the call to + -- wrap the type string in parentheses. + -- + mkTypePrecCall = \case + (typVarName, Nothing) -> + [| $(varE showsTypePrecName) 11 (Proxy @($(varT typVarName))) |] + (_, Just _) -> + -- XXX: Not sure how to deal with non-Type type variables so we do the dumb + -- thing and insert an underscore. + [| showString "_" |] + + -- Constructs: + -- + -- > showString "Maybe" . showChar ' ' . showsTypePrec 11 (Proxy @a) + -- + -- This is wrapped in an if-statement wrapping the result in parentheses if the + -- incoming prec is more than 10 (function application). + -- + mkShowTypeBody :: [(Name, Maybe Type)] -> Q Exp + mkShowTypeBody typeVarNames = + case typeVarNames of + [] -> + -- We seq on `n` here to prevent _unused variable_ warnings. This is a + -- bit of a hack (the real solution would be to selectively pattern + -- match). + [| $(varE nName) `seq` $(showTypeName) |] + _ -> [| + let + showSpace = showChar ' ' + precCalls = $(listE (map mkTypePrecCall typeVarNames)) + interspersedPrecCalls = intersperse showSpace precCalls + showType = foldl (.) $(showTypeName) (showSpace : interspersedPrecCalls) + in + showParen ($(varE nName) > 10) showType + |] + + nName = mkName "n" + deriveTermToData :: Name -> Q Exp deriveTermToData typName = do TyConI (DataD _ _ _ _ constrs _) <- reify typName pure (deriveTermToData1 (map toConstr' constrs)) where toConstr' (NormalC cName fields) = (cName, length fields) + toConstr' (RecC cName fields) = (cName, length fields) toConstr' c = error $ "Unexpected constructor: " ++ show c deriveTermToData1 :: [(Name, Int)] -> Exp @@ -46,7 +182,7 @@ nArgs = maximum (map snd constrs) args :: [Dec] - args = zipWith (\n nm -> ValD (VarP nm) (NormalB (arg n)) []) [0..] argNames + args = zipWith (\n nm -> ValD (VarP nm) (NormalB (arg (toInteger n))) []) [0..nArgs-1] (NE.toList argNames) arg n = UInfixE (VarE argsName) (VarE '(!!)) (LitE (IntegerL n)) -- case nm of {"ConstrOne" -> ConstOne <$> termToData arg0; "ConstrTwo" -> ...} @@ -68,7 +204,7 @@ UInfixE (ConE cName) (VarE '(<$>)) - (VarE termToDataName `AppE` VarE (head argNames)) + (VarE termToDataName `AppE` VarE (NE.head argNames)) mkCall cName nFields = foldl (\e aName -> @@ -77,7 +213,7 @@ (VarE '(<*>)) (VarE termToDataName `AppE` VarE aName)) (mkCall cName 1) - (take (nFields-1) (tail argNames)) + (take (nFields-1) (NE.tail argNames)) -- term@(collectArgs -> (Data (dcName' -> nm), args)) pat :: Pat @@ -86,13 +222,16 @@ termName (ViewP (VarE 'collectArgs) +#if MIN_VERSION_template_haskell(2,18,0) + (TupP [ ConP 'Data [] [ViewP (VarE 'dcName') (VarP nameName)] +#else (TupP [ ConP 'Data [ViewP (VarE 'dcName') (VarP nameName)] +#endif , ViewP (VarE 'lefts) (if nArgs == 0 then WildP else VarP argsName)])) termName = mkName "term" argsName = mkName "args" - argNames = [mkName ("arg" ++ show n) | n <- [0..nArgs-1]] + argNames = fmap (mkName . ("arg" <>) . show) (NE.iterate (+1) (0 :: Word)) nameName = mkName "nm" - diff --git a/src/Clash/Core/TyCon.hs b/src/Clash/Core/TyCon.hs --- a/src/Clash/Core/TyCon.hs +++ b/src/Clash/Core/TyCon.hs @@ -38,6 +38,7 @@ import Clash.Core.Name import {-# SOURCE #-} Clash.Core.Type (Kind, Type) import Clash.Core.Var (TyVar) +import Clash.Data.UniqMap (UniqMap) import Clash.Unique -- | Type Constructor @@ -118,13 +119,13 @@ -- | Does the TyCon look like a tuple TyCon isTupleTyConLike :: TyConName -> Bool -isTupleTyConLike nm = tupleName (nameOcc nm) +isTupleTyConLike nm = tupleName (T.takeWhileEnd (/= '.') (nameOcc nm)) where - tupleName nm' - | '(' <- T.head nm' - , ')' <- T.last nm' - = T.all (== ',') (T.init $ T.tail nm') - tupleName _ = False + tupleName nm0 + | Just ('(', nm1) <- T.uncons nm0 + , Just (nm2, ')') <- T.unsnoc nm1 + = T.all (== ',') nm2 + tupleName _ = T.pack "GHC.Tuple.Prim.Tuple" `T.isPrefixOf` (nameOcc nm) -- | Get the DataCons belonging to a TyCon tyConDataCons :: TyCon -> [DataCon] diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -65,17 +65,31 @@ import Data.List (foldl') import Data.List.Extra (splitAtList) import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text) import GHC.Base (isTrue#,(==#)) import GHC.Generics (Generic(..)) import GHC.Integer (smallInteger) import GHC.Integer.Logarithms (integerLogBase#) import GHC.TypeLits (type TypeError, ErrorMessage(Text, (:<>:))) +#if MIN_VERSION_base(4,16,0) +import GHC.Base (ord) +import Data.Char (chr) +import Data.Maybe (fromMaybe) +import Data.Text.Extra (showt) +#endif -- GHC API #if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) import GHC.Builtin.Names + (typeCharCmpTyFamNameKey, typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey, + typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey) +#else +import GHC.Builtin.Names (typeNatLeqTyFamNameKey) +#endif +import GHC.Builtin.Names (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey, - typeNatLeqTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, + typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey, typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import GHC.Types.SrcLoc (wiredInSrcSpan) @@ -99,12 +113,13 @@ #endif -- Local imports +import Clash.Annotations.SynthesisAttributes import Clash.Core.DataCon import Clash.Core.Name import {-# SOURCE #-} Clash.Core.Subst import Clash.Core.TyCon import Clash.Core.Var -import Clash.Unique +import qualified Clash.Data.UniqMap as UniqMap import Clash.Util #if __GLASGOW_HASKELL__ <= 806 @@ -114,7 +129,7 @@ ordGTDataConKey = gtDataConKey #endif -varAttrs :: Var a -> [Attr'] +varAttrs :: Var a -> [Attr Text] varAttrs t@(TyVar {}) = error $ $(curLoc) ++ "Unexpected argument: " ++ show t @@ -131,7 +146,7 @@ | ForAllTy !TyVar !Type -- ^ Polymorphic Type | AppTy !Type !Type -- ^ Type Application | LitTy !LitTy -- ^ Type literal - | AnnType [Attr'] !Type -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes + | AnnType [Attr Text] !Type -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes deriving (Show, Generic, NFData, Binary) instance TypeError ( @@ -158,6 +173,7 @@ data LitTy = NumTy !Integer | SymTy !String + | CharTy !Char deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) -- | The level above types @@ -263,7 +279,7 @@ , [_,elTy] <- args -> Just elTy | otherwise - -> case tcMap `lookupUniqMap'` tcNm of + -> case UniqMap.find tcNm tcMap of AlgTyCon {algTcRhs = (NewTyCon _ nt)} -> newTyConInstRhs nt args _ -> reduceTypeFamily tcMap ty @@ -373,9 +389,7 @@ -- | Extract attributes from type. Will return an empty list if this is an -- AnnType with an empty list AND if this is not an AnnType at all. -typeAttrs - :: Type - -> [Attr'] +typeAttrs :: Type -> [Attr Text] typeAttrs (AnnType attrs _typ) = attrs typeAttrs _ = [] @@ -522,16 +536,18 @@ -> Just (LitTy (NumTy z)) _ -> Nothing +#if !MIN_VERSION_ghc(9,2,0) | nameUniq tc == getKey typeNatLeqTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] - | Just (FunTyCon {tyConKind = tck}) <- lookupUniqMap tc tcm + | Just (FunTyCon {tyConKind = tck}) <- UniqMap.lookup tc tcm , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck - , Just boolTc <- lookupUniqMap boolTcNm tcm + , Just boolTc <- UniqMap.lookup boolTcNm tcm -> let [falseTc,trueTc] = map (coerce . dcName) (tyConDataCons boolTc) in if i1 <= i2 then Just (mkTyConApp trueTc []) else Just (mkTyConApp falseTc []) _ -> Nothing +#endif | nameUniq tc == getKey typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat" = case mapMaybe (litView tcm) tys of @@ -553,6 +569,50 @@ GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan _ -> Nothing +#if MIN_VERSION_base(4,16,0) + | nameUniq tc == getKey typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" + = case mapMaybe (charLitView tcm) tys of + [s1, s2] -> + Just $ ConstTy $ TyCon $ + case compare s1 s2 of + LT -> Name User (showt 'LT) (getKey ordLTDataConKey) wiredInSrcSpan + EQ -> Name User (showt 'EQ) (getKey ordEQDataConKey) wiredInSrcSpan + GT -> Name User (showt 'GT) (getKey ordGTDataConKey) wiredInSrcSpan + _ -> Nothing + + | nameUniq tc == getKey typeConsSymbolTyFamNameKey -- ConsSymbol + , [c0, s0] <- tys + , Just c1 <- charLitView tcm c0 + , Just s1 <- symLitView tcm s0 + = Just (LitTy (SymTy (c1:s1))) + + | nameUniq tc == getKey typeUnconsSymbolTyFamNameKey -- UnconsSymbol + , [s1] <- mapMaybe (symLitView tcm) tys + = fromMaybe (error "reduceTypeFamily: cannot construct UnconsSymbol result") $ do + FunTyCon {tyConKind = tck} <- UniqMap.lookup tc tcm + TyConApp maybeTcNm [tupTcApp] <- pure (tyView (snd (splitFunTys tcm tck))) + maybeTc <- UniqMap.lookup maybeTcNm tcm + [nothingTc,justTc] <- pure (map (coerce . dcName) (tyConDataCons maybeTc)) + TyConApp tupTcNm [charTy,symbolTy] <- pure (tyView tupTcApp) + tupTc <- UniqMap.lookup tupTcNm tcm + [tupDc] <- pure (map (coerce . dcName) (tyConDataCons tupTc)) + case s1 of + [] -> + pure (Just (mkTyConApp nothingTc [tupTcApp])) + (c:cs) -> + let tup = mkTyConApp tupDc + [charTy,symbolTy,LitTy (CharTy c),LitTy (SymTy cs)] + in pure (Just (mkTyConApp justTc [tupTcApp,tup])) + + | nameUniq tc == getKey typeCharToNatTyFamNameKey -- CharToNat + , [c1] <- mapMaybe (charLitView tcm) tys + = Just (LitTy (NumTy (fromIntegral (ord c1)))) + + | nameUniq tc == getKey typeNatToCharTyFamNameKey -- NatToChar + , [n1] <- mapMaybe (litView tcm) tys + = Just (LitTy (CharTy (chr (fromInteger n1)))) +#endif + | nameUniq tc == getKey typeSymbolAppendFamNameKey -- GHC.TypeLits.AppendSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> @@ -614,7 +674,7 @@ -> Just (LitTy (NumTy (i1 `mod` i2))) _ -> Nothing - | Just (FunTyCon {tyConSubst = tcSubst}) <- lookupUniqMap tc tcm + | Just (FunTyCon {tyConSubst = tcSubst}) <- UniqMap.lookup tc tcm = let -- See [Note: Eager type families] tysR = map (argView tcm) tys in findFunSubst tcm tcSubst tysR @@ -624,7 +684,7 @@ -- | isTypeFamilyApplication :: TyConMap -> Type -> Bool isTypeFamilyApplication tcm (tyView -> TyConApp tcNm _args) - | Just (FunTyCon {}) <- lookupUniqMap tcNm tcm = True + | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm = True isTypeFamilyApplication _tcm _type = False argView :: TyConMap -> Type -> Type @@ -642,6 +702,13 @@ symLitView m (reduceTypeFamily m -> Just ty') = symLitView m ty' symLitView _ _ = Nothing +#if MIN_VERSION_base(4,16,0) +charLitView :: TyConMap -> Type -> Maybe Char +charLitView _ (LitTy (CharTy c)) = Just c +charLitView m (reduceTypeFamily m -> Just t) = charLitView m t +charLitView _ _ = Nothing +#endif + isIntegerTy :: Type -> Bool isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == getKey integerTyConKey isIntegerTy _ = False @@ -663,7 +730,7 @@ nameOcc tcNm == "Clash.Sized.Internal.Unsigned.Unsigned" -> mkTyConApp tcNm (map go args) | otherwise - -> case lookupUniqMap' tcMap tcNm of + -> case UniqMap.find tcNm tcMap of AlgTyCon {algTcRhs = (NewTyCon _ nt)} -> case newTyConInstRhs nt args of Just ty' -> go ty' @@ -691,7 +758,7 @@ -> Type -> Bool isClassTy tcm (tyView -> TyConApp tcNm _) = - case lookupUniqMap tcNm tcm of + case UniqMap.lookup tcNm tcm of Just (AlgTyCon {isClassTc}) -> isClassTc _ -> False isClassTy _ _ = False diff --git a/src/Clash/Core/TysPrim.hs b/src/Clash/Core/TysPrim.hs --- a/src/Clash/Core/TysPrim.hs +++ b/src/Clash/Core/TysPrim.hs @@ -9,7 +9,9 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Core.TysPrim ( liftedTypeKind @@ -19,10 +21,20 @@ , integerPrimTy , charPrimTy , stringPrimTy +#if !MIN_VERSION_ghc(9,2,0) , voidPrimTy +#endif , wordPrimTy , int64PrimTy , word64PrimTy +#if MIN_VERSION_ghc(8,8,0) + , int8PrimTy + , int16PrimTy + , int32PrimTy + , word8PrimTy + , word16PrimTy + , word32PrimTy +#endif , floatPrimTy , doublePrimTy , naturalPrimTy @@ -32,7 +44,6 @@ ) where -import qualified Data.List as List #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names @@ -42,16 +53,31 @@ import Unique (getKey) #endif +#if MIN_VERSION_ghc(8,8,0) +import GHC.Base hiding (Type, TyCon) +import Data.Text.Extra (showt) +#endif + +#if MIN_VERSION_base(4,17,0) +import Clash.Core.DataCon (DataCon(..), DcStrictness(..)) +import GHC.Num.Integer (Integer(..)) +import GHC.Num.Natural (Natural(..)) +#endif + import Clash.Core.Name import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var (mkTyVar) -import Clash.Unique +import qualified Clash.Data.UniqMap as UniqMap -- | Builtin Name liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName liftedTypeKindTyConName = mkUnsafeSystemName "Type" (getKey liftedTypeKindTyConKey) +#if MIN_VERSION_ghc(9,2,0) +typeNatKindTyConName = naturalPrimTyConName +#else typeNatKindTyConName = mkUnsafeSystemName "Nat" (getKey typeNatKindConNameKey) +#endif typeSymbolKindTyConName = mkUnsafeSystemName "Symbol" (getKey typeSymbolKindConNameKey) -- | Builtin Kind @@ -66,8 +92,8 @@ typeSymbolKind = mkTyConTy typeSymbolKindTyConName intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, - voidPrimTyConName, wordPrimTyConName, int64PrimTyConName, - word64PrimTyConName, floatPrimTyConName, doublePrimTyConName, + wordPrimTyConName, int64PrimTyConName, word64PrimTyConName, + floatPrimTyConName, doublePrimTyConName, naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName intPrimTyConName = mkUnsafeSystemName "GHC.Prim.Int#" (getKey intPrimTyConKey) @@ -81,7 +107,6 @@ stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#" (getKey addrPrimTyConKey) charPrimTyConName = mkUnsafeSystemName "GHC.Prim.Char#" (getKey charPrimTyConKey) -voidPrimTyConName = mkUnsafeSystemName "Void#" (getKey voidPrimTyConKey) wordPrimTyConName = mkUnsafeSystemName "GHC.Prim.Word#" (getKey wordPrimTyConKey) int64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Int64#" @@ -104,27 +129,144 @@ eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (getKey eqPrimTyConKey) +#if !MIN_VERSION_ghc(9,2,0) +voidPrimTyConName :: TyConName +voidPrimTyConName = mkUnsafeSystemName "Void#" (getKey voidPrimTyConKey) +#endif + +#if MIN_VERSION_ghc(8,8,0) +int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName, + word16PrimTyConName, word32PrimTyConName :: TyConName +int8PrimTyConName = mkUnsafeSystemName (showt ''Int8#) (getKey int8PrimTyConKey) +int16PrimTyConName = mkUnsafeSystemName (showt ''Int16#) (getKey int16PrimTyConKey) +int32PrimTyConName = mkUnsafeSystemName (showt ''Int32#) (getKey int32PrimTyConKey) +word8PrimTyConName = mkUnsafeSystemName (showt ''Word8#) (getKey word8PrimTyConKey) +word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#) (getKey word16PrimTyConKey) +word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#) (getKey word32PrimTyConKey) +#endif + liftedPrimTC :: TyConName -> TyCon liftedPrimTC name = PrimTyCon (nameUniq name) name liftedTypeKind 0 -- | Builtin Type -intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc, +intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, wordPrimTc, int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc, byteArrayPrimTc :: TyCon intPrimTc = liftedPrimTC intPrimTyConName +#if MIN_VERSION_base(4,17,0) +-- While GHC might have dropped Integer and Natural literals, in Clash it is +-- still nice to have them around. However, Integer and Natural are also no +-- longer primitive types in GHC, but we still want to give the Integer and +-- Natural type to our Integer and Natural literals. +-- +-- So instead of recording the primitive types, we record the algebraic types, +-- i.e. the complete data type for Integer and Natural, data constructors and all. + +integerPrimTc = + let + name = integerPrimTyConName + uniq = nameUniq name + isDcNm = mkUnsafeSystemName (showt 'IS) (getKey integerISDataConKey) + isDc = MkData + { dcName = isDcNm + , dcUniq = nameUniq isDcNm + , dcTag = 1 + , dcType = mkPolyFunTy integerPrimTy [Right intPrimTy] + , dcUnivTyVars = [] + , dcExtTyVars = [] + , dcArgTys = [intPrimTy] + , dcArgStrict = [Strict] + , dcFieldLabels = [] + } + ipDcNm = mkUnsafeSystemName (showt 'IP) (getKey integerIPDataConKey) + ipDc = MkData + { dcName = ipDcNm + , dcUniq = nameUniq ipDcNm + , dcTag = 2 + , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy] + , dcUnivTyVars = [] + , dcExtTyVars = [] + , dcArgTys = [byteArrayPrimTy] + , dcArgStrict = [Strict] + , dcFieldLabels = [] + } + inDcNm = mkUnsafeSystemName (showt 'IN) (getKey integerINDataConKey) + inDc = MkData + { dcName = inDcNm + , dcUniq = nameUniq inDcNm + , dcTag = 3 + , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy] + , dcUnivTyVars = [] + , dcExtTyVars = [] + , dcArgTys = [byteArrayPrimTy] + , dcArgStrict = [Strict] + , dcFieldLabels = [] + } + rhs = DataTyCon [isDc,ipDc,inDc] + in + AlgTyCon uniq name liftedTypeKind 0 rhs False + +naturalPrimTc = + let + name = naturalPrimTyConName + uniq = nameUniq name + nsDcNm = mkUnsafeSystemName (showt 'NS) (getKey naturalNSDataConKey) + nsDc = MkData + { dcName = nsDcNm + , dcUniq = nameUniq nsDcNm + , dcTag = 1 + , dcType = mkPolyFunTy naturalPrimTy [Right wordPrimTy] + , dcUnivTyVars = [] + , dcExtTyVars = [] + , dcArgTys = [wordPrimTy] + , dcArgStrict = [Strict] + , dcFieldLabels = [] + } + nbDcNm = mkUnsafeSystemName (showt 'NB) (getKey naturalNBDataConKey) + nbDc = MkData + { dcName = nbDcNm + , dcUniq = nameUniq nbDcNm + , dcTag = 2 + , dcType = mkPolyFunTy naturalPrimTy [Right byteArrayPrimTy] + , dcUnivTyVars = [] + , dcExtTyVars = [] + , dcArgTys = [byteArrayPrimTy] + , dcArgStrict = [Strict] + , dcFieldLabels = [] + } + rhs = DataTyCon [nsDc,nbDc] + in + AlgTyCon uniq name liftedTypeKind 0 rhs False +#else integerPrimTc = liftedPrimTC integerPrimTyConName +naturalPrimTc = liftedPrimTC naturalPrimTyConName +#endif charPrimTc = liftedPrimTC charPrimTyConName stringPrimTc = liftedPrimTC stringPrimTyConName -voidPrimTc = liftedPrimTC voidPrimTyConName wordPrimTc = liftedPrimTC wordPrimTyConName int64PrimTc = liftedPrimTC int64PrimTyConName word64PrimTc = liftedPrimTC word64PrimTyConName floatPrimTc = liftedPrimTC floatPrimTyConName doublePrimTc = liftedPrimTC doublePrimTyConName -naturalPrimTc = liftedPrimTC naturalPrimTyConName byteArrayPrimTc = liftedPrimTC byteArrayPrimTyConName +#if !MIN_VERSION_ghc(9,2,0) +voidPrimTc :: TyCon +voidPrimTc = liftedPrimTC voidPrimTyConName +#endif + +#if MIN_VERSION_ghc(8,8,0) +int8PrimTc, int16PrimTc, int32PrimTc, word8PrimTc, word16PrimTc, + word32PrimTc :: TyCon +int8PrimTc = liftedPrimTC int8PrimTyConName +int16PrimTc = liftedPrimTC int16PrimTyConName +int32PrimTc = liftedPrimTC int32PrimTyConName +word8PrimTc = liftedPrimTC word8PrimTyConName +word16PrimTc = liftedPrimTC word16PrimTyConName +word32PrimTc = liftedPrimTC word32PrimTyConName +#endif + eqPrimTc :: TyCon eqPrimTc = PrimTyCon (nameUniq eqPrimTyConName) eqPrimTyConName ty 4 where @@ -138,14 +280,13 @@ aTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0) bTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1) -intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy, +intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, wordPrimTy, int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy, byteArrayPrimTy, eqPrimTy :: Type intPrimTy = mkTyConTy intPrimTyConName integerPrimTy = mkTyConTy integerPrimTyConName charPrimTy = mkTyConTy charPrimTyConName stringPrimTy = mkTyConTy stringPrimTyConName -voidPrimTy = mkTyConTy voidPrimTyConName wordPrimTy = mkTyConTy wordPrimTyConName int64PrimTy = mkTyConTy int64PrimTyConName word64PrimTy = mkTyConTy word64PrimTyConName @@ -155,8 +296,24 @@ byteArrayPrimTy = mkTyConTy byteArrayPrimTyConName eqPrimTy = mkTyConTy eqPrimTyConName +#if !MIN_VERSION_ghc(9,2,0) +voidPrimTy :: Type +voidPrimTy = mkTyConTy voidPrimTyConName +#endif + +#if MIN_VERSION_ghc(8,8,0) +int8PrimTy, int16PrimTy, int32PrimTy, word8PrimTy, word16PrimTy, + word32PrimTy :: Type +int8PrimTy = mkTyConTy int8PrimTyConName +int16PrimTy = mkTyConTy int16PrimTyConName +int32PrimTy = mkTyConTy int32PrimTyConName +word8PrimTy = mkTyConTy word8PrimTyConName +word16PrimTy = mkTyConTy word16PrimTyConName +word32PrimTy = mkTyConTy word32PrimTyConName +#endif + tysPrimMap :: TyConMap -tysPrimMap = List.foldl' (\s (k,x) -> extendUniqMap k x s) emptyUniqMap +tysPrimMap = UniqMap.fromList [ (liftedTypeKindTyConName , liftedTypeKindTc) , (typeNatKindTyConName , typeNatKindTc) , (typeSymbolKindTyConName , typeSymbolKindTc) @@ -164,10 +321,20 @@ , (integerPrimTyConName , integerPrimTc) , (charPrimTyConName , charPrimTc) , (stringPrimTyConName , stringPrimTc) +#if !MIN_VERSION_ghc(9,2,0) , (voidPrimTyConName , voidPrimTc) +#endif , (wordPrimTyConName , wordPrimTc) , (int64PrimTyConName , int64PrimTc) , (word64PrimTyConName , word64PrimTc) +#if MIN_VERSION_ghc(8,8,0) + , (int8PrimTyConName , int8PrimTc) + , (int16PrimTyConName , int16PrimTc) + , (int32PrimTyConName , int32PrimTc) + , (word8PrimTyConName , word8PrimTc) + , (word16PrimTyConName , word16PrimTc) + , (word32PrimTyConName , word32PrimTc) +#endif , (floatPrimTyConName , floatPrimTc) , (doublePrimTyConName , doublePrimTc) , (naturalPrimTyConName , naturalPrimTc) diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -1,6 +1,6 @@ {-| Copyright : (C) 2012-2016, University of Twente, - 2021 , QBayLogic B.V., + 2021-2023, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -20,13 +20,14 @@ import Control.Concurrent.Supply (Supply, freshId) import Control.Monad.Trans.Except (Except, throwE, runExcept) -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import qualified Data.HashSet as HashSet import qualified Data.Graph as Graph -import Data.List (mapAccumR) +import Data.List (mapAccumR, uncons) import Data.List.Extra (zipEqual) +import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Maybe - (fromJust, isJust, mapMaybe, catMaybes) + (fromMaybe, isJust, mapMaybe, catMaybes) import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import qualified Data.Text as T @@ -55,8 +56,8 @@ import Clash.Core.TysPrim (liftedTypeKind, typeNatKind) import Clash.Core.Var (Id, Var(..), mkLocalId, mkTyVar) import Clash.Core.VarEnv +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf) -import Clash.Unique import Clash.Util -- | Rebuild a let expression / let expressions by taking the SCCs of a list @@ -105,12 +106,15 @@ ,Left x ,Left (go (n-1) xs)] - nilCoTy = head (fromJust $! dataConInstArgTys nilCon [(LitTy (NumTy 0)) - ,resTy]) - consCoTy n = head (fromJust $! dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) + nilCoTy = case dataConInstArgTys nilCon [(LitTy (NumTy 0)) ,resTy] of + Just (x:_) -> x + _ -> error "impossible" + consCoTy n = case dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))] of + Just (x:_) -> x + _ -> error "impossible" -- | Append elements to the supplied vector appendToVec :: DataCon -- ^ The Cons (:>) constructor @@ -129,16 +133,19 @@ ,Left x ,Left (go (n-1) xs)] - consCoTy n = head (fromJust $! dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) + consCoTy n = case dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))] of + Just (x:_) -> x + _ -> error "impossible" -- | Create let-bindings with case-statements that select elements out of a -- vector. Returns both the variables to which element-selections are bound -- and the let-bindings extractElems - :: Supply + :: HasCallStack + => Supply -- ^ Unique supply -> InScopeSet -- ^ (Superset of) in scope variables @@ -152,22 +159,22 @@ -- ^ Length of the vector -> Term -- ^ The vector - -> (Supply, [(Term,[(Id, Term)])]) + -> (Supply, NonEmpty (Term,NonEmpty (Id, Term))) extractElems supply inScope consCon resTy s maxN vec = - first fst (go maxN (supply,inScope) vec) + if maxN >= 1 then + first fst (go maxN (supply,inScope) vec) + else + error "extractElems must be called with positive number" where go :: Integer -> (Supply,InScopeSet) -> Term - -> ((Supply,InScopeSet),[(Term,[(Id, Term)])]) - go 0 uniqs _ = (uniqs,[]) - go n uniqs0 e = - (uniqs3,(elNVar,[(elNId, lhs),(restNId, rhs)]):restVs) - where - tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] - (Just idTys) = dataConInstArgTys consCon tys - restTy = last idTys + -> ((Supply,InScopeSet),NonEmpty (Term, NonEmpty (Id, Term))) + go n uniqs0 e = fromMaybe (error "extractElems: failed to project elements") $ do + let tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))] + idTys <- dataConInstArgTys consCon tys + let restTy = last idTys - (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind) - (uniqs2,[elNId,restNId,co,el,rest]) = + let (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind) + (uniqs2,[elNId,restNId,co,el,rest]) <- pure $ mapAccumR mkUniqSystemId uniqs1 $ zipEqual ["el" `T.append` (s `T.cons` T.pack (show (maxN-n))) ,"rest" `T.append` (s `T.cons` T.pack (show (maxN-n))) @@ -177,13 +184,15 @@ ] (resTy:restTy:idTys) - elNVar = Var elNId - pat = DataPat consCon [mTV] [co,el,rest] - lhs = Case e resTy [(pat,Var el)] - rhs = Case e restTy [(pat,Var rest)] + let elNVar = Var elNId + pat = DataPat consCon [mTV] [co,el,rest] + lhs = Case e resTy [(pat,Var el)] + rhs = Case e restTy [(pat,Var rest)] - (uniqs3,restVs) = go (n-1) uniqs2 (Var restNId) + let (uniqs3,restVs) = if n < 2 then (uniqs2,[]) else second toList (go (n-1) uniqs2 (Var restNId)) + return (uniqs3,(elNVar,(elNId, lhs) :| [(restNId, rhs)]) :| restVs) + -- | Create let-bindings with case-statements that select elements out of a -- tree. Returns both the variables to which element-selections are bound -- and the let-bindings @@ -214,35 +223,31 @@ -> (Supply,InScopeSet) -> Term -> ((Supply,InScopeSet),([Term],[(Id, Term)])) - go 0 _ ks uniqs0 e = (uniqs1,([elNVar],[(elNId, rhs)])) - where - tys = [LitTy (NumTy 0),resTy] - (Just idTys) = dataConInstArgTys lrCon tys + go 0 _ ks uniqs0 e = fromMaybe (error "extractTElems: failed to project elements") $ do + let tys = [LitTy (NumTy 0),resTy] + idTys <- dataConInstArgTys lrCon tys + (k,_) <- uncons ks - (uniqs1,[elNId,co,el]) = + (uniqs1,[elNId,co,el]) <- pure $ mapAccumR mkUniqSystemId uniqs0 $ zipEqual - [ "el" `T.append` (s `T.cons` T.pack (show (head ks))) + [ "el" `T.append` (s `T.cons` T.pack (show k)) , "_co_" , "el" ] (resTy:idTys) - elNVar = Var elNId - pat = DataPat lrCon [] [co,el] - rhs = Case e resTy [(pat,Var el)] + let elNVar = Var elNId + pat = DataPat lrCon [] [co,el] + rhs = Case e resTy [(pat,Var el)] + return (uniqs1,([elNVar],[(elNId, rhs)])) - go n bs ks uniqs0 e = - (uniqs4 - ,(lVars ++ rVars,(ltNId, ltRhs): - (rtNId, rtRhs): - (lBinds ++ rBinds))) - where - tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] - (Just idTys) = dataConInstArgTys brCon tys + go n bs ks uniqs0 e = fromMaybe (error "extractTElems: failed to project elements") $ do + let tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] + idTys <- dataConInstArgTys brCon tys - (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind) - (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs - brTy = last idTys - (uniqs2,[ltNId,rtNId,co,lt,rt]) = + let (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind) + (b0:bL,b1:bR) <- pure (splitAt (length bs `div` 2) bs) + let brTy = last idTys + (uniqs2,[ltNId,rtNId,co,lt,rt]) <- pure $ mapAccumR mkUniqSystemId uniqs1 $ zipEqual ["lt" `T.append` (s `T.cons` T.pack (show b0)) ,"rt" `T.append` (s `T.cons` T.pack (show b1)) @@ -251,16 +256,22 @@ ,"rt" ] (brTy:brTy:idTys) - ltVar = Var ltNId - rtVar = Var rtNId - pat = DataPat brCon [mTV] [co,lt,rt] - ltRhs = Case e brTy [(pat,Var lt)] - rtRhs = Case e brTy [(pat,Var rt)] + let ltVar = Var ltNId + rtVar = Var rtNId + pat = DataPat brCon [mTV] [co,lt,rt] + ltRhs = Case e brTy [(pat,Var lt)] + rtRhs = Case e brTy [(pat,Var rt)] - (kL,kR) = splitAt (length ks `div` 2) ks - (uniqs3,(lVars,lBinds)) = go (n-1) bL kL uniqs2 ltVar - (uniqs4,(rVars,rBinds)) = go (n-1) bR kR uniqs3 rtVar + (kL,kR) = splitAt (length ks `div` 2) ks + (uniqs3,(lVars,lBinds)) = go (n-1) bL kL uniqs2 ltVar + (uniqs4,(rVars,rBinds)) = go (n-1) bR kR uniqs3 rtVar + return ( uniqs4 + , ( lVars ++ rVars + , (ltNId, ltRhs):(rtNId, rtRhs): (lBinds ++ rBinds) + ) + ) + -- | Create a vector of supplied elements mkRTree :: DataCon -- ^ The LR constructor -> DataCon -- ^ The BR constructor @@ -285,12 +296,15 @@ ,Left (go (n-1) xsL) ,Left (go (n-1) xsR)] - lrCoTy = head (fromJust $! dataConInstArgTys lrCon [(LitTy (NumTy 0)) - ,resTy]) - brCoTy n = head (fromJust $! dataConInstArgTys brCon - [(LitTy (NumTy n)) - ,resTy - ,(LitTy (NumTy (n-1)))]) + lrCoTy = case dataConInstArgTys lrCon [(LitTy (NumTy 0)) ,resTy] of + Just (x:_) -> x + _ -> error "impossible" + brCoTy n = case dataConInstArgTys brCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))] of + Just (x:_) -> x + _ -> error "impossible" -- | Determine whether a type is isomorphic to "Clash.Signal.Internal.Signal" -- @@ -315,7 +329,7 @@ "Clash.Signal.BiSignal.BiSignalIn" -> True "Clash.Signal.BiSignal.BiSignalOut" -> True _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types - | otherwise -> case lookupUniqMap tcNm tcm of + | otherwise -> case UniqMap.lookup tcNm tcm of Just tc -> let dcs = tyConDataCons tc dcInsArgTys = concat $ mapMaybe (`dataConInstArgTys` args) dcs @@ -344,6 +358,7 @@ isClockOrReset m (coreView1 m -> Just ty) = isClockOrReset m ty isClockOrReset _ (tyView -> TyConApp tcNm _) = case nameOcc tcNm of "Clash.Signal.Internal.Clock" -> True + "Clash.Signal.Internal.ClockN" -> True "Clash.Signal.Internal.Reset" -> True _ -> False isClockOrReset _ _ = False @@ -472,6 +487,7 @@ , "GHC.Err.error" , "GHC.Err.errorWithoutStackTrace" , "GHC.Err.undefined" + , "GHC.Prim.Panic.absentError" , "GHC.Real.divZeroError" , "GHC.Real.overflowError" , "GHC.Real.ratioZeroDenominatorError" @@ -552,7 +568,7 @@ -> TypeView -> Maybe ([Term] -> Term, Projections, [Type]) shouldSplit0 tcm (TyConApp tcNm tyArgs) - | Just tc <- lookupUniqMap tcNm tcm + | Just tc <- UniqMap.lookup tcNm tcm , [dc] <- tyConDataCons tc , let dcArgs = substArgTys dc tyArgs , let dcArgsLen = length dcArgs @@ -571,7 +587,7 @@ , [nTy,argTy] <- tyArgs , Right n <- runExcept (tyNatSize tcm nTy) , n > 1 - , Just tc <- lookupUniqMap tcNm tcm + , Just tc <- UniqMap.lookup tcNm tcm , [nil,cons] <- tyConDataCons tc = if shouldSplitTy (tyView (coreView tcm argTy)) then Just ( mkVec nil cons argTy n @@ -603,7 +619,7 @@ -- to it being a zero-width type -- -- TODO: This currently only handles (IP $x, KnownDomain) given that $x is any - -- TODO: of the constructs handled in 'splitTy'. In practise this means only + -- TODO: of the constructs handled in 'splitTy'. In practice this means only -- TODO: HiddenClock, HiddenReset, and HiddenEnable are handled. If a user were -- TODO: to define their own versions with -for example- the elements of the -- TODO: tuple swapped, 'isHidden' wouldn't recognize it. We could generalize @@ -616,9 +632,9 @@ && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain" isHidden _ _ = False - -- Currently we're only interested in splitting of Clock, Reset, and Enable splitTy (TyConApp tcNm0 _) = nameOcc tcNm0 `elem` [ "Clash.Signal.Internal.Clock" + , "Clash.Signal.Internal.ClockN" , "Clash.Signal.Internal.Reset" , "Clash.Signal.Internal.Enable" -- iverilog doesn't like it when we put file handles @@ -663,9 +679,9 @@ -- | Do an inverse topological sorting of the let-bindings in a let-expression inverseTopSortLetBindings :: HasCallStack - => Term - -> Term -inverseTopSortLetBindings (Letrec bndrs0 res) = + => [(Id, Term)] + -> [(Id, Term)] +inverseTopSortLetBindings bndrs0 = let (graph,nodeMap,_) = Graph.graphFromEdges (map (\(i,e) -> let fvs = fmap varUniq @@ -673,7 +689,7 @@ in ((i,e),varUniq i,fvs)) bndrs0) nodes = postOrd graph bndrs1 = map ((\(x,_,_) -> x) . nodeMap) nodes - in Letrec bndrs1 res + in bndrs1 where postOrd :: Graph.Graph -> [Graph.Vertex] postOrd g = postorderF (Graph.dff g) [] @@ -683,8 +699,6 @@ postorder :: Graph.Tree a -> [a] -> [a] postorder (Graph.Node a ts) = postorderF ts . (a :) - -inverseTopSortLetBindings e = e {-# SCC inverseTopSortLetBindings #-} -- | Group let-bindings into cyclic groups and acyclic individual bindings @@ -714,12 +728,14 @@ where go (coreView1 tcm -> Just ty') = go ty' go scrutTy@(tyView -> TyConApp tc args) = - case tyConDataCons (lookupUniqMap' tcm tc) of + case tyConDataCons (UniqMap.find tc tcm) of [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showPpr tc) scrutTy dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy | otherwise -> do let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1) - let (Just fieldTys) = dataConInstArgTysE inScope tcm dc args + let fieldTys = + fromMaybe (cantCreate $(curLoc) "Cannot instantiate dataCon" scrutTy) + (dataConInstArgTysE inScope tcm dc args) if fieldI >= length fieldTys then cantCreate $(curLoc) "Field index exceed max" scrutTy else do @@ -732,6 +748,7 @@ return retVal go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showPpr scrutTy) scrutTy + cantCreate :: String -> String -> Type -> a cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showPpr scrut ++ " :: " ++ showPpr scrutTy ++ ")\nAdditional info: " ++ info -- | Make a binder that should not be referenced diff --git a/src/Clash/Core/Var.hs b/src/Clash/Core/Var.hs --- a/src/Clash/Core/Var.hs +++ b/src/Clash/Core/Var.hs @@ -14,8 +14,7 @@ {-# LANGUAGE RankNTypes #-} module Clash.Core.Var - ( Attr' (..) - , Var (..) + ( Var (..) , IdScope (..) , Id , TyVar @@ -27,7 +26,6 @@ , modifyVarName , isGlobalId , isLocalId - , attrName ) where @@ -41,24 +39,6 @@ import {-# SOURCE #-} Clash.Core.Term (Term, TmName) import {-# SOURCE #-} Clash.Core.Type (Kind, Type, TyName) import Clash.Unique - - --- | Interal version of Clash.Annotations.SynthesisAttributes.Attr. --- --- Needed because Clash.Annotations.SynthesisAttributes.Attr uses the Symbol --- kind for names, which do not have a term-level representation -data Attr' - = BoolAttr' String Bool - | IntegerAttr' String Integer - | StringAttr' String String - | Attr' String - deriving (Eq, Show, NFData, Generic, Hashable, Ord, Binary) - -attrName :: Attr' -> String -attrName (BoolAttr' n _) = n -attrName (IntegerAttr' n _) = n -attrName (StringAttr' n _) = n -attrName (Attr' n) = n -- | Variables in CoreHW data Var a diff --git a/src/Clash/Core/VarEnv.hs b/src/Clash/Core/VarEnv.hs --- a/src/Clash/Core/VarEnv.hs +++ b/src/Clash/Core/VarEnv.hs @@ -25,6 +25,7 @@ , delVarEnvList , unionVarEnv , unionVarEnvWith + , differenceVarEnv -- ** Element-wise operations -- *** Mapping , mapVarEnv @@ -115,6 +116,8 @@ import Clash.Core.Pretty () import Clash.Core.Var +import Clash.Data.UniqMap (UniqMap) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn) import Clash.Unique import Clash.Util @@ -128,28 +131,28 @@ -- | Empty map emptyVarEnv :: VarEnv a -emptyVarEnv = emptyUniqMap +emptyVarEnv = UniqMap.empty -- | Environment containing a single variable-value pair unitVarEnv :: Var b -> a -> VarEnv a -unitVarEnv = unitUniqMap +unitVarEnv = UniqMap.singleton -- | Look up a value based on the variable lookupVarEnv :: Var b -> VarEnv a -> Maybe a -lookupVarEnv = lookupUniqMap +lookupVarEnv = UniqMap.lookup -- | Lookup a value based on the unique of a variable lookupVarEnvDirectly :: Unique -> VarEnv a -> Maybe a -lookupVarEnvDirectly = lookupUniqMap +lookupVarEnvDirectly = UniqMap.lookup -- | Lookup a value based on the variable -- @@ -159,21 +162,21 @@ => VarEnv a -> Var b -> a -lookupVarEnv' = lookupUniqMap' +lookupVarEnv' = flip UniqMap.find -- | Remove a variable-value pair from the environment delVarEnv :: VarEnv a -> Var b -> VarEnv a -delVarEnv = delUniqMap +delVarEnv = flip UniqMap.delete -- | Remove a list of variable-value pairs from the environment delVarEnvList :: VarEnv a -> [Var b] -> VarEnv a -delVarEnvList = delListUniqMap +delVarEnvList = flip UniqMap.deleteMany -- | Add a variable-value pair to the environment; overwrites the value if the -- variable already exists @@ -182,7 +185,7 @@ -> a -> VarEnv a -> VarEnv a -extendVarEnv = extendUniqMap +extendVarEnv = UniqMap.insert -- | Add a variable-value pair to the environment; if the variable already -- exists, the two values are merged with the given function @@ -192,7 +195,8 @@ -> (a -> a -> a) -> VarEnv a -> VarEnv a -extendVarEnvWith = extendUniqMapWith +extendVarEnvWith k v f = + UniqMap.insertWith f k v -- | Add a list of variable-value pairs; the values of existing keys will be -- overwritten @@ -200,20 +204,20 @@ :: VarEnv a -> [(Var b, a)] -> VarEnv a -extendVarEnvList = extendListUniqMap +extendVarEnvList = flip UniqMap.insertMany -- | Is the environment empty nullVarEnv :: VarEnv a -> Bool -nullVarEnv = nullUniqMap +nullVarEnv = UniqMap.null -- | Get the (left-biased) union of two environments unionVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -unionVarEnv = unionUniqMap +unionVarEnv = (<>) -- | Get the union of two environments, mapped values existing in both -- environments will be merged with the given function. @@ -222,20 +226,27 @@ -> VarEnv a -> VarEnv a -> VarEnv a -unionVarEnvWith = unionUniqMapWith +unionVarEnvWith = UniqMap.unionWith +-- | Filter the first varenv to only contain keys which are not in the second varenv. +differenceVarEnv + :: VarEnv a + -> VarEnv a + -> VarEnv a +differenceVarEnv = UniqMap.difference + -- | Create an environment given a list of var-value pairs mkVarEnv :: [(Var a,b)] -> VarEnv b -mkVarEnv = listToUniqMap +mkVarEnv = UniqMap.fromList -- | Apply a function to every element in the environment mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -mapVarEnv = mapUniqMap +mapVarEnv = fmap -- | Apply a function to every element in the environment; values for which the -- function returns 'Nothing' are removed from the environment @@ -243,7 +254,7 @@ :: (a -> Maybe b) -> VarEnv a -> VarEnv b -mapMaybeVarEnv = mapMaybeUniqMap +mapMaybeVarEnv = UniqMap.mapMaybe -- | Strict left-fold over an environment using both the unique of the -- the variable and the value @@ -252,78 +263,78 @@ -> a -> VarEnv b -> a -foldlWithUniqueVarEnv' = foldlWithUnique' +foldlWithUniqueVarEnv' = UniqMap.foldlWithUnique' -- | Extract the elements eltsVarEnv :: VarEnv a -> [a] -eltsVarEnv = eltsUniqMap +eltsVarEnv = UniqMap.elems -- | Does the variable exist in the environment elemVarEnv :: Var a -> VarEnv b -> Bool -elemVarEnv = elemUniqMap +elemVarEnv = UniqMap.elem -- | Does the variable not exist in the environment notElemVarEnv :: Var a -> VarEnv b -> Bool -notElemVarEnv = notElemUniqMap +notElemVarEnv = UniqMap.notElem -- * VarSet -- | Set of variables -type VarSet = UniqSet (Var Any) +type VarSet = UniqMap (Var Any) -- | The empty set emptyVarSet :: VarSet -emptyVarSet = emptyUniqSet +emptyVarSet = UniqMap.empty -- | The set of a single variable unitVarSet :: Var a -> VarSet -unitVarSet v = unitUniqSet (coerce v) +unitVarSet v = UniqMap.singletonUnique (coerce v) -- | Add a variable to the set extendVarSet :: VarSet -> Var a -> VarSet -extendVarSet env v = extendUniqSet env (coerce v) +extendVarSet env v = UniqMap.insertUnique (coerce v) env -- | Union two sets unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSet = unionUniqSet +unionVarSet = (<>) -- | Take the difference of two sets differenceVarSet :: VarSet -> VarSet -> VarSet -differenceVarSet = differenceUniqSet +differenceVarSet = UniqMap.difference -- | Is the variable an element in the set elemVarSet :: Var a -> VarSet -> Bool -elemVarSet v = elemUniqSet (coerce v) +elemVarSet v = UniqMap.elem (getUnique v) -- | Is the variable not an element in the set notElemVarSet :: Var a -> VarSet -> Bool -notElemVarSet v = notElemUniqSet (coerce v) +notElemVarSet v = UniqMap.notElem (getUnique v) -- | Is the set of variables A a subset of the variables B subsetVarSet @@ -332,45 +343,45 @@ -> VarSet -- ^ Set of variables B -> Bool -subsetVarSet = subsetUniqSet +subsetVarSet = UniqMap.submap -- | Are the sets of variables disjoint disjointVarSet :: VarSet -> VarSet -> Bool -disjointVarSet = disjointUniqSet +disjointVarSet = UniqMap.disjoint -- | Check whether a varset is empty nullVarSet :: VarSet -> Bool -nullVarSet = nullUniqSet +nullVarSet = UniqMap.null -- | Look up a variable in the set, returns it if it exists lookupVarSet :: Var a -> VarSet -> Maybe (Var Any) -lookupVarSet = lookupUniqSet +lookupVarSet = UniqMap.lookup -- | Remove a variable from the set based on its 'Unique' delVarSetByKey :: Unique -> VarSet -> VarSet -delVarSetByKey = delUniqSetDirectly +delVarSetByKey = UniqMap.delete -- | Create a set from a list of variables mkVarSet :: [Var a] -> VarSet -mkVarSet xs = mkUniqSet (coerce xs) +mkVarSet xs = UniqMap.fromList $ fmap (\x -> (getUnique x, coerce x)) xs eltsVarSet :: VarSet -> [Var Any] -eltsVarSet = eltsUniqSet +eltsVarSet = UniqMap.elems -- * InScopeSet @@ -440,7 +451,7 @@ :: Unique -> InScopeSet -> Bool -elemUniqInScopeSet u (InScopeSet s _) = u `elemUniqSetDirectly` s +elemUniqInScopeSet u (InScopeSet s _) = UniqMap.elem u s -- | Is the variable not in scope notElemInScopeSet @@ -467,7 +478,7 @@ -> a -> a uniqAway (InScopeSet set n) a = - uniqAway' (`elemUniqSetDirectly` set) n a + uniqAway' (`UniqMap.elem` set) n a uniqAway' :: (Uniquable a, ClashPretty a) diff --git a/src/Clash/Data/UniqMap.hs b/src/Clash/Data/UniqMap.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Data/UniqMap.hs @@ -0,0 +1,235 @@ +{- +Copyright : (C) 2016-2021 QBayLogic B.V. + 2022 Alexander McKenna +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Data.UniqMap + ( UniqMap(..) + , empty + , singleton + , singletonUnique + , null + , insert + , insertUnique + , insertWith + , insertMany + , lookup + , find + , elem + , notElem + , filter + , mapMaybe + , foldrWithUnique + , foldlWithUnique' + , delete + , deleteMany + , unionWith + , difference + , disjoint + , submap + , fromList + , toList + , keys + , elems + ) where + +import Prelude hiding (elem, filter, lookup, notElem, null) + +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Bifunctor (first) +import Data.Function (on) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.List as List (foldl') + +#if !MIN_VERSION_containers(0,6,2) +import qualified Data.IntMap.Extra as IntMap +#endif + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +#else +import Data.Text.Prettyprint.Doc +#endif + +import Clash.Pretty +import Clash.Unique (Unique, Uniquable(getUnique)) + +-- | A map indexed by a 'Unique'. Typically the elements of this map are also +-- uniqueable and provide their own key, however a unique can be associated +-- with any value. +newtype UniqMap a + = UniqMap { uniqMapToIntMap :: IntMap a } + deriving stock Traversable + deriving newtype + ( Binary + , Foldable + , Functor + , Monoid + , NFData + , Semigroup + , Show + ) + +instance ClashPretty a => ClashPretty (UniqMap a) where + clashPretty xs = + brackets $ fillSep $ punctuate comma $ + [ fromPretty k <+> ":->" <+> clashPretty v + | (k, v) <- toList xs + ] + +-- | An empty map. +empty :: UniqMap a +empty = + UniqMap IntMap.empty + +{-# SPECIALIZE singleton :: Unique -> b -> UniqMap b #-} +-- | A map containing a single value indexed by the given key's unique. +singleton :: Uniquable a => a -> b -> UniqMap b +singleton k v = + UniqMap (IntMap.singleton (getUnique k) v) + +{-# SPECIALIZE singletonUnique :: Unique -> UniqMap Unique #-} +-- | A map containing a single value indexed by the value's unique. +singletonUnique :: Uniquable a => a -> UniqMap a +singletonUnique v = + singleton (getUnique v) v + +-- | Check if the map is empty. +null :: UniqMap a -> Bool +null = + IntMap.null . uniqMapToIntMap + +{-# SPECIALIZE insert :: Unique -> b -> UniqMap b -> UniqMap b #-} +-- | Insert a new key-value pair into the map. +insert :: Uniquable a => a -> b -> UniqMap b -> UniqMap b +insert k v = + UniqMap . IntMap.insert (getUnique k) v . uniqMapToIntMap + +{-# SPECIALIZE insertUnique :: Unique -> UniqMap Unique -> UniqMap Unique #-} +-- | Insert a new value into the map, using the unique of the value as the key. +insertUnique :: Uniquable a => a -> UniqMap a -> UniqMap a +insertUnique v = + insert (getUnique v) v + +-- | Insert a new key-value pair into the map, using the given combining +-- function if there is already an entry with the same unique in the map. +insertWith :: Uniquable a => (b -> b -> b) -> a -> b -> UniqMap b -> UniqMap b +insertWith f k v = + UniqMap . IntMap.insertWith f (getUnique k) v . uniqMapToIntMap + +-- | Insert a list of key-value pairs into the map. +insertMany :: Uniquable a => [(a, b)] -> UniqMap b -> UniqMap b +insertMany kvs xs = + List.foldl' (\acc (k, v) -> insert k v acc) xs kvs + +{-# SPECIALIZE lookup :: Unique -> UniqMap b -> Maybe b #-} +-- | Lookup an item in the map, using the unique of the given key. +lookup :: Uniquable a => a -> UniqMap b -> Maybe b +lookup k = + IntMap.lookup (getUnique k) . uniqMapToIntMap + +{-# SPECIALIZE find :: Unique -> UniqMap b -> b #-} +-- | Lookup and item in the map, using the unique of the given key. If the item +-- is not found in the map an error is raised. +find :: Uniquable a => a -> UniqMap b -> b +find k = + let notFound = + error ("find: Key " <> show (getUnique k) <> " is not in the UniqMap") + in IntMap.findWithDefault notFound (getUnique k) . uniqMapToIntMap + +{-# SPECIALIZE elem :: Unique -> UniqMap b -> Bool #-} +-- | Check if there is an entry in the map for the unique of the given value. +elem :: Uniquable a => a -> UniqMap b -> Bool +elem k = + IntMap.member (getUnique k) . uniqMapToIntMap + +{-# SPECIALIZE notElem :: Unique -> UniqMap b -> Bool #-} +-- | Check if there is not an entry in the map for the unique of the given +-- value. +notElem :: Uniquable a => a -> UniqMap b -> Bool +notElem k = + IntMap.notMember (getUnique k) . uniqMapToIntMap + +-- | Filter all elements in the map according to some predicate. +filter :: (b -> Bool) -> UniqMap b -> UniqMap b +filter p = + UniqMap . IntMap.filter p . uniqMapToIntMap + +-- | Apply a function to all elements in the map, keeping those where the +-- result is not @Nothing@. +mapMaybe :: (a -> Maybe b) -> UniqMap a -> UniqMap b +mapMaybe f = + UniqMap . IntMap.mapMaybe f . uniqMapToIntMap + +-- | Lazily right-fold over the map using the given function. +foldrWithUnique :: (Unique -> a -> b -> b) -> b -> UniqMap a -> b +foldrWithUnique f x = + IntMap.foldrWithKey f x . uniqMapToIntMap + +-- | Strictly left-fold over the map using the given function. +foldlWithUnique' :: (b -> Unique -> a -> b) -> b -> UniqMap a -> b +foldlWithUnique' f x = + IntMap.foldlWithKey' f x . uniqMapToIntMap + +{-# SPECIALIZE delete :: Unique -> UniqMap b -> UniqMap b #-} +-- | Delete the entry in the map indexed by the unique of the given value. +delete :: Uniquable a => a -> UniqMap b -> UniqMap b +delete k = + UniqMap . IntMap.delete (getUnique k) . uniqMapToIntMap + +-- | Delete all entries in the map indexed by the uniques of the given values. +deleteMany :: Uniquable a => [a] -> UniqMap b -> UniqMap b +deleteMany ks xs = + List.foldl' (\acc k -> delete k acc) xs ks + +-- | Merge two unique maps, using the given combining funcion if a value with +-- the same unique key exists in both maps. +unionWith :: (b -> b -> b) -> UniqMap b -> UniqMap b -> UniqMap b +unionWith f xs ys = + UniqMap ((IntMap.unionWith f `on` uniqMapToIntMap) xs ys) + +-- | Filter the first map to only contain keys which are not in the second map. +difference :: UniqMap b -> UniqMap b -> UniqMap b +difference xs ys = + UniqMap ((IntMap.difference `on` uniqMapToIntMap) xs ys) + +-- | Check if there are no common keys between two maps. +disjoint :: UniqMap b -> UniqMap b -> Bool +disjoint = + IntMap.disjoint `on` uniqMapToIntMap + +-- | Check if one map is a submap of another. +submap :: UniqMap b -> UniqMap b -> Bool +submap = + -- We only check that the keys of the map make it a submap, the elements do + -- not need to be equal. Maybe this should be changed? + IntMap.isSubmapOfBy (\_ _ -> True) `on` uniqMapToIntMap + +{-# SPECIALIZE fromList :: [(Unique, b)] -> UniqMap b #-} +-- | Convert a list of key-value pairs to a map. +fromList :: Uniquable a => [(a, b)] -> UniqMap b +fromList = + UniqMap . IntMap.fromList . fmap (first getUnique) + +-- | Convert a map to a list of unique-value pairs. +toList :: UniqMap b -> [(Unique, b)] +toList = + IntMap.toList . uniqMapToIntMap + +-- | Get the unique keys of a map. +keys :: UniqMap b -> [Unique] +keys = + IntMap.keys . uniqMapToIntMap + +-- | Get the values of a map. +elems :: UniqMap b -> [b] +elems = + IntMap.elems . uniqMapToIntMap diff --git a/src/Clash/DataFiles.hs b/src/Clash/DataFiles.hs new file mode 100644 --- /dev/null +++ b/src/Clash/DataFiles.hs @@ -0,0 +1,63 @@ +{-| +Copyright : (C) 2022 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +This module provides a way to access static files that are useful when working +with Clash designs. +-} + +module Clash.DataFiles where + +import System.FilePath (()) + +import Paths_clash_lib (getDataFileName) + +{- | The Tcl Connector: a Tcl script that can parse Clash output and emit the + correct commands for loading the design into Vivado (Quartus support will be + added later). + + Apart from parsing the @clash-manifest.json@ files produced by Clash, the Tcl + Connector also supports the so-called /Clash\<->Tcl API/. This functionality + enables Clash primitives to pass complex instructions to the Tcl Connector. + Current features are instantiating IP in Vivado and passing metadata along + with Vivado XDC files. + + An example use of the Tcl Connector, demonstrating its basic features: + + > source -notrace clashConnector.tcl + > # Pass it the path to "clash-manifest.json" of your top entity + > clash::readMetadata vhdl/Design.topEntity + > # Instantiate IP (no-op if no IP defined) + > file mkdir ip + > clash::createAndReadIp -dir ip + > # Read all VHDL/Verilog/SystemVerilog files generated by Clash + > clash::readHdl + > # Handle XDC files, in correct order + > clash::readXdc early + > # A file containing PACKAGE_PIN and IOSTANDARD definitions (but not + > # create_clock, clocks are part of the Clash-generated files) + > read_xdc Arty-A7-35-Master.xdc + > set_property USED_IN implementation [get_files Arty-A7-35-Master.xdc] + > clash::readXdc {normal late} + > synth_design -top $clash::topEntity -part xc7a35ticsg324-1L + > opt_design + > place_design + > route_design + > write_bitstream ${clash::topEntity}.bit + + "Clash.Xilinx.ClockGen" and @clash-cores:Clash.Cores.Xilinx@ + modules make use of the IP instantiating functionality; XDC metadata + functionality is not currently used as the IP is already packaged with correct + constraints by Vivado. + + More documentation about the Tcl Connector and the Clash\<->Tcl API will be + made available later. + + In addition to this module, you can also write a copy of the Tcl script to a + file by invoking + + > cabal run clash-lib:static-files -- --tcl-connector clashConnector.tcl +-} +tclConnector :: IO FilePath +tclConnector = getDataFileName $ "data-files" "tcl" "clashConnector.tcl" diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , QBayLogic, Google Inc. - 2020-2022, QBayLogic, + 2020-2023, QBayLogic, 2022 , Google Inc. License : BSD2 (see the file LICENSE) @@ -35,7 +35,7 @@ import Control.Monad.State.Strict (State) import qualified Control.Monad.State.Strict as State import qualified Crypto.Hash.SHA256 as Sha256 -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringLazy @@ -48,6 +48,7 @@ import qualified Data.HashSet as HashSet import Data.Proxy (Proxy(..)) import Data.List (intercalate) +import qualified Data.List as List import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map.Ordered as OMap import Data.Map.Ordered.Extra () @@ -138,7 +139,9 @@ import qualified Clash.Primitives.GHC.Int as P import qualified Clash.Primitives.GHC.Word as P import qualified Clash.Primitives.Intel.ClockGen as P +import qualified Clash.Primitives.Magic as P import qualified Clash.Primitives.Verification as P +import qualified Clash.Primitives.Xilinx.ClockGen as P import Clash.Primitives.Types import Clash.Signal.Internal import Clash.Unique (Unique, getUnique) @@ -313,8 +316,8 @@ -> WHNF.Evaluator -- ^ Hardcoded evaluator for WHNF (old evaluator) -> Maybe (TopEntityT, [TopEntityT]) - -- ^ Main top entity to compile. If Nothing, all top entities in previous - -- argument will be compiled. + -- ^ Main top entity to compile. If Nothing, all top entities in the + -- 'ClashDesign' argument will be compiled. -> Clock.UTCTime -> IO () generateHDL env design hdlState typeTrans peEval eval mainTopEntity startTime = do @@ -361,7 +364,7 @@ -> TopEntityT -> IO () go compNames seenV edamFilesV ioLockV deps topEntityMap (TopEntityT topEntity annM isTb) = do - let domainConfs = designDomains design + let domainConfs = envDomains env let bindingsMap = designBindings design let primMap = envPrimitives env let topEntities0 = designEntities design @@ -467,7 +470,7 @@ -- 4. Generate topEntity wrapper (hdlDocs, dfiles, mfiles) <- withMVar seenV $ \seen -> - pure $! createHDL hdlState' modNameT seen netlist domainConfs topComponent topNmT + pure $! createHDL hdlState' opts modNameT seen netlist domainConfs topComponent topNmT -- TODO: Data files should go into their own directory -- FIXME: Files can silently overwrite each other @@ -478,9 +481,11 @@ let components = map (snd . snd) (OMap.assocs netlist) filesAndDigests0 = - zip (map fst hdlDocs) hdlDocDigests + -- FIXME: We should track dependencies of `mfiles` and `dfiles` and + -- maintain the proper topological sort of all these. + zip (map fst mfiles) memoryFilesDigests <> zip (map fst dfiles) dataFilesDigests - <> zip (map fst mfiles) memoryFilesDigests + <> zip (map fst hdlDocs) hdlDocDigests filesAndDigests1 <- modifyMVar edamFilesV $ \edamFiles -> if opt_edalize opts @@ -573,6 +578,7 @@ [ ('P.checkBBF, P.checkBBF) , ('P.bvToIntegerVHDL, P.bvToIntegerVHDL) , ('P.bvToIntegerVerilog, P.bvToIntegerVerilog) + , ('P.clashCompileErrorBBF, P.clashCompileErrorBBF) , ('P.foldBBF, P.foldBBF) , ('P.indexIntVerilog, P.indexIntVerilog) , ('P.indexToIntegerVerilog, P.indexToIntegerVerilog) @@ -596,6 +602,10 @@ , ('P.alteraPllTF, P.alteraPllTF) , ('P.altpllTF, P.altpllTF) , ('P.fromIntegerTFvhdl, P.fromIntegerTFvhdl) + , ('P.clockWizardTF, P.clockWizardTF) + , ('P.clockWizardDifferentialTF, P.clockWizardDifferentialTF) + , ('P.clockWizardTclTF, P.clockWizardTclTF) + , ('P.clockWizardDifferentialTclTF, P.clockWizardDifferentialTclTF) ] -- | Compiles blackbox functions and parses blackbox templates. @@ -661,14 +671,14 @@ loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction" compilePrimitive idirs pkgDbs topDir - (BlackBox pNm wf rVoid multiRes tkind () oReg libM imps fPlural incs rM riM templ) = do + (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM imps fPlural incs rM riM templ) = do libM' <- mapM parseTempl libM imps' <- mapM parseTempl imps incs' <- mapM (traverse parseBB) incs templ' <- parseBB templ rM' <- traverse parseBB rM riM' <- traverse parseBB riM - return (BlackBox pNm wf rVoid multiRes tkind () oReg libM' imps' fPlural incs' rM' riM' templ') + return (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM' imps' fPlural incs' rM' riM' templ') where iArgs = concatMap (("-package-db":) . (:[])) pkgDbs @@ -746,6 +756,8 @@ :: Backend backend => backend -- ^ Backend + -> ClashOpts + -- ^ Global Clash options -> IdentifierText -- ^ Module hierarchy root -> Id.IdentifierSet @@ -761,21 +773,21 @@ -> ([(String,Doc)],[(String,FilePath)],[(String,String)]) -- ^ The pretty-printed HDL documents -- + The data files that need to be copied -createHDL backend modName seen components domainConfs top topName = flip evalState backend $ getAp $ do +createHDL backend opts modName seen components domainConfs top topName = flip evalState backend $ getAp $ do let componentsL = map snd (OMap.assocs components) - (hdlNmDocs,incs) <- + (hdlNmDocs0,incs) <- fmap unzip $ - forM componentsL $ \(ComponentMeta{cmLoc, cmScope}, comp) -> - genHDL modName cmLoc (Id.union seen cmScope) comp + forM componentsL $ \(ComponentMeta{cmLoc, cmScope,cmUsage}, comp) -> + genHDL opts modName cmLoc (Id.union seen cmScope) cmUsage comp hwtys <- HashSet.toList <$> extractTypes <$> Ap get - typesPkg <- mkTyPackage modName hwtys + typesPkg0 <- mkTyPackage modName hwtys dataFiles <- Ap getDataFiles memFiles <- Ap getMemoryDataFiles let - hdl = map (first (<.> Clash.Backend.extension backend)) (typesPkg ++ hdlNmDocs) - qincs = concat incs - topFiles = hdl ++ qincs + typesPkg1 = map (first (<.> Clash.Backend.extension backend)) typesPkg0 + hdlNmDocs1 = map (first (<.> Clash.Backend.extension backend)) hdlNmDocs0 + topFiles = concat incs ++ typesPkg1 ++ hdlNmDocs1 topClks = findClocks top sdcInfo = fmap findDomainConfig <$> topClks @@ -1079,28 +1091,37 @@ typeTrans peEval eval emptyVarEnv topEntities doNorm --- | topologically sort the top entities -sortTop - :: BindingMap - -> [TopEntityT] - -> ([TopEntityT], HashMap Unique [Unique]) +-- | Reverse topologically sort given top entities. Also returns a mapping that +-- maps a top entity to its reverse topologically sorted transitive dependencies. +sortTop :: + BindingMap -> + [TopEntityT] -> + ( [TopEntityT] + , HashMap Unique [Unique] + ) sortTop bindingsMap topEntities = - let (nodes,edges) = unzip (map go topEntities) - edges' = concat edges - in case reverseTopSort nodes edges' of - Left msg -> error msg - Right tops -> (tops, mapFrom edges') + case reverseTopSort nodes edges of + Left msg -> error msg + Right tops -> (tops, mapFrom tops) where - go t@(TopEntityT topE _ _) = - let topRefs = goRefs topE topE - in ((varUniq topE,t) - ,map ((\top -> (varUniq topE, varUniq (topId top)))) topRefs) + nodes = [(varUniq topE, t) | t@(TopEntityT topE _ _) <- topEntities] + edges = concatMap getEdges topEntities - goRefs top i_ = - let cg = callGraph bindingsMap i_ - in - filter - (\t -> topId t /= top && topId t /= i_ && topId t `elemVarEnv` cg) - topEntities + getEdges (TopEntityT topE _ _) = + map + (\top -> (varUniq topE, topToUnique top)) + (getTransitiveRefs topE) - mapFrom = HashMap.fromListWith mappend . fmap (fmap pure) + getTransitiveRefs top = + let allDeps = callGraph bindingsMap top + in filter (\t -> topId t /= top && topId t `elemVarEnv` allDeps) topEntities + + topToUnique = varUniq . topId + + mapFrom tops = + let + topIndices = HashMap.fromList (zip (map topToUnique tops) [(0 :: Int)..]) + nonOrdered = HashMap.fromListWith (<>) (map (second pure) edges) + orderFunc k = fromMaybe (-1) (HashMap.lookup k topIndices) + in + HashMap.map (List.sortOn orderFunc) nonOrdered diff --git a/src/Clash/Driver/Manifest.hs b/src/Clash/Driver/Manifest.hs --- a/src/Clash/Driver/Manifest.hs +++ b/src/Clash/Driver/Manifest.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2021-2022, QBayLogic B.V. +Copyright : (C) 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -58,7 +58,7 @@ import Clash.Primitives.Types import Clash.Core.Var (Id, varName) import Clash.Netlist.Types - (TopEntityT, Component(..), HWType (Clock), hwTypeDomain) + (TopEntityT, Component(..), HWType (Clock, ClockN), hwTypeDomain) import qualified Clash.Netlist.Types as Netlist import qualified Clash.Netlist.Id as Id import Clash.Netlist.Util (typeSize) @@ -66,7 +66,9 @@ import Clash.Signal (VDomainConfiguration(..)) import Clash.Util.Graph (callGraphBindings) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Data.Bool (OverridingBool(..)) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Utils.Misc (OverridingBool(..)) #else import Util (OverridingBool(..)) @@ -164,10 +166,8 @@ -- ^ Dependencies of this design (fully qualified binder names). Is a -- transitive closure of all dependencies. -- - -- This list is topologically sorted. I.e., a dependency might depend - -- on any dependency listed after it, but not before it. - -- - -- TODO: this ordered differs from `fileNames` and `componentNames`. Fix? + -- This list is reverse topologically sorted. I.e., a component might depend + -- on any component listed before it, but not after it. } deriving (Show,Read,Eq) instance ToJSON Manifest where @@ -291,7 +291,7 @@ mpName = Id.toText portId mpWidth = typeSize portType mpDirection = portDir - mpIsClock = case portType of {Clock _ -> True; _ -> False} + mpIsClock = case portType of {Clock _ -> True; ClockN _ -> True; _ -> False} mpDomain = hwTypeDomain portType mpTypeName = flip evalState backend $ getAp $ do LText.toStrict . renderOneLine <$> hdlType (External mpName) portType diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs --- a/src/Clash/Driver/Types.hs +++ b/src/Clash/Driver/Types.hs @@ -1,8 +1,9 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2017 , QBayLogic, Google Inc. - 2020-2022, QBayLogic + 2017 , QBayLogic, Google Inc., + 2020-2022, QBayLogic, + 2022 , Google Inc., License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -41,9 +42,13 @@ import GHC.Generics (Generic) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,4,0) import GHC.Types.Basic (InlineSpec) import GHC.Types.SrcLoc (SrcSpan) +import GHC.Data.Bool (OverridingBool(..)) +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Types.Basic (InlineSpec) +import GHC.Types.SrcLoc (SrcSpan) import GHC.Utils.Misc (OverridingBool(..)) #else import BasicTypes (InlineSpec) @@ -54,6 +59,7 @@ import Clash.Annotations.BitRepresentation.Internal (CustomReprs) import Clash.Signal.Internal +import Clash.Backend.Verilog.Time (Period(..), Unit(Fs)) import Clash.Core.Term (Term) import Clash.Core.TyCon (TyConMap, TyConName) import Clash.Core.Var (Id) @@ -68,18 +74,17 @@ , envTupleTyCons :: IntMap TyConName , envPrimitives :: CompiledPrimMap , envCustomReprs :: CustomReprs + , envDomains :: DomainMap } deriving (Generic, NFData) data ClashDesign = ClashDesign { designEntities :: [TopEntityT] - , designDomains :: DomainMap , designBindings :: BindingMap } instance NFData ClashDesign where rnf design = designEntities design `seq` - designDomains design `deepseq` designBindings design `deepseq` () @@ -340,7 +345,7 @@ -- -- Command line flag: -fdiagnostics-color , opt_intWidth :: Int - -- ^ Set the bit width for the Int/Word/Integer types. The only allowed values + -- ^ Set the bit width for the Int\/Word\/Integer types. The only allowed values -- are 32 or 64. , opt_hdlDir :: Maybe String -- ^ Directory to save HDL files to @@ -358,8 +363,8 @@ , opt_escapedIds :: Bool -- ^ Use escaped identifiers in HDL. See: -- - -- * http://vhdl.renerta.com/mobile/source/vhd00037.htm - -- * http://verilog.renerta.com/source/vrg00018.htm + -- * https://peterfab.com/ref/vhdl/vhdl_renerta/source/vhd00037.htm + -- * https://peterfab.com/ref/verilog/verilog_renerta/source/vrg00018.htm , opt_lowerCaseBasicIds :: PreserveCase -- ^ Force all generated basic identifiers to lowercase. Among others, this -- affects module and file names. @@ -392,6 +397,9 @@ , opt_renderEnums :: Bool -- ^ Render sum types with all zero-width fields as enums where supported, as -- opposed to rendering them as bitvectors. + , opt_timescalePrecision :: Period + -- ^ Timescale precision set in Verilog files. E.g., setting this would sets + -- the second part of @`timescale 100fs/100fs@. } deriving (Show) @@ -424,6 +432,7 @@ opt_inlineWFCacheLimit o `deepseq` opt_edalize o `deepseq` opt_renderEnums o `deepseq` + opt_timescalePrecision o `deepseq` () instance Eq ClashOpts where @@ -454,7 +463,8 @@ opt_aggressiveXOptBB s0 == opt_aggressiveXOptBB s1 && opt_inlineWFCacheLimit s0 == opt_inlineWFCacheLimit s1 && opt_edalize s0 == opt_edalize s1 && - opt_renderEnums s0 == opt_renderEnums s1 + opt_renderEnums s0 == opt_renderEnums s1 && + opt_timescalePrecision s0 == opt_timescalePrecision s1 where eqOverridingBool :: OverridingBool -> OverridingBool -> Bool @@ -492,7 +502,8 @@ opt_aggressiveXOptBB `hashWithSalt` opt_inlineWFCacheLimit `hashWithSalt` opt_edalize `hashWithSalt` - opt_renderEnums + opt_renderEnums `hashWithSalt` + opt_timescalePrecision where hashOverridingBool :: Int -> OverridingBool -> Int hashOverridingBool s1 Auto = hashWithSalt s1 (0 :: Int) @@ -531,6 +542,7 @@ , opt_inlineWFCacheLimit = 10 -- TODO: find "optimal" value , opt_edalize = False , opt_renderEnums = True + , opt_timescalePrecision = Period 100 Fs } -- | Synopsys Design Constraint (SDC) information for a component. diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs --- a/src/Clash/Netlist.hs +++ b/src/Clash/Netlist.hs @@ -3,6 +3,7 @@ 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021-2022, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -24,18 +25,20 @@ import Control.Exception (throw) import Control.Lens ((.=), (<~)) import qualified Control.Lens as Lens -import Control.Monad.Extra (concatMapM) +import Control.Monad (zipWithM) +import Control.Monad.Extra (concatMapM, mapMaybeM) import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (State, runStateT, runState) import Data.Bifunctor (first, second) import Data.Char (ord) import Data.Either (partitionEithers, rights) import Data.Foldable (foldlM) -import qualified Data.HashMap.Lazy as HashMap -import Data.List (elemIndex, partition, sortOn) +import Data.List (elemIndex, partition) import Data.List.Extra (zipEqual) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty.Extra as NE import Data.Maybe - (listToMaybe, mapMaybe, fromMaybe) + (listToMaybe, fromMaybe) import qualified Data.Map.Ordered as OMap import qualified Data.Set as Set import Data.Primitive.ByteArray (ByteArray (..)) @@ -55,7 +58,7 @@ import SrcLoc (isGoodSrcSpan) #endif -import Clash.Annotations.Primitive (extractPrim, HDL) +import Clash.Annotations.Primitive (HDL) import Clash.Annotations.BitRepresentation.ClashLib (coreToType') import Clash.Annotations.BitRepresentation.Internal @@ -172,6 +175,7 @@ , _backEndITE=ite , _backend=be , _htyCache=mempty + , _usages=mempty } -- | Generate names for all binders in "BindingMap", except for the ones already @@ -255,6 +259,7 @@ compName1 <- (`lookupVarEnv'` compName0) <$> Lens.use componentNames sp <- (bindingLoc . (`lookupVarEnv'` compName0)) <$> Lens.use bindings curCompNm .= (compName1, sp) + usages .= mempty topEntityTM <- lookupVarEnv compName0 <$> Lens.use topEntityAnns let topAnnMM = topAnnotation <$> topEntityTM @@ -280,29 +285,33 @@ case resultM of Just result -> do - [NetDecl' _ rw _ _ rIM] <- case filter ((==result) . fst) binders of + [NetDecl' _ _ _ rIM] <- case filter ((==result) . fst) binders of b:_ -> mkNetDecl b _ -> error "internal error: couldn't find result binder" + u <- Lens.use usages + let useOf i = fromMaybe Cont $ lookupUsage (fst i) u + let (compOutps',resUnwrappers') = case compOutps of - [oport] -> ([(rw,oport,rIM)],resUnwrappers) - _ -> let NetDecl n res resTy = case resUnwrappers of - decl:_ -> decl - _ -> error "internal error: insufficient resUnwrappers" - in (map (Wire,,Nothing) compOutps - ,NetDecl' n rw res (Right resTy) Nothing:tail resUnwrappers - ) + [oport] -> ([(useOf oport,oport,rIM)],resUnwrappers) + _ -> case resUnwrappers of + NetDecl n res resTy:_ -> + (map (\op -> (useOf op,op,Nothing)) compOutps + ,NetDecl' n res resTy Nothing:drop 1 resUnwrappers + ) + _ -> error "internal error: insufficient resUnwrappers" component = Component compName1 compInps compOutps' (netDecls ++ argWrappers ++ decls ++ resUnwrappers') ids <- Lens.use seenIds - return (ComponentMeta wereVoids sp ids, component) + return (ComponentMeta wereVoids sp ids u, component) -- No result declaration means that the result is empty, this only happens -- when the TopEntity has an empty result. We just create an empty component -- in this case. Nothing -> do let component = Component compName1 compInps [] (netDecls ++ argWrappers ++ decls) ids <- Lens.use seenIds - return (ComponentMeta wereVoids sp ids, component) + u <- Lens.use usages + return (ComponentMeta wereVoids sp ids u, component) mkNetDecl :: (Id, Term) -> NetlistMonad [Declaration] mkNetDecl (id_,tm) = preserveVarEnv $ do @@ -321,19 +330,16 @@ resInits1 = map Just resInits0 <> repeat Nothing mpInfo = multiPrimInfo' tcm pInfo (_, res) = splitMultiPrimArgs mpInfo args0 + netdecl i typ resInit = - -- TODO: Dehardcode Wire. Would entail changing 'outputReg' to a - -- list. - NetDecl' srcNote Wire (id2identifier i) (Right typ) resInit + NetDecl' srcNote (Id.unsafeFromCoreId i) typ resInit hwTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) (mpi_resultTypes mpInfo) pure (zipWith3 netdecl res hwTys resInits1) - singleDecl hwTy = do - wr <- termToWireOrReg tm rIM <- listToMaybe <$> getResInits (id_, tm) - return (NetDecl' srcNote wr (id2identifier id_) (Right hwTy) rIM) + return (NetDecl' srcNote (Id.unsafeFromCoreId id_) hwTy rIM) addSrcNote loc | isGoodSrcSpan loc = Just (StrictText.pack (showSDocUnsafe (ppr loc))) @@ -354,23 +360,6 @@ | isMultiPrimSelect t = False | otherwise = True - termToWireOrReg :: Term -> NetlistMonad WireOrReg - termToWireOrReg (stripTicks -> Case scrut _ alts0@(_:_:_)) = do - tcm <- Lens.view tcCache - let scrutTy = inferCoreTypeOf tcm scrut - scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy - ite <- Lens.use backEndITE - case iteAlts scrutHTy alts0 of - Just _ | ite -> return Wire - _ -> return Reg - termToWireOrReg (collectArgs -> (Prim p,_)) = do - bbM <- HashMap.lookup (primName p) <$> Lens.view primitives - case bbM of - Just (extractPrim -> Just BlackBox {..}) | outputReg -> return Reg - _ | primName p == "Clash.Explicit.SimIO.mealyIO" -> return Reg - _ -> return Wire - termToWireOrReg _ = return Wire - -- Set the initialization value of a signal when a primitive wants to set it getResInits :: (Id, Term) -> NetlistMonad [Expr] getResInits (i,collectArgsTicks -> (k,args0,ticks)) = case k of @@ -431,8 +420,7 @@ -- ^ RHS of the let-binder -> NetlistMonad [Declaration] mkDeclarations' _declType bndr (collectTicks -> (Var v,ticks)) = - withTicks ticks $ \tickDecls -> do - mkFunApp (id2identifier bndr) v [] tickDecls + withTicks ticks (mkFunApp (Id.unsafeFromCoreId bndr) v []) mkDeclarations' _declType _bndr e@(collectTicks -> (Case _ _ [],_)) = do (_,sp) <- Lens.use curCompNm @@ -445,37 +433,42 @@ ]) Nothing -mkDeclarations' declType bndr (collectTicks -> (Case scrut altTy alts@(_:_:_),ticks)) = - withTicks ticks $ \tickDecls -> do - mkSelection declType (CoreId bndr) scrut altTy alts tickDecls +mkDeclarations' declType bndr (collectTicks -> (Case scrut altTy (alt:alts@(_:_)),ticks)) = + withTicks ticks (mkSelection declType (CoreId bndr) scrut altTy (alt :| alts)) mkDeclarations' declType bndr app = do let (appF,args0,ticks) = collectArgsTicks app (args,tyArgs) = partitionEithers args0 case appF of Var f - | null tyArgs -> withTicks ticks (mkFunApp (id2identifier bndr) f args) + | null tyArgs -> + withTicks ticks (mkFunApp (Id.unsafeFromCoreId bndr) f args) | otherwise -> do (_,sp) <- Lens.use curCompNm throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) _ -> do (exprApp,declsApp0) <- mkExpr False declType (CoreId bndr) app - let dstId = id2identifier bndr - assn = - case exprApp of - Identifier _ Nothing -> - -- Supplied 'bndr' was used to assign a result to, so we - -- don't have to manually turn it into a declaration - [] - Noop -> - -- Rendered expression rendered a "noop" - a list of - -- declarations without a result. Used for things like - -- mealy IO / inline assertions / multi result primitives. - [] - _ -> - -- Turn returned expression into declaration by assigning - -- it to 'dstId' - [Assignment dstId exprApp] + let dstId = Id.unsafeFromCoreId bndr + assn <- case exprApp of + Identifier _ Nothing -> + -- Supplied 'bndr' was used to assign a result to, so we + -- don't have to manually turn it into a declaration + pure [] + + Noop -> + -- Rendered expression rendered a "noop" - a list of + -- declarations without a result. Used for things like + -- mealy IO / inline assertions / multi result primitives. + pure [] + + _ -> do + -- Turn returned expression into declaration by assigning + -- it to 'dstId' + assn <- case declType of + Concurrent -> contAssign dstId exprApp + Sequential -> procAssign Blocking dstId exprApp + pure [assn] + declsApp1 <- if null declsApp0 then withTicks ticks return else pure declsApp0 @@ -488,11 +481,11 @@ -> NetlistId -> Term -> Type - -> [Alt] + -> NonEmpty Alt -> [Declaration] -> NetlistMonad [Declaration] mkSelection declType bndr scrut altTy alts0 tickDecls = do - let dstId = netlistId1 id id2identifier bndr + let dstId = netlistId1 id Id.unsafeFromCoreId bndr tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy @@ -500,13 +493,13 @@ (_,sp) <- Lens.use curCompNm ite <- Lens.use backEndITE altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy - case iteAlts scrutHTy alts0 of + case iteAlts scrutHTy (NE.toList alts0) of Just (altT,altF) | ite , Concurrent <- declType -> do (scrutExpr,scrutDecls) <- case scrutHTy of - SP {} -> first (mkScrutExpr sp scrutHTy (fst (last alts0))) <$> + SP {} -> first (mkScrutExpr sp scrutHTy (fst (NE.last alts0))) <$> mkExpr True declType (NetlistId scrutId scrutTy) scrut _ -> mkExpr False declType (NetlistId scrutId scrutTy) scrut altTId <- Id.suffix dstId "sel_alt_t" @@ -525,19 +518,18 @@ | isVoid altHTy -> return $! altTDecls ++ altFDecls | otherwise - -> return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++ - [Assignment dstId (IfThenElse scrutExpr altTExpr altFExpr)] + -> do dstAssign <- contAssign dstId (IfThenElse scrutExpr altTExpr altFExpr) + return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++ [dstAssign] _ -> do reprs <- Lens.view customReprs let alts1 = (reorderDefault . reorderCustom tcm reprs scrutTy) alts0 - (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts1))) <$> + (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (NE.head alts1))) <$> mkExpr True declType (NetlistId scrutId scrutTy) scrut - (exprs,altsDecls) <- unzip <$> mapM (mkCondExpr scrutHTy) alts1 + (exprs,altsDecls) <- unzip <$> mapM (mkCondExpr scrutHTy) (NE.toList alts1) case declType of Sequential -> do -- Assign to the result in every branch - let (altNets,exprAlts) = unzip (zipWith (altAssign dstId) - exprs altsDecls) + (altNets,exprAlts) <- fmap unzip (zipWithM (altAssign dstId) exprs altsDecls) return $! scrutDecls ++ tickDecls ++ concat altNets ++ [Seq [Branch scrutExpr scrutHTy exprAlts]] Concurrent -> @@ -546,12 +538,12 @@ | isVoid altHTy -> return $! concat altsDecls | otherwise - -> return $! scrutDecls ++ concat altsDecls ++ tickDecls - ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] + -> do assign <- condAssign dstId altHTy scrutExpr scrutHTy exprs + return $! scrutDecls ++ concat altsDecls ++ tickDecls ++ [assign] where mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration]) mkCondExpr scrutHTy (pat,alt) = do - altId <- Id.suffix (netlistId1 id id2identifier bndr) "sel_alt" + altId <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "sel_alt" (altExpr,altDecls) <- mkExpr False declType (NetlistId altId altTy) alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) @@ -562,6 +554,14 @@ LitPat (CharLiteral c) -> return (Just (NumLit . toInteger $ ord c), altExpr) LitPat (Int64Literal i) -> return (Just (NumLit i), altExpr) LitPat (Word64Literal w) -> return (Just (NumLit w), altExpr) +#if MIN_VERSION_base(4,16,0) + LitPat (Int8Literal i) -> return (Just (NumLit i), altExpr) + LitPat (Int16Literal i) -> return (Just (NumLit i), altExpr) + LitPat (Int32Literal i) -> return (Just (NumLit i), altExpr) + LitPat (Word8Literal w) -> return (Just (NumLit w), altExpr) + LitPat (Word16Literal w) -> return (Just (NumLit w), altExpr) + LitPat (Word32Literal w) -> return (Just (NumLit w), altExpr) +#endif LitPat (NaturalLiteral n) -> return (Just (NumLit n), altExpr) _ -> do (_,sp) <- Lens.use curCompNm @@ -575,12 +575,18 @@ _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing) _ -> scrutE - altAssign :: Identifier -> (Maybe HW.Literal,Expr) -> [Declaration] - -> ([Declaration],(Maybe HW.Literal,[Seq])) - altAssign i (m,expr) ds = + altAssign + :: Identifier + -> (Maybe HW.Literal,Expr) + -> [Declaration] + -> NetlistMonad ([Declaration],(Maybe HW.Literal,[Seq])) + altAssign i (m,expr) ds = do let (nets,rest) = partition isNet ds - assn = case expr of { Noop -> []; _ -> [SeqDecl (Assignment i expr)] } - in (nets,(m,map SeqDecl rest ++ assn)) + assn <- case expr of + Noop -> pure [] + _ -> do assn <- procAssign Blocking i expr + pure [assn] + pure (nets,(m,map SeqDecl (rest ++ assn))) where isNet NetDecl' {} = True isNet _ = False @@ -588,23 +594,26 @@ -- GHC puts default patterns in the first position, we want them in the -- last position. reorderDefault - :: [(Pat, Term)] - -> [(Pat, Term)] -reorderDefault ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)] -reorderDefault alts' = alts' + :: NonEmpty (Pat, Term) + -> NonEmpty (Pat, Term) +reorderDefault ((DefaultPat,e) :| alts') = + case alts' of + [] -> (DefaultPat,e) :| [] + x:xs -> x :| (xs <> [(DefaultPat,e)]) +reorderDefault alts' = alts' reorderCustom :: TyConMap -> CustomReprs -> Type - -> [(Pat, Term)] - -> [(Pat, Term)] + -> NonEmpty (Pat, Term) + -> NonEmpty (Pat, Term) reorderCustom tcm reprs (coreView1 tcm -> Just ty) alts = reorderCustom tcm reprs ty alts reorderCustom _tcm reprs (coreToType' -> Right typeName) alts = case getDataRepr typeName reprs of Just (DataRepr' _name _size _constrReprs) -> - sortOn (patPos reprs . fst) alts + NE.sortOn (patPos reprs . fst) alts Nothing -> alts reorderCustom _tcm _reprs _type alts = @@ -691,14 +700,13 @@ -- pure (expandTopEntityOrErr is (zip argIds argTys) (resId, resTy) topAnnM) -- Generate ExpandedTopEntity, see TODO^ - is <- Lens.use seenIds argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc) . inferCoreTypeOf tcm) args resTy <- unsafeCoreTypeToHWTypeM $(curLoc) fResTy let ettArgs = (Nothing,) <$> argTys ettRes = (Nothing, resTy) - expandedTopEntity = - expandTopEntityOrErr is ettArgs ettRes (topAnnotation topEntity) + expandedTopEntity <- + expandTopEntityOrErrM ettArgs ettRes (topAnnotation topEntity) instDecls <- mkTopUnWrapper @@ -744,6 +752,7 @@ instLabel3 <- Id.makeBasic instLabel2 let portMap = NamedPortMap (outpAssign ++ inpAssigns) instDecl = InstDecl Entity Nothing [] compName instLabel3 [] portMap + declareInstUses outpAssign return (argDecls ++ argDecls' ++ tickDecls ++ [instDecl]) else let @@ -769,9 +778,10 @@ |] _ -> case args of - [] -> + [] -> do -- TODO: Figure out what to do with zero-width constructs - return [Assignment dstId (Identifier (id2identifier fun) Nothing)] + assn <- contAssign dstId (Identifier (Id.unsafeFromCoreId fun) Nothing) + pure [assn] _ -> error [I.i| Netlist generation encountered a local function. This should not happen. Function: @@ -802,9 +812,8 @@ toSimpleVar dstId (e,ty) = do argNm <- Id.suffix dstId "fun_arg" hTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty - let argDecl = NetDecl Nothing argNm hTy - argAssn = Assignment argNm e - return (Identifier argNm Nothing,[argDecl,argAssn]) + argDecl <- mkInit Concurrent Cont argNm hTy e + return (Identifier argNm Nothing, argDecl) -- | Generate an expression for a term occurring on the RHS of a let-binder mkExpr :: HasCallStack @@ -822,6 +831,14 @@ WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, []) Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, []) Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, []) +#if MIN_VERSION_ghc(8,8,0) + Int8Literal i -> return (HW.Literal (Just (Signed 8,8)) $ NumLit i, []) + Int16Literal i -> return (HW.Literal (Just (Signed 16,16)) $ NumLit i, []) + Int32Literal i -> return (HW.Literal (Just (Signed 32,32)) $ NumLit i, []) + Word8Literal w -> return (HW.Literal (Just (Unsigned 8,8)) $ NumLit w, []) + Word16Literal w -> return (HW.Literal (Just (Unsigned 16,16)) $ NumLit w, []) + Word32Literal w -> return (HW.Literal (Just (Unsigned 32,32)) $ NumLit w, []) +#endif CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, []) FloatLiteral w -> return (HW.Literal (Just (BitVector 32,32)) (NumLit $ toInteger w), []) DoubleLiteral w -> return (HW.Literal (Just (BitVector 64,64)) (NumLit $ toInteger w), []) @@ -843,45 +860,40 @@ hwTy:_ -> hwTy _ -> error ("internal error: unable to extract sufficient hwTys from: " <> show bndr) case appF of - Data dc -> mkDcApplication hwTys bndr dc tmArgs - Prim pInfo -> mkPrimitive False bbEasD bndr pInfo args tickDecls + Data dc -> mkDcApplication declType hwTys bndr dc tmArgs + Prim pInfo -> mkPrimitive False bbEasD declType bndr pInfo args tickDecls Var f | null tmArgs -> if isVoid hwTyA then return (Noop, []) - else - return (Identifier (id2identifier f) Nothing, []) + else do + return (Identifier (Id.unsafeFromCoreId f) Nothing, []) | not (null tyArgs) -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: " ++ "Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) | otherwise -> do - argNm <- Id.suffix (netlistId1 id id2identifier bndr) "fun_arg" + argNm <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "fun_arg" decls <- mkFunApp argNm f tmArgs tickDecls if isVoid hwTyA then return (Noop, decls) else + -- This net was already declared in the call to mkSelection. return ( Identifier argNm Nothing - , NetDecl' Nothing Wire argNm (Right hwTyA) Nothing:decls) + , NetDecl Nothing argNm hwTyA : decls) Case scrut ty' [alt] -> mkProjection bbEasD bndr scrut ty' alt - Case scrut tyA alts -> do - tcm <- Lens.view tcCache - let scrutTy = inferCoreTypeOf tcm scrut - scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy - ite <- Lens.use backEndITE - let wr = case iteAlts scrutHTy alts of - Just _ | ite -> Wire - _ -> Reg - argNm <- Id.suffix (netlistId1 id id2identifier bndr) "sel_arg" + Case scrut tyA (alt:alts) -> do + argNm <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "sel_arg" decls <- mkSelection declType (NetlistId argNm (netlistTypes1 bndr)) - scrut tyA alts tickDecls + scrut tyA (alt :| alts) tickDecls if isVoid hwTyA then return (Noop, decls) else + -- This net was already declared in the call to mkSelection return ( Identifier argNm Nothing - , NetDecl' Nothing wr argNm (Right hwTyA) Nothing:decls) + , NetDecl' Nothing argNm hwTyA Nothing:decls) Letrec binders body -> do netDecls <- concatMapM mkNetDecl binders - decls <- concatMapM (uncurry mkDeclarations) binders + decls <- concatMapM (uncurry (mkDeclarations' declType)) binders (bodyE,bodyDecls) <- mkExpr bbEasD declType bndr (mkApps (mkTicks body ticks) args) return (bodyE,netDecls ++ decls ++ bodyDecls) _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: application of a Lambda-expression\n\n" ++ showPpr app) Nothing) @@ -917,7 +929,7 @@ scrutNm <- netlistId1 Id.next - (\b -> Id.suffix (id2identifier b) "projection") + (\b -> Id.suffix (Id.unsafeFromCoreId b) "projection") bndr (scrutExpr,newDecls) <- mkExpr False Concurrent (NetlistId scrutNm scrutTy) scrut case scrutExpr of @@ -930,14 +942,13 @@ -- TODO: seems useless? pure (Left newDecls) _ -> do - let scrutDecl = NetDecl Nothing scrutNm sHwTy - scrutAssn = Assignment scrutNm scrutExpr - pure (Right (scrutNm, Nothing, newDecls ++ [scrutDecl, scrutAssn])) + scrutDecl <- mkInit Concurrent Cont scrutNm sHwTy scrutExpr + pure (Right (scrutNm, Nothing, newDecls ++ scrutDecl)) case scrutRendered of Left newDecls -> pure (Noop, newDecls) Right (selId, modM, decls) -> do - let altVarId = id2identifier varTm + let altVarId = Id.unsafeFromCoreId varTm modifier <- case pat of DataPat dc exts tms -> do let @@ -968,9 +979,8 @@ case bndr of NetlistId scrutNm _ | mkDec -> do scrutNm' <- Id.next scrutNm - let scrutDecl = NetDecl Nothing scrutNm' vHwTy - scrutAssn = Assignment scrutNm' extractExpr - return (Identifier scrutNm' Nothing,scrutDecl:scrutAssn:decls) + scrutDecl <- mkInit Concurrent Cont scrutNm' vHwTy extractExpr + return (Identifier scrutNm' Nothing, scrutDecl ++ decls) MultiId {} -> error "mkProjection: MultiId" _ -> return (extractExpr,decls) where @@ -981,7 +991,8 @@ -- | Generate an expression for a DataCon application occurring on the RHS of a let-binder mkDcApplication :: HasCallStack - => [HWType] + => DeclarationType + -> [HWType] -- ^ HWType of the LHS of the let-binder, can multiple types when we're -- creating a "split" product type (e.g. a tuple of a Clock and Reset) -> NetlistId @@ -992,15 +1003,15 @@ -- ^ DataCon Arguments -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations -mkDcApplication [dstHType] bndr dc args = do +mkDcApplication declType [dstHType] bndr dc args = do let dcNm = nameOcc (dcName dc) tcm <- Lens.view tcCache let argTys = map (inferCoreTypeOf tcm) args - argNm <- netlistId1 return (\b -> Id.suffix (id2identifier b) "_dc_arg") bndr + argNm <- netlistId1 return (\b -> Id.suffix (Id.unsafeFromCoreId b) "_dc_arg") bndr argHWTys <- mapM coreTypeToHWTypeM' argTys (argExprs, concat -> argDecls) <- unzip <$> - mapM (\(e,t) -> mkExpr False Concurrent (NetlistId argNm t) e) (zip args argTys) + mapM (\(e,t) -> mkExpr False declType (NetlistId argNm t) e) (zip args argTys) -- Filter void arguments, but make sure to render their declarations: let @@ -1127,7 +1138,7 @@ error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) -- Handle MultiId assignment -mkDcApplication dstHTypes (MultiId argNms) _ args = do +mkDcApplication declType dstHTypes (MultiId argNms) _ args = do tcm <- Lens.view tcCache let argTys = map (inferCoreTypeOf tcm) args argHWTys <- mapM coreTypeToHWTypeM' argTys @@ -1137,18 +1148,20 @@ (_hWTysFiltered,argsFiltered) = unzip (filter (maybe True (not . isVoid) . fst) argsBundled) (argExprs,argDecls) <- fmap (second concat . unzip) $! - mapM (uncurry (mkExpr False Concurrent)) argsFiltered + mapM (uncurry (mkExpr False declType)) argsFiltered if length dstHTypes == length argExprs then do - let assns = mapMaybe - (\case (_,Noop) -> Nothing - (dstId,e) -> let nm = netlistId1 id id2identifier dstId - in case e of + assns <- mapMaybeM + (\case (_,Noop) -> pure Nothing + (dstId,e) -> let nm = netlistId1 id Id.unsafeFromCoreId dstId + in case e of Identifier nm0 Nothing - | nm == nm0 -> Nothing - _ -> Just (Assignment nm e)) + | nm == nm0 -> pure Nothing + _ -> Just <$> case declType of + Concurrent -> contAssign nm e + Sequential -> procAssign Blocking nm e) (zipEqual (map CoreId argNms) argExprs) return (Noop,argDecls ++ assns) else error "internal error" -mkDcApplication _ _ _ _ = error "internal error" +mkDcApplication _ _ _ _ _ = error "internal error" diff --git a/src/Clash/Netlist.hs-boot b/src/Clash/Netlist.hs-boot --- a/src/Clash/Netlist.hs-boot +++ b/src/Clash/Netlist.hs-boot @@ -1,7 +1,8 @@ {-| Copyright : (C) 2015-2016, University of Twente + 2022 , Google Inc. License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij + Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} @@ -17,6 +18,8 @@ ,mkFunApp ) where +import Data.List.NonEmpty (NonEmpty) + import Clash.Core.DataCon (DataCon) import Clash.Core.Term (Alt,LetBinding,Term) import Clash.Core.Type (Type) @@ -39,7 +42,8 @@ -> NetlistMonad (Expr,[Declaration]) mkDcApplication :: HasCallStack - => [HWType] + => DeclarationType + -> [HWType] -> NetlistId -> DataCon -> [Term] @@ -58,7 +62,7 @@ -> NetlistId -> Term -> Type - -> [Alt] + -> NonEmpty Alt -> [Declaration] -> NetlistMonad [Declaration] diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -3,7 +3,8 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -30,8 +31,10 @@ import Data.Bifunctor (first, second) import Data.Char (ord) import Data.Either (lefts, partitionEithers) +import Data.Foldable (for_) import qualified Data.HashMap.Lazy as HashMap import qualified Data.IntMap as IntMap +import Data.List.NonEmpty (NonEmpty (..)) import Data.List (elemIndex, partition) import Data.List.Extra (countEq, mapAccumLM) import Data.Maybe (listToMaybe, fromJust, fromMaybe) @@ -50,7 +53,9 @@ , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid)) import System.IO (hPutStrLn, stderr, hFlush, hIsTerminalDevice) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,4,0) +import GHC.Data.Bool (OverridingBool(..)) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Utils.Misc (OverridingBool(..)) #else import Util (OverridingBool(..)) @@ -59,7 +64,7 @@ import Clash.Annotations.Primitive ( PrimitiveGuard(HasBlackBox, DontTranslate) , PrimitiveWarning(WarnNonSynthesizable, WarnAlways) - , extractPrim) + , extractPrim, HDL(VHDL)) import Clash.Core.DataCon as D (dcTag) import Clash.Core.FreeVars (freeIds) import Clash.Core.HasType @@ -79,13 +84,14 @@ import Clash.Core.Util (inverseTopSortLetBindings, splitShouldSplit) import Clash.Core.Var as V - (Id, Var (..), mkLocalId, modifyVarName) + (Id, mkLocalId, modifyVarName, varType) import Clash.Core.VarEnv (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet) import {-# SOURCE #-} Clash.Netlist (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl, mkProjection, mkSelection, mkFunApp, mkDeclarations') import qualified Clash.Backend as Backend +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (debugIsOn) import Clash.Driver.Types (ClashOpts(opt_primWarn, opt_color, opt_werror)) @@ -97,7 +103,6 @@ import Clash.Primitives.Types as P import qualified Clash.Primitives.Util as P import Clash.Signal.Internal (ActiveEdge (..)) -import Clash.Unique (lookupUniqMap') import Clash.Util import qualified Clash.Util.Interpolate as I @@ -140,7 +145,7 @@ mkBlackBoxContext bbName resIds args@(lefts -> termArgs) = do -- Make context inputs let - resNms = map id2identifier resIds + resNms = fmap Id.unsafeFromCoreId resIds resNm = fromMaybe (error "mkBlackBoxContext: head") (listToMaybe resNms) resTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc) . coreTypeOf) resIds (imps,impDecls) <- unzip <$> zipWithM (mkArgument bbName resNm) [0..] termArgs @@ -182,7 +187,7 @@ curBBlvl Lens.+= 1 (fs,ds) <- case resIds of - (resId:_) -> unzip <$> replicateM funcPlurality (mkFunInput resId arg) + (resId:_) -> unzip <$> replicateM funcPlurality (mkFunInput bbName resId arg) _ -> error "internal error: insufficient resIds" curBBlvl Lens.-= 1 @@ -204,6 +209,7 @@ (fmap (first BBTemplate) . setSym bbCtx) (\bbName bbHash bbFunc -> pure (BBFunction bbName bbHash bbFunc, [])) templ + for_ decls goDecl return (t2,decls) Just err0 -> do (_,sp) <- Lens.use curCompNm @@ -211,7 +217,44 @@ , Data.Text.unpack (bbName bbCtx), ". Verification " , "procedure reported:\n\n" ++ err0 ] throw (ClashException sp ($(curLoc) ++ err1) Nothing) + where + -- Right now we assume that (1) a blackbox doesn't assign to a signal + -- declared outside the black box template and (2) all uses of a signal + -- within a blackbox are correct for the targeted HDL (i.e. we don't try + -- to generate new signals when a signal is used incorrectly). + goDecl = \case + Assignment i u _ -> + declareUse u i + CondAssignment i _ _ _ _ -> do + -- Currently, all CondAssignment get rendered as `always @*` blocks in + -- (System)Verilog. This means when we target these HDL, this is _really_ + -- a blocking procedural assignment. + SomeBackend b <- Lens.use backend + let use = case Backend.hdlKind b of { VHDL -> Cont ; _ -> Proc Blocking } + declareUse use i + + Seq seqs -> for_ seqs goSeq + + _ -> pure () + + goSeq = \case + AlwaysClocked _ _ seqs -> + for_ seqs goSeq + + Initial seqs -> + for_ seqs goSeq + + AlwaysComb seqs -> + for_ seqs goSeq + + SeqDecl conc -> + goDecl conc + + Branch _ _ alts -> + let seqs = concatMap snd alts + in for_ seqs goSeq + -- | Determine if a term represents a literal isLiteral :: Term -> Bool isLiteral e = case collectArgs e of @@ -246,8 +289,8 @@ | otherwise -> return ((error ($(curLoc) ++ "Forced to evaluate untranslatable type: " ++ eTyMsg), Void Nothing, False), []) Just hwTy -> case collectArgsTicks e of - (C.Var v,[],_) -> - return ((Identifier (id2identifier v) Nothing,hwTy,False),[]) + (C.Var v,[],_) -> do + return ((Identifier (Id.unsafeFromCoreId v) Nothing,hwTy,False),[]) (C.Literal (IntegerLiteral i),[],_) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) (C.Literal (IntLiteral i), [],_) -> @@ -262,15 +305,29 @@ return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[]) (C.Literal (Word64Literal i), [],_) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) +#if MIN_VERSION_base(4,16,0) + (C.Literal (Int8Literal i), [],_) -> + return ((N.Literal (Just (Signed 8,8)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Int16Literal i), [],_) -> + return ((N.Literal (Just (Signed 16,16)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Int32Literal i), [],_) -> + return ((N.Literal (Just (Signed 16,16)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Word8Literal i), [],_) -> + return ((N.Literal (Just (Unsigned 8,8)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Word16Literal i), [],_) -> + return ((N.Literal (Just (Unsigned 16,16)) (N.NumLit i),hwTy,True),[]) + (C.Literal (Word32Literal i), [],_) -> + return ((N.Literal (Just (Unsigned 32,32)) (N.NumLit i),hwTy,True),[]) +#endif (C.Literal (NaturalLiteral n), [],_) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit n),hwTy,True),[]) (Prim pinfo,args,ticks) -> withTicks ticks $ \tickDecls -> do - (e',d) <- mkPrimitive True False (NetlistId bndr ty) pinfo args tickDecls + (e',d) <- mkPrimitive True False Concurrent (NetlistId bndr ty) pinfo args tickDecls case e' of (Identifier _ _) -> return ((e',hwTy,False), d) _ -> return ((e',hwTy,isLiteral e), d) (Data dc, args,_) -> do - (exprN,dcDecls) <- mkDcApplication [hwTy] (NetlistId bndr ty) dc (lefts args) + (exprN,dcDecls) <- mkDcApplication Concurrent [hwTy] (NetlistId bndr ty) dc (lefts args) return ((exprN,hwTy,isLiteral e),dcDecls) (Case scrut ty' [alt],[],_) -> do (projection,decls) <- mkProjection False (NetlistId bndr ty) scrut ty' alt @@ -356,6 +413,8 @@ -- ^ Put BlackBox expression in parenthesis -> Bool -- ^ Treat BlackBox expression as declaration + -> DeclarationType + -- ^ Are we concurrent or sequential? -> NetlistId -- ^ Id to assign the result to -> PrimInfo @@ -365,7 +424,7 @@ -> [Declaration] -- ^ Tick declarations -> NetlistMonad (Expr,[Declaration]) -mkPrimitive bbEParen bbEasD dst pInfo args tickDecls = +mkPrimitive bbEParen bbEasD declType dst pInfo args tickDecls = go =<< extractPrimWarnOrFail (primName pInfo) where tys = netlistTypes dst @@ -391,7 +450,7 @@ -- Blackbox template generation successful. Rerun 'go', but this time -- around with a 'normal' @BlackBox@ go (P.BlackBox - bbName wf bbRenderVoid multiResult bbKind () bbOutputReg + bbName wf bbRenderVoid multiResult bbKind () bbOutputUsage bbLibrary bbImports bbFunctionPlurality bbIncludes bbResultNames bbResultInits bbTemplate) -- See 'setupMultiResultPrim' in "Clash.Normalize.Transformations": @@ -407,7 +466,7 @@ (templ, templDecl) <- prepareBlackBox name template bbCtx let bbDecl = N.BlackBoxD name (libraries p) (imports p) (includes p) templ bbCtx return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) - p@P.BlackBox {template, name=pNm, kind} -> + p@(P.BlackBox {template, name=pNm, kind,outputUsage}) -> case kind of TDecl -> do resM <- resBndr1 True dst @@ -417,6 +476,7 @@ (templ,templDecl) <- prepareBlackBox pNm template bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx + declareUse outputUsage dstNm return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) -- Render declarations as a Noop when requested @@ -437,12 +497,12 @@ resM <- resBndr1 True dst case resM of Just (dst',dstNm,dstDecl) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst'] args + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst'] args (bbTempl,templDecl) <- prepareBlackBox pNm template bbCtx - let tmpAssgn = Assignment dstNm - (BlackBoxE pNm (libraries p) (imports p) - (includes p) bbTempl bbCtx - bbEParen) + let bbE = BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen + tmpAssgn <- case declType of + Concurrent -> contAssign dstNm bbE + Sequential -> procAssign Blocking dstNm bbE return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn]) -- Render expression as a Noop when requested @@ -494,9 +554,9 @@ case args of [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do tcm <- Lens.view tcCache - let dcs = tyConDataCons (tcm `lookupUniqMap'` tcN) + let dcs = tyConDataCons (UniqMap.find tcN tcm) dc = dcs !! fromInteger i - (exprN,dcDecls) <- mkDcApplication [hwTy] dst dc [] + (exprN,dcDecls) <- mkDcApplication declType [hwTy] dst dc [] return (exprN,dcDecls) [Right _, Left scrut] -> do tcm <- Lens.view tcCache @@ -508,9 +568,9 @@ _ -> do scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy tmpRhs <- Id.make "c$tte_rhs" - let netDeclRhs = NetDecl Nothing tmpRhs scrutHTy - netAssignRhs = Assignment tmpRhs scrutExpr - return (DataTag hwTy (Left tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) + let assignTy = case declType of { Concurrent -> Cont ; Sequential -> Proc Blocking } + netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr + return (DataTag hwTy (Left tmpRhs), netDecl ++ scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showPpr showPpr) args) | pNm == "GHC.Prim.dataToTag#" -> case args of [Right _,Left (Data dc)] -> do @@ -526,9 +586,9 @@ Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls) _ -> do tmpRhs <- Id.make "c$dtt_rhs" - let netDeclRhs = NetDecl Nothing tmpRhs scrutHTy - netAssignRhs = Assignment tmpRhs scrutExpr - return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) + let assignTy = case declType of { Concurrent -> Cont ; Sequential -> Proc Blocking } + netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr + return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls) _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args) | pNm == "Clash.Explicit.SimIO.mealyIO" -> do @@ -548,9 +608,10 @@ Noop -> return (Noop,decls) _ -> case dstNms of - [dstNm] -> + [dstNm] -> do + declareUse (Proc Blocking) dstNm return ( Identifier dstNm Nothing - , dstDecl ++ decls ++ [Assignment dstNm expr]) + , dstDecl ++ decls ++ [Assignment dstNm (Proc Blocking) expr]) _ -> error $ $(curLoc) ++ "bindSimIO: " ++ show resM _ -> return (Noop,decls) @@ -561,26 +622,32 @@ | pNm == "Clash.Explicit.SimIO.fmapSimIO#" -> do resM <- resBndr1 True dst case resM of - Just (_,dstNm,dstDecl) -> do - tcm <- Lens.view tcCache - let (fun0:arg0:_) = lefts args - arg1 = unSimIO tcm arg0 - fun1 = case fun0 of - Lam b bE -> - let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet fun0) - subst = extendIdSubst (mkSubst is0) b arg1 - in substTm "mkPrimitive.fmapSimIO" subst bE - _ -> mkApps fun0 [Left arg1] - (expr,bindDecls) <- mkExpr False Sequential dst fun1 - let assn = case expr of - Noop -> [] - _ -> [Assignment dstNm expr] - return (Identifier dstNm Nothing, dstDecl ++ bindDecls ++ assn) - Nothing -> do - let (_:arg0:_) = lefts args - (_,bindDecls) <- mkExpr True Sequential dst arg0 - return (Noop, bindDecls) + Just (_,dstNm,dstDecl) -> case lefts args of + (fun0:arg0:_) -> do + tcm <- Lens.view tcCache + let arg1 = unSimIO tcm arg0 + fun1 = case fun0 of + Lam b bE -> + let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet fun0) + subst = extendIdSubst (mkSubst is0) b arg1 + in substTm "mkPrimitive.fmapSimIO" subst bE + _ -> mkApps fun0 [Left arg1] + (expr,bindDecls) <- mkExpr False Sequential dst fun1 + assn <- case expr of + Noop -> pure [] + _ -> do declareUse (Proc Blocking) dstNm + pure [Assignment dstNm (Proc Blocking) expr] + return (Identifier dstNm Nothing, dstDecl ++ bindDecls ++ assn) + args1 -> error ("internal error: fmapSimIO# has insufficient arguments" + <> showPpr args1) + Nothing -> case lefts args of + (_:arg0:_) -> do + (_,bindDecls) <- mkExpr True Sequential dst arg0 + return (Noop, bindDecls) + args1 -> error ("internal error: fmapSimIO# has insufficient arguments" + <> showPpr args1) + | pNm == "Clash.Explicit.SimIO.unSimIO#" -> case lefts args of (arg:_) -> mkExpr False Sequential dst arg @@ -596,9 +663,10 @@ Noop -> return (Noop,decls) _ -> case dstNms of - [dstNm] -> + [dstNm] -> do + declareUse (Proc Blocking) dstNm return ( Identifier dstNm Nothing - , dstDecl ++ decls ++ [Assignment dstNm expr]) + , dstDecl ++ decls ++ [Assignment dstNm (Proc Blocking) expr]) _ -> error "internal error" _ -> return (Noop,decls) @@ -683,17 +751,18 @@ pure Nothing else case dst' of - NetlistId dstL _ -> case mkDec of + NetlistId dstL ty' -> case mkDec of False -> do -- TODO: check that it's okay to use `mkUnsafeSystemName` let nm' = mkUnsafeSystemName (Id.toText dstL) 0 - id_ = mkLocalId ty nm' + id_ = mkLocalId ty' nm' return (Just ([id_],[dstL],[])) True -> do nm2 <- Id.suffix dstL "res" -- TODO: check that it's okay to use `mkUnsafeInternalName` let nm3 = mkUnsafeSystemName (Id.toText nm2) 0 id_ = mkLocalId ty nm3 + idDeclM <- mkNetDecl (id_, mkApps (Prim pInfo) args) case idDeclM of [] -> return Nothing @@ -706,10 +775,11 @@ Multi primitive should only appear on the RHS of a let-binding. Please report this as a bug. |] + CoreId dstR -> - return (Just ([dstR], [Id.unsafeMake . nameOcc . varName $ dstR], [])) + return (Just ([dstR], [Id.unsafeFromCoreId dstR], [])) MultiId ids -> - return (Just (ids, map (Id.unsafeMake . nameOcc . varName) ids, [])) + return (Just (ids, map Id.unsafeFromCoreId ids, [])) -- Like resBndr, but fails on MultiId resBndr1 @@ -741,15 +811,16 @@ Lens.foldMapOf freeIds unitVarSet mealyIn) -- Given that we're creating a sequential list of statements from the -- let-bindings, make sure that everything is inverse topologically sorted - (bs,res) = case inverseTopSortLetBindings res0 of - Letrec bsN (C.Var resN) -> (bsN,resN) - Letrec bsN e -> - let u = case dst of - CoreId u0 -> u0 - _ -> uniqAway is0 - (mkLocalId (inferCoreTypeOf tcm e) - (mkUnsafeSystemName "mealyres" 0)) - in (bsN ++ [(u,e)], u) + (bs,res) = case res0 of + Letrec bsU e | let bsN = inverseTopSortLetBindings bsU -> case e of + C.Var resN -> (bsN,resN) + _ -> + let u = case dst of + CoreId u0 -> u0 + _ -> uniqAway is0 + (mkLocalId (inferCoreTypeOf tcm e) + (mkUnsafeSystemName "mealyres" 0)) + in (bsN ++ [(u,e)], u) e -> let u = case dst of CoreId u0 -> u0 @@ -814,37 +885,49 @@ Letrec _ (C.Var {}) -> mkExpr False Concurrent dst (C.Var result) _ -> case dst of CoreId {} -> pure (Noop,[]) - _ -> mkExpr False Concurrent dst (C.Var result) - let resAssn = case resExpr of - Noop -> [] - _ -> [Seq [AlwaysComb [SeqDecl (Assignment dstNm resExpr)]]] + _ -> mkExpr False Sequential dst (C.Var result) + resAssn <- case resExpr of + Noop -> pure [] + _ -> do + assign <- SeqDecl <$> procAssign Blocking dstNm resExpr + pure [Seq [AlwaysComb [assign]]] + -- Create the declarations for the "initial state" block let sDst = case sBinders of [] -> error "internal error: insufficient sBinders" [(b,_)] -> CoreId b _ -> MultiId (map fst sBinders) + (exprInit,initDecls) <- mkExpr False Sequential sDst mealyInit - let initAssign = case exprInit of - Identifier _ Nothing -> [] - Noop -> [] - _ -> case sBinders of - ((b,_):_) -> [Assignment (id2identifier b) exprInit] - _ -> error "internal error: insufficient sBinders" + initAssign <- case exprInit of + Identifier _ Nothing -> pure [] + Noop -> pure [] + _ -> case sBinders of + ((b,_):_) -> do assn <- procAssign Blocking (Id.unsafeFromCoreId b) exprInit + pure [assn] + _ -> error "internal error: insufficient sBinders" + -- Create the declarations that corresponding to the input let iDst = case iBinders of [] -> error "internal error: insufficient iBinders" [(b,_)] -> CoreId b _ -> MultiId (map fst iBinders) + (exprArg,inpDeclsMisc) <- mkExpr False Concurrent iDst mealyIn + argAssign <- case iBinders of + ((i,_):_) -> do assn <- contAssign (Id.unsafeFromCoreId i) exprArg + pure [assn] + _ -> error "internal error: insufficient iBinders" + -- Split netdecl declarations and other declarations let (netDeclsSeqMisc,seqDeclsOther) = partition isNet (seqDecls ++ resDecls) (netDeclsInit,initDeclsOther) = partition isNet initDecls -- All assignments happens within a sequential block, so the nets need to -- be of type 'reg' in Verilog nomenclature - let netDeclsSeq1 = map toReg (netDeclsSeq ++ netDeclsSeqMisc ++ netDeclsInit) + let netDeclsSeq1 = netDeclsSeq ++ netDeclsSeqMisc ++ netDeclsInit -- We run mealy block in the opposite clock edge of the the ambient system -- because we're basically clocked logic; so we need to have our outputs @@ -862,11 +945,8 @@ let netDeclsInp1 = netDeclsInp ++ inpDeclsMisc -- Collate everything - return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ - [ case iBinders of - ((i,_):_) -> Assignment (id2identifier i) exprArg - _ -> error "internal error: insufficient iBinders" - , Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))] + return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ argAssign ++ + [ Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))] , Seq [AlwaysClocked edge clkExpr (map SeqDecl seqDeclsOther)] ] ++ resAssn) _ -> error "internal error" @@ -874,9 +954,6 @@ isNet NetDecl' {} = True isNet _ = False - toReg (NetDecl' cmM _ r ty eM) = NetDecl' cmM Reg r ty eM - toReg d = d - collectMealy _ _ _ _ = error "internal error" -- | Collect the sequential declarations for 'bindIO' @@ -891,14 +968,14 @@ let qS = substTm "collectBindIO1" subst q case splitNormalized tcm qS of Right (args,bs0,res) -> do - let Letrec bs _ = inverseTopSortLetBindings (Letrec bs0 (C.Var res)) + let bs = inverseTopSortLetBindings bs0 let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet qS) normE <- mkUniqueNormalized is0 Nothing (args,bs,res) case normE of (_,_,[],_,[],binders,Just result) -> do ds1 <- concatMapM (uncurry (mkDeclarations' Sequential)) binders netDecls <- concatMapM mkNetDecl binders - return (Identifier (id2identifier result) Nothing, netDecls ++ ds0 ++ ds1) + return (Identifier (Id.unsafeFromCoreId result) Nothing, netDecls ++ ds0 ++ ds1) _ -> error "internal error" _ -> case substTm "collectBindIO2" subst e of Letrec {} -> error "internal error" @@ -912,12 +989,12 @@ where collectAction tcm = case splitNormalized tcm m of Right (args,bs0,res) -> do - let Letrec bs _ = inverseTopSortLetBindings (Letrec bs0 (C.Var res)) + let bs = inverseTopSortLetBindings bs0 let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet m) normE <- mkUniqueNormalized is0 Nothing (args,(x,m):bs,res) case normE of (_,_,[],_,[],binders@(b:_),Just result) -> do - let binders1 = tail binders ++ [(fst b, C.Var result)] + let binders1 = drop 1 binders ++ [(fst b, C.Var result)] ds1 <- concatMapM (uncurry (mkDeclarations' Sequential)) binders1 netDecls <- concatMapM mkNetDecl binders return (netDecls ++ ds1,extendIdSubst (mkSubst eInScopeSet) x (Var (fst b))) @@ -973,20 +1050,23 @@ -- a function mkFunInput :: HasCallStack - => Id + => TextS.Text + -- ^ Name of the primitive of which the function in question is an argument. + -- Used for error reporting. + -> Id -- ^ Identifier binding the encompassing primitive/blackbox application. Used -- as a name hint if 'mkFunInput' needs intermediate signals. -> Term -- ^ The function argument term -> NetlistMonad ((Either BlackBox (Identifier,[Declaration]) - ,WireOrReg + ,Usage ,[BlackBoxTemplate] ,[BlackBoxTemplate] ,[((TextS.Text,TextS.Text),BlackBox)] ,BlackBoxContext) ,[Declaration]) -mkFunInput resId e = +mkFunInput parentName resId e = let (appE,args,ticks) = collectArgsTicks e in withTicks ticks $ \tickDecls -> do tcm <- Lens.view tcCache @@ -997,7 +1077,7 @@ bb <- extractPrimWarnOrFail (primName p) case bb of P.BlackBox {..} -> - pure (Left (kind,outputReg,libraries,imports,includes,primName p,template)) + pure (Left (kind,outputUsage,libraries,imports,includes,primName p,template)) P.Primitive pn _ pt -> error $ $(curLoc) ++ "Unexpected blackbox type: " ++ "Primitive " ++ show pn @@ -1023,7 +1103,7 @@ ++ err Right (BlackBoxMeta{..}, template) -> pure $ - Left ( bbKind, bbOutputReg, bbLibrary, bbImports + Left ( bbKind, bbOutputUsage, bbLibrary, bbImports , bbIncludes, pName, template) Data dc -> do let eTy = inferCoreTypeOf tcm e @@ -1038,8 +1118,8 @@ Just (_resHTy, [areVoids@(countEq False -> 1)]) -> do let nonVoidArgI = fromJust (elemIndex False areVoids) let arg = Id.unsafeMake (TextS.concat ["~ARG[", showt nonVoidArgI, "]"]) - let assign = Assignment (Id.unsafeMake "~RESULT") (Identifier arg Nothing) - return (Right ((Id.unsafeMake "", tickDecls ++ [assign]), Wire)) + let assign = Assignment (Id.unsafeMake "~RESULT") Cont (Identifier arg Nothing) + return (Right ((Id.unsafeMake "", tickDecls ++ [assign]), Cont)) -- Because we filter void constructs, the argument indices and -- the field indices don't necessarily correspond anymore. We @@ -1053,8 +1133,8 @@ mkArg i = Id.unsafeMake ("~ARG[" <> showt i <> "]") dcInps = [Identifier (mkArg x) Nothing | x <- originalIndices areVoids1] dcApp = DataCon resHTy (DC (resHTy,dcI)) dcInps - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- CustomSP the same as SP, but with a user-defined bit -- level representation @@ -1065,16 +1145,16 @@ mkArg i = Id.unsafeMake ("~ARG[" <> showt i <> "]") dcInps = [Identifier (mkArg x) Nothing | x <- originalIndices areVoids1] dcApp = DataCon resHTy (DC (resHTy,dcI)) dcInps - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- Like SP, we have to retrieve the index BEFORE filtering voids Just (resHTy@(Product _ _ _), areVoids1:_) -> do let mkArg i = Id.unsafeMake ("~ARG[" <> showt i <> "]") dcInps = [ Identifier (mkArg x) Nothing | x <- originalIndices areVoids1] dcApp = DataCon resHTy (DC (resHTy,0)) dcInps - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- Vectors never have defined areVoids (or all set to False), as -- it would be converted to Void otherwise. We can therefore @@ -1083,22 +1163,22 @@ let mkArg i = Id.unsafeMake ("~ARG[" <> showt i <> "]") dcInps = [ Identifier (mkArg x) Nothing | x <- [(1::Int)..2] ] dcApp = DataCon resHTy (DC (resHTy,1)) dcInps - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- Sum types OR a Sum type after filtering empty types: Just (resHTy@(Sum _ _), _areVoids) -> do let dcI = dcTag dc - 1 dcApp = DataCon resHTy (DC (resHTy,dcI)) [] - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- Same as Sum, but with user defined bit level representation Just (resHTy@(CustomSum {}), _areVoids) -> do let dcI = dcTag dc - 1 dcApp = DataCon resHTy (DC (resHTy,dcI)) [] - dcAss = Assignment (Id.unsafeMake "~RESULT") dcApp - return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]),Wire)) + dcAss = Assignment (Id.unsafeMake "~RESULT") Cont dcApp + return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) Just (Void {}, _areVoids) -> return (error $ $(curLoc) ++ "Encountered Void in mkFunInput." @@ -1114,7 +1194,7 @@ normalized <- Lens.use bindings case lookupVarEnv fun normalized of Just _ -> do - (meta,N.Component compName compInps [(_,compOutp,_)] _) <- + (meta,N.Component compName compInps compOutps _) <- preserveVarEnv $ genComponent fun let @@ -1123,16 +1203,32 @@ inpVar i = Id.unsafeMake ("~VAR[arg" <> showt i <> "][" <> showt i <> "]") inpVars = [Identifier (inpVar i) Nothing | i <- originalIndices cmWereVoids] inpAssigns = zipWith inpAssign compInps inpVars - outpAssign = - ( Identifier (fst compOutp) Nothing - , Out - , snd compOutp - , Identifier (Id.unsafeMake "~RESULT") Nothing ) + outpAssigns = case compOutps of + [] -> [] -- See issue #2549 + [(_,compOutp,_)] -> + [ ( Identifier (fst compOutp) Nothing + , Out + , snd compOutp + , Identifier (Id.unsafeMake "~RESULT") Nothing ) + ] + outps -> + error [I.i| + Cannot handle multi-result function as an argument to + a primitive. + + Primitive: #{parentName} + + Argument: #{showPpr fun} :: #{showPpr (varType fun)} + + Outputs: #{show (map (\(_,x,_) -> x) outps)} + + Please report this as an issue. + |] instLabel <- Id.next compName let - portMap = NamedPortMap (outpAssign:inpAssigns) + portMap = NamedPortMap (outpAssigns ++ inpAssigns) instDecl = InstDecl Entity Nothing [] compName instLabel [] portMap - return (Right ((Id.unsafeMake "",tickDecls ++ [instDecl]),Wire)) + return (Right ((Id.unsafeMake "",tickDecls ++ [instDecl]), Cont)) Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e C.Lam {} -> do let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet appE) @@ -1143,27 +1239,27 @@ _ -> "__INTERNAL__" (bbCtx,dcls) <- mkBlackBoxContext pNm [resId] args case templ of - Left (TDecl,oreg,libs,imps,inc,_,templ') -> do + Left (TDecl,outputUsage,libs,imps,inc,_,templ') -> do (l',templDecl) <- onBlackBox (fmap (first BBTemplate) . setSym bbCtx) (\bbName bbHash bbFunc -> pure $ (BBFunction bbName bbHash bbFunc, [])) templ' - return ((Left l',if oreg then Reg else Wire,libs,imps,inc,bbCtx),dcls ++ templDecl) + return ((Left l',outputUsage,libs,imps,inc,bbCtx),dcls ++ templDecl) Left (TExpr,_,libs,imps,inc,nm,templ') -> do onBlackBox (\t -> do t' <- getAp (prettyBlackBox t) let t'' = Id.unsafeMake (Text.toStrict t') - assn = Assignment (Id.unsafeMake "~RESULT") (Identifier t'' Nothing) - return ((Right (Id.unsafeMake "",[assn]),Wire,libs,imps,inc,bbCtx),dcls)) + assn = Assignment (Id.unsafeMake "~RESULT") Cont (Identifier t'' Nothing) + return ((Right (Id.unsafeMake "",[assn]),Cont,libs,imps,inc,bbCtx),dcls)) (\bbName bbHash (TemplateFunction k g _) -> do let f' bbCtx' = do - let assn = Assignment (Id.unsafeMake "~RESULT") + let assn = Assignment (Id.unsafeMake "~RESULT") Cont (BlackBoxE nm libs imps inc templ' bbCtx' False) p <- getAp (Backend.blockDecl (Id.unsafeMake "") [assn]) return p return ((Left (BBFunction bbName bbHash (TemplateFunction k g f')) - ,Wire + ,Cont ,[] ,[] ,[] @@ -1173,8 +1269,8 @@ ) ) templ' - Right (decl,wr) -> - return ((Right decl,wr,[],[],[],bbCtx),dcls) + Right (decl,u) -> + return ((Right decl,u,[],[],[],bbCtx),dcls) where goExpr app@(collectArgsTicks -> (C.Var fun,args@(_:_),ticks)) = do tcm <- Lens.view tcCache @@ -1185,10 +1281,10 @@ withTicks ticks $ \tickDecls -> do resNm <- Id.make "result" appDecls <- mkFunApp resNm fun tmArgs tickDecls - let assn = [ Assignment (Id.unsafeMake "~RESULT") (Identifier resNm Nothing) + let assn = [ Assignment (Id.unsafeMake "~RESULT") Cont (Identifier resNm Nothing) , NetDecl Nothing resNm resTy ] nm <- Id.makeBasic "block" - return (Right ((nm,assn++appDecls),Wire)) + return (Right ((nm,assn++appDecls), Cont)) else do (_,sp) <- Lens.use curCompNm throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) @@ -1196,11 +1292,11 @@ tcm <- Lens.view tcCache let eType = inferCoreTypeOf tcm e' (appExpr,appDecls) <- mkExpr False Concurrent (NetlistId (Id.unsafeMake "c$bb_res") eType) e' - let assn = Assignment (Id.unsafeMake "~RESULT") appExpr + let assn = Assignment (Id.unsafeMake "~RESULT") Cont appExpr nm <- if null appDecls then return (Id.unsafeMake "") else Id.makeBasic "block" - return (Right ((nm,appDecls ++ [assn]),Wire)) + return (Right ((nm,appDecls ++ [assn]), Cont)) go is0 n (Lam id_ e') = do lvl <- Lens.use curBBlvl @@ -1213,38 +1309,30 @@ go is1 (n+(1::Int)) e'' go _ _ (C.Var v) = do - let assn = Assignment (Id.unsafeMake "~RESULT") (Identifier (id2identifier v) Nothing) - return (Right ((Id.unsafeMake "",[assn]),Wire)) + let assn = Assignment (Id.unsafeMake "~RESULT") Cont (Identifier (Id.unsafeFromCoreId v) Nothing) + return (Right ((Id.unsafeMake "",[assn]), Cont)) go _ _ (Case scrut ty [alt]) = do tcm <- Lens.view tcCache let sTy = inferCoreTypeOf tcm scrut (projection,decls) <- mkProjection False (NetlistId (Id.unsafeMake "c$bb_res") sTy) scrut ty alt - let assn = Assignment (Id.unsafeMake "~RESULT") projection + let assn = Assignment (Id.unsafeMake "~RESULT") Cont projection nm <- if null decls then return (Id.unsafeMake "") else Id.makeBasic "projection" - return (Right ((nm,decls ++ [assn]),Wire)) - - go _ _ (Case scrut ty alts@(_:_:_)) = do - tcm <- Lens.view tcCache - let scrutTy = inferCoreTypeOf tcm scrut - scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy - ite <- Lens.use backEndITE - let wr = case iteAlts scrutHTy alts of - Just _ | ite -> Wire - _ -> Reg + return (Right ((nm,decls ++ [assn]), Cont)) + go _ _ (Case scrut ty (alt:alts@(_:_))) = do resNm <- Id.make "result" + resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty -- It's safe to use 'mkUnsafeSystemName' here: only the name, not the -- unique, will be used let resId' = NetlistId resNm ty - selectionDecls <- mkSelection Concurrent resId' scrut ty alts [] - resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty - let assn = [ NetDecl' Nothing wr resNm (Right resTy) Nothing - , Assignment (Id.unsafeMake "~RESULT") (Identifier resNm Nothing) ] + selectionDecls <- mkSelection Concurrent resId' scrut ty (alt :| alts) [] + let assn = [ NetDecl' Nothing resNm resTy Nothing + , Assignment (Id.unsafeMake "~RESULT") Cont (Identifier resNm Nothing) ] nm <- Id.makeBasic "selection" - return (Right ((nm,assn++selectionDecls),Wire)) + return (Right ((nm,assn++selectionDecls), Cont)) go is0 _ e'@(Let{}) = do tcm <- Lens.view tcCache @@ -1258,15 +1346,15 @@ netDecls <- concatMapM mkNetDecl $ binders decls <- concatMapM (uncurry mkDeclarations) binders nm <- Id.makeBasic "fun" - let resultId = id2identifier result + let resultId = Id.unsafeFromCoreId result -- TODO: Due to reasons lost in the mists of time, #1265 creates an -- assignement here, whereas it previously wouldn't. With the PR in -- tests break when reverting to the old behavior. In some cases this -- creates "useless" assignments. We should investigate whether we can -- get the old behavior back. - let resDecl = Assignment (Id.unsafeMake "~RESULT") (Identifier resultId Nothing) - return (Right ((nm,resDecl:netDecls ++ decls),Wire)) - Nothing -> return (Right ((Id.unsafeMake "",[]),Wire)) + let resDecl = Assignment (Id.unsafeMake "~RESULT") Cont (Identifier resultId Nothing) + return (Right ((nm,resDecl:netDecls ++ decls), Cont)) + Nothing -> return (Right ((Id.unsafeMake "",[]), Cont)) go is0 n (Tick _ e') = go is0 n e' diff --git a/src/Clash/Netlist/BlackBox/Parser.hs b/src/Clash/Netlist/BlackBox/Parser.hs --- a/src/Clash/Netlist/BlackBox/Parser.hs +++ b/src/Clash/Netlist/BlackBox/Parser.hs @@ -2,6 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd, 2021-2022, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -112,7 +113,9 @@ <|> IsActiveEnable <$> (string "~ISACTIVEENABLE" *> brackets' natural') <|> IsUndefined <$> (string "~ISUNDEFINED" *> brackets' natural') <|> StrCmp <$> (string "~STRCMP" *> brackets' pSigD) <*> brackets' natural' - <|> OutputWireReg <$> (string "~OUTPUTWIREREG" *> brackets' natural') + -- Parse ~OUTPUTWIREREG for backwards compatibility + <|> OutputUsage <$> (string "~OUTPUTWIREREG" *> brackets' natural') + <|> OutputUsage <$> (string "~OUTPUTUSAGE" *> brackets' natural') <|> GenSym <$> (string "~GENSYM" *> brackets' pSigD) <*> brackets' natural' <|> Template <$> (string "~TEMPLATE" *> brackets' pSigD) <*> brackets' pSigD <|> Repeat <$> (string "~REPEAT" *> brackets' pSigD) <*> brackets' pSigD diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs --- a/src/Clash/Netlist/BlackBox/Types.hs +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -3,6 +3,7 @@ 2017 , Myrtle Software Ltd, 2021-2022, QBayLogic B.V. 2022 , LUMI GUIDE FIETSDETECTIE B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -34,7 +35,7 @@ import Clash.Core.Term (Term) import Clash.Core.Type (Type) import {-# SOURCE #-} Clash.Netlist.Types - (BlackBox, NetlistMonad) + (BlackBox, NetlistMonad, Usage(Cont)) import qualified Clash.Signal.Internal as Signal @@ -52,10 +53,10 @@ | TExpr deriving (Show, Eq, Generic, NFData, Binary, Hashable) --- | See @Clash.Primitives.Types.BlackBox@ for documentation on this record's +-- | See 'Clash.Primitives.Types.BlackBox' for documentation on this record's -- fields. (They are intentionally renamed to prevent name clashes.) data BlackBoxMeta = - BlackBoxMeta { bbOutputReg :: Bool + BlackBoxMeta { bbOutputUsage :: Usage , bbKind :: TemplateKind , bbLibrary :: [BlackBoxTemplate] , bbImports :: [BlackBoxTemplate] @@ -67,9 +68,9 @@ } -- | Use this value in your blackbox template function if you do want to --- accept the defaults as documented in @Clash.Primitives.Types.BlackBox@. +-- accept the defaults as documented in 'Clash.Primitives.Types.BlackBox'. emptyBlackBoxMeta :: BlackBoxMeta -emptyBlackBoxMeta = BlackBoxMeta False TExpr [] [] [] [] NoRenderVoid [] [] +emptyBlackBoxMeta = BlackBoxMeta Cont TExpr [] [] [] [] NoRenderVoid [] [] -- | A BlackBox function generates a blackbox template, given the inputs and -- result type of the function it should provide a blackbox for. This is useful @@ -178,7 +179,8 @@ -- ^ Period of a domain. Errors if not applied to a @KnownDomain@ or -- @KnownConfiguration@. | LongestPeriod - -- ^ Longest period of all known domains + -- ^ Longest period of all known domains. The minimum duration returned is + -- 100 ns, see https://github.com/clash-lang/clash-compiler/issues/2455. | ActiveEdge !Signal.ActiveEdge !Int -- ^ Test active edge of memory elements in a certain domain. Errors if not -- applied to a @KnownDomain@ or @KnownConfiguration@. @@ -198,7 +200,7 @@ -- always return 0 (False) if `-fclash-aggressive-x-optimization-blackboxes` -- is NOT set. | StrCmp [Element] !Int - | OutputWireReg !Int + | OutputUsage !Int | Vars !Int | GenSym [Element] !Int | Repeat [Element] [Element] diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -1,8 +1,9 @@ {-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. 2022 , LUMI GUIDE FIETSDETECTIE B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -13,6 +14,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} @@ -55,7 +57,7 @@ import Text.Trifecta.Result hiding (Err) import Clash.Backend - (Backend (..), Usage (..), AggressiveXOptBB(..), RenderEnums(..)) + (Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..)) import Clash.Netlist.BlackBox.Parser import Clash.Netlist.BlackBox.Types import Clash.Netlist.Types @@ -63,7 +65,7 @@ Declaration(BlackBoxD)) import qualified Clash.Netlist.Id as Id import qualified Clash.Netlist.Types as N -import Clash.Netlist.Util (typeSize, isVoid, stripVoid) +import Clash.Netlist.Util (typeSize, isVoid, stripAttributes, stripVoid) import Clash.Signal.Internal (ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..)) import Clash.Util @@ -117,7 +119,7 @@ IsActiveEnable n -> pure n IsUndefined n -> pure n StrCmp _ n -> pure n - OutputWireReg n -> pure n + OutputUsage n -> pure n Vars n -> pure n GenSym _ _ -> Nothing Repeat _ _ -> Nothing @@ -125,7 +127,7 @@ SigD _ nM -> nM CtxName -> Nothing --- | Determine if the number of normal/literal/function inputs of a blackbox +-- | Determine if the number of normal\/literal\/function inputs of a blackbox -- context at least matches the number of argument that is expected by the -- template. verifyBlackBoxContext @@ -183,10 +185,11 @@ Just n -> case indexMaybe (bbInputs bbCtx) n of Just _ -> Nothing - Nothing -> - Just ( "Blackbox required at least " ++ show (n+1) - ++ " arguments, but only " ++ show (length (bbInputs bbCtx)) - ++ " were passed." ) + Nothing -> do + let str = fromJust (fmap Text.unpack (getAp $ prettyElem e)) + Just ( "Blackbox used \"" ++ str ++ "\"" + ++ ", but only " ++ show (length (bbInputs bbCtx)) + ++ " arguments were passed." ) extractLiterals :: BlackBoxContext -> [Expr] @@ -227,7 +230,7 @@ let decls = case typeSize hwTy of 0 -> [] _ -> [N.NetDecl Nothing nm' hwTy - ,N.Assignment nm' e' + ,N.Assignment nm' N.Cont e' -- TODO De-hardcode Cont ] _2 %= (IntMap.insert i (Id.toText nm',decls)) return (ToVar [Text (Id.toLazyText nm')] i) @@ -392,51 +395,57 @@ renderElem b (Component (Decl n subN (l:ls))) = do (o,oTy,_) <- idToExpr <$> bitraverse (lineToIdentifier b) (return . lineToType b) l is <- mapM (fmap idToExpr . bitraverse (lineToIdentifier b) (return . lineToType b)) ls + sp <- getSrcSpan let func0 = IntMap.lookup n (bbFunctions b) errr = concat [ "renderElem: not enough functions rendered? Needed " , show (subN +1 ), " got only ", show (length (fromJust func0)) ] - func1 = indexNote' errr subN <$> func0 - Just (templ0,_,libs,imps,inc,pCtx) = func1 - b' = pCtx { bbResults = [(o,oTy)], bbInputs = bbInputs pCtx ++ is } - layoutOptions = LayoutOptions (AvailablePerLine 120 0.4) - render = N.BBTemplate . parseFail . renderLazy . layoutPretty layoutOptions - - templ1 <- - case templ0 of - Left t -> - return t - Right (nm0,ds) -> do - nm1 <- Id.next nm0 - block <- getAp (blockDecl nm1 ds) - return (render block) + case indexNote' errr subN <$> func0 of + Just (templ0,_,libs,imps,inc,pCtx) -> do + let b' = pCtx { bbResults = [(o,oTy)], bbInputs = bbInputs pCtx ++ is } + layoutOptions = LayoutOptions (AvailablePerLine 120 0.4) + render = N.BBTemplate . parseFail . renderLazy . layoutPretty layoutOptions - templ4 <- - case templ1 of - N.BBFunction {} -> - return templ1 - N.BBTemplate templ2 -> do - (templ3, templDecls) <- setSym b' templ2 - case templDecls of - [] -> - return (N.BBTemplate templ3) - _ -> do - nm1 <- Id.toText <$> Id.makeBasic "bb" - nm2 <- Id.makeBasic "bb" - let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b' - block <- getAp (blockDecl nm2 (templDecls ++ [bbD])) + templ1 <- + case templ0 of + Left t -> + return t + Right (nm0,ds) -> do + nm1 <- Id.next nm0 + block <- getAp (blockDecl nm1 ds) return (render block) - case verifyBlackBoxContext b' templ4 of - Nothing -> do - bb <- renderBlackBox libs imps inc templ4 b' - return (renderLazy . layoutPretty layoutOptions . bb) - Just err0 -> do - sp <- getSrcSpan - let err1 = concat [ "Couldn't instantiate blackbox for " - , Data.Text.unpack (bbName b), ". Verification procedure " - , "reported:\n\n" ++ err0 ] - throw (ClashException sp ($(curLoc) ++ err1) Nothing) + templ4 <- + case templ1 of + N.BBFunction {} -> + return templ1 + N.BBTemplate templ2 -> do + (templ3, templDecls) <- setSym b' templ2 + case templDecls of + [] -> + return (N.BBTemplate templ3) + _ -> do + nm1 <- Id.toText <$> Id.makeBasic "bb" + nm2 <- Id.makeBasic "bb" + let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b' + block <- getAp (blockDecl nm2 (templDecls ++ [bbD])) + return (render block) + case verifyBlackBoxContext b' templ4 of + Nothing -> do + bb <- renderBlackBox libs imps inc templ4 b' + return (renderLazy . layoutPretty layoutOptions . bb) + Just err0 -> do + let err1 = concat [ "Couldn't instantiate blackbox for " + , Data.Text.unpack (bbName b), ". Verification procedure " + , "reported:\n\n" ++ err0 ] + throw (ClashException sp ($(curLoc) ++ err1) Nothing) + Nothing -> + let err1 = concat [show n + , "'th argument isn't a function, only " + , show (IntMap.keys (bbFunctions b)) + , "are."] + in throw (ClashException sp ($(curLoc) ++ err1) Nothing) + renderElem b (SigD e m) = do e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e let ty = case m of @@ -456,7 +465,9 @@ renderElem _ LongestPeriod = do doms <- domainConfigurations - let longestPeriod = maximum [vPeriod v | v <- HashMap.elems doms] + -- Longest period with a minimum of 100 ns, see: + -- https://github.com/clash-lang/clash-compiler/issues/2455 + let longestPeriod = maximum (100_000 : [vPeriod v | v <- HashMap.elems doms]) return (const (Text.pack (show longestPeriod))) renderElem b (Tag n) = do @@ -466,6 +477,8 @@ return (const (Text.pack (Data.Text.unpack dom))) Clock dom -> return (const (Text.pack (Data.Text.unpack dom))) + ClockN dom -> + return (const (Text.pack (Data.Text.unpack dom))) Reset dom -> return (const (Text.pack (Data.Text.unpack dom))) Enable dom -> @@ -480,45 +493,57 @@ syn <- hdlSyn enums <- renderEnums xOpt <- aggressiveXOptBB - let c' = check (coerce xOpt) iw hdl syn enums c + c' <- check (coerce xOpt) iw hdl syn enums c if c' > 0 then renderTemplate b t else renderTemplate b f where - check :: Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> Int + check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int check xOpt iw hdl syn enums c' = case c' of - (Size e) -> typeSize (lineToType b [e]) - (Length e) -> case lineToType b [e] of + (Size e) -> pure $ typeSize (lineToType b [e]) + (Length e) -> pure $ case lineToType b [e] of (Vector n _) -> n Void (Just (Vector n _)) -> n (MemBlob n _) -> n Void (Just (MemBlob n _)) -> n _ -> 0 -- HACK: So we can test in splitAt if one of the -- vectors in the tuple had a zero length - (Lit n) -> case bbInputs b !! n of + (Lit n) -> pure $ case bbInputs b !! n of (l,_,_) | Literal _ l' <- l -> case l' of + -- Integer, Int#, KnownNat, Natural, Word# NumLit i -> fromInteger i + -- Bit BitLit bl -> case bl of N.H -> 1 N.L -> 0 _ -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low" + -- Bool BoolLit bl -> bool 0 1 bl _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" + -- Int | DataCon (Signed _) _ [Literal _ (NumLit i)] <- l -> fromInteger i + -- Word, SNat | DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l -> fromInteger i + | BlackBoxE pNm _lib _use _incl _templ bbCtx _paren <- l + , pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#" + ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#" + ,"GHC.Types.I#","GHC.Types.W#" + ] + , [Literal _ (NumLit j)] <- extractLiterals bbCtx + -> fromInteger j k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k) - (Depth e) -> case lineToType b [e] of + (Depth e) -> pure $ case lineToType b [e] of (RTree n _) -> n _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type" - IW64 -> if iw == 64 then 1 else 0 - (HdlSyn s) -> if s == syn then 1 else 0 - (IsVar n) -> let (e,_,_) = bbInputs b !! n + IW64 -> pure $ if iw == 64 then 1 else 0 + (HdlSyn s) -> pure $ if s == syn then 1 else 0 + (IsVar n) -> pure $ let (e,_,_) = bbInputs b !! n in case e of Identifier _ Nothing -> 1 _ -> 0 - (IsLit n) -> let (e,_,_) = bbInputs b !! n + (IsLit n) -> pure $ let (e,_,_) = bbInputs b !! n in case e of DataCon {} -> 1 Literal {} -> 1 @@ -532,13 +557,13 @@ RenderEnums True -> 1 RenderEnums False -> 0 isScalar _ _ = 0 - in isScalar hdl ty + in pure $ isScalar hdl ty - (IsUndefined n) -> + (IsUndefined n) -> pure $ let (e, _, _) = bbInputs b !! n in if xOpt && checkUndefined e then 1 else 0 - (IsActiveEnable n) -> + (IsActiveEnable n) -> pure $ let (e, ty, _) = bbInputs b !! n in case ty of Enable _ -> @@ -558,54 +583,83 @@ Literal Nothing (BoolLit False) -> 1 _ -> 1 _ -> - error $ $(curLoc) ++ "IsActiveEnable: Expected Bool, not: " ++ show ty + error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty - (ActiveEdge edgeRequested n) -> - let (_, ty, _) = bbInputs b !! n in - case stripVoid ty of - KnownDomain _ _ edgeActual _ _ _ -> + (ActiveEdge edgeRequested n) -> do + let (_, ty, _) = bbInputs b !! n + domConf <- getDomainConf ty + case domConf of + VDomainConfiguration _ _ edgeActual _ _ _ -> pure $ if edgeRequested == edgeActual then 1 else 0 - _ -> - error $ $(curLoc) ++ "ActiveEdge: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty - (IsSync n) -> - let (_, ty, _) = bbInputs b !! n in - case stripVoid ty of - KnownDomain _ _ _ Synchronous _ _ -> 1 - KnownDomain _ _ _ Asynchronous _ _ -> 0 - _ -> error $ $(curLoc) ++ "IsSync: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty + (IsSync n) -> do + let (_, ty, _) = bbInputs b !! n + domConf <- getDomainConf ty + case domConf of + VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1 + VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0 - (IsInitDefined n) -> - let (_, ty, _) = bbInputs b !! n in - case stripVoid ty of - KnownDomain _ _ _ _ Defined _ -> 1 - KnownDomain _ _ _ _ Unknown _ -> 0 - _ -> error $ $(curLoc) ++ "IsInitDefined: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty + (IsInitDefined n) -> do + let (_, ty, _) = bbInputs b !! n + domConf <- getDomainConf ty + case domConf of + VDomainConfiguration _ _ _ _ Defined _ -> pure 1 + VDomainConfiguration _ _ _ _ Unknown _ -> pure 0 - (IsActiveHigh n) -> - let (_, ty, _) = bbInputs b !! n in - case stripVoid ty of - KnownDomain _ _ _ _ _ ActiveHigh -> 1 - KnownDomain _ _ _ _ _ ActiveLow -> 0 - _ -> error $ $(curLoc) ++ "IsActiveHigh: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty + (IsActiveHigh n) -> do + let (_, ty, _) = bbInputs b !! n + domConf <- getDomainConf ty + case domConf of + VDomainConfiguration _ _ _ _ _ ActiveHigh -> pure 1 + VDomainConfiguration _ _ _ _ _ ActiveLow -> pure 0 - (StrCmp [Text t1] n) -> + (StrCmp [Text t1] n) -> pure $ let (e,_,_) = bbInputs b !! n in case exprToString e of Just t2 | t1 == Text.pack t2 -> 1 | otherwise -> 0 Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e - (And es) -> if all (/=0) (map (check xOpt iw hdl syn enums) es) + (And es) -> do + es' <- mapM (check xOpt iw hdl syn enums) es + pure $ if all (/=0) es' then 1 else 0 - CmpLE e1 e2 -> if check xOpt iw hdl syn enums e1 <= check xOpt iw hdl syn enums e2 - then 1 - else 0 + CmpLE e1 e2 -> do + v1 <- check xOpt iw hdl syn enums e1 + v2 <- check xOpt iw hdl syn enums e2 + if v1 <= v2 + then pure 1 + else pure 0 _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, LIT, DEPTH, IW64, VIVADO, OTHERSYN, ISVAR, ISLIT, ISUNDEFINED, ISACTIVEENABLE, ACTIVEEDGE, ISSYNC, ISINITDEFINED, ISACTIVEHIGH, STRCMP, AND, ISSCALAR or CMPLE." ++ "\nGot: " ++ show c' renderElem b e = fmap const (renderTag b e) +getDomainConf :: (Backend backend, HasCallStack) => HWType -> State backend VDomainConfiguration +getDomainConf = generalGetDomainConf domainConfigurations + +generalGetDomainConf + :: forall m. (Monad m, HasCallStack) + => (m DomainMap) -- ^ a way to get the `DomainMap` + -> HWType -> m VDomainConfiguration +generalGetDomainConf getDomainMap ty = case (snd . stripAttributes . stripVoid) ty of + KnownDomain dom period activeEdge resetKind initBehavior resetPolarity -> + pure $ VDomainConfiguration (Data.Text.unpack dom) (fromIntegral period) activeEdge resetKind initBehavior resetPolarity + + Clock dom -> go dom + ClockN dom -> go dom + Reset dom -> go dom + Enable dom -> go dom + Product _DiffClock _ [Clock dom,_clkN] -> go dom + t -> error $ "Don't know how to get a Domain out of HWType: " <> show t + where + go :: HasCallStack => N.DomainName -> m VDomainConfiguration + go dom = do + doms <- getDomainMap + case HashMap.lookup dom doms of + Nothing -> error $ "Can't find domain " <> show dom <> ". Please report an issue at https://github.com/clash-lang/clash-compiler/issues." + Just conf -> pure conf + parseFail :: Text -> BlackBoxTemplate parseFail t = case runParse t of Failure errInfo -> @@ -690,6 +744,7 @@ mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#" ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#" + ,"GHC.Types.I#","GHC.Types.W#" ] , [Literal _ i] <- extractLiterals bbCtx = Literal Nothing i @@ -789,9 +844,19 @@ renderTag b (IncludeName n) = case indexMaybe (bbQsysIncName b) n of Just nm -> return (Text.fromStrict nm) _ -> error $ $(curLoc) ++ "~INCLUDENAME[" ++ show n ++ "] does not correspond to any index of the 'includes' field that is specified in the primitive definition" -renderTag b (OutputWireReg n) = case IntMap.lookup n (bbFunctions b) of - Just ((_,rw,_,_,_,_):_) -> case rw of {N.Wire -> return "wire"; N.Reg -> return "reg"} - _ -> error $ $(curLoc) ++ "~OUTPUTWIREREG[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function" +renderTag b (OutputUsage n) = do + hdl <- gets hdlKind + + let u = case IntMap.lookup n (bbFunctions b) of + Just ((_,u',_,_,_,_):_) -> u' + _ -> error $ $(curLoc) ++ "~OUTPUTUSAGE[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function" + + pure $ case (hdl, u) of + (VHDL, N.Proc N.Blocking) -> "variable" + (VHDL, _) -> "signal" + + (_, N.Cont) -> "wire" + (_, _) -> "reg" renderTag b (Repeat [es] [i]) = do i' <- Text.unpack <$> renderTag b i es' <- renderTag b es @@ -1033,7 +1098,7 @@ (((string "~SIGD" <> brackets (string es')) <>) . int) mI) prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i)) -prettyElem (OutputWireReg i) = renderOneLine <$> (string "~RESULTWIREREG" <> brackets (int i)) +prettyElem (OutputUsage n) = renderOneLine <$> (string "~OUTPUTUSAGE" <> brackets (int n)) prettyElem (ArgGen n x) = renderOneLine <$> (string "~ARGN" <> brackets (int n) <> brackets (int x)) prettyElem (Template bbname source) = do @@ -1108,7 +1173,7 @@ IsActiveEnable _ -> [] IsUndefined _ -> [] StrCmp es _ -> concatMap go es - OutputWireReg _ -> [] + OutputUsage _ -> [] Vars _ -> [] Repeat es1 es2 -> concatMap go es1 ++ concatMap go es2 @@ -1186,7 +1251,7 @@ IW64 -> Nothing Length _ -> Nothing MaxIndex _ -> Nothing - OutputWireReg _ -> Nothing + OutputUsage _ -> Nothing Repeat _ _ -> Nothing Result -> Nothing Sel _ _ -> Nothing diff --git a/src/Clash/Netlist/Expr.hs b/src/Clash/Netlist/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/Expr.hs @@ -0,0 +1,172 @@ +{-| + Copyright : (C) 2012-2016, University of Twente, + 2017 , Myrtle Software Ltd, + 2017-2018, Google Inc. + 2020-2022, QBayLogic B.V. + 2022 , Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Functions for expression manipulation +-} + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Netlist.Expr where + +import Control.Monad (zipWithM) +import Control.Exception (assert) +import Data.Set (fromList, member) +import Data.Bits (Bits, testBit, setBit, zeroBits) +import Data.Foldable (fold) +import Data.Tree (Tree(..)) +import GHC.Stack (HasCallStack) +import Data.Text (unpack) +import Language.Haskell.TH.Quote (dataToPatQ) + +import qualified Clash.Sized.Vector as V (replicate) +import qualified Clash.Sized.Internal.Index as I (fromInteger#) +import qualified Clash.Sized.Internal.Signed as S (fromInteger#) +import qualified Clash.Sized.Internal.Unsigned as U (fromInteger#) +import qualified Clash.Sized.Internal.BitVector as BV + (high, low, fromInteger#, fromInteger##) +import GHC.Int (Int8(I8#), Int16(I16#), Int32(I32#), Int64(I64#)) +import GHC.Word (Word8(W8#), Word16(W16#), Word32(W32#), Word64(W64#)) + +import Clash.Primitives.DSL (tySize) +import Clash.Netlist.Types + ( Size, Bit(..), Expr(..), HWType(..), Literal(..), Modifier(..) + , BlackBoxContext(..) + ) + +-- | Turns a constant expression of known bitsize into their +-- corresponding bitstream representation, arranged as a tree +-- that corresponds to the structure of the expression. +-- +-- NOTE: This conversion serves as a best effort approach and can be +-- considered a hack. Fully featured constant expression evaluation is +-- not available in clash yet and will replace this implementation +-- once it is officially supported. +bits :: HasCallStack => Size -> Expr -> Either Expr (Tree [Bool]) +bits size expr = case expr of + Literal _ lit -> case lit of + BitLit bLit -> case bLit of + H -> leaf [True] + L -> leaf [False] + _ -> Left expr + BoolLit bLit -> leaf [bLit] + NumLit nLit -> leaf $ toBits size nLit + BitVecLit _ bvLit -> leaf $ toBits size bvLit + VecLit lits -> + mapM (bits (size `div` length lits) . lit2Expr) lits >>= inner + StringLit{} -> Left expr + DataCon ty m subs -> assert (tySize ty == size) $ case ty of + Vector s t -> vecBits (tySize t) s subs + Product _ _ tys -> zipWithM bits (map tySize tys) subs >>= inner + Sum _ cs -> spBits expr size m subs $ map (const []) cs + SP _ xs -> spBits expr size m subs $ map (map tySize . snd) xs + _ -> case subs of + [e] -> bits size e + [] -> leaf [] + _ -> Left expr + -- appears in case of complex transformations, e.g., + -- >>> (bv2v 0b010) :: Vec 3 Bit + -- >>> (iterate (SNat @3) not True) :: Vec 3 Bool + -- >>> (complement <$> (True :> False :> Nil)) :: Vec 2 Bool + Identifier{} -> Left expr + DataTag{} -> Left expr + BlackBoxE bbName _ _ _ _ bbCtx _ -> case unpack bbName of + $(dataToPatQ (const Nothing) $ show 'BV.low) -> leaf [False] + $(dataToPatQ (const Nothing) $ show 'BV.high) -> leaf [True] + $(dataToPatQ (const Nothing) $ show 'V.replicate) -> case bbInputs bbCtx of + [ (eSize, ty, _), (eValue, _, _) ] -> do + bs <- bits (tySize ty) eSize + let s = fromBits $ fold bs + v <- bits (size `div` s) eValue + inner $ replicate s v + _ -> Left expr + _ -> + if unpack bbName `member` skippableBBs + then skippableBBBits expr bbCtx size + else Left expr + ToBv _ _ e -> bits size e + FromBv _ _ e -> bits size e + IfThenElse cond match alt -> case bits 1 cond of + Right (Node [True] []) -> bits size match + Right (Node [False] []) -> bits size alt + _ -> Left expr + Noop -> leaf [] + + where + -- known skippable blackboxes + skippableBBs = fromList $ map show + [ 'I.fromInteger#, 'S.fromInteger#, 'U.fromInteger# + , 'BV.fromInteger#, 'BV.fromInteger## + , 'I8#, 'I16#, 'I32#, 'I64# + , 'W8#, 'W16#, 'W32#, 'W64# + ] + + -- skips the blackbox conversion and obtains the constant result + -- directly from the last input argument instead + skippableBBBits e Context{..} n = case reverse bbInputs of + (x, _, _) : _ -> bits n x + _ -> Left e + + -- turns sum (& product) expressions into bitstreams (preserving the + -- expressions' tree layout) + spBits :: Expr -> Size -> Modifier -> [Expr] -> [[Size]] + -> Either Expr (Tree [Bool]) + spBits e n m es sizes = case m of + DC (_, i) -> do + xs <- zipWithM bits (sizes !! i) es + bs <- fold <$> inner xs + l <- leaf $ toBits (n - length bs) i + r <- leaf bs + inner [ l, r ] + _ -> Left e + + -- turns vector expressions into bitstream (preserving the + -- expressions' tree layout) + vecBits :: Size -> Int -> [Expr] -> Either Expr (Tree [Bool]) + vecBits elemSize elems = \case + [] -> assert (elems == 0) $ leaf [] + x:xr -> assert (elems > 0) $ do + (processedElems, cur) <- case x of + DataCon t _ xs -> case t of + Vector subElems (tySize -> subTySize) -> + assert (subElems <= elems && subTySize == elemSize) + ((subElems,) <$> vecBits elemSize subElems xs) + _ -> (1,) <$> bits elemSize x + _ -> (1,) <$> bits elemSize x + sub <- vecBits elemSize (elems - processedElems) xr + inner [cur, sub] + + -- creates a leaf node holding the leaf value + leaf :: [a] -> Either b (Tree [a]) + leaf x = return $ Node x [] + + -- creates an inner node (holding no value) with the given + -- sub-trees + inner :: [Tree [a]] -> Either b (Tree [a]) + inner = return . Node [] + + -- turns a literal into an expression + lit2Expr = Literal Nothing + +-- | Turns values into bitstreams of known length. If the bit stream +-- requires more bits for representing the given value, then only the +-- suffix of the corresponding bitstream gets returned. +toBits :: Bits a => Int -> a -> [Bool] +toBits n x = + map (testBit x) [n-1,n-2..0] + +-- | Turns bitstreams into values. +fromBits :: Bits a => [Bool] -> a +fromBits xs = + foldl setBit zeroBits $ map snd $ filter fst $ zip xs [n-1,n-2..0] + where + n = length xs diff --git a/src/Clash/Netlist/Id.hs b/src/Clash/Netlist/Id.hs --- a/src/Clash/Netlist/Id.hs +++ b/src/Clash/Netlist/Id.hs @@ -1,5 +1,6 @@ {-| Copyright : (C) 2020, QBayLogic B.V. + 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -8,7 +9,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Netlist.Id @@ -24,6 +24,7 @@ , Identifier , IdentifierType (..) , unsafeMake + , unsafeFromCoreId , toText , toLazyText , toList @@ -54,7 +55,8 @@ where import Clash.Annotations.Primitive (HDL (..)) -import Clash.Core.Var (Id) +import Clash.Core.Name (nameOcc) +import Clash.Core.Var (Id, varName) import Clash.Debug (debugIsOn) import Clash.Netlist.Types (PreserveCase(..), HasIdentifierSet(..), IdentifierSet(..), Identifier(..), @@ -116,13 +118,11 @@ toList :: IdentifierSet -> [Identifier] toList (IdentifierSet _ _ _ _ idStore) = HashSet.toList idStore --- | Convert an identifier to string. Use 'unmake' if you need the --- "IdentifierType" too. +-- | Convert an identifier to string toText :: Identifier -> Text toText = toText# --- | Convert an identifier to string. Use 'unmake' if you need the --- "IdentifierType" too. +-- | Convert an identifier to string toLazyText :: Identifier -> LT.Text toLazyText = LT.fromStrict . toText @@ -235,3 +235,10 @@ -- is unique. fromCoreId :: (HasCallStack, IdentifierSetMonad m) => Id -> m Identifier fromCoreId = withIdentifierSetM fromCoreId# + +-- | Like 'fromCoreId, 'unsafeFromCoreId' creates an identifier that will be +-- spliced at verbatim in the HDL. As opposed to 'fromCoreId', the resulting +-- Identifier might be generated at a later point as it is NOT added to an +-- IdentifierSet. +unsafeFromCoreId :: HasCallStack => Id -> Identifier +unsafeFromCoreId = unsafeMake . nameOcc . varName diff --git a/src/Clash/Netlist/Id/Common.hs b/src/Clash/Netlist/Id/Common.hs --- a/src/Clash/Netlist/Id/Common.hs +++ b/src/Clash/Netlist/Id/Common.hs @@ -95,7 +95,7 @@ maybeTuple :: Text -> Maybe (Text, Text) maybeTuple "(# #)" = Just ("Unit", "") maybeTuple "()" = Just ("Unit", "") -maybeTuple t = first (\n -> "Tup" <> showt n) <$> parseTuple t +maybeTuple t = first (\n -> "Tuple" <> showt n) <$> parseTuple t parseTuple :: Text -> Maybe (Int, Text) parseTuple t0 = do diff --git a/src/Clash/Netlist/Id/Internal.hs b/src/Clash/Netlist/Id/Internal.hs --- a/src/Clash/Netlist/Id/Internal.hs +++ b/src/Clash/Netlist/Id/Internal.hs @@ -80,10 +80,12 @@ where freshCache = updateFreshCache# (is_freshCache is) id2 isStore = HashSet.insert id2 (is_store is) - id2 = id1{i_provenance=if debugIsOn then callStack else emptyCallStack} + id2 = case id1 of + x@RawIdentifier{} -> x + y -> y{i_provenance=if debugIsOn then callStack else emptyCallStack} id1 = case lookupFreshCache# (is_freshCache is) id0 of Just currentMax -> - id0{i_extensionsRev=currentMax+1 : tail (i_extensionsRev id0)} + id0{i_extensionsRev=currentMax+1 : drop 1 (i_extensionsRev id0)} Nothing -> -- Identifier doesn't exist in set yet, so just return it. id0 diff --git a/src/Clash/Netlist/Types.hs b/src/Clash/Netlist/Types.hs --- a/src/Clash/Netlist/Types.hs +++ b/src/Clash/Netlist/Types.hs @@ -2,7 +2,8 @@ Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd, 2017-2018, Google Inc. - 2020-2022, QBayLogic B.V. + 2020-2023, QBayLogic B.V. + 2022-2023, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -38,6 +39,8 @@ import qualified Control.Monad.State as Lazy (State) import qualified Control.Monad.State.Strict as Strict (State, MonadIO, MonadState, StateT) +import Data.Aeson (FromJSON(..)) +import qualified Data.Aeson as Aeson import Data.Bits (testBit) import Data.Binary (Binary(..)) import Data.Function (on) @@ -48,6 +51,7 @@ import Data.IntMap (IntMap, empty) import Data.Map.Ordered (OMap) import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Monoid (Ap(..)) import qualified Data.Set as Set @@ -65,13 +69,14 @@ import SrcLoc (SrcSpan) #endif +import Clash.Annotations.SynthesisAttributes(Attr) import Clash.Annotations.BitRepresentation (FieldAnn) import Clash.Annotations.Primitive (HDL(..)) import Clash.Annotations.TopEntity (TopEntity) -import Clash.Backend (Backend) +import Clash.Backend (Backend, HasUsageMap (..)) import Clash.Core.HasType import Clash.Core.Type (Type) -import Clash.Core.Var (Attr', Id) +import Clash.Core.Var (Id) import Clash.Core.TyCon (TyConMap) import Clash.Core.VarEnv (VarEnv) import Clash.Driver.Types (BindingMap, ClashEnv(..), ClashOpts(..)) @@ -202,7 +207,7 @@ -- identifiers internally. Any Identifier should be trivially printable to any -- HDL. -- --- __NB__: use the functions in Clash.Netlist.Id. Don't use these constructors +-- __NB__: use the functions in "Clash.Netlist.Id". Don't use these constructors -- directly. data Identifier -- | Unparsed identifier. Used for things such as port names, which should @@ -283,6 +288,7 @@ { cmWereVoids :: [Bool] , cmLoc :: SrcSpan , cmScope :: IdentifierSet + , cmUsage :: UsageMap } deriving (Generic, Show, NFData) type ComponentMap = OMap Unique (ComponentMeta, Component) @@ -338,6 +344,10 @@ , _backend :: SomeBackend -- ^ The current HDL backend , _htyCache :: HWMap + , _usages :: UsageMap + -- ^ The current way signals are assigned in netlist. This is used to + -- determine how signals are rendered in HDL (i.e. wire/reg in Verilog, or + -- signal/variable in VHDL). } data ComponentPrefix @@ -365,7 +375,7 @@ = Component { componentName :: !Identifier -- ^ Name of the component , inputs :: [(Identifier,HWType)] -- ^ Input ports - , outputs :: [(WireOrReg,(Identifier,HWType),Maybe Expr)] -- ^ Output ports + , outputs :: [(Usage,(Identifier,HWType),Maybe Expr)] -- ^ Output ports , declarations :: [Declaration] -- ^ Internal declarations } deriving (Show, Generic, NFData) @@ -373,11 +383,16 @@ -- | Check if an input port is really an inout port. -- isBiDirectional :: (Identifier, HWType) -> Bool -isBiDirectional (_, BiDirectional _ _) = True -isBiDirectional _ = False +isBiDirectional = go . snd + where + go BiDirectional{} = True + go (Annotated _ hwty) = go hwty + go _ = False -- | Find the name and domain name of each clock argument of a component. -- +-- This will not consider @ClockN@ to be a clock argument, which means only the +-- positive phase of a differential pair will be added to @sdcClock@. findClocks :: Component -> [(Text, Text)] findClocks (Component _ is _ _) = mapMaybe isClock is @@ -437,6 +452,8 @@ -- ^ Sum-of-Product type: Name and Constructor names + field types | Clock !DomainName -- ^ Clock type corresponding to domain /DomainName/ + | ClockN !DomainName + -- ^ ClockN type corresponding to domain /DomainName/ | Reset !DomainName -- ^ Reset type corresponding to domain /DomainName/ | Enable !DomainName @@ -452,7 +469,7 @@ | CustomProduct !Text !DataRepr' !Size (Maybe [Text]) [(FieldAnn, HWType)] -- ^ Same as Product, but with a user specified bit representation. For more -- info, see: Clash.Annotations.BitRepresentations. - | Annotated [Attr'] !HWType + | Annotated [Attr Text] !HWType -- ^ Annotated with HDL attributes | KnownDomain !DomainName !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity -- ^ Domain name, period, active edge, reset kind, initial value behavior @@ -460,9 +477,17 @@ -- ^ File type for simulation-level I/O deriving (Eq, Ord, Show, Generic, NFData, Hashable) +-- | Smart constructor for 'Annotated'. Wraps the given type in an 'Annotated' +-- if the attribute list is non-empty. If it is empty, it will return the given +-- 'HWType' unchanged. +annotated :: [Attr Text] -> HWType -> HWType +annotated [] t = t +annotated attrs t = Annotated attrs t + hwTypeDomain :: HWType -> Maybe DomainName hwTypeDomain = \case Clock dom -> Just dom + ClockN dom -> Just dom Reset dom -> Just dom Enable dom -> Just dom KnownDomain dom _ _ _ _ _ -> Just dom @@ -470,7 +495,7 @@ -- | Extract hardware attributes from Annotated. Returns an empty list if -- non-Annotated given or if Annotated has an empty list of attributes. -hwTypeAttrs :: HWType -> [Attr'] +hwTypeAttrs :: HWType -> [Attr Text] hwTypeAttrs (Annotated attrs _type) = attrs hwTypeAttrs _ = [] @@ -503,6 +528,7 @@ -- | Signal assignment = Assignment !Identifier -- ^ Signal to assign + !Usage -- ^ How the signal is assigned !Expr -- ^ Assigned expression -- | Conditional signal assignment: @@ -517,7 +543,7 @@ | InstDecl EntityOrComponent -- ^ Whether it's an entity or a component (Maybe Text) -- ^ Library instance is defined in - [Attr'] -- ^ Attributes to add to the generated code + [Attr Text] -- ^ Attributes to add to the generated code !Identifier -- ^ The component's (or entity's) name !Identifier -- ^ Instance label [(Expr,HWType,Expr)] -- ^ List of parameters for this component (param name, param type, param value) @@ -532,12 +558,19 @@ !BlackBox -- ^ Template tokens BlackBoxContext -- ^ Context in which tokens should be rendered + -- | @component@ declaration (VHDL). + -- + -- See [this tutorial](https://www.ics.uci.edu/~jmoorkan/vhdlref/compdec.html); + -- refer to §4.5 of IEEE 1076-1993 + | CompDecl + !Text + [(Text, PortDirection, HWType)] + -- | Signal declaration | NetDecl' (Maybe Comment) -- ^ Note; will be inserted as a comment in target hdl - WireOrReg -- ^ Wire or register !Identifier -- ^ Name of signal - (Either IdentifierText HWType) -- ^ Pointer to type of signal or type of signal + HWType -- ^ Type of signal (Maybe Expr) -- ^ Initial value -- ^ Signal declaration @@ -578,14 +611,111 @@ [(Maybe Literal,[Seq])] -- ^ List of: (Maybe match, RHS of Alternative) deriving Show -data EntityOrComponent = Entity | Comp | Empty - deriving Show +-- | Procedural assignment in HDL can be blocking or non-blocking. This +-- determines when the assignment takes place in simulation. The name refers to +-- whether evaluation of the remaining statements in a process is blocked +-- until the assignment is performed or not. +-- +-- See Also: +-- +-- IEEE 1364-2001, sections 9.2.1 and 9.2.2 +-- IEEE 1076-1993, sections 8.4 and 8.5 +-- +data Blocking + = NonBlocking + -- ^ A non-blocking assignment means the new value is not observed until the + -- next time step in simulation. Using the signal later in the process will + -- continue to return the old value. + | Blocking + -- ^ A blocking assignment means the new value is observed immediately. Using + -- the signal later in the process will return the new value. + deriving (Binary, Eq, Generic, Hashable, NFData, Show) -data WireOrReg = Wire | Reg - deriving (Show,Generic) +-- NOTE [`Semigroup` instances for `Blocking` and `Usage`] +instance Semigroup Blocking where + NonBlocking <> y = y + Blocking <> _ = Blocking -instance NFData WireOrReg +-- | The usage of a signal refers to how the signal is written to in netlist. +-- This is used to determine if the signal should be a @wire@ or @reg@ in +-- (System)Verilog, or a @signal@ or @variable@ in VHDL. +-- +data Usage + = Cont + -- ^ Continuous assignment, which occurs in a concurrent context. + | Proc Blocking + -- ^ Procedural assignment, which occurs in a sequential context. + deriving (Binary, Eq, Generic, Hashable, NFData, Show) +-- NOTE [`Semigroup` instances for `Blocking` and `Usage`] +instance Semigroup Usage where + Cont <> y = y + Proc x <> Proc y = Proc (x <> y) + Proc x <> _ = Proc x + +{- +NOTE [`Semigroup` instances for `Blocking` and `Usage`] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usages (and Blocking) are combined by taking the most restrictive usage, where +most restrictive means "has the most influence over the choice of declaration". +Clash produces three types of assignment: + + * continuous + * prodecural non-blocking + * prodecural blocking + +Both VHDl and (System)Verilog have a type of declaration which only admits one +type of assignment. This is the most restrictive for that HDL. However, since +that would involve knowing the HDL type in these Semigroup instances, the +most restrictive here is based on ordering where the most restrictive for each +HDL is an extreme value (max for VHDL, min for Verilog). i.e. + + |-------------------------------------| + | Continuous | NonBlocking | Blocking | +|---------|-------------------------------------| +| VHDL | signal | variable | +|---------|-------------------------------------| +| Verilog | wire | reg | +|---------|-------------------------------------| +-} + +instance FromJSON Usage where + parseJSON = Aeson.withText "Usage" $ \case + "Continuous" -> pure Cont + "NonBlocking" -> pure (Proc NonBlocking) + "Blocking" -> pure (Proc Blocking) + str -> fail $ mconcat + [ "Could not parse usage: " + , show str + , "\nRecognized values are 'Continuous', 'NonBlocking' and 'Blocking'" + ] + +-- See NOTE [`Text` key for `UsageMap`] +type UsageMap = Map Text Usage + +lookupUsage :: Identifier -> UsageMap -> Maybe Usage +lookupUsage i = Map.lookup (Id.toText i) + +{- +NOTE [`Text` key for `UsageMap`] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We would like to use netlist identifiers as the key for the usage map, since +conceptually it is a map from an identifier to how it is used in assignments. +However, in practice we commonly end up with the same textual identifier +appearing in different ways in the netlist. + +The most obvious example of this are identifiers that appear as both +`UniqueIdentifier` and `RawIdentifier`. If we track the usage on the raw +identifier, but the `NetDecl` uses the `UniqueIdentifier` then the wrong +declaration may be used in the rendered HDL. + +Attempting to fix this by not generating the same textual identifier in +different ways proved difficult, so for now the key type is `Text` instead. +-} + +data EntityOrComponent = Entity | Comp | Empty + deriving Show + pattern NetDecl :: Maybe Comment -- ^ Note; will be inserted as a comment in target hdl @@ -594,9 +724,9 @@ -> HWType -- ^ Type of signal -> Declaration -pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty) _ +pattern NetDecl note d ty <- NetDecl' note d ty _ where - NetDecl note d ty = NetDecl' note Wire d (Right ty) Nothing + NetDecl note d ty = NetDecl' note d ty Nothing data PortDirection = In | Out deriving (Eq,Ord,Show,Generic,NFData,Hashable) @@ -606,11 +736,18 @@ -- | Expression Modifier data Modifier - = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag) - | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag) - | VecAppend -- ^ See the expression in the context of a Vector append operation - | RTreeAppend -- ^ See the expression in the context of a Tree append operation - | Sliced (HWType,Int,Int) -- ^ Slice the identifier of the given type from start to end + = Indexed (HWType, Int, Int) + -- ^ Index the expression: (Type of expression, DataCon tag, Field Tag). Note + -- that the type of the expression is the type we are slicing from, not the type + -- returned by the index operation. + | DC (HWType, Int) + -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag) + | VecAppend + -- ^ See the expression in the context of a Vector append operation + | RTreeAppend + -- ^ See the expression in the context of a Tree append operation + | Sliced (HWType, Int, Int) + -- ^ Slice the identifier of the given type from start to end | Nested Modifier Modifier deriving Show @@ -651,6 +788,24 @@ instance NFData Expr where rnf x = x `seq` () +isConstExpr :: Expr -> Bool +isConstExpr = \case + Literal{} -> True + DataCon _ _ es -> all isConstExpr es + Identifier{} -> False + DataTag{} -> False + BlackBoxE nm _ _ _ _ ctx _ + -- When using SimIO, `reg` creates (in Haskell) the mutable reference to + -- some value. The blackbox for this however is simply `~ARG[0]`, so if + -- the argument given is constant, the rendered HDL will also be constant. + | nm == "Clash.Explicit.SimIO.reg" -> + all (\(e, _, _) -> isConstExpr e) (bbInputs ctx) + | otherwise -> False + ToBv _ _ e -> isConstExpr e + FromBv _ _ e -> isConstExpr e + IfThenElse{} -> False + Noop -> False + -- | Literals used in an expression data Literal = NumLit !Integer -- ^ Number literal @@ -689,7 +844,7 @@ , bbInputs :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal , bbFunctions :: IntMap [(Either BlackBox (Identifier,[Declaration]) - ,WireOrReg + ,Usage ,[BlackBoxTemplate] ,[BlackBoxTemplate] ,[((Text,Text),BlackBox)] @@ -758,7 +913,7 @@ | MultiId [Id] -- ^ A split identifier (into several sub-identifiers), needed to assign -- expressions of types that have to be split apart (e.g. tuples of Files) - deriving Show + deriving (Eq, Show) -- | Eliminator for 'NetlistId', fails on 'MultiId' netlistId1 @@ -838,6 +993,12 @@ instance HasIdentifierSet IdentifierSet where identifierSet = ($) + +instance HasUsageMap NetlistState where + usageMap = usages + +instance HasIdentifierSet s => HasIdentifierSet (s, a) where + identifierSet = Lens._1 . identifierSet -- | An "IdentifierSetMonad" supports unique name generation for Clash Netlist class Monad m => IdentifierSetMonad m where diff --git a/src/Clash/Netlist/Types.hs-boot b/src/Clash/Netlist/Types.hs-boot --- a/src/Clash/Netlist/Types.hs-boot +++ b/src/Clash/Netlist/Types.hs-boot @@ -1,6 +1,7 @@ {-| Copyright : (C) 2018, Google Inc, 2022, QBayLogic B.V. + 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -11,7 +12,11 @@ import Control.DeepSeq (NFData) import Control.Lens (Lens') -import Data.Hashable +import Data.Aeson (FromJSON) +import Data.Binary (Binary) +import Data.Hashable (Hashable) +import Data.Map (Map) +import Data.Text (Text) data IdentifierType data Identifier @@ -38,3 +43,26 @@ instance Eq PreserveCase instance Show PreserveCase instance NFData PreserveCase + +data Blocking + = NonBlocking + | Blocking + +instance Binary Blocking +instance Eq Blocking +instance Hashable Blocking +instance NFData Blocking +instance Show Blocking + +data Usage + = Cont + | Proc Blocking + +instance Binary Usage +instance Eq Usage +instance FromJSON Usage +instance Hashable Usage +instance NFData Usage +instance Show Usage + +type UsageMap = Map Text Usage diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -2,7 +2,8 @@ Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd 2017-2018, Google Inc. - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -11,6 +12,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} #if !MIN_VERSION_ghc(8,8,0) {-# LANGUAGE MonadFailDesugaring #-} @@ -26,7 +28,7 @@ import Data.Coerce (coerce) import Control.Exception (throw) -import Control.Lens ((.=)) +import Control.Lens ((.=), (%=)) import qualified Control.Lens as Lens import Control.Monad (when, zipWithM) import Control.Monad.Extra (concatMapM) @@ -39,6 +41,7 @@ import Data.Bifunctor (second) import Data.Either (partitionEithers) import Data.Foldable (Foldable(toList)) +import Data.Functor (($>)) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -73,7 +76,9 @@ import Clash.Annotations.BitRepresentation.Internal (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr, uncheckedGetConstrRepr) -import Clash.Backend (HWKind(..), hdlHWTypeKind) +import Clash.Annotations.SynthesisAttributes (Attr) +import Clash.Annotations.Primitive (HDL(VHDL)) +import Clash.Backend (HasUsageMap (..), HWKind(..), hdlHWTypeKind, hdlKind) import Clash.Core.DataCon (DataCon (..)) import Clash.Core.EqSolver (typeEq) import Clash.Core.FreeVars (typeFreeVars, typeFreeVars') @@ -97,9 +102,10 @@ import Clash.Core.Util (substArgTys, tyLitShow) import Clash.Core.Var - (Id, Var (..), mkLocalId, modifyVarName, Attr') + (Id, Var (..), mkLocalId, modifyVarName) import Clash.Core.VarEnv (InScopeSet, extendInScopeSetList, uniqAway, lookupVarEnv) +import qualified Clash.Data.UniqMap as UniqMap import {-# SOURCE #-} Clash.Netlist.BlackBox import {-# SOURCE #-} Clash.Netlist.BlackBox.Util import Clash.Netlist.BlackBox.Types @@ -107,7 +113,6 @@ import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types as HW import Clash.Primitives.Types -import Clash.Unique import Clash.Util import qualified Clash.Util.Interpolate as I @@ -432,7 +437,7 @@ | isRecursiveTy m tc = throwE $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString -mkADT builtInTranslation reprs m tyString tc args = case tyConDataCons (m `lookupUniqMap'` tc) of +mkADT builtInTranslation reprs m tyString tc args = case tyConDataCons (UniqMap.find tc m) of [] -> return (FilteredHWType (Void Nothing) []) dcs -> do let tcName = nameOcc tc @@ -576,7 +581,7 @@ Bool isGenerative t efvs = case tyView t of TyConApp tcNm _ - | Just (FunTyCon {}) <- lookupUniqMap tcNm tcm + | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm -- For type families we can only "calculate" the `eTV` if it is -- the only free variable. e.g. we can work out from `n + 1 ~ 4` -- that `n ~ 3`, but can't do anything for `n + m ~ 4`. @@ -626,7 +631,7 @@ -- Without looking through type families, we would think that /SList/ is not -- recursive. This lead to issue #1921 isRecursiveTy :: TyConMap -> TyConName -> Bool -isRecursiveTy m tc = case tyConDataCons (m `lookupUniqMap'` tc) of +isRecursiveTy m tc = case tyConDataCons (UniqMap.find tc m) of [] -> False dcs -> let argTyss = map dcArgTys dcs argTycons = (map fst . catMaybes) @@ -674,6 +679,7 @@ typeSize Bool = 1 typeSize Bit = 1 typeSize (Clock _) = 1 +typeSize (ClockN _) = 1 typeSize (Reset _) = 1 typeSize (Enable _) = 1 typeSize (BitVector i) = i @@ -725,10 +731,12 @@ isBiSignalIn :: HWType -> Bool isBiSignalIn (BiDirectional In _) = True +isBiSignalIn (Annotated _ ty) = isBiSignalIn ty isBiSignalIn _ = False isBiSignalOut :: HWType -> Bool isBiSignalOut (BiDirectional Out _) = True +isBiSignalOut (Annotated _ ty) = isBiSignalOut ty isBiSignalOut _ = False containsBiSignalIn @@ -739,6 +747,7 @@ containsBiSignalIn (SP _ tyss) = any (any containsBiSignalIn . snd) tyss containsBiSignalIn (Vector _ ty) = containsBiSignalIn ty containsBiSignalIn (RTree _ ty) = containsBiSignalIn ty +containsBiSignalIn (Annotated _ ty) = containsBiSignalIn ty containsBiSignalIn _ = False -- | Uniquely rename all the variables and their references in a normalized @@ -785,7 +794,6 @@ resM <- mkUniqueResult substArgs etopM res case resM of Just (oports, owrappers, res1, subst0) -> do - -- Collect new names, see 'renameBinder' for more information (listToMaybe -> resRenameM0, HashMap.fromList -> renames0) <- partition ((== res) . fst) <$> concatMapM renameBinder binds @@ -814,7 +822,11 @@ let -- Result binder is already unique, so don't rename that renames1 = [(b, hmFindWithDefault b b renames0) | b <- bndrs] - (renamesL0, (_:renamesR0)) = break ((==res) . fst) renames1 + (renamesL0, renamesR0) = case break ((==res) . fst) renames1 of + (ls,_:rs) -> (ls,rs) + _ -> error (concat [ "internal error: unable to find: " + , show res , " in: " + , show renames1 ]) (renamesL1, subst2) <- mkUnique subst1 (map snd renamesL0) (renamesR1, subst3) <- mkUnique subst2 (map snd renamesR0) @@ -997,10 +1009,7 @@ hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf var) if isVoid hwTy then return Nothing - else return (Just (id2identifier var, hwTy)) - -id2identifier :: Id -> Identifier -id2identifier = Id.unsafeMake . nameOcc . varName + else return (Just (Id.unsafeFromCoreId var, hwTy)) setRepName :: Text -> Name a -> Name a setRepName s (Name sort' _ i loc) = Name sort' s i loc @@ -1037,7 +1046,7 @@ State.put state pure val --- | Preserve the Netlist '_curCompNm','_seenIds' when executing +-- | Preserve the Netlist '_curCompNm','_seenIds','_usageMap' when executing -- a monadic action preserveVarEnv :: NetlistMonad a @@ -1046,11 +1055,13 @@ -- store state vComp <- Lens.use curCompNm vSeen <- Lens.use seenIds + vUses <- Lens.use usageMap -- perform action val <- action -- restore state curCompNm .= vComp seenIds .= vSeen + usageMap .= vUses return val dcToLiteral :: HWType -> Int -> Literal @@ -1070,9 +1081,214 @@ prefixParent parent (PortProduct "" ps) = PortProduct parent ps prefixParent parent (PortProduct p ps) = PortProduct (parent <> "_" <> p) ps -mkAssign :: Identifier -> HWType -> Expr -> [Declaration] -mkAssign id_ hwty expr = [NetDecl Nothing id_ hwty, Assignment id_ expr] +-- | Make a new signal which is assigned with an initial value. This should be +-- used in place of NetDecl directly, as it also updates the usage map to +-- include the new identifier and usage. +-- +mkInit + :: HasCallStack + => DeclarationType + -- ^ Are we in a concurrent or sequential context? + -> Usage + -- ^ How is the initial value assigned if the assignment is separate + -> Identifier + -- ^ The identifier of the declared net + -> HWType + -- ^ The typr of the declared net + -> Expr + -- ^ The value assigned to the net + -> NetlistMonad [Declaration] + -- ^ The declarations needed to declare and assign the net +mkInit _ _ i ty e + -- When the initial value is a constant, we can set the value at the same + -- point the declaration happens. Initial assignments of this form do not + -- count as a usage as they are always allowed. + | isConstExpr e + = pure [NetDecl' Nothing i ty (Just e)] +mkInit Concurrent Cont i ty e = do + usageMap %= Map.insert (Id.toText i) Cont + pure [NetDecl' Nothing i ty Nothing, Assignment i Cont e] + +mkInit Concurrent proc i ty e = do + usageMap %= Map.insert (Id.toText i) proc + pure + [ NetDecl' Nothing i ty Nothing + , Seq [Initial [SeqDecl (Assignment i proc e)]] + ] + +mkInit Sequential Cont _ _ _ = + error "mkInit: Cannot continuously assign in a sequential block" + +mkInit Sequential proc i ty e = do + usageMap %= Map.insert (Id.toText i) proc + pure + [ NetDecl' Nothing i ty Nothing + , Seq [SeqDecl (Assignment i proc e)] + ] + +-- | Determine if for the specified HDL, the type of assignment wanted can be +-- performed on a signal which has been assigned another way. This identifies +-- when a new intermediary signal needs to be created, e.g. +-- +-- * when attempting to use blocking and non-blocking procedural assignment +-- on the same signal in VHDL +-- +-- * when attempting to use continuous and procedural assignment on the same +-- signal in (System)Verilog +-- +canUse :: HDL -> Usage -> Usage -> Bool +canUse VHDL (Proc Blocking) = \case + Proc Blocking -> True + _ -> False + +canUse VHDL _ = \case + Proc Blocking -> False + _ -> True + +canUse _ Cont = \case + Cont -> True + _ -> False + +canUse _ _ = \case + Cont -> False + _ -> True + +declareUse :: Usage -> Identifier -> NetlistMonad () +declareUse u i = usageMap %= Map.insertWith (<>) (Id.toText i) u + +-- | Like 'declareUse', but will throw an exception if we run into a name +-- collision. +declareUseOnce :: HasUsageMap s => Usage -> Identifier -> State.State s () +declareUseOnce u i = usageMap %= Map.alter go (Id.toText i) + where + go Nothing = Just u + go Just{} = error ("Internal error: unexpected re-declaration of usage for" ++ show i) + +-- | Declare uses which occur as a result of a component being instantiated, +-- for example the following design (verilog) +-- +-- @ +-- module f ( input p; output reg r ) ... endmodule +-- +-- module top ( ... ) +-- ... +-- f f_inst ( .p(p), .r(foo)); +-- ... +-- endmodule +-- @ +-- +-- would declare a usage of foo, since it is assigned by @f_inst@. +-- +declareInstUses + :: [(Expr, PortDirection, HWType, Expr)] + -- ^ The port mappings (named) + -> NetlistMonad () +declareInstUses = + mapM_ declare + where + -- Modifiers don't matter for these identifiers + declare (Identifier _ _, Out, _, Identifier n _) = + -- See NOTE [output ports are continuously assigned] + declareUse Cont n + + declare (_, In, _, _) = + pure () + + declare portMapping = + error ("declareInstUses: Unexpected port mapping: " <> show portMapping) + +{- +NOTE [output ports are continuously assigned] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a module is instantiated in Verilog, the output of the module is always +continuously assigned. This means if I have the module + + module f ( ..., output reg result) + +and an instantiation + + f f_inst ( ..., .result(foo) ); + +then the assignment of result to foo is a continuous assignment. This may seem +strange, but consider + + * instantiations can only occur in a concurrent context, and concurrent + contexts only admit continuous assignment + + * the usage being tracked is not for the result port, but for foo. Whenever + the value of the port changes, the value of foo will change (i.e. there is + a wire between them, it cannot "hold" state). + +This means when we declare uses that occur as a result of an instantiation in +netlist, the uses are always continuous assignment, and not the usage of the +output port as given in the `outputs` field of the `Component` type. +-} + +assignmentWith + :: HasCallStack + => (Identifier -> Declaration) + -> Usage + -> Identifier + -> NetlistMonad Declaration +assignmentWith assign new i = do + u <- Lens.use usageMap + SomeBackend b <- Lens.use backend + + case lookupUsage i u of + Just old | not $ canUse (hdlKind b) new old -> + error $ mconcat + [ "assignmentWith: Cannot assign as " + , show new + , " after " + , show old + , " for " + , show i + ] + + _ -> + declareUse new i $> assign i + +-- | Attempt to continuously assign an expression to the given identifier. If +-- the assignment is not allowed for the backend being used, a new signal is +-- created which allows the assignment. The identifier which holds the result +-- of the assignment is returned alongside the new declarations. +-- +-- This function assumes the identifier being assigned is already declared. If +-- the identifier is not in the usage map then an error is thrown. +-- +contAssign + :: HasCallStack + => Identifier + -> Expr + -> NetlistMonad Declaration +contAssign dst expr = + assignmentWith (\i -> Assignment i Cont expr) Cont dst + +procAssign + :: HasCallStack + => Blocking + -> Identifier + -> Expr + -> NetlistMonad Declaration +procAssign block dst expr = + assignmentWith (\i -> Assignment i (Proc block) expr) (Proc block) dst + +condAssign + :: Identifier + -> HWType + -> Expr + -> HWType + -> [(Maybe Literal, Expr)] + -> NetlistMonad Declaration +condAssign dst dstTy scrut scrutTy alts = do + -- Currently, all CondAssignment get rendered as `always @*` blocks in + -- (System)Verilog. This means when we target these HDL, this is _really_ a + -- blocking procedural assignment. + SomeBackend b <- Lens.use backend + let use = case hdlKind b of { VHDL -> Cont ; _ -> Proc Blocking } + assignmentWith (\i -> CondAssignment i dstTy scrut scrutTy alts) use dst + -- | See 'toPrimitiveType' / 'fromPrimitiveType' convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a convPrimitiveType hwty a action = do @@ -1094,7 +1310,8 @@ -> NetlistMonad ([Declaration], Identifier, Expr, HWType) toPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do id1 <- Id.next id0 - pure (mkAssign id1 hwty1 expr, id1, expr, hwty1) + ds <- mkInit Concurrent Cont id1 hwty1 expr + pure (ds, id1, expr, hwty1) where dflt = ([], id0, Identifier id0 Nothing, hwty0) hwty1 = BitVector (typeSize hwty0) @@ -1111,7 +1328,8 @@ -> NetlistMonad ([Declaration], Identifier, Expr, HWType) fromPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do id1 <- Id.next id0 - pure (mkAssign id1 hwty0 expr, id1, expr, hwty1) + ds <- mkInit Concurrent Cont id1 hwty0 expr + pure (ds, id1, expr, hwty1) where dflt = ([], id0, Identifier id0 Nothing, hwty0) hwty1 = BitVector (typeSize hwty0) @@ -1130,32 +1348,29 @@ mkTopInput epp@(ExpandedPortProduct p hwty ps) = do pN <- Id.makeBasic p - let netdecl = NetDecl Nothing pN hwty case hwty of Vector sz eHwty -> do (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps let vecExpr = mkVectorChain sz eHwty exprs - netassgn = Assignment pN vecExpr - return (concat ports, [netdecl, netassgn], vecExpr, pN) + decls <- mkInit Concurrent Cont pN hwty vecExpr + return (concat ports, decls, vecExpr, pN) RTree d eHwty -> do (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps let trExpr = mkRTreeChain d eHwty exprs - netassgn = Assignment pN trExpr - return (concat ports, [netdecl, netassgn], trExpr, pN) + decls <- mkInit Concurrent Cont pN hwty trExpr + return (concat ports, decls, trExpr, pN) Product _ _ _ -> do (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps case exprs of - [expr] -> - let netassgn = Assignment pN expr in - return (concat ports, [netdecl, netassgn], expr, pN) - _ -> - let - dcExpr = DataCon hwty (DC (hwty, 0)) exprs - netassgn = Assignment pN dcExpr - in - return (concat ports, [netdecl, netassgn], dcExpr, pN) + [expr] -> do + decls <- mkInit Concurrent Cont pN hwty expr + return (concat ports, decls, expr, pN) + _ -> do + let dcExpr = DataCon hwty (DC (hwty, 0)) exprs + decls <- mkInit Concurrent Cont pN hwty dcExpr + return (concat ports, decls, dcExpr, pN) SP _ ((concat . map snd) -> [elTy]) -> do (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps @@ -1163,8 +1378,8 @@ [conExpr, elExpr] -> do let dcExpr = DataCon hwty (DC (BitVector (typeSize hwty), 0)) [conExpr, ToBv Nothing elTy elExpr] - netassgn = Assignment pN dcExpr - return (concat ports, [netdecl, netassgn], dcExpr, pN) + decls <- mkInit Concurrent Cont pN hwty dcExpr + return (concat ports, decls, dcExpr, pN) _ -> error $ $(curLoc) ++ "Internal error" _ -> @@ -1247,7 +1462,7 @@ -- non-Annotated. Accumulates all attributes of nested annotations. stripAttributes :: HWType - -> ([Attr'], HWType) + -> ([Attr Text], HWType) -- Recursively strip type, accumulate attrs: stripAttributes (Annotated attrs typ) = let (attrs', typ') = stripAttributes typ @@ -1267,60 +1482,63 @@ -- No type conversion happened, so we can just request caller to assign to -- port name directly. return ([(i0, hwty0)], [], i0) - else + else do -- Type conversion happened, so we must use intermediate variable. - return ([(i0, hwty1)], [Assignment i0 bvExpr, NetDecl Nothing i1 hwty0], i1) + assn <- contAssign i0 bvExpr + pure ( [(i0, hwty1)], [NetDecl' Nothing i1 hwty0 Nothing, assn], i1) mkTopOutput epp@(ExpandedPortProduct p hwty ps) = do pN <- Id.makeBasic p - let netdecl = NetDecl Nothing pN hwty + let netdecl = NetDecl' Nothing pN hwty Nothing case hwty of Vector {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps - let assigns = zipWith (assignId pN hwty 10) ids [0..] - return (concat ports, netdecl:assigns ++ concat decls, pN) + assigns <- zipWithM (\i n -> assignId pN hwty 10 i n) ids [0..] + return (concat ports, netdecl : assigns ++ concat decls, pN) RTree {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps - let assigns = zipWith (assignId pN hwty 10) ids [0..] - return (concat ports, netdecl:assigns ++ concat decls, pN) + assigns <- zipWithM (\i n -> assignId pN hwty 10 i n) ids [0..] + return (concat ports, netdecl : assigns ++ concat decls, pN) Product {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps case ids of - [i] -> let assign = Assignment i (Identifier pN Nothing) - in return (concat ports, netdecl:assign:concat decls, pN) + [i] -> do + assn <- contAssign i (Identifier pN Nothing) + pure (concat ports, netdecl : assn : concat decls, pN) - _ -> let assigns = zipWith (assignId pN hwty 0) ids [0..] - in return (concat ports, netdecl:assigns ++ concat decls, pN) + _ -> do + assigns <- zipWithM (\i n -> assignId pN hwty 0 i n) ids [0..] + pure (concat ports, netdecl : assigns ++ concat decls, pN) SP _ ((concat . map snd) -> [elTy]) -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps case ids of - [conId, elId] -> + [conId, elId] -> do let conIx = Sliced ( BitVector (typeSize hwty) , typeSize hwty - 1 , typeSize elTy ) elIx = Sliced ( BitVector (typeSize hwty) , typeSize elTy - 1 , 0 ) - assigns = [ Assignment conId (Identifier pN (Just conIx)) - , Assignment elId (FromBv Nothing elTy - (Identifier pN (Just elIx))) - ] - in return (concat ports, netdecl:assigns ++ concat decls, pN) + + conAssgn <- contAssign conId (Identifier pN (Just conIx)) + elAssgn <- contAssign elId (FromBv Nothing elTy (Identifier pN (Just elIx))) + + pure (concat ports, netdecl:conAssgn:elAssgn:concat decls, pN) _ -> error $ $(curLoc) ++ "Internal error" -- 'expandTopEntity' should have made sure this isn't possible _ -> error $ $(curLoc) ++ "Internal error: " ++ show epp where assignId p_ hwty_ con i n = - Assignment i (Identifier p_ (Just (Indexed (hwty_, con, n)))) + contAssign i (Identifier p_ (Just (Indexed (hwty_, con, n)))) mkTopCompDecl :: Maybe Text -- ^ Library entity is defined in - -> [Attr'] + -> [Attr Text] -- ^ Attributes to add to generate code -> Identifier -- ^ The component's (or entity's) name @@ -1366,11 +1584,11 @@ -- inputs (iports, wrappers, idsI) <- unzip3 <$> mapM mkTopInstInput (catMaybes (et_inputs annM)) - let inpAssigns = zipWith Assignment idsI (map fst args) + inpAssigns <- zipWithM (\i e -> contAssign i e) idsI (fst <$> args) -- output let - iResult = inpAssigns ++ concat wrappers + iResult = inpAssigns : wrappers instLabel0 = Text.concat [topName, "_", Id.toText (fst dstId)] instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName @@ -1382,10 +1600,10 @@ case topOutputM of Nothing -> - pure (topDecl [] : iResult) + pure (topDecl [] : concat iResult) Just (oports, unwrappers, id0) -> do - let outpAssign = Assignment (fst dstId) (Identifier id0 Nothing) - pure (iResult ++ tickDecls ++ (topDecl oports:unwrappers) ++ [outpAssign]) + outpAssign <- contAssign (fst dstId) (Identifier id0 Nothing) + pure (concat iResult ++ tickDecls ++ (topDecl oports:unwrappers) ++ [outpAssign]) data InstancePort = InstancePort { ip_id :: Identifier @@ -1393,7 +1611,7 @@ -- arguments, so this doesn't hold a port name. , ip_type :: HWType -- ^ Type assigned to port - } + } deriving Show -- | Generate input port(s) associated with a single argument for an -- instantiation of a top entity. This function composes the input ports into @@ -1407,21 +1625,21 @@ pN' <- Id.next pN (decls, pN'', _bvExpr, hwty1) <- toPrimitiveType pN' hwty0 return ( [InstancePort pN'' hwty1] - , NetDecl Nothing pN' hwty0 : decls + , NetDecl' Nothing pN' hwty0 Nothing : decls , pN' ) mkTopInstInput epp@(ExpandedPortProduct pNameHint hwty0 ps) = do pName <- Id.makeBasic pNameHint + let pDecl = NetDecl' Nothing pName hwty0 Nothing let - pDecl = NetDecl Nothing pName hwty0 (attrs, hwty1) = stripAttributes hwty0 indexPN constr n = Identifier pName (Just (Indexed (hwty0, constr, n))) case hwty1 of Vector {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps - let assigns = zipWith Assignment ids (map (indexPN 10) [0..]) + let assigns = zipWith3 Assignment ids (repeat Cont) (map (indexPN 10) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else @@ -1429,7 +1647,7 @@ RTree {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps - let assigns = zipWith Assignment ids (map (indexPN 10) [0..]) + let assigns = zipWith3 Assignment ids (repeat Cont) (map (indexPN 10) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else @@ -1437,7 +1655,7 @@ Product {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps - let assigns = zipWith Assignment ids (map (indexPN 0) [0..]) + let assigns = zipWith3 Assignment ids (repeat Cont) (map (indexPN 0) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else @@ -1459,8 +1677,8 @@ , 0 ) assigns = - [ Assignment conId (Identifier pName (Just conIx)) - , Assignment elId (FromBv Nothing elTy (Identifier pName (Just elIx))) ] + [ Assignment conId Cont (Identifier pName (Just conIx)) + , Assignment elId Cont (FromBv Nothing elTy (Identifier pName (Just elIx))) ] return (concat ports, pDecl:assigns ++ concat decls, pName) _ -> error "Internal error: Unexpected error for PortProduct" @@ -1503,19 +1721,18 @@ mkTopInstOutput (ExpandedPortName hwty0 portName) = do assignName0 <- Id.next portName (decls, assignName1, _expr, hwty1) <- fromPrimitiveType assignName0 hwty0 - return ( [InstancePort assignName0 hwty1] - , NetDecl Nothing assignName0 hwty1 : decls - , assignName1 ) + let net = NetDecl' Nothing assignName0 hwty1 Nothing + return ([InstancePort assignName0 hwty1], net : decls, assignName1) mkTopInstOutput epp@(ExpandedPortProduct productNameHint hwty ps) = do pName <- Id.makeBasic productNameHint - let pDecl = NetDecl Nothing pName hwty - (attrs, hwty') = stripAttributes hwty + let pDecl = NetDecl' Nothing pName hwty Nothing + let (attrs, hwty') = stripAttributes hwty case hwty' of Vector sz hwty'' -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 - netassgn = Assignment pName (mkVectorChain sz hwty'' ids1) + netassgn = Assignment pName Cont (mkVectorChain sz hwty'' ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else @@ -1524,7 +1741,7 @@ RTree d hwty'' -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 - netassgn = Assignment pName (mkRTreeChain d hwty'' ids1) + netassgn = Assignment pName Cont (mkRTreeChain d hwty'' ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else @@ -1533,7 +1750,7 @@ Product {} -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 - netassgn = Assignment pName (DataCon hwty (DC (hwty,0)) ids1) + netassgn = Assignment pName Cont (DataCon hwty (DC (hwty,0)) ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else @@ -1545,7 +1762,7 @@ ids2 = case ids1 of [conId, elId] -> [conId, ToBv Nothing elTy elId] _ -> error "Unexpected error for PortProduct" - netassgn = Assignment pName (DataCon hwty (DC (BitVector (typeSize hwty),0)) ids2) + netassgn = Assignment pName Cont (DataCon hwty (DC (BitVector (typeSize hwty),0)) ids2) return (concat ports, pDecl:netassgn:concat decls, pName) _ -> @@ -1689,14 +1906,14 @@ -- | Errors 'expandTopEntity' might yield data ExpandError -- | Synthesis attributes are not supported on PortProducts - = AttrError [Attr'] + = AttrError [Attr Text] -- | Something was annotated as being a PortProduct, but wasn't one | PortProductError PortName HWType -- | Same as 'expandTopEntity', but also adds identifiers to the identifier -- set of the monad. expandTopEntityOrErrM - :: (HasCallStack, IdentifierSetMonad m) + :: HasCallStack => [(Maybe Id, FilteredHWType)] -- ^ Arguments. Ids are used as name hints. -> (Maybe Id, FilteredHWType) @@ -1704,36 +1921,13 @@ -> Maybe TopEntity -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/ -- was passed. - -> m (ExpandedTopEntity Identifier) + -> NetlistMonad (ExpandedTopEntity Identifier) -- ^ Either some error (see "ExpandError") or and expanded top entity. All -- identifiers in the expanded top entity will be added to NetlistState's -- IdentifierSet. expandTopEntityOrErrM ihwtys ohwty topM = do is <- identifierSetM id - let ett = expandTopEntityOrErr is ihwtys ohwty topM - Id.addMultiple (toList ett) - pure ett --- | Take a top entity and /expand/ its port names. I.e., make sure that every --- port that should be generated in the HDL is part of the data structure. -expandTopEntityOrErr - :: HasCallStack - => IdentifierSet - -- ^ Settings of this IdentifierSet will be used to generate valid - -- identifiers. Note that the generated identifiers are /not/ guaranteed to be - -- unique w.r.t. this set. - -> [(Maybe Id, FilteredHWType)] - -- ^ Arguments. Ids are used as name hints. - -> (Maybe Id, FilteredHWType) - -- ^ Result. Id is used as name hint. - -> Maybe TopEntity - -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/ - -- was passed. - -> ExpandedTopEntity Identifier - -- ^ Either some error (see "ExpandError") or and expanded top entity. All - -- identifiers in the expanded top entity will be added to NetlistState's - -- IdentifierSet. -expandTopEntityOrErr is ihwtys ohwty topM = do case expandTopEntity ihwtys ohwty topM of Left (AttrError attrs) -> (error [I.i| @@ -1754,8 +1948,10 @@ is not a product! |]) - Right eTop -> - evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is) + Right eTop -> do + let ete = evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is) + Id.addMultiple (toList ete) + pure ete -- | Take a top entity and /expand/ its port names. I.e., make sure that every -- port that should be generated in the HDL is part of the data structure. It @@ -1773,13 +1969,13 @@ -- expanded top entity in turn contains an Either too. /Left/ means that -- the name was supplied by the user and should be inserted at verbatim, -- /Right/ is a name generated by Clash. -expandTopEntity ihwtys (oId, ohwty) topEntityM = do +expandTopEntity ihwtys (oId, ohwty) topEntityM + | Synthesize {..} <- fromMaybe (defSyn (error $(curLoc))) topEntityM = do -- TODO 1: Check sizes against number of PortProduct fields -- TODO 2: Warn about duplicate fields let - Synthesize{..} = fromMaybe (defSyn (error $(curLoc))) topEntityM - argHints = map (maybe "arg" (Id.toText . id2identifier) . fst) ihwtys - resHint = maybe "result" (Id.toText . id2identifier) oId + argHints = map (maybe "arg" (Id.toText . Id.unsafeFromCoreId) . fst) ihwtys + resHint = maybe "result" (Id.toText . Id.unsafeFromCoreId) oId inputs <- zipWith3M goInput argHints (map snd ihwtys) (extendPorts t_inputs) @@ -1917,3 +2113,6 @@ where (attrs, hwty1) = stripAttributes hwty0 hints = map (\i -> hint <> "_" <> showt i) [(0::Int)..] + +expandTopEntity _ _ topEntityM = + error ("expandTopEntity expects a Synthesize annotation, but got: " <> show topEntityM) diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -37,11 +37,7 @@ import Data.Text.Prettyprint.Doc (vcat) #endif -#if MIN_VERSION_ghc(9,0,0) -import GHC.Types.Basic (InlineSpec (..)) -#else -import BasicTypes (InlineSpec (..)) -#endif +import GHC.BasicTypes.Extra (isNoInline) import Clash.Annotations.BitRepresentation.Internal (CustomReprs) @@ -75,7 +71,8 @@ import Clash.Normalize.Transformations import Clash.Normalize.Types import Clash.Normalize.Util -import Clash.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) +import Clash.Rewrite.Combinators + ((>->), (!->), bottomupR, repeatR, topdownR) import Clash.Rewrite.Types (RewriteEnv (..), RewriteState (..), bindings, debugOpts, extra, tcCache, topEntities, newInlineStrategy) @@ -298,7 +295,7 @@ flattenNode :: CallTree -> NormalizeSession (Either CallTree ((Id,Term),[CallTree])) -flattenNode c@(CLeaf (_,(Binding _ _ NoInline _ _ _))) = return (Left c) +flattenNode c@(CLeaf (_,(Binding _ _ spec _ _ _))) | isNoInline spec = return (Left c) flattenNode c@(CLeaf (nm,(Binding _ _ _ _ e _))) = do isTopEntity <- elemVarSet nm <$> Lens.view topEntities if isTopEntity then return (Left c) else do @@ -312,7 +309,7 @@ return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),[])) _ -> return (Right ((nm,e),[])) _ -> return (Right ((nm,e),[])) -flattenNode b@(CBranch (_,(Binding _ _ NoInline _ _ _)) _) = +flattenNode b@(CBranch (_,(Binding _ _ spec _ _ _)) _) | isNoInline spec = return (Left b) flattenNode b@(CBranch (nm,(Binding _ _ _ _ e _)) us) = do isTopEntity <- elemVarSet nm <$> Lens.view topEntities @@ -366,7 +363,7 @@ -- inline all components when the resulting expression after flattening -- is still considered "cheap". This happens often at the topEntity which -- wraps another functions and has some selectors and data-constructors. - if inl /= NoInline && isCheapFunction newExpr + if not (isNoInline inl) && isCheapFunction newExpr then do let (toInline',allUsed') = unzip (map goCheap allUsed) subst' = extendGblSubstList (mkSubst emptyInScopeSet) @@ -382,15 +379,15 @@ apply "caseCon" caseCon >-> (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >-> apply "reduceNonRepPrim" reduceNonRepPrim >-> - apply "removeUnusedExpr" removeUnusedExpr >-> - apply "flattenLet" flattenLet)) !-> + apply "removeUnusedExpr" removeUnusedExpr) >-> + bottomupR (apply "flattenLet" flattenLet)) !-> topdownSucR (apply "topLet" topLet) goCheap c@(CLeaf (nm2,(Binding _ _ inl2 _ e _))) - | inl2 == NoInline = (Nothing ,[c]) + | isNoInline inl2 = (Nothing ,[c]) | otherwise = (Just (nm2,e),[]) goCheap c@(CBranch (nm2,(Binding _ _ inl2 _ e _)) us) - | inl2 == NoInline = (Nothing, [c]) + | isNoInline inl2 = (Nothing, [c]) | otherwise = (Just (nm2,e),us) callTreeToList :: [Id] -> CallTree -> ([Id], [(Id, Binding Term)]) diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs --- a/src/Clash/Normalize/PrimitiveReductions.hs +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -40,10 +40,14 @@ import qualified Control.Lens as Lens import Control.Lens ((.=)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Bifunctor (second) import Data.List (mapAccumR) import Data.List.Extra (zipEqual) +import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe +import Data.Semigroup (sconcat) import Data.Text.Extra (showt) import GHC.Stack (HasCallStack) @@ -82,14 +86,13 @@ (appendToVec, extractElems, extractTElems, mkRTree, mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys, primCo) import Clash.Core.Var (mkTyVar, mkLocalId) -import Clash.Core.VarEnv - (InScopeSet, extendInScopeSetList) +import Clash.Core.VarEnv (extendInScopeSetList) +import qualified Clash.Data.UniqMap as UniqMap import qualified Clash.Normalize.Primitives as NP (undefined) import {-# SOURCE #-} Clash.Normalize.Strategy import Clash.Normalize.Types import Clash.Rewrite.Types import Clash.Rewrite.Util -import Clash.Unique import Clash.Util import qualified Clash.Util.Interpolate as I @@ -177,25 +180,28 @@ -> Type -- ^ Element type -> Integer - -- ^ Length of the vector + -- ^ Length of the vector, must be positive -> Term -- ^ Vector to extract head from -> (Term, Term) -- ^ (head of vector, tail of vector) extractHeadTail consCon elTy n vec = - ( Case vec elTy [(pat, Var el)] - , Case vec restTy [(pat, Var rest)] ) + case dataConInstArgTys consCon tys of + Just [coTy, _elTy, restTy] -> + let + mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0) + co = mkLocalId coTy (mkUnsafeSystemName "_co_" 1) + el = mkLocalId elTy (mkUnsafeSystemName "el" 2) + rest = mkLocalId restTy (mkUnsafeSystemName "res" 3) + + pat = DataPat consCon [mTV] [co, el, rest] + in + ( Case vec elTy [(pat, Var el)] + , Case vec restTy [(pat, Var rest)] ) + _ -> error "extractHeadTail: failed to instantiate Cons DC" where tys = [(LitTy (NumTy n)), elTy, (LitTy (NumTy (n-1)))] - Just [coTy, _elTy, restTy] = dataConInstArgTys consCon tys - mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0) - co = mkLocalId coTy (mkUnsafeSystemName "_co_" 1) - el = mkLocalId elTy (mkUnsafeSystemName "el" 2) - rest = mkLocalId restTy (mkUnsafeSystemName "res" 3) - - pat = DataPat consCon [mTV] [co, el, rest] - -- | Create a vector of supplied elements mkVecCons :: HasCallStack @@ -212,17 +218,16 @@ -> Term mkVecCons consCon resTy n h t | n <= 0 = error "mkVecCons: n <= 0" - | otherwise = - mkApps (Data consCon) [ Right (LitTy (NumTy n)) - , Right resTy - , Right (LitTy (NumTy (n-1))) - , Left (primCo consCoTy) - , Left h - , Left t ] - - where - args = dataConInstArgTys consCon [LitTy (NumTy n), resTy, LitTy (NumTy (n-1))] - Just (consCoTy : _) = args + | otherwise + = case dataConInstArgTys consCon [LitTy (NumTy n), resTy, LitTy (NumTy (n-1))] of + Just (consCoTy : _) -> + mkApps (Data consCon) [ Right (LitTy (NumTy n)) + , Right resTy + , Right (LitTy (NumTy (n-1))) + , Left (primCo consCoTy) + , Left h + , Left t ] + _ -> error "mkVecCons: failed to instantiate Cons DC" -- | Create an empty vector mkVecNil @@ -231,42 +236,41 @@ -> Type -- ^ The element type -> Term -mkVecNil nilCon resTy = - mkApps (Data nilCon) [ Right (LitTy (NumTy 0)) - , Right resTy - , Left (primCo nilCoTy) ] - where - args = dataConInstArgTys nilCon [LitTy (NumTy 0), resTy] - Just (nilCoTy : _ ) = args +mkVecNil nilCon resTy = case dataConInstArgTys nilCon [LitTy (NumTy 0), resTy] of + Just (nilCoTy : _) -> + mkApps (Data nilCon) [ Right (LitTy (NumTy 0)) + , Right resTy + , Left (primCo nilCoTy) ] + _ -> error "mkVecNil: failed to instantiate Nil DC" -- | Replace an application of the @Clash.Sized.Vector.reverse@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.reverse@ reduceReverse - :: InScopeSet - -> Integer - -- ^ Length of the vector + :: Integer + -- ^ Length of the vector, must be positive -> Type -- ^ Element of type of the vector -> Term -- ^ The vector to reverse + -> TransformContext -> NormalizeSession Term -reduceReverse inScope0 n elTy vArg = do +reduceReverse n elTy vArg (TransformContext inScope0 _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm vArg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | Just vecTc <- lookupUniqMap vecTcNm tcm + | Just vecTc <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon, consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(vars,elems)) = second (second concat . unzip) + let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope0 consCon elTy 'V' n vArg - lbody = mkVec nilCon consCon elTy n (reverse vars) - lb = Letrec (init elems) lbody + lbody = mkVec nilCon consCon elTy n (reverse (NE.toList vars)) + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceReverse: argument does not have a vector type: " ++ showPpr ty @@ -275,8 +279,7 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.zipWith@ reduceZipWith - :: TransformContext - -> PrimInfo -- ^ zipWith primitive info + :: PrimInfo -- ^ zipWith primitive info -> Integer -- ^ Length of the vector(s) -> Type -- ^ Element type of the lhs of the function -> Type -- ^ Element type of the rhs of the function @@ -284,14 +287,15 @@ -> Term -- ^ The zipWith'd functions -> Term -- ^ The 1st vector argument -> Term -- ^ The 2nd vector argument + -> TransformContext -> NormalizeSession Term -reduceZipWith _ctx zipWithPrimInfo n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do +reduceZipWith zipWithPrimInfo n lhsElTy rhsElTy resElTy fun lhsArg rhsArg _ctx = do tcm <- Lens.view tcCache changed (go tcm (inferCoreTypeOf tcm lhsArg)) where go tcm (coreView1 tcm -> Just ty) = go tcm ty go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon, consCon] <- tyConDataCons vecTc = if n == 0 then @@ -321,22 +325,22 @@ -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.map@ reduceMap - :: TransformContext - -> PrimInfo -- ^ map primitive info + :: PrimInfo -- ^ map primitive info -> Integer -- ^ Length of the vector -> Type -- ^ Argument type of the function -> Type -- ^ Result type of the function -> Term -- ^ The map'd function -> Term -- ^ The map'd over vector + -> TransformContext -> NormalizeSession Term -reduceMap _ctx mapPrimInfo n argElTy resElTy fun arg = do +reduceMap mapPrimInfo n argElTy resElTy fun arg _ctx = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg changed (go tcm ty) where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = if n == 0 then @@ -364,21 +368,22 @@ -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.imap@ reduceImap - :: TransformContext - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Argument type of the function -> Type -- ^ Result type of the function + -> Term -- ^ Lenght of the vector (as a KnownNat) -> Term -- ^ The imap'd function -> Term -- ^ The imap'd over vector + -> TransformContext -> NormalizeSession Term -reduceImap (TransformContext is0 ctx) n argElTy resElTy fun arg = do +reduceImap n argElTy resElTy _kn fun arg (TransformContext is0 ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = do @@ -386,10 +391,12 @@ fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun let is1 = extendInScopeSetList is0 (collectTermIds fun1) (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind) - (uniqs2,(vars,elems)) = second (second concat . unzip) + (uniqs2,(vars,elems)) = second (second sconcat . NE.unzip) $ uncurry extractElems uniqs1 consCon argElTy 'I' n arg - (Right idxTy:_,_) = splitFunForallTy (inferCoreTypeOf tcm fun) - (TyConApp idxTcNm _) = tyView idxTy + idxTcNm = Maybe.fromMaybe (error "reduceImap: failed to create Index TC") $ do + (Right idxTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm fun)) + TyConApp nm _ <- pure (tyView idxTy) + return nm -- fromInteger# :: KnownNat n => Integer -> Index n idxFromIntegerTy = ForAllTy nTv (foldr mkFunTy @@ -400,9 +407,9 @@ idxs = map (App (App (TyApp idxFromInteger (LitTy (NumTy n))) (Literal (IntegerLiteral (toInteger n)))) . Literal . IntegerLiteral . toInteger) [0..(n-1)] - funApps = zipWith (\i v -> App (App fun1 i) v) idxs vars + funApps = zipWith (\i v -> App (App fun1 i) v) idxs (NE.toList vars) lbody = mkVec nilCon consCon resElTy n funApps - lb = Letrec (init elems) lbody + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs2 changed lb go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showPpr ty @@ -411,20 +418,22 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.iterateI@ reduceIterateI - :: TransformContext - -> Integer + :: Integer -- ^ Length of vector -> Type -- ^ Vector's element type -> Type -- ^ Vector's type -> Term + -- ^ Length of the vector (as a KnownNat) + -> Term -- ^ iterateI's HO-function argument -> Term -- ^ iterateI's start value + -> TransformContext -> RewriteMonad NormalizeState Term -- ^ Fully unrolled definition -reduceIterateI (TransformContext is0 ctx) n aTy vTy f0 a = do +reduceIterateI n aTy vTy _kn f0 a (TransformContext is0 ctx) = do tcm <- Lens.view tcCache f1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) f0 @@ -440,11 +449,12 @@ uniqSupply .= uniqs1 let - TyConApp vecTcNm _ = tyView vTy - Just vecTc = lookupUniqMap vecTcNm tcm - [nilCon, consCon] = tyConDataCons vecTc elems = map (App f1) (a:map Var elementIds) - vec = mkVec nilCon consCon aTy n (take (fromInteger n) (a:map Var elementIds)) + vec = Maybe.fromMaybe (error "reduceIterateI: failed to create Vec DCs") $ do + TyConApp vecTcNm _ <- pure (tyView vTy) + vecTc <- UniqMap.lookup vecTcNm tcm + [nilCon, consCon] <- pure (tyConDataCons vecTc) + return (mkVec nilCon consCon aTy n (take (fromInteger n) (a:map Var elementIds))) -- Result: -- let @@ -461,84 +471,86 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.traverse#@ reduceTraverse - :: TransformContext - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the argument vector -> Type -- ^ The type of the applicative -> Type -- ^ Element type of the result vector -> Term -- ^ The @Applicative@ dictionary -> Term -- ^ The function to traverse with -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceTraverse (TransformContext is0 ctx) n aTy fTy bTy dict fun arg = do +reduceTraverse n aTy fTy bTy dict fun arg (TransformContext is0 ctx) = do tcm <- Lens.view tcCache - let (TyConApp apDictTcNm _) = tyView (inferCoreTypeOf tcm dict) - ty = inferCoreTypeOf tcm arg - go tcm apDictTcNm ty + case tyView (inferCoreTypeOf tcm dict) of + TyConApp apDictTcNm _ -> + let ty = inferCoreTypeOf tcm arg + in go tcm apDictTcNm ty + t -> error ("reduceTraverse: expected a TC, but got: " <> show t) where go tcm apDictTcNm (coreView1 tcm -> Just ty') = go tcm apDictTcNm ty' go tcm apDictTcNm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc - = do - uniqs0 <- Lens.use uniqSupply - fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let is1 = extendInScopeSetList is0 (collectTermIds fun1) - (Just apDictTc) = lookupUniqMap apDictTcNm tcm - [apDictCon] = tyConDataCons apDictTc - (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] - (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_,_]) = - mapAccumR mkUniqInternalId (uniqs0,is1) - (zipEqual ["functorDict","pure","ap","liftA2","apConstL","apConstR"] - apDictIdTys) + = fmap (Maybe.fromMaybe (error "reduceTraverse: failed to build")) $ runMaybeT $ do + uniqs0 <- Lens.use uniqSupply + fun1 <- lift (constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun) + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + apDictTc <- hoistMaybe (UniqMap.lookup apDictTcNm tcm) + apDictCon <- hoistMaybe (Maybe.listToMaybe (tyConDataCons apDictTc)) + apDictIdTys <- hoistMaybe (dataConInstArgTys apDictCon [fTy]) + (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_,_]) <- pure $ + mapAccumR mkUniqInternalId (uniqs0,is1) + (zipEqual ["functorDict","pure","ap","liftA2","apConstL","apConstR"] + apDictIdTys) - (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) - (Just funcDictTc) = lookupUniqMap funcDictTcNm tcm - [funcDictCon] = tyConDataCons funcDictTc - (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy] - (uniqs2,funcDicIds@[fmapId,_]) = - mapAccumR mkUniqInternalId uniqs1 - (zipEqual ["fmap","fmapConst"] funcDictIdTys) + TyConApp funcDictTcNm _ <- hoistMaybe (tyView <$> Maybe.listToMaybe apDictIdTys) + funcDictTc <- hoistMaybe (UniqMap.lookup funcDictTcNm tcm) + funcDictCon <- hoistMaybe (Maybe.listToMaybe (tyConDataCons funcDictTc)) + funcDictIdTys <- hoistMaybe (dataConInstArgTys funcDictCon [fTy]) + (uniqs2,funcDicIds@[fmapId,_]) <- pure $ + mapAccumR mkUniqInternalId uniqs1 + (zipEqual ["fmap","fmapConst"] funcDictIdTys) - apPat = DataPat apDictCon [] apDictIds - fnPat = DataPat funcDictCon [] funcDicIds + let apPat = DataPat apDictCon [] apDictIds + fnPat = DataPat funcDictCon [] funcDicIds - -- Extract the 'pure' function from the Applicative dictionary - pureTy = coreTypeOf pureId - pureTm = Case dict pureTy [(apPat,Var pureId)] + -- Extract the 'pure' function from the Applicative dictionary + pureTy = coreTypeOf pureId + pureTm = Case dict pureTy [(apPat,Var pureId)] - -- Extract the '<*>' function from the Applicative dictionary - apTy = coreTypeOf apId - apTm = Case dict apTy [(apPat, Var apId)] + -- Extract the '<*>' function from the Applicative dictionary + apTy = coreTypeOf apId + apTm = Case dict apTy [(apPat, Var apId)] - -- Extract the Functor dictionary from the Applicative dictionary - funcTy = coreTypeOf functorDictId - funcTm = Case dict funcTy - [(apPat,Var functorDictId)] + -- Extract the Functor dictionary from the Applicative dictionary + funcTy = coreTypeOf functorDictId + funcTm = Case dict funcTy + [(apPat,Var functorDictId)] - -- Extract the 'fmap' function from the Functor dictionary - fmapTy = coreTypeOf fmapId - fmapTm = Case (Var functorDictId) fmapTy - [(fnPat, Var fmapId)] + -- Extract the 'fmap' function from the Functor dictionary + fmapTy = coreTypeOf fmapId + fmapTm = Case (Var functorDictId) fmapTy + [(fnPat, Var fmapId)] - (uniqs3,(vars,elems)) = second (second concat . unzip) - $ uncurry extractElems uniqs2 consCon aTy 'T' n arg + (uniqs3,(vars,elems)) = second (second sconcat . NE.unzip) + $ uncurry extractElems uniqs2 consCon aTy 'T' n arg - funApps = map (fun1 `App`) vars + funApps = map (fun1 `App`) (NE.toList vars) - lbody = mkTravVec vecTcNm nilCon consCon (Var (apDictIds!!1)) - (Var (apDictIds!!2)) - (Var (funcDicIds!!0)) - bTy n funApps + lbody = mkTravVec vecTcNm nilCon consCon (Var (apDictIds!!1)) + (Var (apDictIds!!2)) + (Var (funcDicIds!!0)) + bTy n funApps - lb = Letrec ([((apDictIds!!0), funcTm) - ,((apDictIds!!1), pureTm) - ,((apDictIds!!2), apTm) - ,((funcDicIds!!0), fmapTm) - ] ++ init elems) lbody - uniqSupply Lens..= uniqs3 - changed lb + lb = Letrec ([((apDictIds!!0), funcTm) + ,((apDictIds!!1), pureTm) + ,((apDictIds!!2), apTm) + ,((funcDicIds!!0), fmapTm) + ] ++ NE.init elems) lbody + uniqSupply Lens..= uniqs3 + lift (changed lb) go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showPpr ty -- | Create the traversable vector @@ -580,20 +592,22 @@ ,Left x]) ,Left (go (n-1) xs)] - nilCoTy = head (Maybe.fromJust (dataConInstArgTys nilCon [(LitTy (NumTy 0)) - ,bTy])) + nilCoTy = case dataConInstArgTys nilCon [(LitTy (NumTy 0)), bTy] of + Just (x:_) -> x + _ -> error "impossible" - consCoTy n = head (Maybe.fromJust (dataConInstArgTys consCon - [(LitTy (NumTy n)) - ,bTy - ,(LitTy (NumTy (n-1)))])) + consCoTy n = case dataConInstArgTys consCon + [(LitTy (NumTy n)) + ,bTy + ,(LitTy (NumTy (n-1)))] of + Just (x:_) -> x + _ -> error "impossible" -- | Replace an application of the @Clash.Sized.Vector.foldr@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.foldr@ reduceFoldr - :: TransformContext - -> PrimInfo + :: PrimInfo -- ^ Primitive info for foldr blackbox -> Integer -- ^ Length of the vector @@ -605,9 +619,10 @@ -- ^ The starting value -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceFoldr _ _ 0 _ _ start _ = changed start -reduceFoldr _ctx foldrPrimInfo n aTy fun start arg = do +reduceFoldr _ 0 _ _ start _ _ = changed start +reduceFoldr foldrPrimInfo n aTy fun start arg _ctx = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg changed (go tcm ty) @@ -615,7 +630,7 @@ go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) | nameOcc vecTcNm == "Clash.Sized.Vector.Vec" - , Just vecTc <- lookupUniqMap vecTcNm tcm + , Just vecTc <- UniqMap.lookup vecTcNm tcm , [_nilCon, consCon] <- tyConDataCons vecTc = let (a, as) = extractHeadTail consCon aTy n arg @@ -639,34 +654,34 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.fold@ reduceFold - :: TransformContext - -> Integer - -- ^ Length of the vector + :: Integer + -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the argument vector -> Term -- ^ The function to fold with -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceFold (TransformContext is0 ctx) n aTy fun arg = do +reduceFold n aTy fun arg (TransformContext is0 ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun let is1 = extendInScopeSetList is0 (collectTermIds fun1) - (uniqs1,(vars,elems)) = second (second concat . unzip) + (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 is1 consCon aTy 'F' n arg - lbody = foldV fun1 vars - lb = Letrec (init elems) lbody + lbody = foldV fun1 (NE.toList vars) + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showPpr ty @@ -681,27 +696,31 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.dfold@ reduceDFold - :: InScopeSet - -> Integer + :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Term + -- ^ Length of the vector (as a KnownNat) + -> Term + -- ^ The motive + -> Term -- ^ Function to fold with -> Term -- ^ Starting value -> Term -- ^ The vector to fold + -> TransformContext -> NormalizeSession Term -reduceDFold _ 0 _ _ start _ = changed start -reduceDFold is0 n aTy fun start arg = do +reduceDFold 0 _ _ _ _ start _ _ = changed start +reduceDFold n aTy _kn _motive fun start arg (TransformContext is0 _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do @@ -709,14 +728,15 @@ let is1 = extendInScopeSetList is0 (collectTermIds fun) -- TODO: Should 'constantPropagation' be used on 'fun'? It seems to -- TOOD: be used for every other function in this module. - (uniqs1,(vars,elems)) = second (second concat . unzip) + (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 is1 consCon aTy 'D' n arg - (_ltv:Right snTy:_,_) = splitFunForallTy (inferCoreTypeOf tcm fun) - (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = lookupUniqMap snatTcNm tcm - [snatDc] = tyConDataCons snatTc - lbody = doFold (buildSNat snatDc) (n-1) vars - lb = Letrec (init elems) lbody + snatDc = Maybe.fromMaybe (error "reduceDFold: faild to build SNat") $ do + (_ltv:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm fun)) + (TyConApp snatTcNm _) <- pure (tyView snTy) + snatTc <- UniqMap.lookup snatTcNm tcm + Maybe.listToMaybe (tyConDataCons snatTc) + lbody = doFold (buildSNat snatDc) (n-1) (NE.toList vars) + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showPpr ty @@ -733,26 +753,26 @@ -- vectors of a known length @n@, by a projection of the first element of a -- vector. reduceHead - :: InScopeSet - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceHead inScope n aTy vArg = do +reduceHead n aTy vArg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm vArg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(vars,elems)) = second (second concat . unzip) + let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'H' n vArg - lb = Letrec [head elems] (head vars) + lb = Letrec [NE.head elems] (NE.head vars) uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showPpr ty @@ -761,26 +781,26 @@ -- vectors of a known length @n@, by a projection of the tail of a -- vector. reduceTail - :: InScopeSet - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceTail inScope n aTy vArg = do +reduceTail n aTy vArg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm vArg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(_,elems)) = second (second concat . unzip) + let (uniqs1,(_,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'L' n vArg - b@(tB,_) = elems !! 1 + b@(tB,_) = elems NE.!! 1 lb = Letrec [b] (Var tB) uniqSupply Lens..= uniqs1 changed lb @@ -790,50 +810,50 @@ -- vectors of a known length @n@, by a projection of the last element of a -- vector. reduceLast - :: InScopeSet - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceLast inScope n aTy vArg = do +reduceLast n aTy vArg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm vArg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(_,elems)) = second unzip + let (uniqs1,(_,elems)) = second NE.unzip $ extractElems uniqs0 inScope consCon aTy 'L' n vArg - (tB,_) = head (last elems) + (tB,_) = NE.head (NE.last elems) uniqSupply Lens..= uniqs1 case n of 0 -> changed (TyApp (Prim NP.undefined) aTy) - _ -> changed (Letrec (init (concat elems)) (Var tB)) + _ -> changed (Letrec (NE.init (sconcat elems)) (Var tB)) go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.init@ primitive on -- vectors of a known length @n@, by a projection of the init of a -- vector. reduceInit - :: InScopeSet - -> PrimInfo -- ^ Primitive info for 'init' + :: PrimInfo -- ^ Primitive info for 'init' -> Integer -- ^ Length of the vector -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector + -> TransformContext -> NormalizeSession Term -reduceInit _inScope initPrimInfo n aTy vArg = do +reduceInit initPrimInfo n aTy vArg _ctx = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm vArg changed (go tcm ty) where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon, consCon] <- tyConDataCons vecTc = if n == 0 then @@ -857,29 +877,31 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.(++)@ reduceAppend - :: InScopeSet - -> Integer -- ^ Length of the LHS arg + :: Integer -- ^ Length of the LHS arg -> Integer -- ^ Lenght of the RHS arg -> Type -- ^ Element type of the vectors -> Term -- ^ The LHS argument -> Term -- ^ The RHS argument + -> TransformContext -> NormalizeSession Term -reduceAppend inScope n m aTy lArg rArg = do +reduceAppend 0 _ _ _ rArg _ = changed rArg +reduceAppend _ 0 _ lArg _ _ = changed lArg +reduceAppend n m aTy lArg rArg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm lArg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(vars,elems)) = second (second concat . unzip) + let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'C' n lArg - lbody = appendToVec consCon aTy rArg (n+m) vars - lb = Letrec (init elems) lbody + lbody = appendToVec consCon aTy rArg (n+m) (NE.toList vars) + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showPpr ty @@ -887,22 +909,23 @@ -- | Replace an application of the @Clash.Sized.Vector.unconcat@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.unconcat@ -reduceUnconcat :: InScopeSet - -> PrimInfo -- ^ Unconcat primitive info +reduceUnconcat :: PrimInfo -- ^ Unconcat primitive info -> Integer -- ^ Length of the result vector -> Integer -- ^ Length of the elements of the result vector -> Type -- ^ Element type + -> Term -- ^ Length of the result vector (as a KnownNat) -> Term -- ^ SNat "Length of the elements of the result vector" -> Term -- ^ Argument vector + -> TransformContext -> NormalizeSession Term -reduceUnconcat inScope unconcatPrimInfo n m aTy sm arg = do +reduceUnconcat unconcatPrimInfo n m aTy _kn sm arg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc , let innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy m), aTy] @@ -917,17 +940,19 @@ uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,headsAndTails)) = - second (second concat . unzip) + second (second sconcat . NE.unzip) (extractElems uniqs0 inScope consCon aTy 'U' (n*m) arg) -- Build a vector out of the first m elements - mvec = mkVec nilCon consCon aTy m (take (fromInteger m) vars) + mvec = mkVec nilCon consCon aTy m (NE.take (fromInteger m) vars) -- Get the vector representing the next ((n-1)*m) elements -- N.B. `extractElems (xs :: Vec 2 a)` creates: -- x0 = head xs -- xs0 = tail xs -- x1 = head xs0 -- xs1 = tail xs0 - (lbs,head -> nextVec) = splitAt ((2*fromInteger m)-1) headsAndTails + (lbs,nextVec) = case NE.splitAt ((2*fromInteger m)-1) headsAndTails of + (xs,y:_) -> (xs,y) + _ -> error "impossible" -- recursively call unconcat nextUnconcat = mkApps (Prim unconcatPrimInfo) [ Right (LitTy (NumTy (n-1))) @@ -952,16 +977,18 @@ reduceTranspose :: Integer -- ^ Length of the result vector -> Integer -- ^ Length of the elements of the result vector -> Type -- ^ Element type + -> Term -- ^ Lenght of the result vector (as a KnownNat) -> Term -- ^ Argument vector + -> TransformContext -> NormalizeSession Term -reduceTranspose n 0 aTy arg = do +reduceTranspose n 0 aTy _kn arg _ctx = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = let nilVec = mkVec nilCon consCon aTy 0 [] @@ -970,20 +997,22 @@ in changed retVec go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showPpr ty -reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" +reduceTranspose _ _ _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" reduceReplicate :: Integer -> Type -> Type -> Term + -> Term + -> TransformContext -> NormalizeSession Term -reduceReplicate n aTy eTy arg = do +reduceReplicate n aTy eTy _sn arg _ctx = do tcm <- Lens.view tcCache go tcm eTy where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg) @@ -995,21 +1024,23 @@ -- TODO: Clash will eliminate one-by-one if the index turned out to be literal. -- TODO: It would of course be best to not create the cases in the first place! reduceReplace_int - :: InScopeSet - -> Integer - -- ^ Size of vector + :: Integer + -- ^ Size of vector, must be positive -> Type -- ^ Type of vector element -> Type -- ^ Type of vector -> Term + -- ^ Size of vector (as a KnownNat) + -> Term -- ^ Vector -> Term -- ^ Index -> Term -- ^ Element + -> TransformContext -> NormalizeSession Term -reduceReplace_int is0 n aTy vTy v i newA = do +reduceReplace_int n aTy vTy _kn v i newA (TransformContext is0 _ctx) = do tcm <- Lens.view tcCache go tcm vTy where @@ -1040,17 +1071,18 @@ -> Term replace_intElement tcm iDc iTy oldA elIndex = case0 where - (Just boolTc) = lookupUniqMap (getKey boolTyConKey) tcm - [_,trueDc] = tyConDataCons boolTc - eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) - case0 = Case (mkApps eqInt [Left i - ,Left (mkApps (Data iDc) - [Left (Literal (IntLiteral elIndex))]) - ]) - aTy - [(DefaultPat, oldA) - ,(DataPat trueDc [] [], newA) - ] + case0 = Maybe.fromMaybe (error "replace_intElement: faild to build Truce DC") $ do + boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm + [_,trueDc] <- pure (tyConDataCons boolTc) + let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) + return (Case (mkApps eqInt [ Left i + , Left (mkApps (Data iDc) + [Left (Literal (IntLiteral elIndex))]) + ]) + aTy + [ (DefaultPat, oldA) + , (DataPat trueDc [] [], newA) + ]) -- Equality on lifted Int that returns a Bool eqIntPrim @@ -1067,19 +1099,20 @@ go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = do -- Get data constructors of 'Int' uniqs0 <- Lens.use uniqSupply let iTy = inferCoreTypeOf tcm i - (TyConApp iTcNm _) = tyView iTy - (Just iTc) = lookupUniqMap iTcNm tcm - [iDc] = tyConDataCons iTc + iDc = Maybe.fromMaybe (error "replace_intElement: faild to build Int DC") $ do + (TyConApp iTcNm _) <- pure (tyView iTy) + iTc <- UniqMap.lookup iTcNm tcm + Maybe.listToMaybe (tyConDataCons iTc) -- Get elements from vector - (uniqs1,(vars,elems)) = second (second concat . unzip) + (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 is0 @@ -1090,9 +1123,9 @@ v -- Replace every element with (if i == elIndex then newA else oldA) - let replacedEls = zipWith (replace_intElement tcm iDc iTy) vars [0..] + let replacedEls = zipWith (replace_intElement tcm iDc iTy) (NE.toList vars) [0..] lbody = mkVec nilCon consCon aTy n replacedEls - lb = Letrec (init elems) lbody + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceReplace_int: argument does not have " @@ -1103,17 +1136,19 @@ -- TODO: Clash will eliminate one-by-one if the index turned out to be literal. -- TODO: It would of course be best to not create the cases in the first place! reduceIndex_int - :: InScopeSet - -> Integer - -- ^ Size of vector + :: Integer + -- ^ Size of vector, must be positive -> Type -- ^ Type of vector element -> Term + -- ^ Size of vector (as a KnownNat) + -> Term -- ^ Vector -> Term -- ^ Index + -> TransformContext -> NormalizeSession Term -reduceIndex_int is0 n aTy v i = do +reduceIndex_int n aTy _kn v i (TransformContext is0 _ctx) = do tcm <- Lens.view tcCache let vTy = inferCoreTypeOf tcm v go tcm vTy @@ -1145,17 +1180,18 @@ -> Term index_intElement tcm iDc iTy (cur,elIndex) next = case0 where - (Just boolTc) = lookupUniqMap (getKey boolTyConKey) tcm - [_,trueDc] = tyConDataCons boolTc - eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) - case0 = Case (mkApps eqInt [Left i - ,Left (mkApps (Data iDc) - [Left (Literal (IntLiteral elIndex))]) - ]) - aTy - [(DefaultPat, next) - ,(DataPat trueDc [] [], cur) - ] + case0 = Maybe.fromMaybe (error "reduceIndex_int: faild to build True DC") $ do + boolTc <- UniqMap.lookup (getKey boolTyConKey) tcm + [_,trueDc] <- pure (tyConDataCons boolTc) + let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) []) + return (Case (mkApps eqInt [ Left i + , Left (mkApps (Data iDc) + [Left (Literal (IntLiteral elIndex))]) + ]) + aTy + [ (DefaultPat, next) + , (DataPat trueDc [] [], cur) + ]) -- Equality on lifted Int that returns a Bool eqIntPrim @@ -1172,19 +1208,20 @@ go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_nilCon,consCon] <- tyConDataCons vecTc = do -- Get data constructors of 'Int' uniqs0 <- Lens.use uniqSupply let iTy = inferCoreTypeOf tcm i - (TyConApp iTcNm _) = tyView iTy - (Just iTc) = lookupUniqMap iTcNm tcm - [iDc] = tyConDataCons iTc + iDc = Maybe.fromMaybe (error "reduceIndex_int: faild to build Int DC") $ do + (TyConApp iTcNm _) <- pure (tyView iTy) + iTc <- UniqMap.lookup iTcNm tcm + Maybe.listToMaybe (tyConDataCons iTc) -- Get elements from vector - (uniqs1,(vars,elems)) = second (second concat . unzip) + (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 is0 @@ -1197,8 +1234,8 @@ -- Build a right-biased tree of case-expressions let indexed = foldr (index_intElement tcm iDc iTy) (TyApp (Prim NP.undefined) aTy) - (zip vars [0..]) - lb = Letrec (init elems) indexed + (zip (NE.toList vars) [0..]) + lb = Letrec (NE.init elems) indexed uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "indexReplace_int: argument does not have " @@ -1208,33 +1245,36 @@ -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.dtfold@ reduceDTFold - :: InScopeSet - -> Integer -- ^ Length of the vector + :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector + -> Term -- ^ Length of the vector (as a KnownNat) + -> Term -- ^ The motive -> Term -- ^ Function to convert elements with -> Term -- ^ Function to combine branches with -> Term -- ^ The vector to fold + -> TransformContext -> NormalizeSession Term -reduceDTFold inScope n aTy lrFun brFun arg = do +reduceDTFold n aTy _kn _motive lrFun brFun arg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) - | (Just vecTc) <- lookupUniqMap vecTcNm tcm + | (Just vecTc) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(vars,elems)) = second (second concat . unzip) + let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'T' (2^n) arg - (_ltv:Right snTy:_,_) = splitFunForallTy (inferCoreTypeOf tcm brFun) - (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = lookupUniqMap snatTcNm tcm - [snatDc] = tyConDataCons snatTc - lbody = doFold (buildSNat snatDc) (n-1) vars - lb = Letrec (init elems) lbody + snatDc = Maybe.fromMaybe (error "reduceDTFold: faild to build SNat") $ do + (_ltv:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm brFun)) + (TyConApp snatTcNm _) <- pure (tyView snTy) + snatTc <- UniqMap.lookup snatTcNm tcm + Maybe.listToMaybe (tyConDataCons snatTc) + lbody = doFold (buildSNat snatDc) (n-1) (NE.toList vars) + lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showPpr ty @@ -1256,31 +1296,34 @@ -- trees of a known depth @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.RTree.tdfold@ reduceTFold - :: InScopeSet - -> Integer -- ^ Depth of the tree + :: Integer -- ^ Depth of the tree -> Type -- ^ Element type of the argument tree + -> Term -- ^ Depth of the tree (as a KnownNat) + -> Term -- ^ The motive -> Term -- ^ Function to convert elements with -> Term -- ^ Function to combine branches with -> Term -- ^ The tree to fold + -> TransformContext -> NormalizeSession Term -reduceTFold inScope n aTy lrFun brFun arg = do +reduceTFold n aTy _kn _motive lrFun brFun arg (TransformContext inScope _ctx) = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm arg go tcm ty where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp treeTcNm _) - | (Just treeTc) <- lookupUniqMap treeTcNm tcm + | (Just treeTc) <- UniqMap.lookup treeTcNm tcm , nameOcc treeTcNm == "Clash.Sized.RTree.RTree" , [lrCon,brCon] <- tyConDataCons treeTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,elems)) = extractTElems uniqs0 inScope lrCon brCon aTy 'T' n arg - (_ltv:Right snTy:_,_) = splitFunForallTy (inferCoreTypeOf tcm brFun) - (TyConApp snatTcNm _) = tyView snTy - (Just snatTc) = lookupUniqMap snatTcNm tcm - [snatDc] = tyConDataCons snatTc + snatDc = Maybe.fromMaybe (error "reduceTFold: faild to build SNat") $ do + (_ltv:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm brFun)) + (TyConApp snatTcNm _) <- pure (tyView snTy) + snatTc <- UniqMap.lookup snatTcNm tcm + Maybe.listToMaybe (tyConDataCons snatTc) lbody = doFold (buildSNat snatDc) (n-1) vars - lb = Letrec elems lbody + lb = (Letrec elems lbody) uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showPpr ty @@ -1300,15 +1343,17 @@ reduceTReplicate :: Integer -- ^ Depth of the tree -> Type -- ^ Element type -> Type -- ^ Result type + -> Term -- ^ Depth of the tree (as an SNat) -> Term -- ^ Element + -> TransformContext -> NormalizeSession Term -reduceTReplicate n aTy eTy arg = do +reduceTReplicate n aTy eTy _sn arg _ctx = do tcm <- Lens.view tcCache go tcm eTy where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp treeTcNm _) - | (Just treeTc) <- lookupUniqMap treeTcNm tcm + | (Just treeTc) <- UniqMap.lookup treeTcNm tcm , nameOcc treeTcNm == "Clash.Sized.RTree.RTree" , [lrCon,brCon] <- tyConDataCons treeTc = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg) diff --git a/src/Clash/Normalize/Transformations/Case.hs b/src/Clash/Normalize/Transformations/Case.hs --- a/src/Clash/Normalize/Transformations/Case.hs +++ b/src/Clash/Normalize/Transformations/Case.hs @@ -273,7 +273,8 @@ -- WHNF of subject is _|_, in the form of `absentError`: that means that -- the entire case-expression is evaluates to _|_ (Prim pInfo,_:msgOrCallStack:_,ticks) - | primName pInfo == "Control.Exception.Base.absentError" -> + | primName pInfo `elem` ["Control.Exception.Base.absentError" + ,"GHC.Prim.Panic.absentError"] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,msgOrCallStack] in changed e1 @@ -579,18 +580,21 @@ {-# SCC collectFlat #-} collectEqArgs :: Term -> Maybe (Term,Term) -collectEqArgs (collectArgsTicks -> (Prim p, args, ticks)) +collectEqArgs f@(collectArgsTicks -> (Prim p, args, ticks)) | nm == Text.showt 'BV.eq# - = let [_,_,Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) + = case args of + [_,_,Left scrut,Left val] -> Just (mkTicks scrut ticks,val) + _ -> error ("collectEqArgs: BV.eq expects 4 arguments, but got: " <> showPpr f) | nm == Text.showt 'I.eq# || nm == Text.showt 'S.eq# || nm == Text.showt 'U.eq# - = let [_,Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) + = case args of + [_,Left scrut,Left val] -> Just (mkTicks scrut ticks,val) + _ -> error (show nm <> " expects 3 arguments, but got: " <> showPpr f) | nm == "GHC.Classes.eqInt" - = let [Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) + = case args of + [Left scrut,Left val] -> Just (mkTicks scrut ticks,val) + _ -> error ("eqInt expects 2 arguments, but got: " <> showPpr f) where nm = primName p @@ -644,8 +648,8 @@ | otherwise -> return e -caseOneAlt (Case _ _ alts@((pat,alt):_:_)) - | all ((== alt) . snd) (tail alts) +caseOneAlt (Case _ _ ((pat,alt):alts@(_:_))) + | all ((== alt) . snd) alts , (tvs,xs) <- patIds pat , (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` alt = changed alt diff --git a/src/Clash/Normalize/Transformations/DEC.hs b/src/Clash/Normalize/Transformations/DEC.hs --- a/src/Clash/Normalize/Transformations/DEC.hs +++ b/src/Clash/Normalize/Transformations/DEC.hs @@ -57,7 +57,9 @@ import qualified Data.Text as Text import GHC.Stack (HasCallStack) -#if MIN_VERSION_ghc(8,10,0) +#if MIN_VERSION_ghc(9,6,0) +import GHC.Core.Make (chunkify, mkChunkified) +#elif MIN_VERSION_ghc(8,10,0) import GHC.Hs.Utils (chunkify, mkChunkified) #else import HsUtils (chunkify, mkChunkified) @@ -88,13 +90,13 @@ import Clash.Core.VarEnv ( InScopeSet, elemInScopeSet, extendInScopeSet, extendInScopeSetList , notElemInScopeSet, unionInScope) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Normalize.Transformations.Letrec (deadCode) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators (bottomupR) import Clash.Rewrite.Types import Clash.Rewrite.Util (changed, isUntranslatableType) import Clash.Rewrite.WorkFree (isConstant) -import Clash.Unique (lookupUniqMap) import Clash.Util (MonadUnique, curLoc) -- | This transformation lifts applications of global binders out of @@ -301,7 +303,7 @@ let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap - let eval = (Lens.view Lens._3) . whnf' evaluate bndrs tcm gh ids1 is0 False + let eval = (Lens.view Lens._3) . whnf' evaluate bndrs mempty tcm gh ids1 is0 False let eTy = inferCoreTypeOf tcm e untran <- isUntranslatableType False eTy case untran of @@ -478,7 +480,8 @@ let argss = Foldable.toList cs argssT = zip [0..] (List.transpose argss) (sharedT,distinctT) = List.partition (areShared tcm inScope . fmap (first stripTicks) . snd) argssT - shared = map (second head) sharedT + -- TODO: find a better solution than "maybe undefined fst . uncons" + shared = map (second (maybe (error "impossible") fst . List.uncons)) sharedT distinct = map (Either.lefts) (List.transpose (map snd distinctT)) cs' = fmap (zip [0..]) cs cs'' = removeEmpty @@ -618,11 +621,12 @@ -- | Lookup the TyConName and DataCon for a tuple of size n findTup :: TyConMap -> IntMap TyConName -> Int -> (TyConName,DataCon) -findTup tcm tupTcm n = (tupTcNm,tupDc) - where - tupTcNm = Maybe.fromMaybe (error $ $curLoc ++ "Can't find " ++ show n ++ "-tuple") $ IntMap.lookup n tupTcm - Just tupTc = lookupUniqMap tupTcNm tcm - [tupDc] = tyConDataCons tupTc +findTup tcm tupTcm n = + Maybe.fromMaybe (error ("Cannot build " <> show n <> "-tuble")) $ do + tupTcNm <- IntMap.lookup n tupTcm + tupTc <- UniqMap.lookup tupTcNm tcm + tupDc <- Maybe.listToMaybe (tyConDataCons tupTc) + return (tupTcNm,tupDc) mkBigTupTm :: TyConMap -> IntMap TyConName -> [(Type,Term)] -> Term mkBigTupTm tcm tupTcm args = snd $ mkBigTup tcm tupTcm args @@ -763,7 +767,7 @@ allNonPow2 = all (not . termIsPow2) lArgs tailNonPow2 = case lArgs of [] -> True - _ -> all (not . termIsPow2) (tail lArgs) + _ -> all (not . termIsPow2) (drop 1 lArgs) lastNotPow2 = case lArgs of [] -> True _ -> not (termIsPow2 (last lArgs)) diff --git a/src/Clash/Normalize/Transformations/EtaExpand.hs b/src/Clash/Normalize/Transformations/EtaExpand.hs --- a/src/Clash/Normalize/Transformations/EtaExpand.hs +++ b/src/Clash/Normalize/Transformations/EtaExpand.hs @@ -71,7 +71,7 @@ return $ Lam bndr e' etaExpansionTL (TransformContext is0 ctx) (Let (NonRec i x) e) = do - let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [i] : ctx) + let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [(i,x)] : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do @@ -81,7 +81,7 @@ etaExpansionTL (TransformContext is0 ctx) (Let (Rec xes) e) = do let bndrs = map fst xes - ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody bndrs : ctx) + ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody xes : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do diff --git a/src/Clash/Normalize/Transformations/Inline.hs b/src/Clash/Normalize/Transformations/Inline.hs --- a/src/Clash/Normalize/Transformations/Inline.hs +++ b/src/Clash/Normalize/Transformations/Inline.hs @@ -33,8 +33,9 @@ import qualified Control.Lens as Lens import qualified Control.Monad as Monad +import Control.Monad ((>=>)) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Writer ((>=>),lift,listen) +import Control.Monad.Writer (lift,listen) import Data.Default (Default(..)) import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap @@ -44,12 +45,7 @@ import qualified Data.Text as Text import qualified Data.Text.Extra as Text import GHC.Stack (HasCallStack) - -#if MIN_VERSION_ghc(9,0,0) -import GHC.Types.Basic (InlineSpec (..)) -#else -import BasicTypes (InlineSpec (..)) -#endif +import GHC.BasicTypes.Extra (isNoInline) import qualified Clash.Explicit.SimIO as SimIO import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV)) @@ -464,12 +460,16 @@ case r of (e1, Monoid.getAny -> True) -> return e1 - (~(Case subj0 typ alts), _) -> do + (e1, _) -> do -- If a term _in_ the subject triggers 'inlineNonRepWorker', inline and -- propagate might eliminate this case. We therefore don't explore the -- alternatives. Note that this makes it substantially different from a -- 'topdownSucR' transformation. let + (subj0,typ,alts) = case e1 of + Case s t a -> (s,t,a) + _ -> error ("internal error, inlineNonRep triggered on a non-Case:" <> + showPpr e1) TransformContext inScope ctx1 = ctx0 ctx2 = TransformContext inScope (CaseScrut:ctx1) @@ -602,7 +602,7 @@ -- Don't inline recursive expressions Just b -> do isRecBndr <- isRecursiveBndr f - if not isRecBndr && bindingSpec b /= NoInline && termSize (bindingTerm b) < sizeLimit + if not isRecBndr && not (isNoInline (bindingSpec b)) && termSize (bindingTerm b) < sizeLimit then do let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) changed $ mkApps tm args diff --git a/src/Clash/Normalize/Transformations/Letrec.hs b/src/Clash/Normalize/Transformations/Letrec.hs --- a/src/Clash/Normalize/Transformations/Letrec.hs +++ b/src/Clash/Normalize/Transformations/Letrec.hs @@ -33,6 +33,7 @@ import Data.List ((\\)) import qualified Data.List as List import qualified Data.List.Extra as List +import Data.Maybe (fromMaybe) import qualified Data.Monoid as Monoid (Any(..)) import qualified Data.Text as Text import qualified Data.Text.Extra as Text @@ -62,6 +63,7 @@ import Clash.Core.VarEnv ( InScopeSet, elemInScopeSet, emptyVarEnv, extendInScopeSetList, lookupVarEnv , unionVarEnvWith, unitVarEnv, mkVarSet) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Netlist.BlackBox.Types () import Clash.Netlist.BlackBox.Util (getUsedArguments) import Clash.Netlist.Util (splitNormalized) @@ -74,7 +76,6 @@ import Clash.Rewrite.Util (changed, isFromInt, isUntranslatable, mkTmBinderFor, removeUnusedBinders, setChanged) import Clash.Rewrite.WorkFree -import Clash.Unique (lookupUniqMap) {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in @@ -160,10 +161,11 @@ | (con, _) <- collectArgs nil , not (isCon con) -> let eTy = inferCoreTypeOf tcm e - (TyConApp vecTcNm _) = tyView eTy - (Just vecTc) = lookupUniqMap vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - v = mkTicks (mkVec nilCon consCon aTy 1 [a]) ticks + v = fromMaybe (error "removeUnusedExpr: failed to create Vec DCs") $ do + (TyConApp vecTcNm _) <- pure (tyView eTy) + vecTc <- UniqMap.lookup vecTcNm tcm + [nilCon,consCon] <- pure (tyConDataCons vecTc) + return (mkTicks (mkVec nilCon consCon aTy 1 [a]) ticks) in changed v _ -> return e @@ -181,10 +183,11 @@ flattenLet ctx@(TransformContext is0 _) (Letrec binds0 body0@Letrec{}) = do -- deshadow binds1, so binds0 and binds1 don't conflict when merged let is1 = extendInScopeSetList is0 (fmap fst binds0) - Letrec binds1 body1 = deShadowTerm is1 body0 - - setChanged - flattenLet ctx{tfInScope=is1} (Letrec (binds0 <> binds1) body1) + case deShadowTerm is1 body0 of + Letrec binds1 body1 -> do + setChanged + flattenLet ctx{tfInScope=is1} (Letrec (binds0 <> binds1) body1) + _ -> error "internal error" flattenLet (TransformContext is0 _) (Letrec binds body) = do let is1 = extendInScopeSetList is0 (map fst binds) @@ -222,8 +225,10 @@ -- This is much better than blindly calling freshenTm, and saves -- almost 30% run-time of the normalization phase on some examples. if any (`elemInScopeSet` isN) bs1 then - let Letrec bindsN bodyN = deShadowTerm isN (Letrec binds1 body1) - in (bindsN,bodyN,extendInScopeSetList isN (map fst bindsN)) + case deShadowTerm isN (Letrec binds1 body1) of + Letrec bindsN bodyN -> + (bindsN,bodyN,extendInScopeSetList isN (map fst bindsN)) + _ -> error "internal error" else (binds1,body1,extendInScopeSetList isN bs1) let bodyOccs = Lens.foldMapByOf @@ -398,8 +403,8 @@ -- On the two examples that were tested, Reducer and PipelinesViaFolds, this new -- version of CSE removed the same amount of let-binders. simpleCSE :: HasCallStack => NormRewrite -simpleCSE (TransformContext is0 _) term@Letrec{} = do - let Letrec bndrs body = inverseTopSortLetBindings term +simpleCSE (TransformContext is0 _) term@(Letrec bndrsX body) = do + let bndrs = inverseTopSortLetBindings bndrsX let is1 = extendInScopeSetList is0 (map fst bndrs) ((subst,bndrs1), change) <- listen $ reduceBinders (mkSubst is1) [] bndrs -- TODO: check whether a substitution over the body is enough, the reason I'm diff --git a/src/Clash/Normalize/Transformations/Reduce.hs b/src/Clash/Normalize/Transformations/Reduce.hs --- a/src/Clash/Normalize/Transformations/Reduce.hs +++ b/src/Clash/Normalize/Transformations/Reduce.hs @@ -9,6 +9,7 @@ Transformations for compile-time reduction of expressions / primitives. -} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Normalize.Transformations.Reduce @@ -23,25 +24,28 @@ import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Maybe as Maybe +import Data.Maybe (fromMaybe, listToMaybe) import GHC.Stack (HasCallStack) import Clash.Core.FreeVars (typeFreeVars) import Clash.Core.HasType import Clash.Core.Name (nameOcc) +import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (Subst, extendIdSubst, substTm) import Clash.Core.Term - ( LetBinding, PrimInfo(..), Term(..), TickInfo(..), collectArgs - , collectArgsTicks, mkApps, mkTicks) + ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..), collectArgs + , collectArgsTicks, mkApps, mkTicks, mkTmApps) import Clash.Core.TyCon (tyConDataCons) -import Clash.Core.Type (TypeView(..), mkTyConApp, tyView) -import Clash.Core.Util (mkVec, shouldSplit, tyNatSize) +import Clash.Core.Type (Type, TypeView(..), mkTyConApp, splitFunForallTy, tyView) +import Clash.Core.Util (mkVec, shouldSplit, tyNatSize, mkInternalVar) +import Clash.Core.VarEnv (extendInScopeSet) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Normalize.PrimitiveReductions import Clash.Normalize.Primitives (removedArg) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Normalize.Util (shouldReduce) import Clash.Rewrite.Types (TransformContext(..), tcCache, normalizeUltra) import Clash.Rewrite.Util (changed, isUntranslatableType, setChanged, whnfRW) -import Clash.Unique (lookupUniqMap) -- | XXX: is given inverse topologically sorted binders, but returns -- topologically sorted binders @@ -146,24 +150,26 @@ -- -- See https://github.com/clash-lang/clash-compiler/issues/1606 reduceNonRepPrim :: HasCallStack => NormRewrite -reduceNonRepPrim c@(TransformContext is0 ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do +reduceNonRepPrim c@(TransformContext _ ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do tcm <- Lens.view tcCache ultra <- Lens.view normalizeUltra let eTy = inferCoreTypeOf tcm e - case tyView eTy of + let resTy = snd (splitFunForallTy eTy) + case tyView resTy of (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec") [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do - let (Just vecTc) = lookupUniqMap vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - nilE = mkVec nilCon consCon aTy 0 [] + let nilE = fromMaybe (error "reduceNonRepPrim: unable to create Vec DCs") $ do + vecTc <- UniqMap.lookup vecTcNm tcm + [nilCon,consCon] <- pure (tyConDataCons vecTc) + return (mkVec nilCon consCon aTy 0 []) changed (mkTicks nilE ticks) tv -> let argLen = length args in case primName p of - "Clash.Sized.Vector.zipWith" | argLen == 7 -> do - let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args - TyConApp vecTcNm _ = tv - lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy] - rhsTy = mkTyConApp vecTcNm [nTy,rhsElty] - case runExcept (tyNatSize tcm nTy) of + "Clash.Sized.Vector.zipWith" + | (tmArgs,[lhsElTy,rhsElty,resElTy,nTy]) <- Either.partitionEithers args + , TyConApp vecTcNm _ <- tv + , let lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy] + , let rhsTy = mkTyConApp vecTcNm [nTy,rhsElty] + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure (ultra || n < 2) , shouldReduce ctx @@ -171,18 +177,20 @@ [lhsElTy,rhsElty,resElTy] -- Note [Unroll shouldSplit types] , pure (any (Maybe.isJust . shouldSplit tcm) - [lhsTy,rhsTy,eTy]) ] + [lhsTy,rhsTy,resTy]) ] if shouldReduce1 - then let [fun,lhsArg,rhsArg] = Either.lefts args - in (`mkTicks` ticks) <$> - reduceZipWith c p n lhsElTy rhsElty resElTy fun lhsArg rhsArg + then abstractOverMissingArgs ticks tmArgs eTy c + (reduceZipWith p n lhsElTy rhsElty resElTy) else return e _ -> return e - "Clash.Sized.Vector.map" | argLen == 5 -> do - let [argElTy,resElTy,nTy] = Either.rights args - TyConApp vecTcNm _ = tv - argTy = mkTyConApp vecTcNm [nTy,argElTy] - case runExcept (tyNatSize tcm nTy) of + | argLen >= 4 + -> error ("reduceNonRepPrim: zipWith bad args" <> showPpr e) + + "Clash.Sized.Vector.map" + | (tmArgs,[argElTy,resElTy,nTy]) <- Either.partitionEithers args + , TyConApp vecTcNm _ <- tv + , let argTy = mkTyConApp vecTcNm [nTy,argElTy] + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure (ultra || n < 2 ) , shouldReduce ctx @@ -190,23 +198,27 @@ [argElTy,resElTy] -- Note [Unroll shouldSplit types] , pure (any (Maybe.isJust . shouldSplit tcm) - [argTy,eTy]) ] + [argTy,resTy]) ] if shouldReduce1 - then let [fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceMap c p n argElTy resElTy fun arg + then abstractOverMissingArgs ticks tmArgs eTy c + (reduceMap p n argElTy resElTy) else return e _ -> return e - "Clash.Sized.Vector.traverse#" | argLen == 7 -> - let [aTy,fTy,bTy,nTy] = Either.rights args - in case runExcept (tyNatSize tcm nTy) of - Right n -> - let [dict,fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceTraverse c n aTy fTy bTy dict fun arg + | argLen >= 3 + -> error ("reduceNonRepPrim: map bad args" <> showPpr e) + + "Clash.Sized.Vector.traverse#" + | (tmArgs,[aTy,fTy,bTy,nTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of + Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTraverse n aTy fTy bTy) _ -> return e - "Clash.Sized.Vector.fold" | argLen == 4 -> do - let ([fun,arg],[nTy,aTy]) = Either.partitionEithers args - argTy = inferCoreTypeOf tcm arg - case runExcept (tyNatSize tcm nTy) of + | argLen >= 4 + -> error ("reduceNonRepPrim: traverse# bad args" <> showPpr e) + + "Clash.Sized.Vector.fold" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure (ultra || n == 0) , shouldReduce ctx @@ -214,13 +226,16 @@ -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy))] if shouldReduce1 then - (`mkTicks` ticks) <$> reduceFold c (n + 1) aTy fun arg + abstractOverMissingArgs ticks tmArgs eTy c (reduceFold (n + 1) aTy) else return e _ -> return e - "Clash.Sized.Vector.foldr" | argLen == 6 -> - let ([fun,start,arg],[aTy,bTy,nTy]) = Either.partitionEithers args - argTy = inferCoreTypeOf tcm arg - in case runExcept (tyNatSize tcm nTy) of + | argLen >= 2 + -> error ("reduceNonRepPrim: fold bad args" <> showPpr e) + + "Clash.Sized.Vector.foldr" + | (tmArgs,[aTy,bTy,nTy]) <- Either.partitionEithers args + , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [aTy,bTy,nTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure ultra , shouldReduce ctx @@ -228,63 +243,73 @@ -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceFoldr c p n aTy fun start arg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceFoldr p n aTy) else return e _ -> return e - "Clash.Sized.Vector.dfold" | argLen == 8 -> - let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceDFold is0 n aTy fun start arg + | argLen >= 3 + -> error ("reduceNonRepPrim: foldr bad args" <> showPpr e) + + "Clash.Sized.Vector.dfold" + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of + Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDFold n aTy) _ -> return e - "Clash.Sized.Vector.++" | argLen == 5 -> - let [nTy,aTy,mTy] = Either.rights args - [lArg,rArg] = Either.lefts args - in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right m) - | n == 0 -> changed rArg - | m == 0 -> changed lArg - | otherwise -> do - shouldReduce1 <- List.orM [ shouldReduce ctx + | argLen >= 3 + -> error ("reduceNonRepPrim: dfold bad args" <> showPpr e) + + "Clash.Sized.Vector.++" + | (tmArgs,[nTy,aTy,mTy]) <- Either.partitionEithers args + -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right m) -> do + shouldReduce1 <- List.orM [ pure (n==0) + , pure (m==0) + , shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm eTy)) ] + , pure (Maybe.isJust (shouldSplit tcm resTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceAppend is0 n m aTy lArg rArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceAppend n m aTy) else return e _ -> return e - "Clash.Sized.Vector.head" | argLen == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - argTy = inferCoreTypeOf tcm vArg - case runExcept (tyNatSize tcm nTy) of + | argLen >= 3 + -> error ("reduceNonRepPrim: ++ bad args" <> showPpr e) + + "Clash.Sized.Vector.head" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceHead is0 (n+1) aTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceHead (n+1) aTy) else return e _ -> return e - "Clash.Sized.Vector.tail" | argLen == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - argTy = inferCoreTypeOf tcm vArg - case runExcept (tyNatSize tcm nTy) of + | argLen >= 2 + -> error ("reduceNonRepPrim: head bad args" <> showPpr e) + + "Clash.Sized.Vector.tail" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceTail is0 (n+1) aTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceTail (n+1) aTy) else return e _ -> return e - "Clash.Sized.Vector.last" | argLen == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - argTy = inferCoreTypeOf tcm vArg - case runExcept (tyNatSize tcm nTy) of + | argLen >= 2 + -> error ("reduceNonRepPrim: tail bad args" <> showPpr e) + + "Clash.Sized.Vector.last" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy @@ -292,27 +317,32 @@ , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceLast is0 (n+1) aTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceLast (n+1) aTy) else return e _ -> return e - "Clash.Sized.Vector.init" | argLen == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - argTy = inferCoreTypeOf tcm vArg - case runExcept (tyNatSize tcm nTy) of + | argLen >= 2 + -> error ("reduceNonRepPrim: last bad args" <> showPpr e) + + "Clash.Sized.Vector.init" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceInit is0 p n aTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceInit p n aTy) else return e _ -> return e - "Clash.Sized.Vector.unconcat" | argLen == 6 -> do - let ([_knN,sm,arg],[nTy,mTy,aTy]) = Either.partitionEithers args - argTy = inferCoreTypeOf tcm arg - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + | argLen >= 2 + -> error ("reduceNonRepPrim: init bad args" <> showPpr e) + + "Clash.Sized.Vector.unconcat" + | (tmArgs,[nTy,mTy,aTy]) <- Either.partitionEithers args + , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,mTy,aTy])) + -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of (Right n, Right m) -> do shouldReduce1 <- List.orM [ pure (m==0) , shouldReduce ctx @@ -321,48 +351,59 @@ , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 then - (`mkTicks` ticks) <$> reduceUnconcat is0 p n m aTy sm arg + abstractOverMissingArgs ticks tmArgs eTy c (reduceUnconcat p n m aTy) else return e _ -> return e - "Clash.Sized.Vector.transpose" | argLen == 5 -> do - let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> (`mkTicks` ticks) <$> reduceTranspose n 0 aTy arg + | argLen >= 3 + -> error ("reduceNonRepPrim: unconcat bad args" <> showPpr e) + + "Clash.Sized.Vector.transpose" + | (tmArgs,[mTy,nTy,aTy]) <- Either.partitionEithers args + -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right 0) -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTranspose n 0 aTy) _ -> return e - "Clash.Sized.Vector.replicate" | argLen == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of + | argLen >= 3 + -> error ("reduceNonRepPrim: transpose bad args" <> showPpr e) + + "Clash.Sized.Vector.replicate" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm eTy)) + , pure (Maybe.isJust (shouldSplit tcm resTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceReplicate n aTy eTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplicate n aTy resTy) else return e _ -> return e + | argLen >= 2 + -> error ("reduceNonRepPrim: replicate bad args" <> showPpr e) + -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a - "Clash.Sized.Vector.replace_int" | argLen == 6 -> do - let ([_knArg,vArg,iArg,aArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of + "Clash.Sized.Vector.replace_int" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure ultra , shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm eTy)) + , pure (Maybe.isJust (shouldSplit tcm resTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceReplace_int is0 n aTy eTy vArg iArg aArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplace_int n aTy resTy) else return e _ -> return e + | argLen >= 2 + -> error ("reduceNonRepPrim: replace_int bad args" <> showPpr e) - "Clash.Sized.Vector.index_int" | argLen == 5 -> do - let ([_knArg,vArg,iArg],[nTy,aTy]) = Either.partitionEithers args - argTy = inferCoreTypeOf tcm vArg - case runExcept (tyNatSize tcm nTy) of + "Clash.Sized.Vector.index_int" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy])) + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure ultra , shouldReduce ctx @@ -370,104 +411,122 @@ -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceIndex_int is0 n aTy vArg iArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceIndex_int n aTy) else return e _ -> return e + | argLen >= 2 + -> error ("reduceNonRepPrim: index_int bad args" <> showPpr e) - "Clash.Sized.Vector.imap" | argLen == 6 -> do - let [nTy,argElTy,resElTy] = Either.rights args - TyConApp vecTcNm _ = tv - argTy = mkTyConApp vecTcNm [nTy,argElTy] - case runExcept (tyNatSize tcm nTy) of + "Clash.Sized.Vector.imap" + | (tmArgs,[nTy,argElTy,resElTy]) <- Either.partitionEithers args + , TyConApp vecTcNm _ <- tv + , let argTy = mkTyConApp vecTcNm [nTy,argElTy] + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure (ultra || n < 2) , shouldReduce ctx , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] -- Note [Unroll shouldSplit types] , pure (any (Maybe.isJust . shouldSplit tcm) - [argTy,eTy]) ] + [argTy,resTy]) ] if shouldReduce1 - then let [_,fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceImap n argElTy resElTy) else return e _ -> return e - "Clash.Sized.Vector.iterateI" | argLen == 5 -> - let ([_kn,f,a],[nTy,aTy]) = Either.partitionEithers args in - case runExcept (tyNatSize tcm nTy) of + | argLen >= 3 + -> error ("reduceNonRepPrim: imap bad args" <> showPpr e) + + "Clash.Sized.Vector.iterateI" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ pure (ultra || n < 2) , shouldReduce ctx , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] - , pure (Maybe.isJust (shouldSplit tcm eTy)) ] + , pure (Maybe.isJust (shouldSplit tcm resTy)) ] if shouldReduce1 then - (`mkTicks` ticks) <$> reduceIterateI c n aTy eTy f a + abstractOverMissingArgs ticks tmArgs eTy c (reduceIterateI n aTy resTy) else return e _ -> return e - "Clash.Sized.Vector.dtfold" | argLen == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceDTFold is0 n aTy lrFun brFun arg + | argLen >= 2 + -> error ("reduceNonRepPrim: iterateI bad args" <> showPpr e) + + "Clash.Sized.Vector.dtfold" + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of + Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDTFold n aTy) _ -> return e + | argLen >= 3 + -> error ("reduceNonRepPrim: dtfold bad args" <> showPpr e) "Clash.Sized.Vector.reverse" | ultra - , ([vArg],[nTy,aTy]) <- Either.partitionEithers args + , (tmArgs,[nTy,aTy]) <- Either.partitionEithers args , Right n <- runExcept (tyNatSize tcm nTy) - -> (`mkTicks` ticks) <$> reduceReverse is0 n aTy vArg + -> abstractOverMissingArgs ticks tmArgs eTy c (reduceReverse n aTy) - "Clash.Sized.RTree.tdfold" | argLen == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceTFold is0 n aTy lrFun brFun arg + "Clash.Sized.RTree.tdfold" + | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args + -> case runExcept (tyNatSize tcm nTy) of + Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTFold n aTy) _ -> return e - "Clash.Sized.RTree.treplicate" | argLen == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + | argLen >= 3 + -> error ("reduceNonRepPrim: tdfold bad args" <> showPpr e) + "Clash.Sized.RTree.treplicate" + | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args -> case runExcept (tyNatSize tcm nTy) of Right n -> do shouldReduce1 <- List.orM [ shouldReduce ctx , isUntranslatableType False aTy ] if shouldReduce1 - then (`mkTicks` ticks) <$> reduceTReplicate n aTy eTy vArg + then abstractOverMissingArgs ticks tmArgs eTy c (reduceTReplicate n aTy resTy) else return e _ -> return e - "Clash.Sized.Internal.BitVector.split#" | argLen == 4 -> do - let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args + | argLen >= 2 + -> error ("reduceNonRepPrim: treplicate bad args" <> showPpr e) + "Clash.Sized.Internal.BitVector.split#" + | (tmArgs,[nTy,mTy]) <- Either.partitionEithers args -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) - | n == 0 -> do - let (Just tupTc) = lookupUniqMap tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left bvArg - ,Left (TyApp (Prim removedArg) rTy) - ] + | n == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do + let tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left bvArg + ,Left (TyApp (Prim removedArg) rTy) + ] - changed (mkTicks tup ticks) - | m == 0 -> do - let (Just tupTc) = lookupUniqMap tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left (TyApp (Prim removedArg) lTy) - ,Left bvArg - ] + (changed (mkTicks tup ticks) :: NormalizeSession Term) + | m == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do + let tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left (TyApp (Prim removedArg) lTy) + ,Left bvArg + ] - changed (mkTicks tup ticks) + (changed (mkTicks tup ticks) :: NormalizeSession Term) + where + tupDc = fromMaybe (error "reduceNonRepPrim: faield to create tup DC") $ do + tupTc <- UniqMap.lookup tupTcNm tcm + listToMaybe (tyConDataCons tupTc) _ -> return e + | argLen >= 3 + -> error ("reduceNonRepPrim: split# bad args" <> showPpr e) "Clash.Sized.Internal.BitVector.eq#" - | ([_,_],[nTy]) <- Either.partitionEithers args + | (tmArgs,[nTy]) <- Either.partitionEithers args , Right 0 <- runExcept (tyNatSize tcm nTy) , TyConApp boolTcNm [] <- tv - -> let (Just boolTc) = lookupUniqMap boolTcNm tcm - [_falseDc,trueDc] = tyConDataCons boolTc - in changed (mkTicks (Data trueDc) ticks) + -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) (_l :: Term) (_r :: Term) (_ctx :: TransformContext) -> do + let trueDc = fromMaybe (error "reduceNonRepPrim: failed to create True DC") $ do + boolTc <- UniqMap.lookup boolTcNm tcm + [_falseDc,dc] <- pure (tyConDataCons boolTc) + return dc + in (changed (Data trueDc) :: NormalizeSession Term) _ -> return e where isUntranslatableType_not_poly t = do @@ -478,3 +537,29 @@ reduceNonRepPrim _ e = return e {-# SCC reduceNonRepPrim #-} + +class AbstractOverMissingArgs a where + -- | Abstract over a primitive until it is saturated + abstractOverMissingArgs :: + HasCallStack => + -- | Ticks originally tagged to the applied primitive + [TickInfo] -> + -- | Available arguments + [Term] -> + -- | The type of the expression containing the applied primitive + Type -> + -- | The context in which reduceNonRepPrim was called + TransformContext -> + a -> + NormalizeSession Term + +instance AbstractOverMissingArgs (TransformContext -> NormalizeSession Term) where + abstractOverMissingArgs ticks args _ is f = (`mkTmApps` args) <$> (`mkTicks` ticks) <$> f is + +instance AbstractOverMissingArgs a => AbstractOverMissingArgs (Term -> a) where + abstractOverMissingArgs ticks (t:ts) ty ctx f = abstractOverMissingArgs ticks ts ty ctx (f t) + abstractOverMissingArgs ticks [] (tyView -> FunTy argTy resTy) (TransformContext is0 ctx) f = do + newId <- mkInternalVar is0 "arg" argTy + let ctx1 = TransformContext (extendInScopeSet is0 newId) (LamBody newId : ctx) + Lam newId <$> abstractOverMissingArgs ticks [] resTy ctx1 (f (Var newId)) + abstractOverMissingArgs _ _ ty _ _ = error ("not a funty: " <> showPpr ty) diff --git a/src/Clash/Normalize/Transformations/Specialize.hs b/src/Clash/Normalize/Transformations/Specialize.hs --- a/src/Clash/Normalize/Transformations/Specialize.hs +++ b/src/Clash/Normalize/Transformations/Specialize.hs @@ -2,7 +2,7 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -80,6 +80,7 @@ import Clash.Core.VarEnv ( InScopeSet, extendInScopeSet, extendInScopeSetList, lookupVarEnv , mkInScopeSet, mkVarSet, unionInScope, elemVarSet) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf, traceM) import Clash.Driver.Types (Binding(..), TransformationInfo(..), hasTransformationInfo) import Clash.Netlist.Util (representableType) @@ -95,9 +96,6 @@ ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory) import Clash.Normalize.Util (constantSpecInfo, csrFoundConstant, csrNewBindings, csrNewTerm) -import Clash.Unique - ( eltsUniqMap, eltsUniqSet, extendUniqMapWith, unitUniqSet, filterUniqMap - , lookupUniqMap) import Clash.Util (ClashException(..)) -- | Propagate arguments of application inwards; except for 'Lam' where the @@ -343,6 +341,27 @@ miss on virtually every lookup which could add to normalization time. -} +-- | Given two 'InlineSpec's, return the \"strongest\" one. I.e., the one that's +-- closest to @NoInline@ (or @Opaque@ for newer GHCs). +preferNoInline :: InlineSpec -> InlineSpec -> InlineSpec +preferNoInline is0 is1 + | enumInlineSpec is0 >= enumInlineSpec is1 = is0 + | otherwise = is1 + where + enumInlineSpec :: InlineSpec -> Int + enumInlineSpec = \case +#if MIN_VERSION_ghc(9,2,0) + NoUserInlinePrag {} -> -1 +#else + NoUserInline {} -> -1 +#endif + Inline {} -> 0 + Inlinable {} -> 1 + NoInline {} -> 2 +#if MIN_VERSION_ghc(9,4,0) + Opaque {} -> 3 +#endif + -- | Specialize an application on its argument specialize' :: TransformContext @@ -400,11 +419,11 @@ -- Create new specialized function Nothing -> do -- Determine if we can specialize f - bodyMaybe <- fmap (lookupUniqMap (varName f)) $ Lens.use bindings + bodyMaybe <- fmap (UniqMap.lookup f) $ Lens.use bindings case bodyMaybe of Just (Binding _ sp inl _ bodyTm _) -> do -- Determine if we see a sequence of specializations on a growing argument - specHistM <- lookupUniqMap f <$> Lens.use (extra.specialisationHistory) + specHistM <- UniqMap.lookup f <$> Lens.use (extra.specialisationHistory) specLim <- Lens.view specializationLimit if maybe False (> specLim) specHistM then throw (ClashException @@ -443,21 +462,32 @@ -- binding @g'@ where both the body of @mealy@ and @g@ -- are inlined, meaning the state-transition-function -- and the memory element will be in a single function. - gTmM <- fmap (lookupUniqMap (varName g)) $ Lens.use bindings - return (g,maybe inl bindingSpec gTmM, maybe specArg (Left . (`mkApps` gArgs) . bindingTerm) gTmM) + gTmM <- fmap (UniqMap.lookup g) $ Lens.use bindings + return + ( g + , preferNoInline inl (maybe noUserInline bindingSpec gTmM) + , maybe specArg (Left . (`mkApps` gArgs) . bindingTerm) gTmM + ) else return (f,inl,specArg) _ -> return (f,inl,specArg) -- Create specialized functions let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg'])) (boundArgs ++ specBndrs) newf <- mkFunction (varName fId) sp inl' newBody -- Remember specialization - (extra.specialisationHistory) %= extendUniqMapWith f 1 (+) + (extra.specialisationHistory) %= UniqMap.insertWith (+) f 1 (extra.specialisationCache) %= Map.insert (f,argLen,specAbs) newf -- use specialized function let newExpr = mkApps (mkTicks (Var newf) ticks) (args ++ specVars) newf `deepseq` changed newExpr Nothing -> return e where + noUserInline :: InlineSpec +#if MIN_VERSION_ghc(9,2,0) + noUserInline = NoUserInlinePrag +#else + noUserInline = NoUserInline +#endif + collectBndrsMinusApps :: Term -> [Name a] collectBndrsMinusApps = reverse . go [] where @@ -479,11 +509,15 @@ newBody = mkAbstraction specArg specBndrs -- See if there's an existing binder that's alpha-equivalent to the -- specialized function - existing <- filterUniqMap ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings + existing <- UniqMap.filter ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings -- Create a new function if an alpha-equivalent binder doesn't exist - newf <- case eltsUniqMap existing of + newf <- case UniqMap.elems existing of [] -> do (cf,sp) <- Lens.use curFun +#if MIN_VERSION_ghc(9,2,0) + mkFunction (appendToName (varName cf) "_specF") sp NoUserInlinePrag newBody +#else mkFunction (appendToName (varName cf) "_specF") sp NoUserInline newBody +#endif (b:_) -> return (bindingId b) -- Create specialized argument let newArg = Left $ mkApps (Var newf) specVars @@ -530,7 +564,9 @@ (specFTVs,specFVs) = case specArg of Left tm -> (OSet.toListL *** OSet.toListL) . getConst $ Lens.foldMapOf freeLocalVars unitFV tm - Right ty -> (eltsUniqSet (Lens.foldMapOf typeFreeVars unitUniqSet ty),[] :: [Id]) + Right ty -> ( UniqMap.elems + (Lens.foldMapOf typeFreeVars (\x -> UniqMap.singletonUnique (coerce x)) ty) + , [] :: [Id]) specTyBndrs = map Right specFTVs specTmBndrs = map Left specFVs @@ -648,7 +684,7 @@ -- where all fields are also zero-width. | otherwise -> do - tc <- lookupUniqMap tcNm tcm + tc <- UniqMap.lookup tcNm tcm case tyConDataCons tc of [dc] -> do diff --git a/src/Clash/Normalize/Util.hs b/src/Clash/Normalize/Util.hs --- a/src/Clash/Normalize/Util.hs +++ b/src/Clash/Normalize/Util.hs @@ -74,6 +74,7 @@ import Clash.Core.VarEnv (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, extendVarEnvWith, lookupVarEnv, unionVarEnvWith, unitVarEnv, extendInScopeSetList, mkInScopeSet, mkVarSet) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug (traceIf) import Clash.Driver.Types (BindingMap, Binding(..), TransformationInfo(FinalTerm), hasTransformationInfo) @@ -348,8 +349,8 @@ collectCallGraphUniques :: CallGraph -> HashSet.HashSet Unique collectCallGraphUniques cg = HashSet.fromList (us0 ++ us1) where - us0 = keysUniqMap cg - us1 = concatMap keysUniqMap (eltsUniqMap cg) + us0 = UniqMap.keys cg + us1 = concatMap UniqMap.keys (UniqMap.elems cg) -- | Create a call graph for a set of global binders, given a root callGraph @@ -359,12 +360,12 @@ callGraph bndrs rt = go emptyVarEnv (varUniq rt) where go cg root - | Nothing <- lookupUniqMap root cg - , Just rootTm <- lookupUniqMap root bndrs = + | Nothing <- UniqMap.lookup root cg + , Just rootTm <- UniqMap.lookup root bndrs = let used = Lens.foldMapByOf globalIds (unionVarEnvWith (+)) - emptyVarEnv (`unitUniqMap` 1) (bindingTerm rootTm) - cg' = extendUniqMap root used cg - in List.foldl' go cg' (keysUniqMap used) + emptyVarEnv (`UniqMap.singleton` 1) (bindingTerm rootTm) + cg' = UniqMap.insert root used cg + in List.foldl' go cg' (UniqMap.keys used) go cg _ = cg -- | Give a "performance/size" classification of a function in normal form. diff --git a/src/Clash/Primitives/Annotations/SynthesisAttributes.hs b/src/Clash/Primitives/Annotations/SynthesisAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Annotations/SynthesisAttributes.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Primitives.Annotations.SynthesisAttributes where + +import Prelude + +import Control.Monad.State (State) +import Data.Either (lefts, rights) +import Data.List.Infinite((...), Infinite((:<))) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc.Extra (Doc) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (someNatVal) +import GHC.TypeNats (KnownNat, SomeNat(..)) +import Text.Show.Pretty (ppShow) + +import qualified Control.Lens as Lens +import qualified Data.Text as T + +import Clash.Annotations.SynthesisAttributes +import Clash.Backend (Backend) +import Clash.Core.TermLiteral (termToDataError) +import Clash.Core.Type (Type(LitTy), LitTy(NumTy), coreView) +import Clash.Netlist.BlackBox.Types +import Clash.Netlist.Types +import Clash.Sized.Vector (Vec, toList) + +import qualified Clash.Primitives.DSL as DSL + +usedArguments :: [Int] +usedArguments = [attrs, signal] + where + attrs :< signal :< _ = (0...) + +annotateBBF :: HasCallStack => BlackBoxFunction +annotateBBF _isD _primName args _resTys = Lens.view tcCache >>= go + where + go tcm + | ((coreView tcm -> LitTy (NumTy n)) : _) <- rights args + , Just (SomeNat (Proxy :: Proxy n)) <- someNatVal n + , (attrs0 : _) <- lefts args + = case termToDataError attrs0 of + Left msg -> error msg + Right attrs1 -> pure $ Right (bbMeta, bb @n (fmap T.pack <$> attrs1)) + go _ = error $ "Unexpected args:\n " <> ppShow args + + bbMeta :: BlackBoxMeta + bbMeta = emptyBlackBoxMeta{bbKind = TDecl} + + bb :: KnownNat n => Vec n (Attr Text) -> BlackBox + bb attrs = BBFunction (show 'annotateTF) 0 (annotateTF attrs) + +annotateTF :: HasCallStack => KnownNat n => Vec n (Attr Text) -> TemplateFunction +annotateTF attrs = TemplateFunction usedArguments (const True) (annotateBBTF attrs) + +annotateBBTF :: + (Backend s, KnownNat n, HasCallStack) => + Vec n (Attr Text) -> + BlackBoxContext -> + State s Doc +annotateBBTF attrs0 bbCtx + | (_attrs : signal0 : _) <- map fst $ DSL.tInputs bbCtx + = DSL.declarationReturn bbCtx "annotate_block" $ do + let + attrs1 = toList attrs0 + signal1ty = Annotated attrs1 (DSL.ety signal0) + signal1 = DSL.TExpr{DSL.eex=DSL.eex signal0, DSL.ety=signal1ty} + resultExpr <- DSL.assign (getSignalName (bbCtxName bbCtx)) signal1 + pure [resultExpr] + where + -- Return user-friendly name given a context name hint. + getSignalName :: Maybe T.Text -> T.Text + getSignalName Nothing = "result" + getSignalName (Just "__VOID_TDECL_NOOP__") = getSignalName Nothing + getSignalName (Just s) = s + +annotateBBTF _attrs bbCtx = error $ "Unexpected context:\n " <> ppShow bbCtx diff --git a/src/Clash/Primitives/DSL.hs b/src/Clash/Primitives/DSL.hs --- a/src/Clash/Primitives/DSL.hs +++ b/src/Clash/Primitives/DSL.hs @@ -1,7 +1,8 @@ {-| - Copyright : (C) 2019, Myrtle Software Ltd. - 2020-2022, QBayLogic B.V. - 2021, Myrtle.ai + Copyright : (C) 2019, Myrtle Software Ltd. + 2020-2023, QBayLogic B.V. + 2021, Myrtle.ai + 2022-2023, Google Inc License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -9,8 +10,11 @@ instantiations. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} @@ -27,9 +31,14 @@ -- * Declarations , BlockState (..) - , TExpr + , TExpr(..) + , addDeclaration + , assign + , compInBlock , declaration , declarationReturn + , declare + , declareN , instDecl , instHO , viaAnnotatedSignal @@ -48,14 +57,18 @@ , tResults , getStr , getBool + , getVec , exprToInteger , tExprToInteger , deconstructProduct , untuple , unvec + , deconstructMaybe -- ** Conversion + , bitCoerce , toBV + , toBvWithAttrs , fromBV , enableToBit , boolToBit @@ -64,6 +77,9 @@ , unsignedFromBitVector , boolFromBits + , unsafeToActiveHigh + , unsafeToActiveLow + -- ** Operations , andExpr , notExpr @@ -72,12 +88,16 @@ , open -- ** Utilities + , clog2 + , litTExpr , toIdentifier , tySize - , clog2 ) where import Control.Lens hiding (Indexed, assign) +#if MIN_VERSION_mtl(2,3,0) +import Control.Monad (forM, forM_, zipWithM) +#endif import Control.Monad.State import Data.Default (Default(def)) import Data.IntMap (IntMap) @@ -95,10 +115,11 @@ import GHC.Stack (HasCallStack) import Clash.Annotations.Primitive (HDL (..), Primitive (..)) -import Clash.Backend hiding (fromBV, toBV) +import Clash.Annotations.SynthesisAttributes (Attr) +import Clash.Backend hiding (Usage, fromBV, toBV) import Clash.Backend.VHDL (VHDLState) -import Clash.Core.Var (Attr') -import Clash.Netlist.BlackBox.Util (exprToString, renderElem) +import Clash.Explicit.Signal (ResetPolarity(..), vResetPolarity) +import Clash.Netlist.BlackBox.Util (exprToString, getDomainConf, renderElem) import Clash.Netlist.BlackBox.Types (BlackBoxTemplate, Element(Component, Text), Decl(..)) import qualified Clash.Netlist.Id as Id @@ -106,7 +127,6 @@ import Clash.Netlist.Util import Clash.Util (clogBase) import qualified Data.String.Interpolate as I -import Data.String.Interpolate.Util (unindent) import Language.Haskell.TH (Name) import Prelude @@ -139,7 +159,7 @@ -- | Create a blackBoxHaskell primitive. To be used as part of an annotation: -- -- @ --- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{_ignoredArguments=[1,2]}) \#-} +-- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{bo_ignoredArguments=[1,2]}) \#-} -- @ -- -- @[1,2]@ would mean this blackbox __ignores__ its second and third argument. @@ -152,19 +172,17 @@ -- ^ Options, see data structure for more information -> Primitive blackBoxHaskell bb tf BlackBoxHaskellOpts{..} = - InlinePrimitive bo_supportedHdls $ unindent [I.i| - [ { "BlackBoxHaskell" : - { "name" : "#{bb}" - , "templateFunction" : "#{tf}" - , "ignoredArguments" : #{show bo_ignoredArguments} - , "multiResult" : #{toJsonBool bo_multiResult} - } - } - ] |] + InlineYamlPrimitive bo_supportedHdls [I.__i| + BlackBoxHaskell: + name: #{bb} + templateFunction: #{tf} + ignoredArguments : #{bo_ignoredArguments} + multiResult : #{toYamlBool bo_multiResult} + |] where - toJsonBool :: Bool -> String - toJsonBool True = "true" - toJsonBool False = "false" + toYamlBool :: Bool -> String + toYamlBool True = "true" + toYamlBool False = "false" -- | The state of a block. Contains a list of declarations and a the -- backend state. @@ -183,6 +201,20 @@ identifierSet :: Lens' (BlockState backend) IdentifierSet identifierSet = bsBackend . identifierSet +instance HasUsageMap backend => HasUsageMap (BlockState backend) where + usageMap = bsBackend.usageMap + +liftToBlockState + :: forall backend a. Backend backend + => State backend a -> State (BlockState backend) a +liftToBlockState (StateT f) = StateT g + where + g :: BlockState backend -> Identity (a, BlockState backend) + g sbsIn = do + let sIn = _bsBackend sbsIn + (res,sOut) <- f sIn + pure (res, sbsIn{_bsBackend = sOut}) + -- | A typed expression. data TExpr = TExpr { ety :: HWType @@ -205,10 +237,19 @@ declarationReturn bbCtx blockName blockBuilder = declaration blockName $ do res <- blockBuilder - forM_ (zip (bbResults bbCtx) res) $ \(rNm, r) -> do - let (Identifier resultNm Nothing, _) = rNm - addDeclaration (Assignment resultNm (eex r)) + forM_ (zip (bbResults bbCtx) res) $ \(rNm, r) -> case rNm of + (Identifier resultNm Nothing, _) -> + addDeclaration (Assignment resultNm Cont (eex r)) + (t,_) -> error ("declarationReturn expected an Identifier, but got: " <> show t) + +emptyBlockState :: backend -> BlockState backend +emptyBlockState bck = BlockState + { _bsDeclarations = [] + , _bsHigherOrderCalls = IntMap.empty + , _bsBackend = bck + } + -- | Run a block declaration. declaration :: Backend backend @@ -218,13 +259,13 @@ -- ^ block builder -> State backend Doc -- ^ pretty printed block -declaration blockName s = do +declaration blockName c = do backend0 <- get - let initState = BlockState [] IntMap.empty backend0 - BlockState decs _hoCalls backend1 = execState s initState - put backend1 + let initState = emptyBlockState backend0 + (BlockState {..}) = execState c initState + put _bsBackend blockNameUnique <- Id.makeBasic blockName - getAp $ blockDecl blockNameUnique (reverse decs) + getAp $ blockDecl blockNameUnique (reverse _bsDeclarations) -- | Add a declaration to the state. addDeclaration :: Declaration -> State (BlockState backend) () @@ -235,15 +276,13 @@ :: Backend backend => Text -- ^ Name hint - -> WireOrReg - -- ^ Should signal be declared as a wire or a reg -> HWType -- ^ Type of new signal -> State (BlockState backend) Identifier -- ^ Expression pointing the the new signal -declare' decName wireOrReg ty = do +declare' decName ty = do uniqueName <- Id.makeBasic decName - addDeclaration (NetDecl' Nothing wireOrReg uniqueName (Right ty) Nothing) + addDeclaration (NetDecl' Nothing uniqueName ty Nothing) pure uniqueName -- | Declare a new signal with the given name and type. @@ -251,16 +290,33 @@ :: Backend backend => Text -- ^ Name hint - -> WireOrReg - -- ^ Should signal be declared as a wire or a reg -> HWType -- ^ Type of new signal -> State (BlockState backend) TExpr -- ^ Expression pointing the the new signal -declare decName wireOrReg ty = do - uniqueName <- declare' decName wireOrReg ty +declare decName ty = do + uniqueName <- declare' decName ty pure (TExpr ty (Identifier uniqueName Nothing)) +-- | Declare /n/ new signals with the given type and based on the given name +declareN + :: Backend backend + => Text + -- ^ Name hint + -> [HWType] + -- ^ Types of the signals + -> State (BlockState backend) [TExpr] + -- ^ Expressions pointing the the new signals +declareN decName tys = do + firstName <- Id.makeBasic decName + nextNames <- Id.nextN (length tys - 1) firstName + let uniqueNames = firstName : nextNames + zipWithM + (\uniqueName ty -> do + addDeclaration $ NetDecl' Nothing uniqueName ty Nothing + pure $ TExpr ty (Identifier uniqueName Nothing) + ) uniqueNames tys + -- | Assign an expression to an identifier, returns the new typed -- identifier expression. assign @@ -268,12 +324,16 @@ => Text -- ^ Name hint for assignment -> TExpr - -- ^ expression to be assigned to + -- ^ expression to be assigned to freshly generated identifier -> State (BlockState backend) TExpr -- ^ the identifier of the expression that actually got assigned assign aName (TExpr ty aExpr) = do - texp@(~(TExpr _ (Identifier uniqueName Nothing))) <- declare aName Wire ty - addDeclaration (Assignment uniqueName aExpr) + texp <- declare aName ty + let uniqueName = case texp of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("assign expected an Identifier, but got: " <> show t') + + addDeclaration (Assignment uniqueName Cont aExpr) pure texp -- | Extract the elements of a vector expression and return expressions @@ -288,11 +348,49 @@ -> State (BlockState backend) [TExpr] -- ^ Vector elements unvec vName v@(ety -> Vector vSize eType) = do - ~(TExpr _ (Identifier vUniqueName Nothing)) <- toIdentifier vName v + texp <- toIdentifier vName v + let vUniqueName = case texp of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("unvec expected an Identifier, but got: " <> show t') + let vIndex i = Identifier vUniqueName (Just (Indexed (ety v, 10, i))) pure (map (TExpr eType . vIndex) [0..vSize-1]) unvec _ e = error $ "unvec: cannot be called on non-vector: " <> show (ety e) +-- | Deconstruct a 'Maybe' into its constructor 'Bit' and contents of its 'Just' +-- field. Note that the contents might be undefined, if the constructor bit is +-- set to 'Nothing'. +deconstructMaybe :: + (HasCallStack, Backend backend) => + -- | Maybe expression + TExpr -> + -- | Name hint for constructor bit, data + (Text, Text) -> + -- | Constructor represented as a Bit, contents of Just + State (BlockState backend) (TExpr, TExpr) +deconstructMaybe e@TExpr{ety} (bitName, contentName) + | SP tyName [(_nothing, []),(_just, [aTy])] <- ety + , tyName == fromString (show ''Maybe) + = do + eBv <- toBV (bitName <> "_and_" <> contentName <> "_bv") e + eId <- toIdentifier' (bitName <> "_and_" <> contentName) eBv + let eSize = typeSize ety + + bitExpr <- fromBV bitName Bit TExpr + { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1, eSize - 1))) + , ety = BitVector 1 + } + + contentExpr <- fromBV contentName aTy TExpr + { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1 - 1, 0))) + , ety = BitVector (eSize - 1) + } + + pure (bitExpr, contentExpr) + +deconstructMaybe e _ = + error $ "deconstructMaybe: cannot be called on non-Maybe: " <> show (ety e) + -- | Extract the fields of a product type and return expressions -- to them. These new expressions are given unique names and get -- declared in the block scope. @@ -303,10 +401,15 @@ -> [Text] -- ^ Name hints for element assignments -> State (BlockState backend) [TExpr] -deconstructProduct (TExpr ty@(Product _ _ tys) (Identifier resName _)) vals = do - newNames <- zipWithM (flip declare Wire) vals tys - addDeclaration $ Assignment resName $ DataCon ty (DC (ty, 0)) (fmap eex newNames) - pure newNames +deconstructProduct (TExpr ty@(Product _ _ fieldTys) (Identifier resName Nothing)) nameHints = + forM (zip3 [0..] nameHints fieldTys) $ \(fieldIndex, nameHint, fieldTy) -> + assign nameHint $ + TExpr fieldTy (Identifier resName (Just (Indexed (ty, 0, fieldIndex)))) + +deconstructProduct t0@(TExpr (Product {}) _) nameHints = do + t1 <- toIdentifier "product" t0 + deconstructProduct t1 nameHints + deconstructProduct e i = error $ "deconstructProduct: " <> show e <> " " <> show i @@ -365,12 +468,16 @@ T -> pure High F -> pure Low TExpr Bool boolExpr -> do - texp@(~(TExpr _ (Identifier uniqueBitName Nothing))) <- declare bitName Wire Bit + texp <- declare bitName Bit + let uniqueBitName = case texp of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("boolFromBit expected an Identifier, but got: " <> show t') addDeclaration $ CondAssignment uniqueBitName Bit boolExpr Bool [ (Just (BoolLit True), Literal Nothing (BitLit H)) , (Nothing , Literal Nothing (BitLit L)) ] + declareUseOnce (Proc NonBlocking) uniqueBitName pure texp tExpr -> error $ "boolToBit: Got \"" <> show tExpr <> "\" expected Bool" @@ -383,13 +490,17 @@ -> State (BlockState backend) TExpr enableToBit bitName = \case TExpr ena@(Enable _) enableExpr -> do - texp@(~(TExpr _ (Identifier uniqueBitName Nothing))) <- declare bitName Wire Bit + texp <- declare bitName Bit + let uniqueBitName = case texp of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("boolFromBit expected an Identifier, but got: " <> show t') addDeclaration $ CondAssignment uniqueBitName Bit enableExpr ena -- Enable normalizes to Bool for all current backends [ (Just (BoolLit True), Literal Nothing (BitLit H)) , (Nothing , Literal Nothing (BitLit L)) ] + declareUseOnce (Proc NonBlocking) uniqueBitName pure texp tExpr -> error $ "enableToBit: Got \"" <> show tExpr <> "\" expected Enable" @@ -398,11 +509,27 @@ -- Returns a reference to a declared `Bit` that should get assigned -- by something (usually the output port of an entity). boolFromBit - :: Text + :: (HasCallStack, Backend backend) + => Text -- ^ Name hint for intermediate signal -> TExpr - -> State (BlockState VHDLState) TExpr -boolFromBit = outputCoerce Bit Bool (<> " = '1'") + -> State (BlockState backend) TExpr +boolFromBit boolName = \case + High -> pure T + Low -> pure F + TExpr Bit bitExpr -> do + texp <- declare boolName Bool + let uniqueBoolName = case texp of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("boolFromBit expected an Identifier, but got: " <> show t') + addDeclaration $ + CondAssignment uniqueBoolName Bool bitExpr Bit + [ (Just (BitLit H), Literal Nothing (BoolLit True)) + , (Nothing , Literal Nothing (BoolLit False)) + ] + declareUseOnce (Proc NonBlocking) uniqueBoolName + pure texp + tExpr -> error $ "boolFromBit: Got \"" <> show tExpr <> "\" expected Bit" -- | Used to create an output `Bool` from a `BitVector` of given size. -- Works in a similar way to `boolFromBit` above. @@ -419,17 +546,18 @@ -- | Used to create an output `Unsigned` from a `BitVector` of given -- size. Works in a similar way to `boolFromBit` above. --- --- TODO: Implement for (System)Verilog -unsignedFromBitVector - :: HasCallStack - => Size - -> Text - -- ^ Name hint for intermediate signal - -> TExpr - -> State (BlockState VHDLState) TExpr -unsignedFromBitVector n = - outputCoerce (BitVector n) (Unsigned n) (\i -> "unsigned(" <> i <> ")") +unsignedFromBitVector :: + (HasCallStack, Backend backend) => + -- | Name hint for intermediate signal + Text -> + -- | BitVector expression + TExpr -> + -- | Unsigned expression + State (BlockState backend) TExpr +unsignedFromBitVector nameHint e@TExpr{ety=BitVector n} = + fromBV nameHint (Unsigned n) e +unsignedFromBitVector _nameHint TExpr{ety} = + error $ "unsignedFromBitVector: Expected BitVector, got: " <> show ety -- | Used to create an output `Bool` from a number of `Bit`s, using -- conjunction. Similarly to `untuple`, it returns a list of @@ -465,7 +593,7 @@ let inName2 = Id.unsafeMake (exprStringFn (Id.toText inName1)) exprIdent = Identifier inName2 Nothing addDeclaration (NetDecl Nothing inName1 fromType) - addDeclaration (Assignment outName exprIdent) + addDeclaration (Assignment outName Cont exprIdent) pure (TExpr fromType (Identifier inName1 Nothing)) outputCoerce _ toType _ _ texpr = error $ "outputCoerce: the expression " <> show texpr <> " must be an Identifier with type " <> show toType @@ -491,7 +619,7 @@ exprIdent = Identifier idExpr Nothing sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t) | (nm, t) <- zip inNames1 fromTypes ] - addDeclaration (Assignment outName exprIdent) + addDeclaration (Assignment outName Cont exprIdent) pure [ TExpr t (Identifier nm Nothing) | (nm,t) <- zipEqual inNames1 fromTypes ] outputFn _ outType _ _ texpr = @@ -539,6 +667,17 @@ getBool (TExpr _ (Literal _ (BoolLit b))) = Just b getBool _ = Nothing +-- | Try to get a Vector of expressions. +getVec :: TExpr -> Maybe [TExpr] +getVec (TExpr (Void (Just (Vector 0 _) )) _) = + pure [] +getVec (TExpr (Vector 1 elementTy) (DataCon _ VecAppend [e])) = + pure [TExpr elementTy e] +getVec (TExpr (Vector n elementTy) (DataCon _ VecAppend [e, es0])) = do + es1 <- getVec (TExpr (Vector (n-1) elementTy) es0) + pure (TExpr elementTy e:es1) +getVec _ = Nothing + -- | Try to get the literal nat value of an expression. tExprToInteger :: TExpr -> Maybe Integer tExprToInteger (TExpr _ e) = exprToInteger e @@ -548,41 +687,72 @@ exprToInteger (Literal _ (NumLit n)) = Just n exprToInteger _ = Nothing --- | Assign an input bitvector to an expression. Declares a new --- bitvector if the expression is not already a bitvector. -toBV - :: Backend backend - => Text - -- ^ BitVector name hint - -> TExpr - -- ^ expression - -> State (BlockState backend) TExpr - -- ^ BitVector expression -toBV bvName a = case a of - TExpr BitVector{} _ -> pure a - TExpr aTy aExpr -> assign bvName $ - TExpr (BitVector (typeSize aTy)) (ToBv Nothing aTy aExpr) +-- | Convert an expression from one type to another. Errors if result type and +-- given expression are sized differently. +bitCoerce :: + (HasCallStack, Backend backend) => + -- | Name hints for intermediate variables + Text -> + -- | Type to convert to + HWType -> + -- | Expression to convert + TExpr -> + -- | Converted expression + State (BlockState backend) TExpr +bitCoerce nameHint destType e@(TExpr ety _) + | tySize ety /= tySize @Int destType = error "Size mismatch" + | ety == destType = pure e + | BitVector _ <- ety = fromBV nameHint destType e + | otherwise = bitCoerce nameHint destType =<< toBV nameHint e --- | Assign an output bitvector to an expression. Declares a new --- bitvector if the expression is not already a bitvector. +-- | Convert an expression to a BitVector +toBV :: + Backend backend => + -- | BitVector name hint + Text -> + -- | Expression to convert to BitVector + TExpr -> + -- | BitVector expression + State (BlockState backend) TExpr +toBV = toBvWithAttrs [] + +-- | Convert an expression to a BitVector and add the given HDL attributes +toBvWithAttrs :: + Backend backend => + [Attr Text] -> + -- | BitVector name hint + Text -> + -- | Expression to convert to BitVector + TExpr -> + -- | BitVector expression + State (BlockState backend) TExpr +toBvWithAttrs attrs bvName (TExpr aTy aExpr) = + assign bvName $ + TExpr + (annotated attrs (BitVector (tySize aTy))) + (ToBv Nothing aTy aExpr) + +-- | Convert an expression from a 'BitVector' into some type. If the expression +-- is 'Annotated', only convert the expression within. fromBV - :: (HasCallStack, Backend backend) - => Text - -- ^ BitVector name hint - -> TExpr - -- ^ expression - -> State (BlockState backend) TExpr - -- ^ bv expression -fromBV _ a@(TExpr BitVector{} _) = pure a -fromBV bvName (TExpr aTy (Identifier aName Nothing)) = do - bvName' <- Id.makeBasic bvName - let bvExpr = FromBv Nothing aTy (Identifier bvName' Nothing) - bvTy = BitVector (typeSize aTy) - addDeclaration (NetDecl Nothing bvName' bvTy) - addDeclaration (Assignment aName bvExpr) - pure (TExpr bvTy (Identifier bvName' Nothing)) -fromBV _ texpr = error $ - "fromBV: the expression " <> show texpr <> "must be an Identifier" + :: (HasCallStack, Backend backend) => + -- | Result name hint + Text -> + -- | Type to convert to + HWType -> + -- | 'BitVector' expression + TExpr -> + -- | Converted 'BitVector' expression + State (BlockState backend) TExpr +fromBV resultName resultType e@TExpr{eex, ety = BitVector _} = + case resultType of + BitVector{} -> pure e + _ -> assign resultName (TExpr resultType (FromBv Nothing resultType eex)) +fromBV resultName resultType e@TExpr{ety = Annotated _ bv@(BitVector _)} = + case resultType of + BitVector{} -> pure (TExpr bv (eex e)) + _ -> assign resultName (TExpr resultType (FromBv Nothing resultType (eex e))) +fromBV _ _ TExpr{ety} = error $ "fromBV: expected BitVector, got: " <> show ety clog2 :: Num i => Integer -> i clog2 = fromIntegral . fromMaybe 0 . clogBase 2 @@ -618,11 +788,11 @@ -> Int -- ^ Position of HO-argument. For example: -- - -- fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a + -- > fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a -- -- would have its HO-argument at position 0, while -- - -- iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a + -- > iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a -- -- would have it at position 1. -> (HWType, BlackBoxTemplate) @@ -646,15 +816,8 @@ let args2 = map (pure . Text . Id.toLazyText) args1 - -- Create result identifier - -- See https://github.com/clash-lang/clash-compiler/issues/919 for info on - -- logic of 'resWireOrReg' - resWireOrReg = - case IntMap.lookup fPos (bbFunctions bbCtx) of - Just ((_,rw,_,_,_,_):_) -> rw - _ -> error "internal error" resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_" - <> showt fSubPos <> "_res") resWireOrReg resTy + <> showt fSubPos <> "_res") resTy let res = ([Text (Id.toLazyText resName)], bbResTy) -- Render HO argument to plain text @@ -674,33 +837,76 @@ pure (TExpr resTy (Identifier resName Nothing)) --- | Instantiate a component/entity in a block state. +-- | This creates a component declaration (for VHDL) given in and out port +-- names, updating the 'BlockState backend' stored in the 'State' monad. +-- +-- A typical result is that a +-- +-- @ +-- component fifo port +-- ( rst : in std_logic +-- ... +-- ; full : out std_logic +-- ; empty : out std_logic ); +-- end component; +-- @ +-- +-- declaration would be added in the appropriate place. +compInBlock + :: forall backend + . Backend backend + => Text + -- ^ Component name + -> [(Text, HWType)] + -- ^ in ports + -> [(Text, HWType)] + -- ^ out ports + -> State (BlockState backend) () +compInBlock compName inPorts0 outPorts0 = + addDeclaration (CompDecl compName (inPorts1 ++ outPorts1)) + where + mkPort inOut (nm, ty) = (nm, inOut, ty) + inPorts1 = mkPort In <$> inPorts0 + outPorts1 = mkPort Out <$> outPorts0 + +-- | Convert a 'LitHDL' to a 'TExpr' +-- +-- __N.B.__: Clash 1.8 changed 'instDecl'\'s type signature. Where it would +-- previously accept 'LitHDL' in its generics/parameters argument, it +-- now accepts a 'TExpr'. This function is mostly there to ease this +-- transition. +litTExpr :: LitHDL -> TExpr +litTExpr (B b) = TExpr Bool (Literal Nothing (BoolLit b)) +litTExpr (S s) = TExpr String (Literal Nothing (StringLit s)) +litTExpr (I i) = TExpr Integer (Literal Nothing (NumLit i)) + +-- | Instantiate a component/entity in a block state instDecl :: forall backend . Backend backend => EntityOrComponent -- ^ Type of instantiation -> Identifier - -- ^ component/entity name + -- ^ Component/entity name -> Identifier - -- ^ instantiation label - -> [(Text, LitHDL)] - -- ^ attributes + -- ^ Instantiation label -> [(Text, TExpr)] - -- ^ in ports + -- ^ Generics / parameters -> [(Text, TExpr)] - -- ^ out ports + -- ^ In ports + -> [(Text, TExpr)] + -- ^ Out ports -> State (BlockState backend) () -instDecl entOrComp compName instLbl attrs inPorts outPorts = do +instDecl entOrComp compName instLbl params inPorts outPorts = do inPorts' <- mapM (mkPort In) inPorts outPorts' <- mapM (mkPort Out) outPorts addDeclaration $ InstDecl - entOrComp Nothing [] compName instLbl (mkAttrs attrs) + entOrComp Nothing [] compName instLbl (mkParams params) (NamedPortMap (inPorts' ++ outPorts')) - where + where mkPort :: PortDirection -> (Text, TExpr) @@ -709,21 +915,12 @@ TExpr ty pExpr' <- toIdentifier (nmText <> "_port") pExpr pure (Identifier (Id.unsafeMake nmText) Nothing, inOrOut, ty, pExpr') - -- Convert a list of name attributes to the form clash wants - mkAttrs :: [(Text.Text, LitHDL)] -> [(Expr, HWType, Expr)] - mkAttrs = map (\(s, ty) -> ( Identifier (Id.unsafeMake s) Nothing - , hdlTy ty, litExpr ty) ) - - litExpr :: LitHDL -> Expr - litExpr (B b) = Literal Nothing (BoolLit b) - litExpr (S s) = Literal Nothing (StringLit s) - litExpr (I i) = Literal Nothing (NumLit i) - - hdlTy :: LitHDL -> HWType - hdlTy = \case - B{} -> Bool - S{} -> String - I{} -> Integer + -- Convert a list of name generics / parameters to the form clash wants + mkParams :: [(Text.Text, TExpr)] -> [(Expr, HWType, Expr)] + mkParams = map $ \(paramName, texpr) -> + ( Identifier (Id.unsafeMake paramName) Nothing + , ety texpr + , eex texpr ) -- | Wires the two given `TExpr`s together using a newly declared -- signal with (exactly) the given name `sigNm`. The new signal has an @@ -736,14 +933,14 @@ -- ^ expression the signal is assigned to -> TExpr -- ^ expression (must be identifier) to which the signal is assigned - -> [Attr'] + -> [Attr Text] -- ^ the attributes to annotate the signal with -> State (BlockState backend) () viaAnnotatedSignal sigNm (TExpr fromTy fromExpr) (TExpr toTy (Identifier outNm Nothing)) attrs | fromTy == toTy = do addDeclaration (NetDecl Nothing sigNm (Annotated attrs fromTy)) - addDeclaration (Assignment sigNm fromExpr) - addDeclaration (Assignment outNm (Identifier sigNm Nothing)) + addDeclaration (Assignment sigNm Cont fromExpr) + addDeclaration (Assignment outNm Cont (Identifier sigNm Nothing)) viaAnnotatedSignal _ inTExpr outTExpr@(TExpr _ (Identifier _ _)) _ = error $ "viaAnnotatedSignal: The in and out expressions \"" <> show inTExpr <> "\" and \"" <> show outTExpr <> "\" have non-matching types." @@ -771,7 +968,10 @@ -- ^ identifier to expression toIdentifier' _ (TExpr _ (Identifier aExpr Nothing)) = pure aExpr toIdentifier' nm texp = do - ~(TExpr _ (Identifier nm' Nothing)) <- assign nm texp + t <- assign nm texp + let nm' = case t of + TExpr _ (Identifier x Nothing) -> x + t' -> error ("toIdentifier' expected an Identifier, but got: " <> show t') pure nm' -- | Get an identifier to an expression, creating a new assignment if @@ -818,15 +1018,43 @@ SystemVerilog -> aIdent <> " && " <> bIdent assign nm $ TExpr Bool (Identifier (Id.unsafeMake andTxt) Nothing) +-- | Massage a reset to work as active-high reset. +unsafeToActiveHigh + :: Backend backend + => Text + -- ^ Name hint + -> TExpr + -- ^ Reset signal + -> State (BlockState backend) TExpr +unsafeToActiveHigh nm rExpr = do + resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr)) + case resetLevel of + ActiveHigh -> pure rExpr + ActiveLow -> notExpr nm rExpr + +-- | Massage a reset to work as active-low reset. +unsafeToActiveLow + :: Backend backend + => Text + -- ^ Name hint + -> TExpr + -- ^ Reset signal + -> State (BlockState backend) TExpr +unsafeToActiveLow nm rExpr = do + resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr)) + case resetLevel of + ActiveLow -> pure rExpr + ActiveHigh -> notExpr nm rExpr + -- | Negate @(not)@ an expression, assigning it to a new identifier. notExpr :: Backend backend => Text -- ^ name hint -> TExpr - -- ^ a + -- ^ @a@ -> State (BlockState backend) TExpr - -- ^ not a + -- ^ @not a@ notExpr _ T = pure F notExpr _ F = pure T notExpr nm aExpr = do @@ -851,9 +1079,9 @@ -> Int -- ^ Size (n) -> TExpr - -- ^ ARG + -- ^ @ARG@ -> State (BlockState VHDLState) TExpr - -- ^ (0 to n => ARG) + -- ^ @(0 to n => ARG)@ pureToBV nm n arg = do arg' <- Id.toText <$> toIdentifier' nm arg -- This is very hard coded and hacky @@ -863,7 +1091,7 @@ -- | Creates a BV that produces the following vhdl: -- -- @ --- std_logic_vector(resize(ARG, Size)) +-- std_logic_vector(resize(ARG, n)) -- @ -- -- TODO: Implement for (System)Verilog @@ -875,7 +1103,7 @@ -> TExpr -- ^ ARG -> State (BlockState VHDLState) TExpr - -- ^ std_logic_vector(resize(ARG, Size)) + -- ^ @std_logic_vector(resize(ARG, n))@ pureToBVResized nm n arg = do arg' <- Id.toText <$> toIdentifier' nm arg -- This is very hard coded and hacky diff --git a/src/Clash/Primitives/GHC/Int.hs b/src/Clash/Primitives/GHC/Int.hs --- a/src/Clash/Primitives/GHC/Int.hs +++ b/src/Clash/Primitives/GHC/Int.hs @@ -5,13 +5,14 @@ Blackbox generation for GHC.Int.IntX# data constructors. (System)Verilog only! -} + +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.GHC.Int (intTF) where -import Clash.Core.Literal - (Literal(IntegerLiteral, IntLiteral, Int64Literal)) +import Clash.Core.Literal (Literal(..)) import Clash.Core.Term (Term(Literal)) import Clash.Core.Type (Type) import Clash.Primitives.GHC.Literal @@ -28,6 +29,11 @@ \case IntegerLiteral i -> Just i IntLiteral i -> Just i +#if MIN_VERSION_ghc(8,8,0) + Int8Literal i -> Just i + Int16Literal i -> Just i + Int32Literal i -> Just i +#endif Int64Literal i -> Just i _ -> Nothing diff --git a/src/Clash/Primitives/GHC/Word.hs b/src/Clash/Primitives/GHC/Word.hs --- a/src/Clash/Primitives/GHC/Word.hs +++ b/src/Clash/Primitives/GHC/Word.hs @@ -5,11 +5,13 @@ Blackbox generation for GHC.Word.WordX# data constructors. (System)Verilog only! -} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.GHC.Word (wordTF) where -import Clash.Core.Literal (Literal(WordLiteral)) +import Clash.Core.Literal (Literal(..)) import Clash.Core.Term (Term(Literal)) import Clash.Core.Type (Type) import Clash.Primitives.GHC.Literal @@ -24,6 +26,20 @@ wordTF :: BlackBoxFunction wordTF = literalTF "GHC.Word.W" wordTF' +getWordLit + :: Literal + -> Maybe Integer +getWordLit = + \case + WordLiteral i -> Just i +#if MIN_VERSION_ghc(8,8,0) + Word8Literal i -> Just i + Word16Literal i -> Just i + Word32Literal i -> Just i +#endif + Word64Literal i -> Just i + _ -> Nothing + wordTF' :: Bool -- ^ Is declaration @@ -32,12 +48,12 @@ -> Int -- ^ Word size -> (BlackBoxMeta, BlackBox) -wordTF' False [Left (Literal (WordLiteral n))] wordSize = +wordTF' False [Left (Literal (getWordLit -> Just n))] wordSize = -- Literal as expression: ( emptyBlackBoxMeta , BBTemplate [unsignedLiteral wordSize n]) -wordTF' True [Left (Literal (WordLiteral n))] wordSize = +wordTF' True [Left (Literal (getWordLit -> Just n))] wordSize = -- Literal as declaration: ( emptyBlackBoxMeta , BBTemplate (assign Result [unsignedLiteral wordSize n])) diff --git a/src/Clash/Primitives/Intel/ClockGen.hs b/src/Clash/Primitives/Intel/ClockGen.hs --- a/src/Clash/Primitives/Intel/ClockGen.hs +++ b/src/Clash/Primitives/Intel/ClockGen.hs @@ -1,10 +1,11 @@ {-| Copyright : (C) 2018 , Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V., + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. - Blackbox template functions for Clash.Intel.ClockGen.{alteraPll,altpll} + Blackbox template functions for Clash.Intel.ClockGen -} {-# LANGUAGE OverloadedStrings #-} @@ -13,271 +14,302 @@ module Clash.Primitives.Intel.ClockGen where +import Control.Monad.State +import Data.List (zip4) +import Data.List.Infinite (Infinite(..), (...)) +import Data.Maybe (fromMaybe) +import Data.Text.Prettyprint.Doc.Extra +import Text.Show.Pretty (ppShow) + import Clash.Backend -import Clash.Netlist.BlackBox.Util import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types import Clash.Netlist.Util - -import Control.Monad.State -import Data.Monoid (Ap(getAp)) -import qualified Data.String.Interpolate.IsString as I -import Data.Text.Prettyprint.Doc.Extra +import qualified Clash.Primitives.DSL as DSL +import Clash.Signal (periodToHz) +import Data.Text.Extra (showt) +import qualified Data.String.Interpolate as I import qualified Data.Text as TextS -import Data.Text.Extra (showt) +import qualified Prettyprinter.Interpolate as I -altpllTF :: TemplateFunction -altpllTF = TemplateFunction used valid altpllTemplate +data Variant = Altpll | AlteraPll + +hdlUsed :: [Int] +hdlUsed = [ clk, rst ] where - used = [0..4] - valid bbCtx - | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx - , Just _ <- exprToString nm - , [(Identifier _ Nothing,Product {})] <- bbResults bbCtx - = True - valid _ = False + _knownDomIn + :< _clocksClass + :< _clocksCxt + :< _numOutClocks + :< clk + :< rst + :< _ = (0...) +hdlValid :: BlackBoxContext -> Bool +hdlValid bbCtx | [(_,Product {})] <- bbResults bbCtx = True +hdlValid _ = False + +qsysUsed :: [Int] +qsysUsed = [ knownDomIn, clocksCxt ] + where + knownDomIn + :< _clocksClass + :< clocksCxt + :< _ = (0...) + +altpllTF :: TemplateFunction +altpllTF = TemplateFunction hdlUsed hdlValid (hdlTemplate Altpll) + altpllQsysTF :: TemplateFunction -altpllQsysTF = TemplateFunction used valid altpllQsysTemplate +altpllQsysTF = TemplateFunction qsysUsed valid altpllQsysTemplate where - used = [0..4] - valid bbCtx - | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx - , Just _ <- exprToString nm - , [(Identifier _ Nothing,Product {})] <- bbResults bbCtx - = True - valid _ = False + valid = const True alteraPllTF :: TemplateFunction -alteraPllTF = TemplateFunction used valid alteraPllTemplate - where - used = [1..20] - valid bbCtx - | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx) - , Just _ <- exprToString nm - = True - valid _ = False +alteraPllTF = TemplateFunction hdlUsed hdlValid (hdlTemplate AlteraPll) alteraPllQsysTF :: TemplateFunction -alteraPllQsysTF = TemplateFunction used valid alteraPllQsysTemplate +alteraPllQsysTF = TemplateFunction qsysUsed valid alteraPllQsysTemplate where - used = [1..20] - valid bbCtx - | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx) - , Just _ <- exprToString nm - = True - valid _ = False + valid = const True -alteraPllTemplate - :: forall s - . Backend s - => BlackBoxContext - -> State s Doc -alteraPllTemplate bbCtx = do - locked <- Id.makeBasic "locked" - pllLock <- Id.makeBasic "pllLock" - alteraPll <- Id.makeBasic "altera_pll_block" - alteraPll_inst <- Id.makeBasic instname0 +hdlTemplate :: + forall s . + Backend s => + Variant -> + BlackBoxContext -> + State s Doc +hdlTemplate variant bbCtx + | [ _knownDomIn + , _clocksClass + , _clocksCxt + , _numOutClocks + , clk + , rst + ] <- map fst (DSL.tInputs bbCtx) + , [DSL.ety -> resultTy] <- DSL.tResults bbCtx + , Product _ _ (init -> pllOutTys) <- resultTy + , [compName] <- bbQsysIncName bbCtx + = do + let + stdName Altpll = "altpll" + stdName AlteraPll = "altera_pll" + pllOutName Altpll = "c" + pllOutName AlteraPll = "outclk_" + clkInName Altpll = "clk" + clkInName AlteraPll = "refclk" + rstName Altpll = "areset" + rstName AlteraPll = "rst" - clocks <- Id.nextN (length tys) =<< Id.make "pllOut" + instName <- Id.makeBasic $ fromMaybe (stdName variant) $ bbCtxName bbCtx - -- TODO: unsafeMake is dubious here: I don't think we take names in - -- TODO: bbQsysIncName into account when generating fresh ids - let compName = Id.unsafeMake (head (bbQsysIncName bbCtx)) + -- TODO: unsafeMake is dubious here: I don't think we take names in + -- TODO: bbQsysIncName into account when generating fresh ids + let compNameId = Id.unsafeMake compName - let outclkPorts = map (\n -> instPort ("outclk_" <> showt n)) [(0 :: Int)..length clocks-1] + DSL.declarationReturn bbCtx (stdName variant <> "_block") $ do - getAp $ blockDecl alteraPll $ concat - [[ NetDecl Nothing locked Bit - , NetDecl' Nothing Reg pllLock (Right Bool) Nothing] - ,[ NetDecl Nothing clkNm ty | (clkNm,ty) <- zip clocks tys] - ,[ InstDecl Comp Nothing [] compName alteraPll_inst [] $ NamedPortMap $ concat - [ [ (instPort "refclk", In, clkTy, clk) - , (instPort "rst", In, rstTy, rst)] - , [ (p, Out, ty, Identifier k Nothing) | (k, ty, p) <- zip3 clocks tys outclkPorts ] - , [(instPort "locked", Out, Bit, Identifier locked Nothing)]] - , CondAssignment pllLock Bool (Identifier locked Nothing) Bit - [(Just (BitLit H),Literal Nothing (BoolLit True)) - ,(Nothing ,Literal Nothing (BoolLit False))] - , Assignment result (DataCon resTy (DC (resTy,0)) $ concat - [[Identifier k Nothing | k <- clocks] - ,[Identifier pllLock Nothing]]) + rstHigh <- DSL.unsafeToActiveHigh "reset" rst + pllOuts <- DSL.declareN "pllOut" pllOutTys + locked <- DSL.declare "locked" Bit + pllLock <- DSL.boolFromBit "pllLock" locked - ] - ] - where - [(Identifier result Nothing,resTy@(Product _ _ (init -> tys)))] = bbResults bbCtx - [(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = drop 3 (bbInputs bbCtx) - Just nm' = exprToString nm - instname0 = TextS.pack nm' + let + pllOutNames = + map (\n -> pllOutName variant <> showt n) + [0 .. length pllOutTys - 1] + compInps = + [ (clkInName variant, DSL.ety clk) + , (rstName variant, DSL.ety rstHigh) + ] + compOuts = zip pllOutNames pllOutTys <> [("locked", Bit)] + inps = + [ (clkInName variant, clk) + , (rstName variant, rstHigh) + ] + outs = zip pllOutNames pllOuts <> [("locked", locked)] -altpllTemplate + DSL.compInBlock compName compInps compOuts + DSL.instDecl Empty compNameId instName [] inps outs + + pure [DSL.constructProduct resultTy (pllOuts <> [pllLock])] + | otherwise + = error $ ppShow bbCtx + +altpllQsysTemplate :: Backend s => BlackBoxContext -> State s Doc -altpllTemplate bbCtx = do - pllOut <- Id.make "pllOut" - locked <- Id.make "locked" - pllLock <- Id.make "pllLock" - alteraPll <- Id.make "altpll_block" - alteraPll_inst <- Id.make instname0 +altpllQsysTemplate bbCtx + | (_,stripVoid -> (KnownDomain _ clkInPeriod _ _ _ _),_) + : _clocksClass + : (_,stripVoid -> Product _ _ (init -> kdOuts),_) + : _ <- bbInputs bbCtx + = let + clkPeriod (KnownDomain _ p _ _ _ _) = p + clkPeriod _ = + error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx - -- TODO: unsafeMake is dubious here: I don't think we take names in - -- TODO: bbQsysIncName into account when generating fresh ids - let compName = Id.unsafeMake (head (bbQsysIncName bbCtx)) + clkFreq p = periodToHz (fromInteger p) / 1e6 :: Double - getAp $ blockDecl alteraPll - [ NetDecl Nothing locked Bit - , NetDecl' Nothing Reg pllLock (Right Bool) Nothing - , NetDecl Nothing pllOut clkOutTy - , InstDecl Comp Nothing [] compName alteraPll_inst [] $ NamedPortMap $ - [ (instPort "clk", In, clkTy, clk) - , (instPort "areset", In, rstTy, rst) - , (instPort "c0", Out, clkOutTy, Identifier pllOut Nothing) - , (instPort "locked", Out, Bit, Identifier locked Nothing)] - , CondAssignment pllLock Bool (Identifier locked Nothing) Bit - [(Just (BitLit H),Literal Nothing (BoolLit True)) - ,(Nothing ,Literal Nothing (BoolLit False))] - , Assignment result (DataCon resTy (DC (resTy,0)) - [Identifier pllOut Nothing - ,Identifier pllLock Nothing]) + clkOutPeriods = map clkPeriod kdOuts + clkLcms = map (lcm clkInPeriod) clkOutPeriods + clkMults = zipWith quot clkLcms clkOutPeriods + clkDivs = map (`quot` clkInPeriod) clkLcms + clkOutFreqs = map clkFreq clkOutPeriods - ] - where - [_,_,(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx - [(Identifier result Nothing,resTy@(Product _ _ [clkOutTy,_]))] = bbResults bbCtx - Just nm' = exprToString nm - instname0 = TextS.pack nm' + qsysParams = TextS.intercalate "\n " + [[I.__i| + + + + + + |] + | (clkMult, clkDiv, n) <- zip3 clkMults clkDivs [(0 :: Word)..] + ] -altpllQsysTemplate - :: Backend s - => BlackBoxContext - -> State s Doc -altpllQsysTemplate bbCtx = pure bbText - where - ((_,stripVoid -> kdIn,_):(_,stripVoid -> kdOut,_):_) = bbInputs bbCtx - KnownDomain _ clkInPeriod _ _ _ _ = kdIn - KnownDomain _ clkOutPeriod _ _ _ _ = kdOut - clkOutFreq :: Double - clkOutFreq = (1.0 / (fromInteger clkOutPeriod * 1.0e-12)) / 1e6 - clklcm = lcm clkInPeriod clkOutPeriod - clkmult = clklcm `quot` clkOutPeriod - clkdiv = clklcm `quot` clkInPeriod - -- Note [QSys file templates] - -- This QSys file template was derived from a "full" QSys system with a single - -- "altpll" IP. Module parameters were then stripped on a trial-and-error - -- basis to get a template that has the minimal number of parameters, but - -- still has the desired, working, configuration. - bbText = [I.i| - - - - - - - - - - - - - - - - - - - - CT#PORT_clk0 PORT_USED - CT#CLK0_MULTIPLY_BY #{clkmult} - CT#WIDTH_CLOCK 5 - CT#LPM_TYPE altpll - CT#PLL_TYPE AUTO - CT#CLK0_PHASE_SHIFT 0 - CT#OPERATION_MODE NORMAL - CT#COMPENSATE_CLOCK CLK0 - CT#INCLK0_INPUT_FREQUENCY #{clkInPeriod} - CT#PORT_INCLK0 PORT_USED - CT#PORT_ARESET PORT_USED - CT#BANDWIDTH_TYPE AUTO - CT#CLK0_DUTY_CYCLE 50 - CT#CLK0_DIVIDE_BY #{clkdiv} - CT#PORT_LOCKED PORT_USED - - IF#phasecounterselect {input 4} - IF#locked {output 0} - IF#reset {input 0} - IF#clk {input 0} - IF#phaseupdown {input 0} - IF#scandone {output 0} - IF#readdata {output 32} - IF#write {input 0} - IF#scanclk {input 0} - IF#phasedone {output 0} - IF#address {input 2} - IF#c0 {output 0} - IF#writedata {input 32} - IF#read {input 0} - IF#areset {input 0} - IF#scanclkena {input 0} - IF#scandataout {output 0} - IF#configupdate {input 0} - IF#phasestep {input 0} - IF#scandata {input 0} - - MF#areset 1 - MF#clk 1 - MF#locked 1 - MF#inclk 1 - - PT#PHASE_SHIFT0 0.00000000 - PT#DIV_FACTOR0 #{clkdiv} - PT#EFF_OUTPUT_FREQ_VALUE0 #{clkOutFreq} - PT#MULT_FACTOR0 #{clkmult} - PT#DUTY_CYCLE0 50.00000000 - -|] + qsysConsts = TextS.intercalate "\n " + [[I.__i| + CT\#PORT_clk#{n} PORT_USED + CT\#CLK#{n}_MULTIPLY_BY #{clkMult} + CT\#CLK#{n}_DIVIDE_BY #{clkDiv} + CT\#CLK#{n}_DUTY_CYCLE 50 + CT\#CLK#{n}_PHASE_SHIFT 0 + |] + | (clkMult, clkDiv, n) <- zip3 clkMults clkDivs [(0 :: Word)..] + ] + qsysPorts = + TextS.intercalate "\n " + [[I.i|IF\#c#{n} {output 0}|] | n <- [0 .. length kdOuts - 1]] + + qsysPrivs = TextS.intercalate "\n " + [[I.__i| + PT\#MULT_FACTOR#{n} #{clkMult} + PT\#DIV_FACTOR#{n} #{clkDiv} + PT\#EFF_OUTPUT_FREQ_VALUE#{n} #{clkOutFreq} + PT\#DUTY_CYCLE#{n} 50.00000000 + PT\#PHASE_SHIFT0 0.00000000 + |] + | (clkMult, clkDiv, clkOutFreq, n) <- + zip4 clkMults clkDivs clkOutFreqs [(0 :: Word)..] + ] + + -- Note [QSys file templates] + -- This QSys file template was derived from a "full" QSys system with a single + -- "altpll" IP. Module parameters were then stripped on a trial-and-error + -- basis to get a template that has the minimal number of parameters, but + -- still has the desired, working, configuration. + bbText = [I.__di| + + + + + + + #{qsysParams} + + + + + + + + + + #{qsysConsts} + CT\#WIDTH_CLOCK 5 + CT\#LPM_TYPE altpll + CT\#PLL_TYPE AUTO + CT\#OPERATION_MODE NORMAL + CT\#COMPENSATE_CLOCK CLK0 + CT\#INCLK0_INPUT_FREQUENCY #{clkInPeriod} + CT\#PORT_INCLK0 PORT_USED + CT\#PORT_ARESET PORT_USED + CT\#BANDWIDTH_TYPE AUTO + CT\#PORT_LOCKED PORT_USED + + IF\#phasecounterselect {input 4} + IF\#locked {output 0} + IF\#reset {input 0} + IF\#clk {input 0} + IF\#phaseupdown {input 0} + IF\#scandone {output 0} + IF\#readdata {output 32} + IF\#write {input 0} + IF\#scanclk {input 0} + IF\#phasedone {output 0} + IF\#address {input 2} + #{qsysPorts} + IF\#writedata {input 32} + IF\#read {input 0} + IF\#areset {input 0} + IF\#scanclkena {input 0} + IF\#scandataout {output 0} + IF\#configupdate {input 0} + IF\#phasestep {input 0} + IF\#scandata {input 0} + + MF\#areset 1 + MF\#clk 1 + MF\#locked 1 + MF\#inclk 1 + + #{qsysPrivs} + + + |] + in + pure bbText + | otherwise + = error $ ppShow bbCtx + alteraPllQsysTemplate :: Backend s => BlackBoxContext -> State s Doc -alteraPllQsysTemplate bbCtx = pure bbText - where - (_:(_,stripVoid -> kdIn,_):(_,stripVoid -> kdOutsProd,_):_) = bbInputs bbCtx - kdOuts = case kdOutsProd of - Product _ _ ps -> ps - KnownDomain {} -> [kdOutsProd] - _ -> error "internal error: not a Product or KnownDomain" - - cklFreq (KnownDomain _ p _ _ _ _) - = (1.0 / (fromInteger p * 1.0e-12 :: Double)) / 1e6 - cklFreq _ = error "internal error: not a KnownDomain" +alteraPllQsysTemplate bbCtx + | (_,stripVoid -> kdIn,_) + : _clocksClass + : (_,stripVoid -> Product _ _ (init -> kdOuts),_) + : _ <- bbInputs bbCtx + = let + clkFreq (KnownDomain _ p _ _ _ _) + = periodToHz (fromIntegral p) / 1e6 :: Double + clkFreq _ = + error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx - clkOuts = TextS.unlines - [[I.i||] - | (n,f) <- zip [(0 :: Word)..] (map cklFreq kdOuts) - ] + clkOuts = TextS.intercalate "\n" + [[I.i| |] + | (n,f) <- zip [(0 :: Word)..] (map clkFreq kdOuts) + ] - -- See Note [QSys file templates] on how this qsys template was derived. - bbText = [I.i| - - - - - - #{clkOuts} - - - - -|] + -- See Note [QSys file templates] on how this qsys template was derived. + bbText = [I.__di| + + + + + + + #{clkOuts} + + + + + + |] + in + pure bbText + | otherwise + = error $ ppShow bbCtx diff --git a/src/Clash/Primitives/Magic.hs b/src/Clash/Primitives/Magic.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Magic.hs @@ -0,0 +1,31 @@ +{-| + Copyright : (C) 2022 , Myrtle.ai, + 2023 , QBayLogic B.V., + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Blackbox functions for primitives in the @Clash.Magic@ module. +-} + +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Clash.Primitives.Magic + ( clashCompileErrorBBF + ) where + +import Data.Either (lefts) +import GHC.Stack (HasCallStack) +import Text.Show.Pretty + +import Clash.Core.TermLiteral (termToDataError) +import Clash.Netlist.BlackBox.Types (BlackBoxFunction) +import Clash.Netlist.Types () + +clashCompileErrorBBF :: HasCallStack => BlackBoxFunction +clashCompileErrorBBF _isD _primName args _ty + | _hasCallstack + : (either error id . termToDataError -> msg) + : _ <- lefts args + = pure $ Left $ "clashCompileError: " <> msg + | otherwise + = pure $ Left $ show 'clashCompileErrorBBF <> ": bad args:\n" <> ppShow args diff --git a/src/Clash/Primitives/Sized/Signed.hs b/src/Clash/Primitives/Sized/Signed.hs --- a/src/Clash/Primitives/Sized/Signed.hs +++ b/src/Clash/Primitives/Sized/Signed.hs @@ -32,9 +32,9 @@ :: Backend s => BlackBoxContext -> State s Doc -fromIntegerTFTemplateVhdl bbCtx = getAp $ do - let [(Literal _ (NumLit sz),_,_), (i, Signed szI, _)] = bbInputs bbCtx - case compare sz (toInteger szI) of +fromIntegerTFTemplateVhdl bbCtx + | [(Literal _ (NumLit sz),_,_), (i, Signed szI, _)] <- bbInputs bbCtx + = getAp $ case compare sz (toInteger szI) of LT -> case i of Identifier iV m -> let sl = Sliced (Signed szI,fromInteger sz-1,0) @@ -44,3 +44,5 @@ EQ -> expr False i GT -> "resize" <> tupled (sequenceA [expr False i ,expr False (Literal Nothing (NumLit sz))]) + | otherwise + = error ("fromIntegerTFTemplateVhdl: bad bInputs: " <> show (bbInputs bbCtx)) diff --git a/src/Clash/Primitives/Sized/ToInteger.hs b/src/Clash/Primitives/Sized/ToInteger.hs --- a/src/Clash/Primitives/Sized/ToInteger.hs +++ b/src/Clash/Primitives/Sized/ToInteger.hs @@ -27,7 +27,41 @@ import System.IO (hPutStrLn, stderr) import Text.Trifecta.Result (Result(Success)) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,8,0) +import GHC.Unit.Module.Warnings (emptyWarningCategorySet) +import GHC.Utils.Error + (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault) +import GHC.Utils.Outputable + (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>), + defaultSDocContext ) +import qualified GHC.Utils.Outputable as Outputable +import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag)) +import GHC.Types.SrcLoc (isGoodSrcSpan) +#elif MIN_VERSION_ghc(9,6,0) +import GHC.Utils.Error + (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault) +import GHC.Utils.Outputable + (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>), + defaultSDocContext ) +import qualified GHC.Utils.Outputable as Outputable +import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag)) +import GHC.Types.SrcLoc (isGoodSrcSpan) +#elif MIN_VERSION_ghc(9,4,0) +import GHC.Utils.Error + (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelope) +import GHC.Utils.Outputable + (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>), + defaultSDocContext ) +import qualified GHC.Utils.Outputable as Outputable +import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag)) +import GHC.Types.SrcLoc (isGoodSrcSpan) +#elif MIN_VERSION_ghc(9,2,0) +import GHC.Utils.Error (mkPlainWarnMsg, pprLocMsgEnvelope) +import GHC.Utils.Outputable + (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>)) +import qualified GHC.Utils.Outputable as Outputable +import GHC.Types.SrcLoc (isGoodSrcSpan) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Session (unsafeGlobalDynFlags) import GHC.Utils.Error (mkPlainWarnMsg, pprLocErrMsg) import GHC.Utils.Outputable @@ -76,10 +110,30 @@ (_,sp) <- Lens.use curCompNm let srcInfo1 | isGoodSrcSpan sp = srcInfo | otherwise = empty - +#if MIN_VERSION_ghc(9,8,0) + opts = DiagOpts mempty mempty emptyWarningCategorySet emptyWarningCategorySet False False Nothing defaultSDocContext + diag = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + warnMsg1 = mkPlainMsgEnvelope opts sp diag + warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1 +#elif MIN_VERSION_ghc(9,6,0) + opts = DiagOpts mempty mempty False False Nothing defaultSDocContext + diag = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + warnMsg1 = mkPlainMsgEnvelope opts sp diag + warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1 +#elif MIN_VERSION_ghc(9,4,0) + opts = DiagOpts mempty mempty False False Nothing defaultSDocContext + diag = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + warnMsg1 = mkPlainMsgEnvelope opts sp diag + warnMsg2 = pprLocMsgEnvelope warnMsg1 +#elif MIN_VERSION_ghc(9,2,0) + warnMsg1 = mkPlainWarnMsg sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + warnMsg2 = pprLocMsgEnvelope warnMsg1 +#else warnMsg1 = mkPlainWarnMsg unsafeGlobalDynFlags sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + warnMsg2 = pprLocErrMsg warnMsg1 +#endif - liftIO (hPutStrLn stderr (showSDocUnsafe (pprLocErrMsg warnMsg1))) + liftIO (hPutStrLn stderr (showSDocUnsafe warnMsg2)) _ -> return () return ((meta,) <$> bb) where diff --git a/src/Clash/Primitives/Sized/Vector.hs b/src/Clash/Primitives/Sized/Vector.hs --- a/src/Clash/Primitives/Sized/Vector.hs +++ b/src/Clash/Primitives/Sized/Vector.hs @@ -1,5 +1,6 @@ {-| Copyright : (C) 2020-2022 QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -12,22 +13,19 @@ module Clash.Primitives.Sized.Vector where -import Control.Monad (replicateM) -import Control.Monad.State (State, zipWithM) +import Control.Monad (replicateM, zipWithM) +import Control.Monad.State (State) import qualified Control.Lens as Lens import Data.Either (rights) -import qualified Data.IntMap as IntMap import Data.List.Extra (iterateNM) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid (Ap(getAp)) import Data.Text.Extra (showt) -import Data.Text.Lazy (pack) import Data.Text.Prettyprint.Doc.Extra (Doc, string, renderLazy, layoutPretty, LayoutOptions(..), PageWidth(AvailablePerLine)) import Text.Trifecta.Result (Result(Success)) import qualified Data.String.Interpolate as I -import qualified Data.String.Interpolate.Util as I import GHC.Stack (HasCallStack) import Clash.Backend @@ -42,11 +40,11 @@ (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TExpr, TDecl), Element(Component, Typ, TypElem, Text), Decl(Decl), emptyBlackBoxMeta) import Clash.Netlist.Types - (Identifier, TemplateFunction, BlackBoxContext, HWType(Vector), - Declaration(..), Expr(Literal, Identifier,DataCon), Literal(NumLit), - BlackBox(BBTemplate, BBFunction), TemplateFunction(..), WireOrReg(Wire), - Modifier(Indexed, Nested, DC), HWType(..), bbInputs, bbResults, emptyBBContext, tcCache, - bbFunctions) + (Identifier, TemplateFunction, BlackBoxContext, HWType(Vector), Usage(Cont), + Declaration(..), Expr(Literal,Identifier,DataCon,BlackBoxE), Literal(NumLit), + BlackBox(BBTemplate, BBFunction), TemplateFunction(..), + Modifier(Indexed, Nested, DC), HWType(..), BlackBoxContext(..), + emptyBBContext, tcCache) import qualified Clash.Netlist.Id as Id import Clash.Netlist.Util (typeSize) import qualified Clash.Primitives.DSL as Prim @@ -63,10 +61,10 @@ where bb = BBFunction "Clash.Primitives.Sized.Vector.iterateBBF" 0 iterateTF vecLength tcm = - case coreView tcm (head (rights args)) of - (LitTy (NumTy 0)) -> error "Unexpected empty vector in 'iterateBBF'" - (LitTy (NumTy n)) -> fromInteger (n - 1) - vl -> error $ "Unexpected vector length: " ++ show vl + case coreView tcm <$> rights args of + (LitTy (NumTy 0)):_ -> error "Unexpected empty vector in 'iterateBBF'" + (LitTy (NumTy n)):_ -> fromInteger (n - 1) + vl -> error $ "Unexpected vector length: " ++ show (listToMaybe vl) meta tcm = emptyBlackBoxMeta { bbKind=TDecl , bbFunctionPlurality=[(1, vecLength tcm)] @@ -116,16 +114,18 @@ foldBBF :: HasCallStack => BlackBoxFunction foldBBF _isD _primName args _resTy = do tcm <- Lens.view tcCache - pure (Right (meta tcm, bb)) - where - bb = BBFunction "Clash.Primitives.Sized.Vector.foldTF" 0 foldTF - [vecLengthMinusOne, _] = rights args - vecLength tcm = - case coreView tcm vecLengthMinusOne of - (LitTy (NumTy n)) -> n + 1 - vl -> error $ "Unexpected vector length: " ++ show vl - funcPlural tcm = foldFunctionPlurality (fromInteger (vecLength tcm)) - meta tcm = emptyBlackBoxMeta {bbKind=TDecl, bbFunctionPlurality=[(0, funcPlural tcm)]} + let + bb = BBFunction "Clash.Primitives.Sized.Vector.foldTF" 0 foldTF + vecLengthMinusOne = case rights args of + (l:_) -> l + _ -> error ("foldBBF: bad Vec: " <> show args) + vecLength = + case coreView tcm vecLengthMinusOne of + (LitTy (NumTy n)) -> n + 1 + vl -> error $ "Unexpected vector length: " ++ show vl + funcPlural = foldFunctionPlurality (fromInteger vecLength) + meta = emptyBlackBoxMeta {bbKind=TDecl, bbFunctionPlurality=[(0, funcPlural)]} + pure (Right (meta, bb)) -- | Type signature of function we're generating netlist for: -- @@ -142,9 +142,9 @@ vecIds <- replicateM n (Id.next baseId) vecId <- Id.make "vec" - let vecDecl = sigDecl vecType Wire vecId - vecAssign = Assignment vecId vec - elemAssigns = zipWith Assignment vecIds (map (iIndex vecId) [0..]) + let vecDecl = sigDecl vecType vecId + vecAssign = Assignment vecId Cont vec + elemAssigns = zipWith3 Assignment vecIds (repeat Cont) (map (iIndex vecId) [0..]) resultId = case bbResults bbCtx of [(Identifier t _, _)] -> t @@ -155,12 +155,8 @@ (concat -> fCalls, result) <- mkTree 1 vecIds let intermediateResultIds = concatMap (\(FCall l r _) -> [l, r]) fCalls - wr = case IntMap.lookup 0 (bbFunctions bbCtx) of - Just ((_,rw,_,_,_,_):_) -> rw - _ -> error "internal error" - sigDecls = zipWith (sigDecl aTy) (wr:replicate n Wire ++ repeat wr) - (result : intermediateResultIds) - resultAssign = Assignment resultId (Identifier result Nothing) + sigDecls = fmap (sigDecl aTy) (result : intermediateResultIds) + resultAssign = Assignment resultId Cont (Identifier result Nothing) callDecls <- zipWithM callDecl [0..] fCalls foldNm <- Id.make "fold" @@ -229,8 +225,8 @@ pure ([], rest) -- Simple wire without comment - sigDecl :: HWType -> WireOrReg -> Identifier -> Declaration - sigDecl typ rw nm = NetDecl' Nothing rw nm (Right typ) Nothing + sigDecl :: HWType -> Identifier -> Declaration + sigDecl typ nm = NetDecl Nothing nm typ -- Index the intermediate vector. This uses a hack in Clash: the 10th -- constructor of Vec doesn't exist; using it will be interpreted by the @@ -250,16 +246,16 @@ [_nTy,_aTy,_kn,Left v,Left ix] | isLiteral ix && isVar v -> Right (meta TExpr, BBFunction "Clash.Primitives.Sized.Vector.indexIntVerilogTF" 0 indexIntVerilogTF) [_nTy,_aTy,_kn,_v,Left ix] | isLiteral ix -> - case runParse (pack (I.unindent bbTextLitIx)) of + case runParse bbTextLitIx of Success t -> Right (meta TDecl, BBTemplate t) _ -> Left "internal error: parse fail" _ -> - case runParse (pack (I.unindent bbText)) of + case runParse bbText of Success t -> Right (meta TDecl, BBTemplate t) _ -> Left "internal error: parse fail" - bbText = [I.i| + bbText = [I.__i| // index begin ~IF~SIZE[~TYP[1]]~THENwire ~TYPO ~GENSYM[vecArray][0] [0:~LIT[0]-1]; genvar ~GENSYM[i][2]; @@ -269,12 +265,14 @@ end ~ENDGENERATE assign ~RESULT = ~SYM[0][~ARG[2]];~ELSEassign ~RESULT = ~ERRORO;~FI - // index end|] + // index end + |] - bbTextLitIx = [I.i| + bbTextLitIx = [I.__i| // index lit begin ~IF~SIZE[~TYP[1]]~THENassign ~RESULT = ~VAR[vec][1][~SIZE[~TYP[1]]-1-~LIT[2]*~SIZE[~TYPO] -: ~SIZE[~TYPO]];~ELSEassign ~RESULT = ~ERRORO;~FI - // index lit end|] + // index lit end + |] indexIntVerilogTF :: TemplateFunction @@ -287,28 +285,28 @@ :: Backend s => BlackBoxContext -> State s Doc -indexIntVerilogTemplate bbCtx = getAp $ case typeSize vTy of +indexIntVerilogTemplate bbCtx + | [ _kn, (vec, vTy, _), (ix, _, _)] <- bbInputs bbCtx + , [(_,rTy)] <- bbResults bbCtx + = getAp $ case typeSize vTy of 0 -> hdlTypeErrValue rTy _ -> case vec of - Identifier i mM -> case mM of - Just m -> - expr False (Identifier i (Just (Nested m (Indexed (vTy,10,ixI ix))))) - _ -> expr False (Identifier i (Just (Indexed (vTy,10,ixI ix)))) + Identifier i mM -> do + let + ixI :: Expr -> Int + ixI ix0 = case ix0 of + Literal _ (NumLit j) -> + fromInteger j + DataCon (Signed _) (DC (Void{},_)) [Literal (Just (Signed _,_)) (NumLit j)] -> + fromInteger j + BlackBoxE "GHC.Types.I#" _lib _use _incl _templ Context{bbInputs=[(Literal _ (NumLit j),_,_)]} _paren -> + fromInteger j + _ -> + error ($(curLoc) ++ "Unexpected literal: " ++ show ix) + case mM of + Just m -> + expr False (Identifier i (Just (Nested m (Indexed (vTy,10,ixI ix))))) + _ -> expr False (Identifier i (Just (Indexed (vTy,10,ixI ix)))) _ -> error ($(curLoc) ++ "Expected Identifier: " ++ show vec) - where - [ _kn - , (vec, vTy, _) - , (ix, _, _) - ] = bbInputs bbCtx - - [(_,rTy)] = bbResults bbCtx - - ixI :: Expr -> Int - ixI ix0 = case ix0 of - Literal _ (NumLit i) -> - fromInteger i - DataCon (Signed _) (DC (Void{},_)) [Literal (Just (Signed _,_)) (NumLit i)] -> - fromInteger i - _ -> - error ($(curLoc) ++ "Unexpected literal: " ++ show ix) - + | otherwise + = error ("indexIntVerilogTemplate: bad bbContext: " <> show bbCtx) diff --git a/src/Clash/Primitives/Types.hs b/src/Clash/Primitives/Types.hs --- a/src/Clash/Primitives/Types.hs +++ b/src/Clash/Primitives/Types.hs @@ -3,6 +3,7 @@ 2016-2017, Myrtle Software Ltd 2018 , Google Inc. 2021 , QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -12,7 +13,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.Types @@ -32,21 +32,24 @@ , CompiledPrimMap ) where -import {-# SOURCE #-} Clash.Netlist.Types (BlackBox) +import {-# SOURCE #-} Clash.Netlist.Types (BlackBox, Usage(..)) import Clash.Annotations.Primitive (PrimitiveGuard) import Clash.Core.Term (WorkInfo (..)) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..), RenderVoid(..)) import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) +import Control.Monad (when) import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?), (.!=)) +import Data.Aeson.Types (Parser) import Data.Binary (Binary) import Data.Char (isUpper, isLower, isAlphaNum) import Data.Either (lefts) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as H import Data.List (intercalate) +import Data.Maybe (isJust) import qualified Data.Text as S import Data.Text.Lazy (Text) import GHC.Generics (Generic) @@ -108,10 +111,11 @@ let errs = lefts $ checkFunc func : map checkMod mods in case errs of [] -> Right $ BlackBoxFunctionName mods func - _ -> Left $ "Error while parsing " ++ show bbfn ++ ": " ++ head errs + e:_ -> Left $ "Error while parsing " ++ show bbfn ++ ": " ++ e where checkMod mod' - | isLower (head mod') = + | m':_ <- mod' + , isLower m' = Left $ "Module name cannot start with lowercase: " ++ mod' | any (not . isAlphaNum) mod' = Left $ "Module name must be alphanumerical: " ++ mod' @@ -119,7 +123,8 @@ Right mod' checkFunc func - | isUpper (head func) = + | f:_ <- func + , isUpper f = Left $ "Function name must start with lowercase: " ++ func | otherwise = Right func @@ -165,10 +170,10 @@ -- ^ A warning to be outputted when the primitive is instantiated. -- This is intended to be used as a warning for primitives that are not -- synthesizable, but may also be used for other purposes. - , outputReg :: Bool - -- ^ Verilog only: whether the result should be a /reg/(@True@) or /wire/ - -- (@False@); when not specified in the /.primitives/ file, the value will default - -- to @False@ (i.e. /wire/). + , outputUsage :: Usage + -- ^ How the result is assigned in HDL. This is used to determine the + -- type of declaration used to render the result (wire/reg or + -- signal/variable). The default usage is continuous assignment. , libraries :: [a] -- ^ VHDL only: add /library/ declarations for the given names , imports :: [a] @@ -241,10 +246,10 @@ [(conKey,Object conVal)] -> case conKey of "BlackBoxHaskell" -> do - usedArguments <- conVal .:? "usedArguments" - ignoredArguments <- conVal .:? "ignoredArguments" + usedArgs <- conVal .:? "usedArguments" + ignoredArgs <- conVal .:? "ignoredArguments" args <- - case (usedArguments, ignoredArguments) of + case (usedArgs, ignoredArgs) of (Nothing, Nothing) -> pure (IgnoredArguments []) (Just a, Nothing) -> pure (UsedArguments a) (Nothing, Just a) -> pure (IgnoredArguments a) @@ -254,20 +259,28 @@ name' <- conVal .: "name" wf <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable) fName <- conVal .: "templateFunction" - multiResult <- conVal .:? "multiResult" .!= False + isMultiResult <- conVal .:? "multiResult" .!= False templ <- (Just . TInline <$> conVal .: "template") <|> (Just . TFile <$> conVal .: "file") <|> (pure Nothing) fName' <- either fail return (parseBBFN fName) - return (BlackBoxHaskell name' wf args multiResult fName' templ) - "BlackBox" -> + return (BlackBoxHaskell name' wf args isMultiResult fName' templ) + "BlackBox" -> do + outReg <- conVal .:? "outputReg" :: Parser (Maybe Bool) + + when (isJust outReg) . + fail $ mconcat + [ "[9] 'outputReg' is no longer a recognized key.\n" + , "Use 'outputUsage: Continuous|NonBlocking|Blocking' instead." + ] + BlackBox <$> conVal .: "name" <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable <*> conVal .:? "renderVoid" .!= NoRenderVoid <*> conVal .:? "multiResult" .!= False <*> (conVal .: "kind" >>= parseTemplateKind) <*> conVal .:? "warning" - <*> conVal .:? "outputReg" .!= False + <*> conVal .:? "outputUsage" .!= Cont <*> conVal .:? "libraries" .!= [] <*> conVal .:? "imports" .!= [] <*> pure [] -- functionPlurality not supported in json diff --git a/src/Clash/Primitives/Util.hs b/src/Clash/Primitives/Util.hs --- a/src/Clash/Primitives/Util.hs +++ b/src/Clash/Primitives/Util.hs @@ -3,6 +3,7 @@ 2017 , Myrtle Software Ltd 2018 , Google Inc. 2021 , QBayLogic B.V. + 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -10,7 +11,6 @@ -} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -61,8 +61,8 @@ hashCompiledPrimitive :: CompiledPrimitive -> Int hashCompiledPrimitive (Primitive {name, primSort}) = hash (name, primSort) hashCompiledPrimitive (BlackBoxHaskell {function}) = fst function -hashCompiledPrimitive (BlackBox {name, kind, outputReg, libraries, imports, includes, template}) = - hash (name, kind, outputReg, libraries, imports, includes', hashBlackbox template) +hashCompiledPrimitive (BlackBox {name, kind, outputUsage, libraries, imports, includes, template}) = + hash (name, kind, outputUsage, libraries, imports, includes', hashBlackbox template) where includes' = map (\(nms, bb) -> (nms, hashBlackbox bb)) includes hashBlackbox (BBTemplate bbTemplate) = hash bbTemplate @@ -99,7 +99,7 @@ return (name, HasBlackBox [] (Primitive name wf primType)) resolvePrimitive' metaPath BlackBox{template=t, includes=i, resultNames=r, resultInits=ri, ..} = do let resolveSourceM = traverse (traverse (resolveTemplateSource metaPath)) - bb <- BlackBox name workInfo renderVoid multiResult kind () outputReg libraries imports functionPlurality + bb <- BlackBox name workInfo renderVoid multiResult kind () outputUsage libraries imports functionPlurality <$> mapM (traverse resolveSourceM) i <*> traverse resolveSourceM r <*> traverse resolveSourceM ri diff --git a/src/Clash/Primitives/Verification.hs b/src/Clash/Primitives/Verification.hs --- a/src/Clash/Primitives/Verification.hs +++ b/src/Clash/Primitives/Verification.hs @@ -7,6 +7,8 @@ import qualified Control.Lens as Lens import Control.Monad.State (State) +import Data.List.Infinite (Infinite(..), (...)) +import Data.Maybe (listToMaybe) import Data.Monoid (Ap(getAp)) import Data.Text.Prettyprint.Doc.Extra (Doc) import qualified Data.Text as Text @@ -20,12 +22,12 @@ import Clash.Core.TermLiteral (termToDataError) import Clash.Util (indexNote) import Clash.Netlist (mkExpr) -import Clash.Netlist.Util (stripVoid, id2identifier) +import Clash.Netlist.Util (stripVoid) import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types (BlackBox(BBFunction), TemplateFunction(..), BlackBoxContext, Identifier, - NetlistMonad, Declaration(Assignment, NetDecl'), - HWType(Bool, KnownDomain), WireOrReg(Wire), NetlistId(..), + NetlistMonad, Declaration(Assignment, NetDecl), Usage(Cont), + HWType(Bool, KnownDomain), NetlistId(..), DeclarationType(Concurrent), tcCache, bbInputs, Expr(Identifier)) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TDecl), RenderVoid(..), @@ -46,15 +48,20 @@ where -- TODO: Improve error handling; currently errors don't indicate what -- TODO: blackbox generated them. - clk = indexNote "clk" (lefts args) 1 + _knownDomainArg + :< clkArg + :< _rstArg + :< propNameArg + :< renderAsArg + :< propArg + :< _ = ((0 :: Int)...) + (Id.unsafeFromCoreId -> clkId) = varToId (indexNote "clk" (lefts args) clkArg) clkExpr = Identifier clkId Nothing - (id2identifier -> clkId) = varToId clk - (id2identifier -> _clkId) = varToId (indexNote "rst" (lefts args) 2) litArgs = do - propName <- termToDataError (indexNote "propName" (lefts args) 3) - renderAs <- termToDataError (indexNote "renderAs" (lefts args) 4) - cvProperty <- termToDataError (indexNote "propArg" (lefts args) 5) + propName <- termToDataError (indexNote "propName" (lefts args) propNameArg) + renderAs <- termToDataError (indexNote "renderAs" (lefts args) renderAsArg) + cvProperty <- termToDataError (indexNote "propArg" (lefts args) propArg) Right (propName, renderAs, cvProperty) bb = BBFunction "Clash.Primitives.Verification.checkTF" 0 @@ -67,7 +74,7 @@ -- ^ Term to bind. Does not bind if it's already a reference to a signal -> NetlistMonad (Identifier, [Declaration]) -- ^ ([new] reference to signal, [declarations need to get it in scope]) - bindMaybe _ (Var vId) = pure (id2identifier vId, []) + bindMaybe _ (Var vId) = pure (Id.unsafeFromCoreId vId, []) bindMaybe Nothing t = bindMaybe (Just "s") t bindMaybe (Just nm) t = do tcm <- Lens.view tcCache @@ -75,11 +82,11 @@ (expr0, decls) <- mkExpr False Concurrent (NetlistId newId (inferCoreTypeOf tcm t)) t pure ( newId - , decls ++ [sigDecl Bool newId, Assignment newId expr0] ) + , decls ++ [sigDecl Bool newId, Assignment newId Cont expr0] ) -- Simple wire without comment sigDecl :: HWType -> Identifier -> Declaration - sigDecl typ nm = NetDecl' Nothing Wire nm (Right typ) Nothing + sigDecl typ nm = NetDecl Nothing nm typ checkTF :: [Declaration] @@ -112,9 +119,9 @@ hdl = hdlKind (undefined :: s) edge = - case head (bbInputs bbCtx) of - (_, stripVoid -> KnownDomain _nm _period e _rst _init _polarity, _) -> e - _ -> error $ "Unexpected first argument: " ++ show (head (bbInputs bbCtx)) + case bbInputs bbCtx of + (_, stripVoid -> KnownDomain _nm _period e _rst _init _polarity, _):_ -> e + _ -> error $ "Unexpected first argument: " ++ show (listToMaybe (bbInputs bbCtx)) renderedPslProperty = case renderAs of PSL -> psl diff --git a/src/Clash/Primitives/Xilinx/ClockGen.hs b/src/Clash/Primitives/Xilinx/ClockGen.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Xilinx/ClockGen.hs @@ -0,0 +1,195 @@ +{-| + Copyright : (C) 2023, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + Blackbox template functions for + Clash.Xilinx.ClockGen.{clockWizard,clockWizardDifferential} +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} + +module Clash.Primitives.Xilinx.ClockGen + ( clockWizardTF + , clockWizardTclTF + , clockWizardDifferentialTF + , clockWizardDifferentialTclTF + ) where + +import Control.Monad.State (State) +import Data.List.Infinite (Infinite(..), (...)) +import Data.Maybe (fromMaybe) +import Data.String.Interpolate (i) +import qualified Data.Text as T +import Prettyprinter.Interpolate (__di) +import Text.Show.Pretty (ppShow) + +import Clash.Signal (periodToHz) + +import Clash.Backend (Backend) +import qualified Clash.Netlist.Id as Id +import Clash.Netlist.Types +import Clash.Netlist.Util (stripVoid) +import qualified Clash.Primitives.DSL as DSL +import Data.Text.Extra (showt) +import Data.Text.Prettyprint.Doc.Extra (Doc) + +usedArguments :: [Int] +usedArguments = [knownDomIn, clocksCxt, clk, rst] + where + knownDomIn + :< _clocksClass + :< clocksCxt + :< _numOutClocks + :< clk + :< rst + :< _ = (0...) + +clockWizardTF :: TemplateFunction +clockWizardTF = + TemplateFunction usedArguments valid (clockWizardTemplate False) + where + valid = const True + +clockWizardDifferentialTF :: TemplateFunction +clockWizardDifferentialTF = + TemplateFunction usedArguments valid (clockWizardTemplate True) + where + valid = const True + +clockWizardTemplate + :: Backend s + => Bool + -> BlackBoxContext + -> State s Doc +clockWizardTemplate isDifferential bbCtx + | [ _knownDomIn + , _clocksClass + , _clocksCxt + , _numOutClocks + , clk + , rst + ] <- map fst (DSL.tInputs bbCtx) + , [DSL.ety -> resultTy] <- DSL.tResults bbCtx + , Product _ _ (init -> pllOutTys) <- resultTy + , [compName] <- bbQsysIncName bbCtx + = do + clkWizInstName <- Id.makeBasic $ fromMaybe "clk_wiz" $ bbCtxName bbCtx + DSL.declarationReturn bbCtx blockName $ do + + rstHigh <- DSL.unsafeToActiveHigh "reset" rst + pllOuts <- DSL.declareN "pllOut" pllOutTys + locked <- DSL.declare "locked" Bit + pllLock <- DSL.boolFromBit "pllLock" locked + + let pllOutNames = + map (\n -> "clk_out" <> showt n) [1 .. length pllOutTys] + compInps = compClkInps <> [ ("reset", Bit) ] + compOuts = zip pllOutNames pllOutTys <> [("locked", Bit)] + inps = clkInps clk <> [ ("reset", rstHigh) ] + outs = zip pllOutNames pllOuts <> [("locked", locked)] + + DSL.compInBlock compName compInps compOuts + DSL.instDecl Empty (Id.unsafeMake compName) clkWizInstName [] inps outs + + pure [DSL.constructProduct resultTy (pllOuts <> [pllLock])] + | otherwise + = error $ ppShow bbCtx + where + blockName | isDifferential = "clockWizardDifferential" + | otherwise = "clockWizard" + compClkInps | isDifferential = [ ("clk_in1_p", Bit) + , ("clk_in1_n", Bit) + ] + | otherwise = [ ("clk_in1", Bit) ] + clkInps clk + | isDifferential + , DataCon (Product "Clash.Signal.Internal.DiffClock" _ clkTys) _ clkEs + <- DSL.eex clk + , [clkP@(Identifier _ Nothing), clkN@(Identifier _ Nothing)] <- clkEs + , [clkPTy, clkNTy] <- clkTys + = [ ("clk_in1_p", DSL.TExpr clkPTy clkP) + , ("clk_in1_n", DSL.TExpr clkNTy clkN) + ] + | not isDifferential + = [ ("clk_in1", clk) ] + | otherwise + = error $ ppShow bbCtx + +clockWizardTclTF :: TemplateFunction +clockWizardTclTF = + TemplateFunction usedArguments valid (clockWizardTclTemplate False) + where + valid = const True + +clockWizardDifferentialTclTF :: TemplateFunction +clockWizardDifferentialTclTF = + TemplateFunction usedArguments valid (clockWizardTclTemplate True) + where + valid = const True + +clockWizardTclTemplate + :: Backend s + => Bool + -> BlackBoxContext + -> State s Doc +clockWizardTclTemplate isDifferential bbCtx + | (_,stripVoid -> kdIn,_) + : _clocksClass + : (_,stripVoid -> Product _ _ (init -> kdOuts),_) + : _ <- bbInputs bbCtx + , [compName] <- bbQsysIncName bbCtx + = let + clkFreq (KnownDomain _ p _ _ _ _) = + periodToHz (fromInteger p) / 1e6 :: Double + clkFreq _ = + error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx + + clkInFreq = clkFreq kdIn + clkOutFreqs = map clkFreq kdOuts + + clkOutProps = concat + [ [ [i|CONFIG.CLKOUT#{n}_USED true \\|] + , [i|CONFIG.CLKOUT#{n}_REQUESTED_OUT_FREQ #{clkOutFreq} \\|] + ] + | (clkOutFreq, n) <- zip clkOutFreqs [(1::Word)..] + ] + + differentialPinString :: T.Text + differentialPinString = if isDifferential + then "Differential_clock_capable_pin" + else "Single_ended_clock_capable_pin" + + propIndent = T.replicate 18 " " + props = T.intercalate "\n" . map (propIndent <>) $ + [ [i|CONFIG.PRIM_SOURCE #{differentialPinString} \\|] + , [i|CONFIG.PRIM_IN_FREQ #{clkInFreq} \\|] + ] <> clkOutProps + + bbText = [__di| + namespace eval $tclIface { + variable api 1 + variable scriptPurpose createIp + variable ipName {#{compName}} + + proc createIp {ipName0 args} { + create_ip \\ + -name clk_wiz \\ + -vendor xilinx.com \\ + -library ip \\ + -version 6.0 \\ + -module_name $ipName0 \\ + {*}$args + + set_property \\ + -dict [list \\ + #{props} + ] [get_ips $ipName0] + return + } + }|] + in pure bbText + | otherwise + = error ("clockWizardTclTemplate: bad bbContext: " <> show bbCtx) diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -54,7 +54,7 @@ allR trans (TransformContext is c) (Letrec xes e) = do xes' <- traverse rewriteBind xes - e' <- trans (TransformContext is' (LetBody bndrs:c)) e + e' <- trans (TransformContext is' (LetBody xes:c)) e return (Letrec xes' e') where bndrs = map fst xes diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs --- a/src/Clash/Rewrite/Types.hs +++ b/src/Clash/Rewrite/Types.hs @@ -16,6 +16,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Rewrite.Types where @@ -174,6 +175,13 @@ , Monad , MonadFix ) +#if MIN_VERSION_transformers(0,5,6) && MIN_VERSION_mtl(2,3,0) + deriving newtype + ( MonadState (RewriteState extra) + , MonadWriter Any + , MonadReader RewriteEnv + ) +#endif -- | Run the computation in the RewriteMonad runR diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -79,7 +79,10 @@ import Clash.Core.VarEnv (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet, uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv, - mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet) + mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet, + differenceVarEnv) +import Clash.Data.UniqMap (UniqMap) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug import Clash.Driver.Types (TransformationInfo(..), DebugOpts(..), BindingMap, Binding(..), IsPrim(..), @@ -554,9 +557,9 @@ -> RewriteMonad extra LetBinding liftBinding (var@Id {varName = idName} ,e) = do -- Get all local FVs, excluding the 'idName' from the let-binding - let unitFV :: Var a -> Const (UniqSet TyVar,UniqSet Id) (Var a) - unitFV v@(Id {}) = Const (emptyUniqSet,unitUniqSet (coerce v)) - unitFV v@(TyVar {}) = Const (unitUniqSet (coerce v),emptyUniqSet) + let unitFV :: Var a -> Const (UniqMap TyVar,UniqMap Id) (Var a) + unitFV v@(Id {}) = Const (UniqMap.empty,UniqMap.singletonUnique (coerce v)) + unitFV v@(TyVar {}) = Const (UniqMap.singletonUnique (coerce v),UniqMap.empty) interesting :: Var a -> Bool interesting Id {idScope = GlobalId} = False @@ -565,8 +568,8 @@ (boundFTVsSet,boundFVsSet) = getConst (Lens.foldMapOf (termFreeVars' interesting) unitFV e) - boundFTVs = eltsUniqSet boundFTVsSet - boundFVs = eltsUniqSet boundFVsSet + boundFTVs = UniqMap.elems boundFTVsSet + boundFVs = UniqMap.elems boundFVsSet -- Make a new global ID tcm <- Lens.view tcCache @@ -594,12 +597,12 @@ newBody = mkTyLams (mkLams e' boundFVs) boundFTVs -- Check if an alpha-equivalent global binder already exists - aeqExisting <- (eltsUniqMap . filterUniqMap ((`aeqTerm` newBody) . bindingTerm)) <$> Lens.use bindings + aeqExisting <- (UniqMap.elems . UniqMap.filter ((`aeqTerm` newBody) . bindingTerm)) <$> Lens.use bindings case aeqExisting of -- If it doesn't, create a new binder [] -> do -- Add the created function to the list of global bindings let r = newBodyId `globalIdOccursIn` newBody - bindings %= extendUniqMap newBodyNm + bindings %= UniqMap.insert newBodyNm -- We mark this function as internal so that -- it can be inlined at the very end of -- the normalisation pipeline as part of the @@ -608,7 +611,11 @@ -- function at this moment for a reason! -- (termination, CSE and DEC oppertunities, -- ,etc.) +#if MIN_VERSION_ghc(9,2,0) + (Binding newBodyId sp NoUserInlinePrag IsFun newBody r) +#else (Binding newBodyId sp NoUserInline IsFun newBody r) +#endif -- Return the new binder return (var, newExpr) -- If it does, use the existing binder @@ -650,7 +657,7 @@ addGlobalBind vNm ty sp inl body = do let vId = mkGlobalId ty vNm r = vId `globalIdOccursIn` body - (ty,body) `deepseq` bindings %= extendUniqMap vNm (Binding vId sp inl IsFun body r) + (ty,body) `deepseq` bindings %= UniqMap.insert vNm (Binding vId sp inl IsFun body r) -- | Create a new name out of the given name, but with another unique. Resulting -- unique is guaranteed to not be in the given InScopeSet. @@ -672,7 +679,7 @@ -> m (Name a) cloneNameWithBindingMap binders nm = do i <- getUniqueM - return (uniqAway' (`elemUniqMapDirectly` binders) i (setUnique nm i)) + return (uniqAway' (`UniqMap.elem` binders) i (setUnique nm i)) {-# INLINE isUntranslatable #-} -- | Determine if a term cannot be represented in hardware @@ -724,7 +731,7 @@ -> Term -> Rewrite extra -> RewriteMonad extra Term -whnfRW isSubj ctx@(TransformContext is0 _) e rw = do +whnfRW isSubj ctx@(TransformContext is0 hist) e rw = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings eval <- Lens.view evaluator @@ -732,11 +739,18 @@ let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap + let lh = localBinders mempty hist - case whnf' eval bndrs tcm gh ids1 is0 isSubj e of + case whnf' eval bndrs lh tcm gh ids1 is0 isSubj e of (!gh1,ph,v) -> do globalHeap Lens..= gh1 - bindPureHeap tcm ph rw ctx v + bindPureHeap tcm (ph `differenceVarEnv` lh) rw ctx v + where + localBinders acc [] = acc + localBinders !acc (h:hs) = case h of + LetBody ls -> localBinders (acc <> mkVarEnv ls) hs + _ -> localBinders acc hs + {-# SCC whnfRW #-} -- | Binds variables on the PureHeap over the result of the rewrite @@ -785,9 +799,9 @@ where heapIds = map fst bndrs is1 = extendInScopeSetList is0 heapIds - ctx = TransformContext is1 (LetBody heapIds : hist) + ctx = TransformContext is1 (LetBody bndrs : hist) - bndrs = map toLetBinding $ toListUniqMap heap + bndrs = map toLetBinding $ UniqMap.toList heap toLetBinding :: (Unique,Term) -> LetBinding toLetBinding (uniq,term) = (nm, term) diff --git a/src/Clash/Unique.hs b/src/Clash/Unique.hs --- a/src/Clash/Unique.hs +++ b/src/Clash/Unique.hs @@ -1,103 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module Clash.Unique - ( -- * Unique - Unique + ( Unique , Uniquable (..) - -- * UniqMap - , UniqMap - -- ** Accessors - -- *** Size information - , nullUniqMap - -- *** Indexing - , lookupUniqMap - , lookupUniqMap' - -- ** Construction - , emptyUniqMap - , unitUniqMap - -- ** Modification - , extendUniqMap - , extendUniqMapWith - , extendListUniqMap - , delUniqMap - , delListUniqMap - , unionUniqMap - , unionUniqMapWith - , differenceUniqMap - -- ** Element-wise operations - -- *** Mapping - , mapUniqMap - , mapMaybeUniqMap - -- ** Working with predicates - -- *** Filtering - , filterUniqMap - -- *** Searching - , elemUniqMap - , notElemUniqMap - , elemUniqMapDirectly - -- ** Folding - , foldrWithUnique - , foldlWithUnique' - -- ** Conversions - -- *** Lists - , eltsUniqMap - , keysUniqMap - , listToUniqMap - , toListUniqMap - -- *** UniqSet - , uniqMapToUniqSet - -- * UniqSet - , UniqSet - -- ** Accessors - -- *** Size information - , nullUniqSet - -- *** Indexing - , lookupUniqSet - -- ** Construction - , emptyUniqSet - , unitUniqSet - -- ** Modifications - , extendUniqSet - , unionUniqSet - , delUniqSetDirectly - -- ** Working with predicates - -- *** Searching - , elemUniqSet - , notElemUniqSet - , elemUniqSetDirectly - -- *** Misc - , subsetUniqSet - , disjointUniqSet - , differenceUniqSet - -- ** Conversions - -- *** Lists - , mkUniqSet - , eltsUniqSet - ) -where - -import Control.DeepSeq (NFData) -import Data.Binary (Binary) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -#if !MIN_VERSION_containers(0,6,2) -import qualified Data.IntMap.Extra as IntMap -#endif - -import qualified Data.List as List - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter -#else -import Data.Text.Prettyprint.Doc -#endif - -import GHC.Stack - -import Clash.Pretty + ) where type Unique = Int @@ -105,344 +11,6 @@ getUnique :: a -> Unique setUnique :: a -> Unique -> a -instance Uniquable Int where - getUnique i = i - setUnique _i0 i1 = i1 - --- | Map indexed by a 'Uniquable' key -newtype UniqMap a = UniqMap (IntMap a) - deriving (Functor, Foldable, Traversable, Semigroup, Monoid, NFData, Binary) - -instance ClashPretty a => ClashPretty (UniqMap a) where - clashPretty (UniqMap env) = - brackets $ fillSep $ punctuate comma $ - [ fromPretty uq <+> ":->" <+> clashPretty elt - | (uq,elt) <- IntMap.toList env - ] - -instance ClashPretty a => Show (UniqMap a) where - show = showDoc . clashPretty - --- | The empty map -emptyUniqMap - :: UniqMap a -emptyUniqMap = UniqMap IntMap.empty - --- | Map with a single key-value pair -unitUniqMap - :: Uniquable a - => a - -> b - -> UniqMap b -unitUniqMap k v = UniqMap (IntMap.singleton (getUnique k) v) - --- | Check whether the map is empty -nullUniqMap - :: UniqMap a - -> Bool -nullUniqMap (UniqMap m) = IntMap.null m - --- | Extend the map with a new key-value pair. If the key already exists in the --- associated value will be overwritten -extendUniqMap - :: Uniquable a - => a - -> b - -> UniqMap b - -> UniqMap b -extendUniqMap k x (UniqMap m) = UniqMap (IntMap.insert (getUnique k) x m) - --- | Extend the map with a new key-value pair. If the key already exists in the --- associated value will be combined with the new value using the function --- provided -extendUniqMapWith - :: Uniquable a - => a - -> b - -> (b -> b -> b) - -> UniqMap b - -> UniqMap b -extendUniqMapWith k x f (UniqMap m) = - UniqMap (IntMap.insertWith f (getUnique k) x m) - --- | Extend the map with a list of key-value pairs. Positions with existing --- keys will be overwritten with the new values -extendListUniqMap - :: Uniquable a - => UniqMap b - -> [(a, b)] - -> UniqMap b -extendListUniqMap (UniqMap env) xs = - UniqMap (List.foldl' (\m (k, v) -> IntMap.insert (getUnique k) v m) env xs) - --- | Look up a value in the map -lookupUniqMap - :: Uniquable a - => a - -> UniqMap b - -> Maybe b -lookupUniqMap k (UniqMap m) = IntMap.lookup (getUnique k) m - --- | Like 'lookupUniqMap'', but errors out when the key is not present -lookupUniqMap' - :: (HasCallStack, Uniquable a) - => UniqMap b - -> a - -> b -lookupUniqMap' (UniqMap m) k = - IntMap.findWithDefault d k' m - where - k' = getUnique k - d = error ("lookupUniqMap': key " ++ show k' ++ " is not an element of the map") - --- | Check whether a key is in the map -elemUniqMap - :: Uniquable a - => a - -> UniqMap b - -> Bool -elemUniqMap k = elemUniqMapDirectly (getUnique k) - --- | Check whether an element exists in the uniqmap based on a given `Unique` -elemUniqMapDirectly - :: Unique - -> UniqMap b - -> Bool -elemUniqMapDirectly k (UniqMap m) = k `IntMap.member` m -{-# INLINE elemUniqMapDirectly #-} - --- | Check whether a key is not in the map -notElemUniqMap - :: Uniquable a - => a - -> UniqMap b - -> Bool -notElemUniqMap k (UniqMap m) = IntMap.notMember (getUnique k) m - --- | Derive a map where all the elements adhere to the predicate -filterUniqMap - :: (b -> Bool) - -> UniqMap b - -> UniqMap b -filterUniqMap f (UniqMap m) = UniqMap (IntMap.filter f m) - --- | Remove a key-value pair from the map -delUniqMap - :: Uniquable a - => UniqMap b - -> a - -> UniqMap b -delUniqMap (UniqMap env) v = UniqMap (IntMap.delete (getUnique v) env) - --- | Remove a list of key-value pairs from the map -delListUniqMap - :: Uniquable a - => UniqMap b - -> [a] - -> UniqMap b -delListUniqMap (UniqMap env) vs = - UniqMap (List.foldl' (\m v -> IntMap.delete (getUnique v) m) env vs) - --- | A (left-biased) union of two maps -unionUniqMap - :: UniqMap a - -> UniqMap a - -> UniqMap a -unionUniqMap (UniqMap m1) (UniqMap m2) = UniqMap (IntMap.union m1 m2) - --- | A union of two maps, key-value pairs with the same key will be merged using --- the given function -unionUniqMapWith - :: (a -> a -> a) - -> UniqMap a - -> UniqMap a - -> UniqMap a -unionUniqMapWith f (UniqMap m1) (UniqMap m2) = UniqMap (IntMap.unionWith f m1 m2) - --- | Get the difference between two maps -differenceUniqMap - :: UniqMap a - -> UniqMap a - -> UniqMap a -differenceUniqMap (UniqMap m1) (UniqMap m2) = UniqMap (IntMap.difference m1 m2) - --- | Convert a list of key-value pairs to a map -listToUniqMap - :: Uniquable a - => [(a,b)] - -> UniqMap b -listToUniqMap xs = - UniqMap (List.foldl' (\m (k, v) -> IntMap.insert (getUnique k) v m) IntMap.empty xs) - --- | Convert a map to a list of key-value pairs -toListUniqMap - :: UniqMap a - -> [(Unique,a)] -toListUniqMap (UniqMap m) = IntMap.toList m - --- | Extract the elements of a map into a list -eltsUniqMap - :: UniqMap a - -> [a] -eltsUniqMap (UniqMap m) = IntMap.elems m - --- | Apply a function to every element in the map -mapUniqMap - :: (a -> b) - -> UniqMap a - -> UniqMap b -mapUniqMap f (UniqMap m) = UniqMap (IntMap.map f m) - --- | Extract the keys of a map into a list -keysUniqMap - :: UniqMap a - -> [Unique] -keysUniqMap (UniqMap m) = IntMap.keys m - --- | Apply a function to every element in the map. When the function returns --- 'Nothing', the key-value pair will be removed -mapMaybeUniqMap - :: (a -> Maybe b) - -> UniqMap a - -> UniqMap b -mapMaybeUniqMap f (UniqMap m) = UniqMap (IntMap.mapMaybe f m) - --- | Right-fold over a map using both the key and value -foldrWithUnique - :: (Unique -> a -> b -> b) - -> b - -> UniqMap a - -> b -foldrWithUnique f s (UniqMap m) = IntMap.foldrWithKey f s m - --- | Strict left-fold over a map using both the key and the value -foldlWithUnique' - :: (a -> Unique -> b -> a) - -> a - -> UniqMap b - -> a -foldlWithUnique' f s (UniqMap m) = IntMap.foldlWithKey' f s m - --- | Set of things that have a 'Unique' --- --- Invariant: they keys in the map are the uniques of the values -newtype UniqSet a = UniqSet (IntMap a) - deriving (Foldable, Semigroup, Monoid, NFData, Binary) - -instance ClashPretty a => ClashPretty (UniqSet a) where - clashPretty (UniqSet env) = - braces (fillSep (map clashPretty (IntMap.elems env))) - --- | The empty set -emptyUniqSet - :: UniqSet a -emptyUniqSet = UniqSet IntMap.empty - --- | Set with a single element -unitUniqSet - :: Uniquable a - => a - -> UniqSet a -unitUniqSet a = UniqSet (IntMap.singleton (getUnique a) a) - --- | Add an element to the set -extendUniqSet - :: Uniquable a - => UniqSet a - -> a - -> UniqSet a -extendUniqSet (UniqSet env) a = UniqSet (IntMap.insert (getUnique a) a env) - --- | Union two sets -unionUniqSet - :: UniqSet a - -> UniqSet a - -> UniqSet a -unionUniqSet (UniqSet env1) (UniqSet env2) = UniqSet (IntMap.union env1 env2) - --- | Check whether an element exists in the set -elemUniqSet - :: Uniquable a - => a - -> UniqSet a - -> Bool -elemUniqSet a (UniqSet env) = IntMap.member (getUnique a) env - --- | Check whether an element does not exist in the set -notElemUniqSet - :: Uniquable a - => a - -> UniqSet a - -> Bool -notElemUniqSet a (UniqSet env) = IntMap.notMember (getUnique a) env - --- | Check whether an element exists in the set based on the `Unique` contained --- in that element -elemUniqSetDirectly - :: Unique - -> UniqSet a - -> Bool -elemUniqSetDirectly k (UniqSet m) = k `IntMap.member` m - --- | Check whether a set is empty -nullUniqSet - :: UniqSet a - -> Bool -nullUniqSet (UniqSet env) = IntMap.null env - --- | Look up an element in the set, returns it if it exists -lookupUniqSet - :: Uniquable a - => a - -> UniqSet b - -> Maybe b -lookupUniqSet a (UniqSet env) = IntMap.lookup (getUnique a) env - --- | Remove an element based on the `Unique` it contains -delUniqSetDirectly - :: Unique - -> UniqSet b - -> UniqSet b -delUniqSetDirectly k (UniqSet env) = UniqSet (IntMap.delete k env) - --- | Get the elements of the set as a list -eltsUniqSet - :: UniqSet a - -> [a] -eltsUniqSet (UniqSet env) = IntMap.elems env - --- | Create a set out of a list of elements that contain a 'Unique' -mkUniqSet - :: Uniquable a - => [a] - -> UniqSet a -mkUniqSet m = UniqSet (IntMap.fromList (map (\x -> (getUnique x,x)) m)) - --- | Convert a 'UniqMap' to a 'UniqSet' -uniqMapToUniqSet - :: UniqMap a - -> UniqSet a -uniqMapToUniqSet (UniqMap m) = UniqSet m - --- | Check whether a A is a subset of B -subsetUniqSet - :: UniqSet a - -- ^ Set A - -> UniqSet a - -- ^ Set B - -> Bool -subsetUniqSet (UniqSet e1) (UniqSet e2) = IntMap.null (IntMap.difference e1 e2) - --- | Check whether A and B are disjoint -disjointUniqSet - :: UniqSet a - -> UniqSet a - -> Bool -disjointUniqSet (UniqSet e1) (UniqSet e2) = IntMap.disjoint e1 e2 - --- | Take the difference of two sets -differenceUniqSet - :: UniqSet a - -> UniqSet a - -> UniqSet a -differenceUniqSet (UniqSet e1) (UniqSet e2) = UniqSet (IntMap.difference e1 e2) +instance Uniquable Unique where + getUnique = id + setUnique = flip const diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs --- a/src/Clash/Util.hs +++ b/src/Clash/Util.hs @@ -18,6 +18,9 @@ ( module Clash.Util , SrcSpan , noSrcSpan +#if MIN_VERSION_transformers(0,6,0) + , hoistMaybe +#endif ) where @@ -25,6 +28,11 @@ import Control.Lens import Control.Monad.State (MonadState,StateT) import qualified Control.Monad.State as State +#if MIN_VERSION_transformers(0,6,0) +import Control.Monad.Trans.Maybe (hoistMaybe) +#else +import Control.Monad.Trans.Maybe (MaybeT (..)) +#endif import Data.Hashable (Hashable) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMapL @@ -59,6 +67,8 @@ import SrcLoc (SrcSpan, noSrcSpan) #endif +import Clash.Data.UniqMap (UniqMap) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug import Clash.Unique @@ -66,6 +76,11 @@ import qualified Paths_clash_lib (version) #endif +{- $setup +>>> :m -Prelude +>>> import Clash.Prelude +-} + data ClashException = ClashException SrcSpan String (Maybe String) instance Show ClashException where @@ -180,11 +195,11 @@ -> m v makeCachedU key l create = do cache <- use l - case lookupUniqMap key cache of + case UniqMap.lookup key cache of Just value -> return value Nothing -> do value <- create - l %= extendUniqMap key value + l %= UniqMap.insert key value return value -- | Cache the result of a monadic action using a 'OMap' @@ -257,8 +272,10 @@ clogBase _ _ = Nothing -- | Get the package id of the type of a value --- >>> pkgIdFromTypeable (undefined :: TopEntity) --- "clash-prelude-0.99.3-64904d90747cb49e17166bbc86fec8678918e4ead3847193a395b258e680373c" +-- +-- >>> pkgIdFromTypeable (0 :: Unsigned 32) +-- "clash-prelude-... +-- pkgIdFromTypeable :: Typeable a => a -> String pkgIdFromTypeable = tyConPackage . typeRepTyCon . typeOf @@ -322,3 +339,12 @@ , LangExt.Strict , LangExt.StrictData ] + +thenCompare :: Ordering -> Ordering -> Ordering +thenCompare EQ rel = rel +thenCompare rel _ = rel + +#if !MIN_VERSION_transformers(0,6,0) +hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b +hoistMaybe = MaybeT . pure +#endif diff --git a/src/Clash/Util/Graph.hs b/src/Clash/Util/Graph.hs --- a/src/Clash/Util/Graph.hs +++ b/src/Clash/Util/Graph.hs @@ -19,8 +19,8 @@ import Clash.Core.Var (Id) import Clash.Core.Term (Term) +import qualified Clash.Data.UniqMap as UniqMap import Clash.Driver.Types (BindingMap, Binding (bindingTerm)) -import Clash.Unique (lookupUniqMap', keysUniqMap) import Clash.Normalize.Util (callGraph) data Marker @@ -145,6 +145,6 @@ -- ^ Root of the call graph -> [Term] callGraphBindings bindingsMap tm = - map (bindingTerm . (bindingsMap `lookupUniqMap'`)) (keysUniqMap cg) + map (bindingTerm . (`UniqMap.find` bindingsMap)) (UniqMap.keys cg) where cg = callGraph bindingsMap tm diff --git a/src/Clash/Util/Interpolate.hs b/src/Clash/Util/Interpolate.hs --- a/src/Clash/Util/Interpolate.hs +++ b/src/Clash/Util/Interpolate.hs @@ -1,6 +1,6 @@ {-| -Copyright : (C) 2019, QBayLogic B.V. - 2013, Nikita Volkov +Copyright : (C) 2019-2022, QBayLogic B.V. + 2013 , Nikita Volkov License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -42,8 +42,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} --- TODO: only export the @i@ quasiquotor when `ghcide` stop type-checking --- exanded quasiquote splices +-- TODO: only export the @i@ quasiquoter when `ghcide` stops type-checking +-- expanded quasiquote splices module Clash.Util.Interpolate (i, format, toString) where import Language.Haskell.Meta.Parse (parseExp) @@ -203,6 +203,30 @@ joinLiterals (Literal s0:Literal s1:ss) = joinLiterals (Literal (s0 ++ s1):ss) joinLiterals (n:ns) = n:joinLiterals ns +{-| +@i@ will reflow the quasi-quoted text to 90 columns wide. If an interpolation +variable is on its own line and expands to a multi-line string, the interpolated +text will be indented the same as the interpolation variable was: + +> :set -XQuasiQuotes +> :{ +> a = "Multi\nLine\nString" +> b = [i| +> This line will be reflowed +> and the interpolated +> multi-line string here: +> #{a} +> will be indented. This +> text is outdented again. +> |] +> :} +> putStrLn b +This line will be reflowed and the interpolated multi-line string here: + Multi + Line + String +will be indented. This text is outdented again. +-} i :: QuasiQuoter i = QuasiQuoter { quoteExp = (varE 'format `appE`) . toExp . parseNodes . decodeNewlines @@ -250,6 +274,7 @@ ------------------------------------------------------------------- -- Everything below this line is unchanged from neat-interpolate -- +-- apart from updated module identifier strings -- ------------------------------------------------------------------- decodeNewlines :: String -> String decodeNewlines = go @@ -363,9 +388,9 @@ readHex :: String -> Int readHex xs = case N.readHex xs of [(n, "")] -> n - _ -> error "Data.String.Interpolate.Util.readHex: no parse" + _ -> error $ (show 'unescape) <> " readHex: no parse" readOct :: String -> Int readOct xs = case N.readOct xs of [(n, "")] -> n - _ -> error "Data.String.Interpolate.Util.readHex: no parse" + _ -> error $ (show 'unescape) <> " readOct: no parse" diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -22,7 +22,8 @@ import qualified Data.Text.Lazy.Encoding as LT import Data.Text.Encoding.Error (UnicodeException(..)) import Data.List (intercalate) -import Data.List.Extra (groupOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Tuple.Extra (second, first) import Data.Aeson (FromJSON, Result (..), fromJSON) import Data.Aeson.Parser (json) @@ -100,12 +101,13 @@ go2 n inString (_:rest) = go2 n inString rest toLineMap :: [Int] -> LineMap - toLineMap virtuals = + toLineMap [] = IntMap.empty + toLineMap (v:virtuals) = IntMap.fromList $ map (second (\reals -> (minimum reals, maximum reals))) - $ map (first head . unzip) - $ groupOn fst - $ zip virtuals [(0::Int)..] + $ map (first NE.head . NE.unzip) + $ NE.groupBy (\(a,_) (b,_) -> a == b) + $ NE.zip (v :| virtuals) (NE.iterate (+1) (0 :: Int)) genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text genLineErr' allLines range errorLines = diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -25,7 +25,9 @@ import "extra" Data.List.Extra as NeilsExtra import "extra" Control.Monad.Extra (anyM, allM, orM, partitionM) +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif #if defined(DEBUG) import GHC.Stack (HasCallStack) diff --git a/src/GHC/BasicTypes/Extra.hs b/src/GHC/BasicTypes/Extra.hs --- a/src/GHC/BasicTypes/Extra.hs +++ b/src/GHC/BasicTypes/Extra.hs @@ -1,7 +1,8 @@ {-| Copyright : (C) 2017, Google Inc. + 2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) - Maintainer : Christiaan Baaij + Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} @@ -18,6 +19,51 @@ import Data.Binary import GHC.Generics +#if MIN_VERSION_ghc(9,4,0) +import GHC.Types.SourceText +#endif + +#if MIN_VERSION_ghc(9,8,0) +import Data.ByteString +import GHC.Data.FastString +import Unsafe.Coerce +#endif + deriving instance Generic InlineSpec instance NFData InlineSpec instance Binary InlineSpec + +#if MIN_VERSION_ghc(9,8,0) +deriving instance Generic FastString +instance Binary FastString +instance Binary FastZString where + put = put . fastZStringToByteString + get = unsafeCoerce (get :: Get ByteString) +#endif + +#if MIN_VERSION_ghc(9,4,0) +deriving instance Generic SourceText +#if !MIN_VERSION_ghc(9,8,0) +instance NFData SourceText +#endif +instance Binary SourceText +#endif + +-- | Determine whether given 'InlineSpec' is NOINLINE or more strict (OPAQUE) +isNoInline :: InlineSpec -> Bool +isNoInline NoInline{} = True +#if MIN_VERSION_ghc(9,4,0) +isNoInline Opaque{} = True +#endif +isNoInline _ = False + +-- | Determine whether given 'InlineSpec' is OPAQUE. If this function is used on +-- a GHC that does not support OPAQUE yet (<9.4), it will return 'True' if given +-- 'InlineSpec' is NOINLINE instead. +isOpaque :: InlineSpec -> Bool +#if MIN_VERSION_ghc(9,4,0) +isOpaque Opaque{} = True +#else +isOpaque NoInline{} = True +#endif +isOpaque _ = False diff --git a/src/GHC/SrcLoc/Extra.hs b/src/GHC/SrcLoc/Extra.hs --- a/src/GHC/SrcLoc/Extra.hs +++ b/src/GHC/SrcLoc/Extra.hs @@ -30,11 +30,14 @@ srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol) import FastString (FastString (..), bytesFS, mkFastStringByteList) #endif - +#if MIN_VERSION_ghc(9,4,0) +import qualified GHC.Data.Strict +#endif -#if MIN_VERSION_ghc(9,0,0) -deriving instance Ord SrcSpan -deriving instance Ord UnhelpfulSpanReason +#if MIN_VERSION_ghc(9,4,0) +deriving instance Generic (GHC.Data.Strict.Maybe a) +instance Hashable a => Hashable (GHC.Data.Strict.Maybe a) +instance Binary a => Binary (GHC.Data.Strict.Maybe a) #endif deriving instance Generic SrcSpan diff --git a/tests/Clash/Tests/Core/TermLiteral.hs b/tests/Clash/Tests/Core/TermLiteral.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/TermLiteral.hs @@ -0,0 +1,67 @@ +{-| +Copyright : (C) 2022, Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +Tests for 'Clash.Core.TermLiteral'. +-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Clash.Tests.Core.TermLiteral where + +import Data.Proxy +import Data.Typeable +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH + +import Clash.Core.TermLiteral +import Clash.Promoted.Nat + +import Clash.Tests.Core.TermLiteral.Types + +showTypeable :: Typeable a => Proxy a -> String +showTypeable proxy = showsPrec 0 (typeRep proxy) "" + +eqTest :: (TermLiteral a, Typeable a) => Proxy a -> Assertion +eqTest proxy = showType proxy @=? showTypeable proxy + +case_int :: Assertion +case_int = eqTest (Proxy @Int) + +case_maybe_int :: Assertion +case_maybe_int = eqTest (Proxy @(Maybe Int)) + +case_maybe_maybe_int :: Assertion +case_maybe_maybe_int = eqTest (Proxy @(Maybe (Maybe Int))) + +case_either_int_int :: Assertion +case_either_int_int = eqTest (Proxy @(Either Int Int)) + +case_either_int_maybe_int :: Assertion +case_either_int_maybe_int = eqTest (Proxy @(Either Int (Maybe Int))) + +case_int_int :: Assertion +case_int_int = eqTest (Proxy @(Int, Int)) + +case_maybe_int_maybe_int :: Assertion +case_maybe_int_maybe_int = eqTest (Proxy @(Maybe Int, Maybe Int)) + +case_maybe_int_int :: Assertion +case_maybe_int_int = eqTest (Proxy @(Maybe (Int, Int))) + +case_snat :: Assertion +case_snat = "SNat _" @=? showType (Proxy @(SNat 5)) + +case_maybe_snat :: Assertion +case_maybe_snat = "Maybe (SNat _)" @=? showType (Proxy @(Maybe (SNat 5))) + +deriveTermLiteral ''NatTypeArg + +case_natTypeArg :: Assertion +case_natTypeArg = "NatTypeArg _" @=? showType (Proxy @(NatTypeArg 10)) + +tests :: TestTree +tests = testGroup "Clash.Tests.Core.TermLiteral" [$(testGroupGenerator)] diff --git a/tests/Clash/Tests/Core/TermLiteral/Types.hs b/tests/Clash/Tests/Core/TermLiteral/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/TermLiteral/Types.hs @@ -0,0 +1,5 @@ +module Clash.Tests.Core.TermLiteral.Types where + +import Clash.Promoted.Nat + +data NatTypeArg n = NatTypeArg (SNat n) diff --git a/tests/Clash/Tests/Driver/Manifest.hs b/tests/Clash/Tests/Driver/Manifest.hs --- a/tests/Clash/Tests/Driver/Manifest.hs +++ b/tests/Clash/Tests/Driver/Manifest.hs @@ -7,6 +7,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import Data.Coerce (coerce) +import Data.Either (fromRight) import Data.Text (Text) import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text @@ -89,7 +90,8 @@ manifest@Manifest{fileNames} <- genManifest let encoded = Aeson.encodePretty manifest - Right (FilesManifest fileNamesDecoded) = Aeson.eitherDecode encoded + FilesManifest fileNamesDecoded = + fromRight (error "Failed to decode manifest") (Aeson.eitherDecode encoded) pure (fileNamesDecoded Q.=== fileNames) ] diff --git a/tests/Clash/Tests/Netlist/Id.hs b/tests/Clash/Tests/Netlist/Id.hs --- a/tests/Clash/Tests/Netlist/Id.hs +++ b/tests/Clash/Tests/Netlist/Id.hs @@ -170,15 +170,15 @@ , testGroup "pretty names" [ testCase "(# #) => Unit" $ "Unit" @=? roundTrip' "(# #)" , testCase "() => Unit" $ "Unit" @=? roundTrip' "()" - , testCase "(,,) => Tup3" $ "Tup3" @=? roundTrip' "(,,)" - , testCase "(#,,,,#) => Tup5" $ "Tup5" @=? roundTrip' "(,,,,)" + , testCase "(,,) => Tuple3" $ "Tuple3" @=? roundTrip' "(,,)" + , testCase "(#,,,,#) => Tuple5" $ "Tuple5" @=? roundTrip' "(,,,,)" ] , testGroup "pretty names (force basic)" [ testCase "(# #) => Unit" $ "Unit" @=? roundTrip False VHDL "(# #)" , testCase "() => Unit" $ "Unit" @=? roundTrip False VHDL "()" - , testCase "(,,) => Tup3" $ "Tup3" @=? roundTrip False VHDL "(,,)" - , testCase "(#,,,,#) => Tup5" $ "Tup5" @=? roundTrip False VHDL "(,,,,)" + , testCase "(,,) => Tuple3" $ "Tuple3" @=? roundTrip False VHDL "(,,)" + , testCase "(#,,,,#) => Tuple5" $ "Tuple5" @=? roundTrip False VHDL "(,,,,)" ] , testGroup "disallow escaped identifiers" diff --git a/tests/Clash/Tests/Normalize/Transformations.hs b/tests/Clash/Tests/Normalize/Transformations.hs --- a/tests/Clash/Tests/Normalize/Transformations.hs +++ b/tests/Clash/Tests/Normalize/Transformations.hs @@ -3,35 +3,26 @@ License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE QuasiQuotes #-} module Clash.Tests.Normalize.Transformations where +import Data.Maybe (fromMaybe) + import Clash.Normalize.Transformations (inlineBndrsCleanup) import Clash.Core.VarEnv - (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv, extendInScopeSetList) + (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv) import Clash.Core.FreeVars (countFreeOccurances) import Clash.Core.Term -import Clash.Unique (UniqSet, extendUniqSet, unitUniqSet) import Test.Tasty import Test.Tasty.HUnit import Test.Clash.Rewrite (parseToTermQQ, parseToTerm) -import Debug.Trace -import Clash.Core.Pretty (showPpr) - t1337a :: Term -t1337a = Letrec keep1 result - where - (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds - is = mkInScopeSet (mkVarSet (map fst binds)) - - keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] - - Letrec binds result = +t1337a = fromMaybe (error "failed to build term") $ do + Letrec binds result <- pure $ [parseToTermQQ| let -- Types don't mean anything for this example @@ -46,6 +37,13 @@ result_1 |] + (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds) + let is = mkInScopeSet (mkVarSet (map fst binds)) + + let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] + + return (Letrec keep1 result) + t1337a_result :: Term t1337a_result = [parseToTermQQ| let @@ -57,14 +55,9 @@ |] t1337b :: Term -t1337b = Letrec keep1 result - where - (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds - is = mkInScopeSet (mkVarSet (map fst binds)) - - keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] +t1337b = fromMaybe (error "failed to build term") $ do - Letrec binds result = + Letrec binds result <- pure $ [parseToTermQQ| let -- Types don't mean anything for this example @@ -80,6 +73,13 @@ result_1 |] + (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds) + let is = mkInScopeSet (mkVarSet (map fst binds)) + + let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] + + return (Letrec keep1 result) + t1337b_result :: Term t1337b_result = [parseToTermQQ| let @@ -91,15 +91,8 @@ |] t1337c :: Term -t1337c = Letrec keep1 result - where - (keep0:inlines)= map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds - Var fv = parseToTerm "freevar_5 :: Int" - is = mkInScopeSet (mkVarSet (fv : map fst binds)) - - keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] - - Letrec binds result = +t1337c = fromMaybe (error "failed to build term") $ do + Letrec binds result <- pure $ [parseToTermQQ| let result_1, a_2, b_3, c_4 :: Int @@ -112,6 +105,14 @@ in result_1 |] + + (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds) + Var fv <- pure (parseToTerm "freevar_5 :: Int") + let is = mkInScopeSet (mkVarSet (fv : map fst binds)) + + let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0] + + return (Letrec keep1 result) t1337c_result :: Term t1337c_result = [parseToTermQQ| diff --git a/tests/Test/Clash/Rewrite.hs b/tests/Test/Clash/Rewrite.hs --- a/tests/Test/Clash/Rewrite.hs +++ b/tests/Test/Clash/Rewrite.hs @@ -11,7 +11,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Test.Clash.Rewrite where @@ -26,7 +26,6 @@ import Clash.Rewrite.Types import Clash.Rewrite.Util (runRewrite) import Clash.Normalize.Types -import Clash.Unique (emptyUniqMap) import qualified Clash.Util.Interpolate as I import Control.Applicative ((<|>)) @@ -62,10 +61,11 @@ def = RewriteEnv { _clashEnv = ClashEnv { envOpts = defClashOpts { opt_debug = debugSilent } - , envTyConMap = emptyUniqMap + , envTyConMap = mempty , envTupleTyCons = IntMap.empty , envPrimitives = HashMap.empty , envCustomReprs = buildCustomReprs [] + , envDomains = HashMap.empty } , _typeTranslator=error "_typeTranslator: NYI" , _peEvaluator=error "_peEvaluator: NYI" diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Environment (getArgs) +import Test.DocTest (mainFromCabal) + +main :: IO () +main = mainFromCabal "clash-lib" =<< getArgs diff --git a/tests/unittests.hs b/tests/unittests.hs --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -5,10 +5,11 @@ import qualified Clash.Tests.Core.FreeVars import qualified Clash.Tests.Core.Subst +import qualified Clash.Tests.Core.TermLiteral import qualified Clash.Tests.Driver.Manifest import qualified Clash.Tests.Netlist.Id -import qualified Clash.Tests.Util.Interpolate import qualified Clash.Tests.Normalize.Transformations +import qualified Clash.Tests.Util.Interpolate -- AFAIK there's no good way to override the default, so we just detect the -- default value and change it. @@ -20,10 +21,11 @@ tests = testGroup "Unittests" [ Clash.Tests.Core.FreeVars.tests , Clash.Tests.Core.Subst.tests + , Clash.Tests.Core.TermLiteral.tests , Clash.Tests.Driver.Manifest.tests - , Clash.Tests.Util.Interpolate.tests , Clash.Tests.Netlist.Id.tests , Clash.Tests.Normalize.Transformations.tests + , Clash.Tests.Util.Interpolate.tests ] main :: IO () diff --git a/tools/static-files.hs b/tools/static-files.hs new file mode 100644 --- /dev/null +++ b/tools/static-files.hs @@ -0,0 +1,71 @@ +{-| +Copyright : (C) 2022 , Google Inc. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +Produce static files that are useful when working with Clash designs. +-} + +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Control.Monad (when) +import Control.Monad.Extra (whenM, unlessM) +import Prelude +import System.Console.Docopt + (Docopt, docopt, isPresent, getArg, longOption, parseArgsOrExit) +import System.Directory (copyFile, doesDirectoryExist, doesFileExist) +import System.Environment (getArgs) +import System.Exit (die) +import System.FilePath (takeDirectory) + +import Clash.DataFiles + +patterns :: Docopt +patterns = [docopt| +Obtain static files useful when working with Clash designs + +Currently, only the Tcl connector is available. + +Usage: + static-files [--force] [--verbose] --tcl-connector= + +Options: + -f, --force Overwrite existing files + -v, --verbose Explain what is being done + --tcl-connector= Write a Tcl script to a file that can parse Clash + manifest JSON files and emit the correct commands + for loading the design into Vivado +|] + +-- Checks whether it looks like we can write a file in the location @path@, +-- accounting for the @--force@ command line argument. Exit with a descriptive +-- error message if something's amiss. +createOkayOrDie :: + FilePath -> + Bool -> + IO () +createOkayOrDie path force = do + let pathDir = takeDirectory path + unlessM (doesDirectoryExist pathDir) $ + die $ "Directory not found: " ++ pathDir + whenM (doesDirectoryExist path) $ + die $ path ++ " is a directory. Please specify a file name." + exists <- doesFileExist path + when (exists && not force) $ + die $ path ++ " already exists and --force not specified. " ++ + "Refusing to overwrite." + +main :: IO () +main = do + args <- parseArgsOrExit patterns =<< getArgs + -- Since we got here, we know we got invoked with the sole mandatory option + -- @--tcl-connector@ and its mandatory argument + let force = args `isPresent` (longOption "force") + verbose = args `isPresent` (longOption "verbose") + Just outFile = args `getArg` (longOption "tcl-connector") + createOkayOrDie outFile force + inFile <- tclConnector + copyFile inFile outFile + when verbose $ putStrLn $ "Tcl Connector written to " ++ outFile